Better type annotation support.

- Delay more errors for additional reporting.
 - Don't re-check expressions that were checked for inference.
 Closes PR 10098.

collects/tests/typed-scheme/fail/dup-ann.rkt

@@ -0,0 +1,18 @@
+#;
+(exn-pred 4)
+#lang typed/racket
+(: bar : (String -> String))
+(: bar : (Number -> Number))
+(define (bar x)
+  (+ x 1))
+
+
+(define: (foo) : Number
+  (: bar : (Number -> Number))
+  (define: (bar [x : Number]) : Number
+    (+ x 1))
+  (bar 5))
+
+
+(: baz Number)
+(define: baz : Number 7)

collects/tests/typed-scheme/fail/internal-ann.rkt

@@ -0,0 +1,8 @@
+
+#lang typed/scheme/base
+
+(define (f x)
+ (: g (Integer -> Integer))
+ (define (g x)
+   (+ x 2))
+ (g x))

collects/tests/typed-scheme/xfail/cl-expected.rkt

@@ -0,0 +1,8 @@
+#lang typed/scheme
+
+
+(: add (case-lambda (Integer -> Integer) (Integer Integer -> Integer)))
+(define add
+  (case-lambda
+    [(x) (add x 0)]
+    [(x y) (+ x y)]))

collects/typed-scheme/env/type-env.rkt

