From 6d05e41a248372aa3eef52bfa01cbdbb301dd79a Mon Sep 17 00:00:00 2001
From: Eric Dobson <eric.n.dobson@gmail.com>
Date: Tue, 14 Jan 2014 22:52:18 -0800
Subject: [PATCH] Make numeric contracts in unions better.

---
 .../typed-racket/private/type-contract.rkt           | 12 ++++++++----
 .../tests/typed-racket/unit-tests/contract-tests.rkt | 12 ++++++++----
 2 files changed, 16 insertions(+), 8 deletions(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt
index ad361c8f06..ec85ccb4a8 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt
@@ -8,7 +8,8 @@
  (rep type-rep filter-rep object-rep)
  (utils tc-utils)
  (env type-name-env)
- (types resolve)
+ (rep rep-utils)
+ (types resolve union)
  (prefix-in t: (types abbrev numeric-tower))
  (private parse-type syntax-properties)
  racket/match racket/syntax racket/list
@@ -30,7 +31,7 @@
                              (#:typed-side boolean?) . c:->* . (c:or/c a static-contract?)))]))
 
 (provide type->contract define/fixup-contract? change-contract-fixups
-         type->contract-fail)
+         type->contract-fail any-wrap/sc)
 
 ;; These check if either the define form or the body form has the syntax
 ;; property. Normally the define form will have the property but lifting an
@@ -197,13 +198,16 @@
         [(Univ:) (if (from-typed? typed-side) any-wrap/sc any/sc)]
         [(Mu: var (Union: (list (Value: '()) (Pair: elem-ty (F: var)))))
          (listof/sc (t->sc elem-ty))]
-        [t (=> fail) (or (numeric-type->static-contract t) (fail))]
         [(Base: sym cnt _ _)
          (flat/sc #`(flat-named-contract '#,sym (flat-contract-predicate #,cnt)) sym)]
         [(Refinement: par p?)
          (and/sc (t->sc par) (flat/sc p?))]
         [(Union: elems)
-         (apply or/sc (map t->sc elems))]
+         (define-values (numeric non-numeric) (partition (λ (t) (equal? 'number (Type-key t))) elems ))
+         (define numeric-sc (numeric-type->static-contract (apply Un numeric)))
+         (if numeric-sc
+             (apply or/sc numeric-sc (map t->sc non-numeric))
+             (apply or/sc (map t->sc elems)))]
         [(and t (Function: _)) (t->sc/fun t)]
         [(Set: t) (set/sc (t->sc t))]
         [(Sequence: ts) (apply sequence/sc (map t->sc ts))]
diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/contract-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/contract-tests.rkt
index 0d0c1c3069..d8bd31e8d9 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/contract-tests.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/contract-tests.rkt
@@ -6,6 +6,7 @@
          (private type-contract)
          (rep type-rep)
          (types abbrev numeric-tower union)
+         (static-contracts combinators optimize)
          (submod typed-racket/private/type-contract numeric-contracts)
          rackunit)
 (provide tests)
@@ -26,10 +27,11 @@
     (let ([t e-t] [sc e-sc])
       (with-check-info (['type t] ['expected sc])
         (define actual
-          (type->static-contract
-            t
-            (λ (#:reason [reason #f])
-              (fail-check (or reason "Type could not be converted to contract")))))
+          (optimize
+            (type->static-contract
+              t
+              (λ (#:reason [reason #f])
+                (fail-check (or reason "Type could not be converted to contract"))))))
         (with-check-info (['actual actual])
           (unless (equal? actual sc)
             (fail-check "Static contract didn't match expected")))))))
@@ -122,5 +124,7 @@
 
               (t-sc -Number number/sc)
               (t-sc -Integer integer/sc)
+              (t-sc (-lst Univ) (listof/sc any-wrap/sc))
+              (t-sc (Un (-lst Univ) -Number) (or/sc number/sc (listof/sc any-wrap/sc)))
 
               ))