From ed98404aafea1f9d0142dabdba73dcf7f16dda73 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Thu, 20 Feb 2014 11:42:07 -0500
Subject: [PATCH] TR: move helper syntax classes to helper file

---
 .../base-env/annotate-classes.rkt             |  93 ++++++++++++++++
 .../typed-racket/base-env/prims.rkt           | 100 +-----------------
 2 files changed, 94 insertions(+), 99 deletions(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt
index 1915b4c739..d50cc9078b 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/annotate-classes.rkt
@@ -1,6 +1,7 @@
 #lang racket/base
 
 (require syntax/parse
+         syntax/parse/experimental/template
          "../private/parse-classes.rkt"
          "../private/syntax-properties.rkt"
          (for-label "colon.rkt"))
@@ -153,6 +154,13 @@
   (pattern (~optional a:standalone-annotation)
            #:with ty (if (attribute a) #'a.ty #f)))
 
+(define-syntax-class type-variables
+  #:attributes ((vars 1))
+  #:description "a sequence of type variables"
+  (pattern (vars:id ...)
+           #:fail-when (check-duplicate-identifier (syntax->list #'(vars ...)))
+           "duplicate type variable declaration"))
+
 (define-splicing-syntax-class lambda-type-vars
   #:description "optional type parameters"
   #:attributes (type-vars)
@@ -164,3 +172,88 @@
   #:attributes (type-vars)
   (pattern :lambda-type-vars)
   (pattern (~seq) #:attr type-vars #f))
+
+(define-splicing-syntax-class kw-formal
+  #:attributes (form id default type kw)
+  #:literal-sets (colon)
+  (pattern (~seq kw:keyword id:id)
+           #:with form #'(kw id)
+           #:attr default #f
+           #:attr type #f)
+  (pattern (~seq kw:keyword [id:id default:expr])
+           #:with form #'(kw [id default])
+           #:attr type #f)
+  (pattern (~seq kw:keyword [id:id : type:expr])
+           #:with form #`(kw #,(type-label-property #'id #'type))
+           #:attr default #f)
+  (pattern (~seq kw:keyword [id:id : type:expr default:expr])
+           #:with form #`(kw [#,(type-label-property #'id #'type) default])))
+
+(define-splicing-syntax-class mand-formal
+  #:description "lambda argument"
+  #:attributes (form id default type kw)
+  #:literal-sets (colon)
+  (pattern id:id
+           #:with form #'(id)
+           #:attr default #f
+           #:attr type #f
+           #:attr kw #f)
+  (pattern [id:id : type:expr]
+           #:with form #`(#,(type-label-property #'id #'type))
+           #:attr default #f
+           #:attr kw #f)
+  (pattern :kw-formal))
+
+(define-splicing-syntax-class opt-formal
+  #:description "optional lambda argument"
+  #:attributes (form id default type kw)
+  #:literal-sets (colon)
+  (pattern [id:id default:expr]
+           #:with form #'([id default])
+           #:attr type #f
+           #:attr kw #f)
+  (pattern [id:id : type:expr default:expr]
+           #:with form #`([#,(type-label-property #'id #'type) default])
+           #:attr kw #f)
+  (pattern :kw-formal))
+
+(define-syntax-class rest-arg
+  #:description "rest argument"
+  #:attributes (form)
+  #:literal-sets (colon)
+  ;; specifying opaque here helps produce a better error
+  ;; message for optional argumenents, but produces worse
+  ;; error messages for rest arguments.
+  #:opaque
+  (pattern rest:id #:attr form #'rest)
+  (pattern (rest:id : type:expr :star)
+           #:attr form (type-label-property #'rest #'type))
+  (pattern (rest:id : type:expr bnd:ddd/bound)
+           #:attr bound (attribute bnd.bound)
+           #:attr form (type-dotted-property
+                        (type-label-property #'rest #'type)
+                        (attribute bound))))
+
+(define-syntax-class lambda-formals
+  #:attributes (opt-property kw-property erased)
+  (pattern (~or (mand:mand-formal ... opt:opt-formal ... . rest:rest-arg)
+                (~and (mand:mand-formal ... opt:opt-formal ...)
+                      (~bind [rest.form #'()])))
+           #:attr kw-property
+           (ormap values (append (attribute mand.kw) (attribute opt.kw)))
+           #:attr opt-property
+           (list (length (attribute mand)) (length (attribute opt)))
+           #:attr erased
+           (template ((?@ . mand.form) ... (?@ . opt.form) ... . rest.form))))
+
+(define-syntax-class curried-formals
+  #:attributes (erased)
+  (pattern fun:id #:with erased #'fun)
+  (pattern (fun:curried-formals . formals:lambda-formals)
+           #:with erased #`(fun.erased . #,(attribute formals.erased))))
+
+(define-splicing-syntax-class return-ann
+  #:description "return type annotation"
+  #:literal-sets (colon)
+  (pattern (~seq : type:expr))
+  (pattern (~seq) #:attr type #f))
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
index 0659cd627b..995c1bb87e 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
@@ -382,14 +382,6 @@ This file defines two sorts of primitives. All of them are provided into any mod
                  (syntax/loc stx (define-type-alias ty (Opaque pred))))
            #,(ignore #'(require/contract pred hidden pred-cnt lib)))))]))
 
-(begin-for-syntax
-  (define-syntax-class type-variables
-    #:attributes ((vars 1))
-    #:description "a sequence of type variables"
-    (pattern (vars:id ...)
-      #:fail-when (check-duplicate-identifier (syntax->list #'(vars ...)))
-                  "duplicate type variable declaration")))
-
 (define-syntax (plambda: stx)
   (syntax-parse stx
     [(plambda: tvars:type-variables formals . body)
@@ -1168,97 +1160,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
         (quasisyntax/loc stx (#,l/c k.ann-name . body))]))
     (values (mk #'let/cc) (mk #'let/ec))))
 
-;; Syntax classes for -lambda
-(begin-for-syntax
-  (define-splicing-syntax-class kw-formal
-    #:attributes (form id default type kw)
-    #:literals (:)
-    (pattern (~seq kw:keyword id:id)
-             #:with form #'(kw id)
-             #:attr default #f
-             #:attr type #f)
-    (pattern (~seq kw:keyword [id:id default:expr])
-             #:with form #'(kw [id default])
-             #:attr type #f)
-    (pattern (~seq kw:keyword [id:id : type:expr])
-             #:with form #`(kw #,(type-label-property #'id #'type))
-             #:attr default #f)
-    (pattern (~seq kw:keyword [id:id : type:expr default:expr])
-             #:with form #`(kw [#,(type-label-property #'id #'type) default])))
-
-  (define-splicing-syntax-class mand-formal
-    #:description "lambda argument"
-    #:attributes (form id default type kw)
-    #:literals (:)
-    (pattern id:id
-             #:with form #'(id)
-             #:attr default #f
-             #:attr type #f
-             #:attr kw #f)
-    (pattern [id:id : type:expr]
-             #:with form #`(#,(type-label-property #'id #'type))
-             #:attr default #f
-             #:attr kw #f)
-    (pattern :kw-formal))
-
-  (define-splicing-syntax-class opt-formal
-    #:description "optional lambda argument"
-    #:attributes (form id default type kw)
-    #:literals (:)
-    (pattern [id:id default:expr]
-             #:with form #'([id default])
-             #:attr type #f
-             #:attr kw #f)
-    (pattern [id:id : type:expr default:expr]
-             #:with form #`([#,(type-label-property #'id #'type) default])
-             #:attr kw #f)
-    (pattern :kw-formal))
-
-  (define-syntax-class rest-arg
-    #:description "rest argument"
-    #:attributes (form)
-    #:literals (:)
-    ;; specifying opaque here helps produce a better error
-    ;; message for optional argumenents, but produces worse
-    ;; error messages for rest arguments.
-    #:opaque
-    (pattern rest:id #:attr form #'rest)
-    (pattern (rest:id : type:expr :star)
-             #:attr form (type-label-property #'rest #'type))
-    (pattern (rest:id : type:expr bnd:ddd/bound)
-             #:attr bound (attribute bnd.bound)
-             #:attr form (type-dotted-property
-                          (type-label-property #'rest #'type)
-                          (attribute bound))))
-
-  (define-syntax-class lambda-formals
-    #:attributes (opt-property kw-property erased)
-    #:literals (:)
-    (pattern (~or (mand:mand-formal ... opt:opt-formal ... . rest:rest-arg)
-                  (~and (mand:mand-formal ... opt:opt-formal ...)
-                        (~bind [rest.form #'()])))
-             #:attr kw-property
-             (ormap values (append (attribute mand.kw) (attribute opt.kw)))
-             #:attr opt-property
-             (list (length (attribute mand)) (length (attribute opt)))
-             #:attr erased
-             (template ((?@ . mand.form) ... (?@ . opt.form) ... . rest.form))))
-
-  (define-syntax-class curried-formals
-    #:attributes (erased)
-    #:literals (:)
-    (pattern fun:id #:with erased #'fun)
-    (pattern (fun:curried-formals . formals:lambda-formals)
-             #:with erased #`(fun.erased . #,(attribute formals.erased))))
-
-  (define-splicing-syntax-class return-ann
-    #:description "return type annotation"
-    #:literals (:)
-    (pattern (~seq : type:expr))
-    (pattern (~seq) #:attr type #f)))
-
-
-;; annotation to help tc-expr pick out keyword functions
+;; lambda with optional type annotations, uses syntax properties
 (define-syntax (-lambda stx)
   (syntax-parse stx
     #:literals (:)