From 2c03aae9f14d51b0fa61b730ea00c56eba49f34d Mon Sep 17 00:00:00 2001
From: Eric Dobson <eric.n.dobson@gmail.com>
Date: Wed, 15 Jan 2014 09:28:43 -0800
Subject: [PATCH] Make case-> reduce to -> when it can.

original commit: f2431bd819b4458cd6b39e3258478f4907d5bf5b
---
 .../combinators/case-lambda.rkt               |  2 +-
 .../static-contracts/optimize.rkt             | 31 +++++++++++++++++++
 .../static-contract-optimizer-tests.rkt       | 16 ++++++++++
 3 files changed, 48 insertions(+), 1 deletion(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/case-lambda.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/case-lambda.rkt
index 92a2a3b8..3ef102c8 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/case-lambda.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/case-lambda.rkt
@@ -62,7 +62,7 @@
 (define-match-expander case->/sc:
   (syntax-parser
     [(_ args ...)
-     #'(case->/combinator (list args ...))]))
+     #'(case-combinator (list args ...))]))
 
 (define-match-expander arr/sc:
   (syntax-parser
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt
index 0bee1d0f..a20f9f5a 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/optimize.rkt
@@ -71,6 +71,37 @@
       [else sc])]
 
 
+    ;; case->/sc cases
+    [(case->/sc: arrs ...)
+     (match arrs
+       ;; We can turn case->/sc contracts int ->* contracts in some cases.
+       [(list (arr/sc: args #f ranges) ...) (=> fail)
+        ;; All results must have the same range
+        (unless (equal? (set-count (apply set ranges)) 1)
+          (fail))
+        (define sorted-args (sort args (λ (l1 l2) (< (length l1) (length l2)))))
+        (define shortest-args (first sorted-args))
+        (define longest-args (last sorted-args))
+        ;; The number of arguments must increase by 1 with no gaps
+        (unless (equal? (map length sorted-args)
+                        (range (length shortest-args)
+                               (add1 (length longest-args))))
+          (fail))
+        ;; All arities must be prefixes of the longest arity
+        (unless (for/and ([args (in-list sorted-args)])
+                  (equal? args (take longest-args (length args))))
+          (fail))
+        ;; All the checks passed
+        (function/sc
+          (take longest-args (length shortest-args))
+          (drop longest-args (length shortest-args))
+          empty
+          empty
+          #f
+          (first ranges))]
+       [else sc])]
+
+
 
     [else sc]))
 
diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt
index 947aa6fd..c84a9459 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-optimizer-tests.rkt
@@ -275,4 +275,20 @@
       #:pos any/sc
       #:neg (cons/sc any/sc list?/sc))
 
+    (check-optimize
+      (case->/sc
+        (list
+          (arr/sc empty #f (list set?/sc))
+          (arr/sc (list identifier?/sc) #f (list (listof/sc set?/sc)))))
+      #:pos  (function/sc (list)
+                          (list identifier?/sc)
+                          (list)
+                          (list)
+                          #f
+                          #f)
+      #:neg (case->/sc
+              (list
+                (arr/sc empty #f (list set?/sc))
+                (arr/sc (list any/sc) #f (list (listof/sc set?/sc))))))
+
     ))