From 6afac961722e406e080815019585d3278b4c6b49 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Tue, 29 Apr 2008 01:42:07 +0000
Subject: [PATCH] Control multiple errors with a parameter.

Don't use same code for handling type ascription and annotation.

svn: r9529

original commit: 1d21ec5ddab6264cf5df4a9f9793f4b40e77d120
---
 .../typed-scheme/private/type-annotation.ss   | 25 ++++++++++++++-----
 1 file changed, 19 insertions(+), 6 deletions(-)

diff --git a/collects/typed-scheme/private/type-annotation.ss b/collects/typed-scheme/private/type-annotation.ss
index 3b61281a..2886db75 100644
--- a/collects/typed-scheme/private/type-annotation.ss
+++ b/collects/typed-scheme/private/type-annotation.ss
@@ -8,6 +8,7 @@
          get-type/infer
          type-label-symbol
          type-ascrip-symbol
+         type-ascription
          check-type)
 
 (define type-label-symbol 'type-label)
@@ -23,7 +24,7 @@
 
 ;; get the type annotation of this syntax
 ;; syntax -> Maybe[Type]
-(define (type-annotation stx)
+(define (type-annotation stx #:infer [let-binding #f])
   (define (pt prop)
     (print-size prop)
     (if (syntax? prop)
@@ -32,13 +33,24 @@
   (cond       
     [(syntax-property stx type-label-symbol) => pt]
     [(syntax-property stx type-ascrip-symbol) => pt]
-    [(and (identifier? stx) (lookup-type stx (lambda () #f)))
+    ;; this is so that : annotation works in internal def ctxts
+    [(and let-binding (identifier? stx) (lookup-type stx (lambda () #f)))
      =>
      (lambda (t)
        (maybe-finish-register-type stx)
        t)]
     [else #f]))
 
+(define (type-ascription stx)
+  (define (pt prop)
+    (print-size prop)
+    (if (syntax? prop)
+        (parse-type prop)
+        (parse-type/id stx prop)))
+  (cond
+    [(syntax-property stx type-ascrip-symbol) => pt]
+    [else #f]))
+
 (define (log/ann stx ty)
   (printf/log "Required Annotated Variable: ~a ~a~n" (syntax-e stx) ty))
 (define (log/extra stx ty ty2)
@@ -72,10 +84,11 @@
                   [else (log/noann stx ty) ty]))
           stx ty)]      
     [(list (list stx) ty)
-     (cond [(type-annotation stx) => (lambda (ann)
-                                       (check-type stx ty ann) 
-                                       (log/extra stx ty ann)
-                                       (list ann))]
+     (cond [(type-annotation stx #:infer #t)
+            => (lambda (ann)
+                 (check-type stx ty ann) 
+                 (log/extra stx ty ann)
+                 (list ann))]
            [else (log/noann stx ty) (list ty)])]
     [else (int-err "wrong type arity - get-type/infer ~a ~a" stxs e-type)]))