From 077574cfe1192c2004b2b1528c103f6b58524359 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Tue, 28 Apr 2009 14:48:53 +0000
Subject: [PATCH] more fixes for lambda with expected

svn: r14639
---
 collects/typed-scheme/test.ss                     |  5 +++++
 collects/typed-scheme/typecheck/tc-expr-unit.ss   | 14 ++++++++++++--
 collects/typed-scheme/typecheck/tc-lambda-unit.ss |  5 ++++-
 collects/typed-scheme/types/printer.ss            |  3 ++-
 collects/typed-scheme/utils/utils.ss              |  2 +-
 5 files changed, 24 insertions(+), 5 deletions(-)

diff --git a/collects/typed-scheme/test.ss b/collects/typed-scheme/test.ss
index bf99f4870f..ea249073ad 100644
--- a/collects/typed-scheme/test.ss
+++ b/collects/typed-scheme/test.ss
@@ -38,4 +38,9 @@
   (define: (z [x : Number]) : Any w)
   (define: (w) : Any z)
   z)
+(case-lambda: [() 1]
+              [([x : Number]) x])
+;; Error
+#;#{(case-lambda: [() 1]
+                [([x : Number]) x]) :: String}
 
diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss
index aaee854b5e..075cc095c0 100644
--- a/collects/typed-scheme/typecheck/tc-expr-unit.ss
+++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss
@@ -130,6 +130,7 @@
 
 ;; check-below : (/\ (Results Type -> Result)
 ;;                   (Results Results -> Result)
+;;                   (Type Results -> Type)
 ;;                   (Type Type -> Type))
 (define (check-below tr1 expected)
   (match* (tr1 expected)
@@ -137,10 +138,19 @@
      (unless (andmap subtype t1 t2)
        (tc-error/expr "Expected ~a, but got ~a" t2 t1))
      expected]
-    [((tc-result1: t1) (? Type? t2))
+    [((tc-result1: t1 f o) (? Type? t2))
      (unless (subtype t1 t2)
        (tc-error/expr "Expected ~a, but got ~a" t2 t1))
-     (ret expected)]
+     (ret t2 f o)]
+    [((? Type? t1) (tc-result1: t2 (FilterSet: (list) (list)) (Empty:)))
+     (unless (subtype t1 t2)
+       (tc-error/expr "Expected ~a, but got ~a" t2 t1))
+     t1]
+    [((? Type? t1) (tc-result1: t2 f o))
+     (if (subtype t1 t2)
+         (tc-error/expr "Expected result with filter ~a and object ~a, got ~a" f o t1)
+         (tc-error/expr "Expected ~a, but got ~a" t2 t1))
+     t1]
     [((? Type? t1) (? Type? t2))
      (unless (subtype t1 t2)
        (tc-error/expr "Expected ~a, but got ~a" t2 t1))
diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss
index 969c7fc8f5..ae4f4296dd 100644
--- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss
+++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss
@@ -202,7 +202,10 @@
       (go (syntax->list formals) (syntax->list bodies) null null null)))
 
 (define (tc/mono-lambda/type formals bodies expected)
-  (make-Function (map lam-result->type (tc/mono-lambda formals bodies expected))))
+  (define t (make-Function (map lam-result->type (tc/mono-lambda formals bodies expected))))
+  (if expected 
+      (check-below t expected)
+      t))
 
 ;; tc/plambda syntax syntax-list syntax-list type -> Poly
 ;; formals and bodies must by syntax-lists
diff --git a/collects/typed-scheme/types/printer.ss b/collects/typed-scheme/types/printer.ss
index 5aa5fcc454..cc5b3673c3 100644
--- a/collects/typed-scheme/types/printer.ss
+++ b/collects/typed-scheme/types/printer.ss
@@ -150,7 +150,8 @@
     [(Union: elems) (fp "~a" (cons 'U elems))]
     [(Pair: l r) (fp "(Pair ~a ~a)" l r)]
     [(F: nm) (fp "~a" nm)]   
-    [(Values: (list v)) (fp "~a" v)]
+    ;; FIXME
+    ;[(Values: (list v)) (fp "~a" v)]
     [(Values: (list v ...)) (fp "~a" (cons 'values v))]
     [(ValuesDots: v dty dbound) (fp "~a" (cons 'values (append v (list dty '... dbound))))]
     [(Param: in out) 
diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss
index a321e257d2..a2503c86e9 100644
--- a/collects/typed-scheme/utils/utils.ss
+++ b/collects/typed-scheme/utils/utils.ss
@@ -190,7 +190,7 @@ at least theoretically.
       [(_ val)
        #'(? (lambda (x) (equal? val x)))])))
 
-(define-for-syntax printing? #f)
+(define-for-syntax printing? #t)
 
 (define-syntax-rule (defprinter t ...)
   (begin