From b4d568a84dfc6bf97b3465b0c155f8e95839e73a Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Sun, 13 Jun 2010 14:50:33 -0400
Subject: [PATCH] Generate -> instead of ->* when required by case->.

Closes PR 10977.

original commit: cf5c74a2ca36a951d7cbeac61e58235f493291dd
---
 .../tests/typed-scheme/fail/all-bad-syntax.rkt    |  4 ++--
 .../typed-scheme/succeed/provide-case-rest.rkt    |  8 ++++++++
 collects/typed-scheme/private/type-contract.rkt   | 15 ++++++++++-----
 3 files changed, 20 insertions(+), 7 deletions(-)
 create mode 100644 collects/tests/typed-scheme/succeed/provide-case-rest.rkt

diff --git a/collects/tests/typed-scheme/fail/all-bad-syntax.rkt b/collects/tests/typed-scheme/fail/all-bad-syntax.rkt
index c076f4d3..daf10f54 100644
--- a/collects/tests/typed-scheme/fail/all-bad-syntax.rkt
+++ b/collects/tests/typed-scheme/fail/all-bad-syntax.rkt
@@ -1,5 +1,5 @@
 #;
-(exn-pred 1)
+(exn-pred 2)
 #lang typed-scheme
 
 (require scheme/list)
@@ -22,4 +22,4 @@
                         (list key)
                         (rt)))
               #;empty))
-(+ 'foo)
\ No newline at end of file
+(+ 'foo)
diff --git a/collects/tests/typed-scheme/succeed/provide-case-rest.rkt b/collects/tests/typed-scheme/succeed/provide-case-rest.rkt
new file mode 100644
index 00000000..02681eb3
--- /dev/null
+++ b/collects/tests/typed-scheme/succeed/provide-case-rest.rkt
@@ -0,0 +1,8 @@
+#lang typed/racket
+
+(provide foo)
+
+(define foo
+ (case-lambda:
+   (((x : Number)) x)
+   (((x : Number) (y : Number) z : Number *) y)))
diff --git a/collects/typed-scheme/private/type-contract.rkt b/collects/typed-scheme/private/type-contract.rkt
index c7cee8a1..914043ce 100644
--- a/collects/typed-scheme/private/type-contract.rkt
+++ b/collects/typed-scheme/private/type-contract.rkt
@@ -64,7 +64,7 @@
           [(Function: arrs)
            (when flat? (exit (fail)))
            (let ()           
-             (define (f a)
+             (define ((f [case-> #f]) a)
                (define-values (dom* opt-dom* rngs* rst)
                  (match a
                    ;; functions with no filters or objects
@@ -91,16 +91,21 @@
                             [(list r) r]
                             [_ #`(values #,@rngs*)])]
                     [rst* rst])
-                 (if (or rst (pair? (syntax-e #'(opt-dom* ...))))
-                     #'((dom* ...) (opt-dom* ...) #:rest (listof rst*) . ->* . rng*)
-                     #'(dom* ... . -> . rng*))))
+		 ;; Garr, I hate case->!
+		 (if (and (pair? (syntax-e #'(opt-dom* ...))) case->)
+		     (exit (fail))
+		     (if (or rst (pair? (syntax-e #'(opt-dom* ...))))
+			 (if case->
+			     #'(dom* ... #:rest (listof rst*) . -> . rng*)
+			     #'((dom* ...) (opt-dom* ...) #:rest (listof rst*) . ->* . rng*))
+			 #'(dom* ... . -> . rng*)))))
              (unless (no-duplicates (for/list ([t arrs])
                                       (match t
                                         [(arr: dom _ _ _ _) (length dom)]
                                         ;; is there something more sensible here?
                                         [(top-arr:) (int-err "got top-arr")])))
                (exit (fail)))
-             (match (map f arrs)
+             (match (map (f (not (= 1 (length arrs)))) arrs)
                [(list e) e]
                [l #`(case-> #,@l)]))]
           [_ (int-err "not a function" f)]))