From d5b1f76319d824f444fd7ef111e9242f74ea143d Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Fri, 31 Aug 2012 10:26:23 -0400
Subject: [PATCH] Simplifying case-> to union is only safe for 1-argument
 functions.

Closes PR 13002.

original commit: ab5403d1ede34b3df761e82ba64f991089cadd81
---
 .../typed-racket/fail/case-union-subtype.rkt  | 20 +++++++++++++++++++
 collects/typed-racket/types/subtype.rkt       |  7 ++++---
 2 files changed, 24 insertions(+), 3 deletions(-)
 create mode 100644 collects/tests/typed-racket/fail/case-union-subtype.rkt

diff --git a/collects/tests/typed-racket/fail/case-union-subtype.rkt b/collects/tests/typed-racket/fail/case-union-subtype.rkt
new file mode 100644
index 00000000..8d237b9d
--- /dev/null
+++ b/collects/tests/typed-racket/fail/case-union-subtype.rkt
@@ -0,0 +1,20 @@
+#lang typed/racket #:no-optimize
+
+
+(define-type T
+     (case->
+       (String Symbol -> Symbol)
+       (Symbol String -> Symbol)))
+
+(define-type S ((U String Symbol) (U String Symbol) -> Symbol))
+
+(: f T)
+(define (f x y)
+  (if (and (string? x) (string? y))
+      "BROKEN"
+      'ok))
+
+(: g S)
+(define g f)
+
+(g "Hello" "World")
diff --git a/collects/typed-racket/types/subtype.rkt b/collects/typed-racket/types/subtype.rkt
index 58fbb2d5..38a925af 100644
--- a/collects/typed-racket/types/subtype.rkt
+++ b/collects/typed-racket/types/subtype.rkt
@@ -195,7 +195,7 @@
     [(list (and a1 (arr: dom1 rng1 #f #f '())) (arr: dom rng #f #f '()) ...)
      (cond
        [(null? dom) (make-arr dom1 rng1 #f #f '())]
-       [(not (apply = (length dom1) (map length dom))) #f]
+       [(not (apply = 1 (length dom1) (map length dom))) #f]
        [(not (for/and ([rng2 (in-list rng)]) (type-equal? rng1 rng2)))
         #f]
        [else (make-arr (apply map Un (cons dom1 dom)) rng1 #f #f '())])]
@@ -310,10 +310,11 @@
                (subtype* A0 -Nat t*)]
               [((Hashtable: k v) (Sequence: (list k* v*)))
                (subtypes* A0 (list k v) (list k* v*))]
-              ;; special-case for case-lambda/union
+              ;; special-case for case-lambda/union with only one argument              
               [((Function: arr1) (Function: (list arr2)))
                (when (null? arr1) (fail! s t))
-               (or (arr-subtype*/no-fail A0 (combine-arrs arr1) arr2)
+               (define comb (combine-arrs arr1))
+               (or (and comb (arr-subtype*/no-fail A0 comb arr2))
                    (supertype-of-one/arr A0 arr2 arr1)
                    (fail! s t))]
               ;; case-lambda