@@ -26,16 +26,19 @@
   (free-id-table-set! the-mapping id type))
 
 (define (register-type-if-undefined id type)
-  (if (free-id-table-ref the-mapping id (lambda _ #f))
+  (cond [(free-id-table-ref the-mapping id (lambda _ #f))
-      (tc-error/stx id "Duplicate type annotation for ~a" (syntax-e id))
+         => (lambda (e)
-      (register-type id type)))
+              (tc-error/expr #:stx id "Duplicate type annotation for ~a" (syntax-e id))
+              (when (box? e)
+                (free-id-table-set! the-mapping id (unbox e))))]
+        [else (register-type id type)]))
 
 ;; add a single type to the mapping
 ;; identifier type -> void
 (define (register-type/undefined id type)
   ;(printf "register-type/undef ~a~n" (syntax-e id))
   (if (free-id-table-ref the-mapping id (lambda _ #f))
-      (tc-error/stx id "Duplicate type annotation for ~a" (syntax-e id))
+      (void (tc-error/expr #:stx id "Duplicate type annotation for ~a" (syntax-e id)))
       (free-id-table-set! the-mapping id (box type))))
 
 ;; add a bunch of types to the mapping
@@ -61,7 +64,8 @@
 
 (define (finish-register-type id)
   (unless (maybe-finish-register-type id)
-    (tc-error/stx id "Duplicate defintion for ~a" (syntax-e id))))
+    (tc-error/expr #:stx id "Duplicate defintion for ~a" (syntax-e id)))
+  (void))
 
 (define (check-all-registered-types)
   (free-id-table-for-each 
@@ -69,11 +73,13 @@
    (lambda (id e) 
      (when (box? e) 
        (let ([bnd (identifier-binding id)])
-         (tc-error/stx id "Declaration for ~a provided, but ~a ~a" 
+         (tc-error/expr #:stx id
-                       (syntax-e id) (syntax-e id)
+                        "Declaration for ~a provided, but ~a ~a" 
-                       (cond [(eq? bnd 'lexical) "is a lexical binding"] ;; should never happen
+                        (syntax-e id) (syntax-e id)
-                             [(not bnd) "has no definition"] 
+                        (cond [(eq? bnd 'lexical) "is a lexical binding"] ;; should never happen
-                             [else "is defined in another module"])))))))
+                              [(not bnd) "has no definition"] 
+                              [else "is defined in another module"]))))
+     (void))))
 
 ;; map over the-mapping, producing a list
 ;; (id type -> T) -> listof[T]  

collects/typed-scheme/private/type-annotation.rkt

@@ -37,7 +37,11 @@
 ;; is let-binding really necessary? - remember to record the bugs!
 (define (type-annotation stx #:infer [let-binding #f])
   (define (pt prop)
-    #;(print-size prop)
+    (when (and (identifier? stx) 
+               let-binding
+               (lookup-type stx (lambda () #f)))
+      (maybe-finish-register-type stx)
+      (tc-error/expr #:stx stx "Duplicate type annotation for ~a" (syntax-e stx)))
     (if (syntax? prop)
         (parse-type prop)
         (parse-type/id stx prop)))
@@ -92,14 +96,14 @@
 ;; get the type annotation of this identifier, otherwise error
 ;; if #:default is provided, return that instead of error
 ;; identifier #:default Type -> Type
-(define (get-type stx #:default [default #f])
+(define (get-type stx #:default [default #f] #:infer [infer #t])
   (parameterize
       ([current-orig-stx stx])
     (cond
-      [(type-annotation stx #:infer #t)]
+      [(type-annotation stx #:infer infer)]
       [default default]
       [(not (syntax-original? stx))
-       (tc-error "untyped var: ~a" (syntax-e stx))]
+       (tc-error "untyped variable: ~a" (syntax-e stx))]
       [else
        (tc-error "no type information on variable ~a" (syntax-e stx))])))
 

collects/typed-scheme/typecheck/tc-let-unit.rkt

@@ -108,7 +108,7 @@
                   [(begin (quote-syntax (define-type-alias-internal nm ty)) (#%plain-app values))
                    (register-resolved-type-alias #'nm (parse-type #'ty))]
                   [(begin (quote-syntax (:-internal nm ty)) (#%plain-app values))
-                   (register-type/undefined #'nm (parse-type #'ty))]
+                   (register-type-if-undefined #'nm (parse-type #'ty))]
                   [_ (void)]))
               names
               exprs)

collects/typed-scheme/typecheck/tc-toplevel.rkt

@@ -3,7 +3,7 @@
 
 (require (rename-in "../utils/utils.rkt" [infer r:infer]))
 (require syntax/kerncase
-	 unstable/list unstable/syntax syntax/parse
+	 unstable/list unstable/syntax syntax/parse unstable/debug
          mzlib/etc
          scheme/match
          "signatures.rkt"
@@ -14,7 +14,7 @@
          (types utils convenience)
          (private parse-type type-annotation type-contract)
          (env type-env init-envs type-name-env type-alias-env lexical-env)
-	 unstable/mutated-vars
+	 unstable/mutated-vars syntax/id-table
          (utils tc-utils)
          "provide-handling.rkt"
          "def-binding.rkt"
@@ -27,6 +27,8 @@
 (import tc-expr^ check-subforms^)
 (export typechecker^)
 
+(define unann-defs (make-free-id-table))
+
 (define (tc-toplevel/pass1 form)
   ;(printf "form-top: ~a~n" form)
   ;; first, find the mutated variables:
@@ -115,7 +117,7 @@
          (cond
            ;; if all the variables have types, we stick them into the environment
            [(andmap (lambda (s) (syntax-property s 'type-label)) vars)        
-            (let ([ts (map get-type vars)])
+            (let ([ts (map (λ (x) (get-type x #:infer #f)) vars)])
               (for-each register-type-if-undefined vars ts)
               (map make-def-binding vars ts))]
            ;; if this already had an annotation, we just construct the binding reps
@@ -123,16 +125,13 @@
             (for-each finish-register-type vars)
             (map (lambda (s) (make-def-binding s (lookup-type s))) vars)]
            ;; special case to infer types for top level defines - should handle the multiple values case here
-           [(and (= 1 (length vars)) 
+           [(= 1 (length vars))
-                 (with-handlers ([exn:fail? (lambda _ #f)])
+            (match (tc-expr #'expr)
-                   (save-errors!)
+              [(tc-result1: t)
-                   (begin0 (tc-expr #'expr)
+               (register-type (car vars) t)
-                           (restore-errors!))))
+               (free-id-table-set! unann-defs (car vars) #t)
-            => (match-lambda 
+               (list (make-def-binding (car vars) t))]
-                 [(tc-result1: t)
+              [t (int-err "~a is not a tc-result" t)])]
-                  (register-type (car vars) t)
-                  (list (make-def-binding (car vars) t))]
-                 [t (int-err "~a is not a tc-result" t)])]
            [else
             (tc-error "Untyped definition : ~a" (map syntax-e vars))]))]
       
@@ -186,10 +185,12 @@
       
       ;; definitions just need to typecheck their bodies
       [(define-values (var ...) expr)
-       (begin (let* ([vars (syntax->list #'(var ...))]
+       (let* ([vars (syntax->list #'(var ...))]
-                     [ts (map lookup-type vars)])
+              [ts (map lookup-type vars)])
-                (tc-expr/check #'expr (ret ts)))
+         (unless (for/and ([v (syntax->list #'(var ...))])
-              (void))]
+                   (free-id-table-ref unann-defs v (lambda _ #f)))
+           (tc-expr/check #'expr (ret ts)))
+         (void))]
       
       ;; to handle the top-level, we have to recur into begins
       [(begin) (void)]