Make toplevel checks use internal syntax class.

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt

@@ -9,15 +9,12 @@
          (private parse-type type-annotation type-contract syntax-properties)
          (env global-env init-envs type-name-env type-alias-env
               lexical-env env-req mvar-env scoped-tvar-env)
-         (utils tc-utils)
+         (utils tc-utils syntax-classes)
          (typecheck provide-handling def-binding tc-structs typechecker)
 
-         ;; to appease syntax-parse in the tests
-         (typecheck internal-forms)
          syntax/location
 
          (for-template
-          "internal-forms.rkt"
           syntax/location
           racket/base
           (env env-req)))
@@ -29,55 +26,22 @@
 
 (define unann-defs (make-free-id-table))
 
-(define-splicing-syntax-class dtsi-fields
+(define (parse-typed-struct form)
- #:attributes (mutable type-only maker)
- (pattern
-  (~seq
-    (~or (~optional (~and #:mutable (~bind (mutable #t))))
-         (~optional (~and #:type-only (~bind (type-only #t))))
-         (~optional (~seq #:maker maker))) ...)))
-
-(define-syntax-class struct-name
- (pattern nm:id)
- (pattern (nm:id parent:id)))
-
-
-(define-syntax-class define-typed-struct
-  #:attributes (name mutable type-only maker nm (tvars 1) (fld 1) (ty 1))
-  (pattern ((~optional (tvars:id ...) #:defaults (((tvars 1) null)))
-            nm:struct-name ([fld:id : ty:expr] ...) fields:dtsi-fields)
-           #:attr name #'nm.nm
-           #:attr mutable (attribute fields.mutable)
-           #:attr type-only (attribute fields.type-only)
-           #:attr maker (or (attribute fields.maker) #'nm.nm)))
-
-(define (parse-define-struct-internal form)
   (parameterize ([current-orig-stx form])
     (syntax-parse form
-      #:literals (values define-typed-struct-internal
+      [t:typed-struct
-                  define-typed-struct/exec-internal quote-syntax #%plain-app)
+       (tc/struct (attribute t.tvars) #'t.nm (syntax->list #'(t.fields ...)) (syntax->list #'(t.types ...))
-
+                  #:mutable (attribute t.mutable)
-      ;; define-typed-struct
+                  #:maker (attribute t.maker)
-      [(define-values () (begin (quote-syntax (define-typed-struct-internal ~! . dts:define-typed-struct)) (#%plain-app values)))
+                  #:type-only (attribute t.type-only))]
-       (tc/struct (attribute dts.tvars) #'dts.nm (syntax->list #'(dts.fld ...)) (syntax->list #'(dts.ty ...))
+      [t:typed-struct/exec
-                  #:mutable (attribute dts.mutable)
+       (tc/struct null #'t.nm (syntax->list #'(t.fields ...)) (syntax->list #'(t.types ...))
-                  #:maker (attribute dts.maker)
+                  #:proc-ty #'t.proc-type)])))
-                  #:type-only (attribute dts.type-only))]
-
-      ;; executable structs - this is a big hack
-      [(define-values () (begin (quote-syntax (define-typed-struct/exec-internal ~! nm ([fld : ty] ...) proc-ty)) (#%plain-app values)))
-       (tc/struct null #'nm (syntax->list #'(fld ...)) (syntax->list #'(ty ...)) #:proc-ty #'proc-ty)])))
 
 (define (type-vars-of-struct form)
-  (parameterize ([current-orig-stx form])
+  (syntax-parse form
-    (syntax-parse form
+    [t:typed-struct (attribute t.tvars)]
-      #:literals (values define-typed-struct-internal quote-syntax #%plain-app)
+    [t:typed-struct/exec null]))
-      ;; define-typed-struct
-      [(define-values () (begin (quote-syntax (define-typed-struct-internal ~! . dts:define-typed-struct)) (#%plain-app values)))
-       (attribute dts.tvars)]
-      [(define-values () (begin (quote-syntax (define-typed-struct/exec-internal ~! nm ([fld : ty] ...) proc-ty)) (#%plain-app values)))
-       ;; Not polymorphic
-       null])))
 
 (define (add-constant-variance! name vars)
   (unless (null? vars)
@@ -90,10 +54,7 @@
 (define (tc-toplevel/pass1 form)
   (parameterize ([current-orig-stx form])
     (syntax-parse form
-      #:literals (values define-type-alias-internal define-typed-struct-internal define-type-internal
+      #:literals (values define-values #%plain-app begin define-syntaxes)
-                         define-typed-struct/exec-internal :-internal assert-predicate-internal
-                         require/typed-internal declare-refinement-internal
-                         define-values quote-syntax #%plain-app begin define-syntaxes)
       ;#:literal-sets (kernel-literals)
 
       ;; forms that are handled in other ways
@@ -108,51 +69,47 @@
        (list)]
 
       ;; type aliases have already been handled by an earlier pass
-      [(define-values () (begin (quote-syntax (define-type-alias-internal nm ty)) (#%plain-app values)))
+      [_:type-alias
        (list)]
 
       ;; declare-refinement
       ;; FIXME - this sucks and should die
-      [(define-values () (begin (quote-syntax (declare-refinement-internal pred)) (#%plain-app values)))
+      [t:type-refinement
-       (match (lookup-type/lexical #'pred)
+       (match (lookup-type/lexical #'t.predicate)
               [(and t (Function: (list (arr: (list dom) (Values: (list (Result: rng _ _))) #f #f '()))))
                (let ([new-t (make-pred-ty (list dom)
                                           rng
-                                          (make-Refinement dom #'pred))])
+                                          (make-Refinement dom #'t.predicate))])
-                 (register-type #'pred new-t))
+                 (register-type #'t.predicate new-t))
                (list)]
               [t (tc-error "cannot declare refinement for non-predicate ~a" t)])]
 
       ;; require/typed
-      [(define-values () (begin (quote-syntax (require/typed-internal nm ty)) (#%plain-app values)))
+      [r:typed-require
-       (let ([t (parse-type #'ty)])
+       (let ([t (parse-type #'r.type)])
-         (register-type #'nm t)
+         (register-type #'r.name t)
-         (list (make-def-binding #'nm t)))]
+         (list (make-def-binding #'r.name t)))]
 
-      [(define-values () (begin (quote-syntax (require/typed-internal nm ty #:struct-maker parent)) (#%plain-app values)))
+      [r:typed-require/struct
-       (let* ([t (parse-type #'ty)]
+       (let* ([t (parse-type #'r.type)]
               [flds (map fld-t (Struct-flds (lookup-type-name (Name-id t))))]
               [mk-ty (flds #f . ->* . t)])
-         (register-type #'nm mk-ty)
+         (register-type #'r.name mk-ty)
-         (list (make-def-binding #'nm mk-ty)))]
+         (list (make-def-binding #'r.name mk-ty)))]
 
       ;; define-typed-struct (handled earlier)
-      [(define-values () (begin (quote-syntax (define-typed-struct-internal . _)) (#%plain-app values)))
+      [(~or _:typed-struct _:typed-struct/exec)
-       (list)]
-
-      ;; executable structs (handled earlier)
-      [(define-values () (begin (quote-syntax (define-typed-struct/exec-internal . _)) (#%plain-app values)))
        (list)]
 
       ;; predicate assertion - needed for define-type b/c or doesn't work
-      [(define-values () (begin (quote-syntax (assert-predicate-internal ty pred)) (#%plain-app values)))
+      [p:predicate-assertion
-       (register-type #'pred (make-pred-ty (parse-type #'ty)))
+       (register-type #'p.predicate (make-pred-ty (parse-type #'p.type)))
        (list)]
 
       ;; top-level type annotation
-      [(define-values () (begin (quote-syntax (:-internal id:identifier ty)) (#%plain-app values)))
+      [t:type-declaration
-       (register-type/undefined #'id (parse-type #'ty))
+       (register-type/undefined #'t.id (parse-type #'t.type))
-       (register-scoped-tvars #'id (parse-literal-alls #'ty))
+       (register-scoped-tvars #'t.id (parse-literal-alls #'t.type))
        (list)]
 
 
@@ -205,8 +162,6 @@
   (parameterize ([current-orig-stx form])
     (syntax-parse form
       #:literal-sets (kernel-literals)
-      #:literals (define-type-alias-internal define-typed-struct-internal
-                  define-type-internal require/typed-internal)
       ;; these forms we have been instructed to ignore
       [stx
        #:when (ignore-property form)
@@ -249,14 +204,6 @@
 
 
 ;; new implementation of type-check
-(define-syntax-rule (internal-syntax-pred nm)
-  (lambda (form)
-    (syntax-parse form
-      #:literals (nm values)
-      #:literal-sets (kernel-literals)
-      [(define-values () (begin (quote-syntax (nm . rest)) (#%plain-app values))) #t]
-      [_ #f])))
-
 (define (parse-def x)
   (syntax-parse x
     #:literal-sets (kernel-literals)
@@ -271,11 +218,7 @@
 
 (define (parse-type-alias form)
   (syntax-parse form
-    #:literals (define-type-alias-internal values)
+    [t:type-alias (values #'t.name #'t.type)]))
-    #:literal-sets (kernel-literals)
-    [(define-values () (begin (quote-syntax (define-type-alias-internal nm ty)) (#%plain-app values)))
-     (values #'nm #'ty)]
-    [_ (int-err "not define-type-alias")]))
 
 ;; actually do the work on a module
 ;; produces prelude and post-lude syntax objects
@@ -285,9 +228,8 @@
   (define-values (type-aliases struct-defs stx-defs0 val-defs0 provs reqs)
     (filter-multiple
      forms
-     (internal-syntax-pred define-type-alias-internal)
+     type-alias? 
-     (lambda (e) (or ((internal-syntax-pred define-typed-struct-internal) e)
+     (lambda (e) (or (typed-struct? e) (typed-struct/exec? e)))
-                     ((internal-syntax-pred define-typed-struct/exec-internal) e)))
      parse-syntax-def
      parse-def
      provide?
@@ -307,7 +249,7 @@
   ;; Parse and register the structure types
   (define parsed-structs
     (for/list ((def (in-list struct-defs)))
-      (define parsed (parse-define-struct-internal def))
+      (define parsed (parse-typed-struct def))
       (register-parsed-struct-sty! parsed)
       parsed))
 
@@ -433,15 +375,15 @@
              (report-all-errors))]
     [_
      ;; Handle type aliases
-     (when ((internal-syntax-pred define-type-alias-internal) form)
+     (when (type-alias? form)
        ((compose register-type-alias parse-type-alias) form))
      ;; Handle struct definitions
-     (when ((internal-syntax-pred define-typed-struct-internal) form)
+     (when (typed-struct? form)
        (define name (name-of-struct form))
        (define tvars (type-vars-of-struct form))
        (register-type-name name)
        (add-constant-variance! name tvars)
-       (define parsed (parse-define-struct-internal form))
+       (define parsed (parse-typed-struct form))
        (register-parsed-struct-sty! parsed)
        (refine-struct-variance! (list parsed))
        (register-parsed-struct-bindings! parsed))

pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/syntax-classes.rkt

@@ -0,0 +1,111 @@
+#lang racket/base
+
+(require
+  (only-in "utils.rkt" typecheck)
+  syntax/parse 
+  (for-template (typecheck internal-forms))
+  (for-template racket/base))
+(provide 
+  type-alias 
+  type-refinement
+  typed-struct
+  typed-struct/exec
+  typed-require
+  typed-require/struct
+  predicate-assertion
+  type-declaration
+  
+  type-alias?
+  typed-struct?
+  typed-struct/exec?
+  )
+
+(define-syntax-class internal
+   #:attributes (value)
+   #:literals (values)
+   #:literal-sets (kernel-literals)
+   (pattern (define-values () (begin (quote-syntax value:expr) (#%plain-app values)))))
+
+
+(define-syntax-class type-alias
+  #:attributes (name type)
+  (pattern i:internal
+    #:with ((~literal define-type-alias-internal) name type) #'i.value))
+
+(define-syntax-class type-refinement
+  #:attributes (predicate)
+  (pattern i:internal
+    #:with ((~literal declare-refinement-internal) predicate) #'i.value))
+
+(define-syntax-class typed-struct
+  #:attributes (name mutable type-only maker nm (tvars 1) (fields 1) (types 1))
+  (pattern i:internal
+    #:with ((~literal define-typed-struct-internal) . :define-typed-struct-body) #'i.value))
+
+(define-syntax-class typed-struct/exec
+  #:attributes (nm proc-type (fields 1) (types 1))
+  (pattern i:internal
+    #:with ((~literal define-typed-struct/exec-internal)
+            nm ([fields:id : types] ...) proc-type) #'i.value))
+
+(define-syntax-class typed-require
+  #:attributes (name type)
+  (pattern i:internal
+    #:with ((~literal require/typed-internal) name type) #'i.value))
+
+(define-syntax-class typed-require/struct
+  #:attributes (name type)
+  (pattern i:internal
+    #:with ((~literal require/typed-internal) name type #:struct-maker parent) #'i.value))
+
+(define-syntax-class predicate-assertion
+  #:attributes (type predicate)
+  (pattern i:internal
+    #:with ((~literal assert-predicate-internal) type predicate) #'i.value))
+
+(define-syntax-class type-declaration
+  #:attributes (id type)
+  (pattern i:internal
+    #:with ((~literal :-internal) id:identifier type) #'i.value))
+
+
+(define type-alias?
+  (syntax-parser
+    [:type-alias #t]
+    [_ #f]))
+
+(define typed-struct?
+  (syntax-parser
+    [:typed-struct #t]
+    [_ #f]))
+
+(define typed-struct/exec?
+  (syntax-parser
+    [:typed-struct/exec #t]
+    [_ #f]))
+
+;;; Helpers
+
+(define-splicing-syntax-class dtsi-fields
+ #:attributes (mutable type-only maker)
+ (pattern
+  (~seq
+    (~or (~optional (~and #:mutable (~bind (mutable #t))))
+         (~optional (~and #:type-only (~bind (type-only #t))))
+         (~optional (~seq #:maker maker))) ...)))
+
+(define-syntax-class struct-name
+ (pattern nm:id)
+ (pattern (nm:id parent:id)))
+
+
+(define-syntax-class define-typed-struct-body
+  #:attributes (name mutable type-only maker nm (tvars 1) (fields 1) (types 1))
+  (pattern ((~optional (tvars:id ...) #:defaults (((tvars 1) null)))
+            nm:struct-name ([fields:id : types:expr] ...) options:dtsi-fields)
+           #:attr name #'nm.nm
+           #:attr mutable (attribute options.mutable)
+           #:attr type-only (attribute options.type-only)
+           #:attr maker (or (attribute options.maker) #'nm.nm)))
+
+