Moved last special cases out of tc-app.rkt.

collects/typed-racket/typecheck/signatures.rkt

@@ -55,6 +55,9 @@
 (define-signature tc-app-lambda^
   ([cond-contracted tc/app-lambda (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))]))
 
+(define-signature tc-app-special^
+  ([cond-contracted tc/app-special (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))]))
+
 
 (define-signature tc-apply^
   ([cond-contracted tc/apply (syntax? syntax? . -> . tc-results?)]))

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

@@ -28,14 +28,16 @@
 
 (import tc-expr^ tc-lambda^ tc-let^ tc-apply^ tc-app-keywords^
         tc-app-hetero^ tc-app-list^ tc-app-apply^ tc-app-values^
-        tc-app-objects^ tc-app-eq^ tc-app-lambda^)
+        tc-app-objects^ tc-app-eq^ tc-app-lambda^ tc-app-special^)
 (export tc-app^)
 
 
 ;; the main dispatching function
 ;; syntax tc-results? -> tc-results?
 (define (tc/app/internal form expected)
-  (or (tc/app-hetero form expected)
+  (or
+    (tc/app-annotated form expected)
+    (tc/app-hetero form expected)
     (tc/app-list form expected)
     (tc/app-apply form expected)
     (tc/app-values form expected)
@@ -43,63 +45,17 @@
     (tc/app-objects form expected)
     (tc/app-eq form expected)
     (tc/app-lambda form expected)
-  (syntax-parse form
+    (tc/app-special form expected)
-    #:literals (#%plain-app #%plain-lambda letrec-values quote
+    (tc/app-regular form expected)))
-                not false? list
-                module-name-fixup cons
-                extend-parameterization)
-    ;; bail out immediately if we have one of these
-    [(#%plain-app rator:special-op . rands) (tc/app/regular form expected)]
-    [(#%plain-app extend-parameterization pmz args ...)
-     (let loop ([args (syntax->list #'(args ...))])
-       (if (null? args) (ret Univ)
-           (let* ([p (car args)]
-                  [pt (single-value p)]
-                  [v (cadr args)]
-                  [vt (single-value v)])
-             (match pt
-               [(tc-result1: (Param: a b))
-                (check-below vt a)
-                (loop (cddr args))]
-               [(tc-result1: t)
-                (tc-error/expr #:return (or expected (ret Univ)) "expected Parameter, but got ~a" t)
-                (loop (cddr args))]))))]
-    ;; use the additional but normally ignored first argument to make-sequence
-    ;; to provide a better instantiation
-    [(#%plain-app (~var op (id-from 'make-sequence 'racket/private/for))
-                  (~and quo (quote (i:id ...))) arg:expr)
-     #:when (andmap type-annotation (syntax->list #'(i ...)))
-     (match (single-value #'op)
-         [(tc-result1: (and t Poly?))
-          (tc-expr/check #'quo (ret Univ))
-          (tc/funapp #'op #'(quo arg)
-                     (ret (instantiate-poly t (extend (list Univ Univ)
-                                                      (map type-annotation (syntax->list #'(i ...)))
-                                                      Univ)))
-                     (list (ret Univ) (single-value #'arg))
-                     expected)])]
-    ;; special-case for not - flip the filters
-    [(#%plain-app (~or false? not) arg)
-     (match (single-value #'arg)
-       [(tc-result1: t (FilterSet: f+ f-) _)
-        (ret -Boolean (make-FilterSet f- f+))])]
-    ;; special case for (current-contract-region)'s default expansion
-    ;; just let it through without any typechecking, since module-name-fixup
-    ;; is a private function from syntax/location, so this must have been
-    ;; (quote-module-name) originally.
-    [(#%plain-app module-name-fixup src path)
-     (ret Univ)]
-    ;; special case for `delay'
-    [(#%plain-app
-      mp1
-      (#%plain-lambda ()
-        (#%plain-app mp2 (#%plain-app call-with-values (#%plain-lambda () e) list))))
-     #:declare mp1 (id-from 'make-promise 'racket/promise)
-     #:declare mp2 (id-from 'make-promise 'racket/promise)
-     (ret (-Promise (tc-expr/t #'e)))]
-    [_ (tc/app/regular form expected)])))
 
-(define (tc/app/regular form expected)
+(define (tc/app-annotated form expected)
+  (syntax-parse form
+    #:literals (#%plain-app)
+    ;; bail out immediately if we have one of these
+    [(#%plain-app rator:special-op . rands) (tc/app-regular form expected)]
+    [_ #f]))
+
+(define (tc/app-regular form expected)
   (syntax-parse form #:literals (#%plain-app)
     [(#%plain-app f . args)
      (let* ([f-ty (single-value #'f)])

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

@@ -0,0 +1,73 @@
+#lang racket/unit
+
+(require "../../utils/utils.rkt"
+         syntax/parse racket/match
+         unstable/list
+         (typecheck signatures tc-app-helper tc-funapp check-below)
+         (types abbrev utils)
+         (private type-annotation)
+         (rep type-rep filter-rep)
+         (utils tc-utils)
+
+         (for-template racket/base))
+
+
+(import tc-expr^)
+(export tc-app-special^)
+
+(define (tc/app-special form expected)
+  (syntax-parse form
+    #:literals (#%plain-app #%plain-lambda extend-parameterization quote
+                false? not call-with-values list)
+    ;; parameterize
+    [(#%plain-app extend-parameterization pmz args ...)
+     (let loop ([args (syntax->list #'(args ...))])
+       (if (null? args) (ret Univ)
+           (let* ([p (car args)]
+                  [pt (single-value p)]
+                  [v (cadr args)]
+                  [vt (single-value v)])
+             (match pt
+               [(tc-result1: (Param: a b))
+                (check-below vt a)
+                (loop (cddr args))]
+               [(tc-result1: t)
+                (tc-error/expr #:return (or expected (ret Univ)) "expected Parameter, but got ~a" t)
+                (loop (cddr args))]))))]
+    ;; use the additional but normally ignored first argument to make-sequence
+    ;; to provide a better instantiation
+    [(#%plain-app (~var op (id-from 'make-sequence 'racket/private/for))
+                  (~and quo (quote (i:id ...))) arg:expr)
+     #:when (andmap type-annotation (syntax->list #'(i ...)))
+     (match (single-value #'op)
+         [(tc-result1: (and t Poly?))
+          (tc-expr/check #'quo (ret Univ))
+          (tc/funapp #'op #'(quo arg)
+                     (ret (instantiate-poly t (extend (list Univ Univ)
+                                                      (map type-annotation (syntax->list #'(i ...)))
+                                                      Univ)))
+                     (list (ret Univ) (single-value #'arg))
+                     expected)])]
+    ;; special-case for not - flip the filters
+    [(#%plain-app (~or false? not) arg)
+     (match (single-value #'arg)
+       [(tc-result1: t (FilterSet: f+ f-) _)
+        (ret -Boolean (make-FilterSet f- f+))])]
+    ;; special case for (current-contract-region)'s default expansion
+    ;; just let it through without any typechecking, since module-name-fixup
+    ;; is a private function from syntax/location, so this must have been
+    ;; (quote-module-name) originally.
+    [(#%plain-app op src path)
+     #:declare op (id-from 'module-name-fixup 'syntax/location)
+     (ret Univ)]
+    ;; special case for `delay'
+    [(#%plain-app
+      mp1
+      (#%plain-lambda ()
+        (#%plain-app mp2 (#%plain-app call-with-values (#%plain-lambda () e) list))))
+     #:declare mp1 (id-from 'make-promise 'racket/promise)
+     #:declare mp2 (id-from 'make-promise 'racket/promise)
+     (ret (-Promise (tc-expr/t #'e)))]
+
+
+    [_ #f]))

collects/typed-racket/typecheck/typechecker.rkt

@@ -13,6 +13,7 @@
          "tc-app/tc-app-lambda.rkt"
          "tc-app/tc-app-list.rkt"
          "tc-app/tc-app-objects.rkt"
+         "tc-app/tc-app-special.rkt"
          "tc-app/tc-app-values.rkt"
          "signatures.rkt"
          "tc-if.rkt" "tc-lambda-unit.rkt" "tc-app.rkt"
@@ -24,4 +25,4 @@
 (define-values/invoke-unit/infer
   (link tc-if@ tc-lambda@ tc-app@ tc-let@ tc-expr@ check-subforms@ tc-apply@
         tc-app-hetero@ tc-app-list@ tc-app-apply@ tc-app-values@ tc-app-keywords@
-        tc-app-objects@ tc-app-eq@ tc-app-lambda@))
+        tc-app-objects@ tc-app-eq@ tc-app-lambda@ tc-app-special@))