From 95d93f7ebbe3794f99efc7af4503350510ae74dd Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Tue, 6 May 2008 00:42:28 +0000
Subject: [PATCH] Remove unneccessary requires. Fix let checking to use
 annotations as the expected type for the RHS. Fix bug in use of expected
 types in inference.

svn: r9674

original commit: c6f2b2d5178b85e0f961f37f2ae4f0e650c7fb3c
---
 collects/typed-scheme/private/base-env.ss     |  2 +-
 .../typed-scheme/private/type-annotation.ss   | 42 ++++++++++++-------
 collects/typed-scheme/typed-reader.ss         |  2 -
 3 files changed, 28 insertions(+), 18 deletions(-)

diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss
index a9ba1625..21ee9fd2 100644
--- a/collects/typed-scheme/private/base-env.ss
+++ b/collects/typed-scheme/private/base-env.ss
@@ -483,7 +483,7 @@
      )))
 
 (begin-for-syntax 
-  ;(printf "running base-env~n")
+  #;(printf "running base-env~n")
   (initialize-type-env initial-env)
   (initialize-others))
 
diff --git a/collects/typed-scheme/private/type-annotation.ss b/collects/typed-scheme/private/type-annotation.ss
index a30d4ff0..f18d107f 100644
--- a/collects/typed-scheme/private/type-annotation.ss
+++ b/collects/typed-scheme/private/type-annotation.ss
@@ -1,7 +1,7 @@
 #lang scheme/base
 
 (require "type-rep.ss" "parse-type.ss" "tc-utils.ss" "subtype.ss" "utils.ss" "union.ss" "resolve-type.ss"
-         "type-env.ss")
+         "type-env.ss" "type-effect-convenience.ss")
 (require (lib "plt-match.ss")
          mzlib/trace)
 (provide type-annotation
@@ -76,22 +76,34 @@
 ;; get the type annotations on this list of identifiers
 ;; if not all identifiers have annotations, return the supplied inferred type
 ;; list[identifier] type -> list[type]
-(define (get-type/infer stxs e-type)
-  (match (list stxs e-type)
-    [(list '() (Values: '())) (list)]
-    [(list (list stx ...) (Values: (list ty ...)))
-     (map (lambda (stx ty)
-            (cond [(type-annotation stx) => (lambda (ann) (check-type stx ty ann) (log/extra stx ty ann) ann)]
-                  [else (log/noann stx ty) ty]))
-          stx ty)]      
-    [(list (list stx) ty)
+(define (get-type/infer stxs expr tc-expr tc-expr/check)
+  (match stxs
+    ['() 
+     (tc-expr/check expr (-values null))
+     (list)]          
+    [(list stx)
      (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)]))
+                 (list (tc-expr/check expr ann)))]
+           [else (list (tc-expr expr))])]
+    [(list stx ...)
+     (let ([anns (for/list ([s stxs]) (type-annotation s #:infer #t))])
+       (if (for/and ([a anns]) a)
+           (begin (tc-expr/check expr (-values anns)) anns)
+           (let ([ty (tc-expr expr)])
+             (match ty
+               [(Values: tys) 
+                (if (not (= (length stxs) (length tys)))
+                    (tc-error/delayed #:ret (map (lambda _ (Un)) stxs) 
+                                      "Expression should produce ~a values, but produces ~a values of types ~a"
+                                      (length stxs) (length tys) (stringify tys))
+                    (map (lambda (stx ty)
+                           (cond [(type-annotation stx #:infer #t) => (lambda (ann) (check-type stx ty ann) (log/extra stx ty ann) ann)]
+                                 [else (log/noann stx ty) ty]))
+                         stxs tys))]
+               [ty (tc-error/delayed #:ret (map (lambda _ (Un)) stxs) 
+                                     "Expression should produce ~a values, but produces one values of type "
+                                     (length stxs) ty)]))))]))
 
 
 ;; check that e-type is compatible with ty in context of stx
diff --git a/collects/typed-scheme/typed-reader.ss b/collects/typed-scheme/typed-reader.ss
index 7a14a18b..ebce7135 100644
--- a/collects/typed-scheme/typed-reader.ss
+++ b/collects/typed-scheme/typed-reader.ss
@@ -1,7 +1,5 @@
 #lang scheme/base
 
-(require (for-template "private/prims.ss"))  
-
 ;; Provides raise-read-error and raise-read-eof-error
 (require syntax/readerr)