Fix errors in tc/app-hetero, cleanup tc/app.

collects/typed-racket/typecheck/tc-app.rkt

@@ -2,6 +2,7 @@
 
 (require "../utils/utils.rkt"
          "tc-app/signatures.rkt"
+         "tc-app/utils.rkt"
          syntax/parse racket/match 
          syntax/parse/experimental/reflect
          (typecheck signatures check-below tc-funapp)
@@ -15,38 +16,46 @@
 (export tc-app^)
 
 
-;; the main dispatching function
-;; syntax tc-results? -> tc-results?
-(define (tc/app/internal form expected)
-  (syntax-parse form
-    [(#%plain-app .
-       (~or (~var v (tc/app-annotated expected))
-            (~reflect v (tc/app-list expected) #:attributes (check))
-            (~reflect v (tc/app-apply expected) #:attributes (check))
-            (~reflect v (tc/app-eq expected) #:attributes (check))
-            (~reflect v (tc/app-hetero expected) #:attributes (check))
-            (~reflect v (tc/app-values expected) #:attributes (check))
-            (~reflect v (tc/app-keywords expected) #:attributes (check))
-            (~reflect v (tc/app-objects expected) #:attributes (check))
-            (~reflect v (tc/app-lambda expected) #:attributes (check))
-            (~reflect v (tc/app-special expected) #:attributes (check))
-            (~var v (tc/app-regular* expected))))
-     ((attribute v.check))]))
-
 (define-syntax-class annotated-op
   (pattern i:identifier
            #:when (or (syntax-property #'i 'type-inst)
                       (syntax-property #'i 'type-ascription))))
 
-
+(define-tc/app-syntax-class (tc/app-annotated expected)
-(define-syntax-class (tc/app-annotated expected)
   ;; Just do regular typechecking if we have one of these.
   (pattern (~and form (rator:annotated-op . rands))
-   #:attr check (lambda () (tc/app-regular #'form expected))))
+    (tc/app-regular #'form expected)))
+
+(define-tc/app-syntax-class (tc/app-regular* expected)
+  (pattern form (tc/app-regular #'form expected)))
+
+(define-syntax-rule (combine-tc/app-syntax-classes class-name case ...)
+  (define-syntax-class (class-name expected)
+    #:attributes (check)
+    (pattern (~reflect v (case expected) #:attributes (check))
+             #:attr check (attribute v.check)) ...))
+
+(combine-tc/app-syntax-classes tc/app-special-cases
+  tc/app-annotated
+  tc/app-list
+  tc/app-apply
+  tc/app-eq
+  tc/app-hetero
+  tc/app-values
+  tc/app-keywords
+  tc/app-objects
+  tc/app-lambda
+  tc/app-special
+  tc/app-regular*)
+
+;; the main dispatching function
+;; syntax tc-results? -> tc-results?
+(define (tc/app/internal form expected)
+  (syntax-parse form
+    [(#%plain-app . (~var v (tc/app-special-cases expected)))
+     ((attribute v.check))]))
+
 
-(define-syntax-class (tc/app-regular* expected)
-  (pattern form 
-   #:attr check (lambda () (tc/app-regular #'form expected))))
 
 (define (tc/app-regular form expected)
   (syntax-parse form

collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt

@@ -83,32 +83,32 @@
               unsafe-struct-ref unsafe-struct*-ref
               unsafe-struct-set! unsafe-struct*-set!
               vector-immutable vector)
-  (pattern ((~or unsafe-struct-ref unsafe-struct*-ref) struct:expr index:expr)
+  (pattern (~and form ((~or unsafe-struct-ref unsafe-struct*-ref) struct:expr index:expr))
     (match (single-value #'struct)
       [(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _))))
        (tc/hetero-ref #'index flds struct-t expected "struct")]
-      [s-ty #f]))
+      [s-ty (tc/app-regular #'form expected)]))
   ;; vector-ref on het vectors
-  (pattern ((~or vector-ref unsafe-vector-ref unsafe-vector*-ref) vec:expr index:expr)
+  (pattern (~and form ((~or vector-ref unsafe-vector-ref unsafe-vector*-ref) vec:expr index:expr))
     (match (single-value #'vec)
       [(tc-result1: (and vec-t (app resolve (HeterogenousVector: es))))
        (tc/hetero-ref #'index es vec-t expected "vector")]
-      [v-ty #f]))
+      [v-ty (tc/app-regular #'form expected)]))
   ;; unsafe struct-set! 
-  (pattern ((~or unsafe-struct-set! unsafe-struct*-set!) s:expr index:expr val:expr)
+  (pattern (~and form ((~or unsafe-struct-set! unsafe-struct*-set!) s:expr index:expr val:expr))
     (match (single-value #'s)
       [(tc-result1: (and struct-t (app resolve (Struct: _ _ (list (fld: flds _ _) ...) _ _ _ _ _))))
        (tc/hetero-set! #'index flds #'val struct-t expected "struct")]
-      [s-ty #f]))
+      [s-ty (tc/app-regular #'form expected)]))
   ;; vector-set! on het vectors
-  (pattern ((~or vector-set! unsafe-vector-set! unsafe-vector*-set!) v:expr index:expr val:expr)
+  (pattern (~and form ((~or vector-set! unsafe-vector-set! unsafe-vector*-set!) v:expr index:expr val:expr))
     (match (single-value #'v)
       [(tc-result1: (and vec-t (app resolve (HeterogenousVector: es))))
        (tc/hetero-set! #'index es #'val vec-t expected "vector")]
-      [v-ty #f]))
+      [v-ty (tc/app-regular #'form expected)]))
   (pattern (~and form ((~or vector-immutable vector) args:expr ...))
     (match expected
-      [(tc-result1: (app resolve (Vector: t))) #f]
+      [(tc-result1: (app resolve (Vector: t))) (tc/app-regular #'form expected)]
       [(tc-result1: (app resolve (HeterogenousVector: ts)))
        (unless (= (length ts) (length (syntax->list #'(args ...))))
          (tc-error/expr "expected vector with ~a elements, but got ~a"