From b0f707b576938f05e121d3b8f64bd61f371437f0 Mon Sep 17 00:00:00 2001
From: Andrew Kent <andmkent@iu.edu>
Date: Sat, 7 Jan 2017 21:17:21 -0500
Subject: [PATCH] fix Union-fmap bug that skipped some base arg results

---
 .../typed-racket/rep/type-rep.rkt             | 55 +++++++++----------
 .../unit-tests/remove-intersect-tests.rkt     | 16 ++++++
 2 files changed, 42 insertions(+), 29 deletions(-)

diff --git a/typed-racket-lib/typed-racket/rep/type-rep.rkt b/typed-racket-lib/typed-racket/rep/type-rep.rkt
index 323b3bea..c76249c6 100644
--- a/typed-racket-lib/typed-racket/rep/type-rep.rkt
+++ b/typed-racket-lib/typed-racket/rep/type-rep.rkt
@@ -647,7 +647,6 @@
    (cond
      [(set-member? elems Univ) Univ]
      [else
-      (set-remove! elems -Bottom)
       (match (set-count elems)
         [0 base]
         [1 #:when (Bottom? base) (set-first elems)]
@@ -715,41 +714,39 @@
   (define nbits #b0)
   (define ts '())
   (define elems (mutable-set))
-  ;; process a Base element
-  (define (process-base! numeric? bits)
+  ;; add a Base element to the union
+  (define (add-base! numeric? bits)
     (cond
       [numeric? (set! nbits (nbits-union nbits bits))]
       [else (set! bbits (bbits-union bbits bits))]))
-  ;; process a BaseUnion element
-  (define (process-base-union! bbits* nbits*)
+  ;; add a BaseUnion to the union
+  (define (add-base-union! bbits* nbits*)
     (set! nbits (nbits-union nbits nbits*))
     (set! bbits (bbits-union bbits bbits*)))
-  ;; process a type from the 'base' field of a Union
-  (define (process-any-base! b)
+  ;; add the type from a 'base' field of a Union to this union
+  (define (add-any-base! b)
     (match b
-      [(Base-bits: numeric? bits) (process-base! numeric? bits)]
-      [(BaseUnion: bbits* nbits*) (process-base-union! bbits* nbits*)]
-      ;; else Bottom
-      [_ (void)]))
-  ;; process a list of types
-  (define (process! args)
-    (for* ([arg (in-list args)]
-           [arg (in-value (f arg))])
-      (match arg
-        [(Base-bits: numeric? bits) (process-base! numeric? bits)]
-        [(BaseUnion: bbits* nbits*) (process-base-union! bbits* nbits*)]
-        [(Union: m* b* ts* _)
-         (set! m (mask-union m m*))
-         (process-any-base! b*)
-         (set! ts (append ts* ts))
-         (for ([t* (in-list ts*)])
-           (set-add! elems t*))]
-        [_ (set! m (mask-union m (mask arg)))
-           (set! ts (cons arg ts))
-           (set-add! elems arg)])))
+      [(? Bottom?) (void)]
+      [(Base-bits: numeric? bits) (add-base! numeric? bits)]
+      [(BaseUnion: bbits* nbits*) (add-base-union! bbits* nbits*)]))
+  ;; apply 'f' to a type and add it to the union appropriately
+  (define (process! arg)
+    (match (f arg)
+      [(? Bottom?) (void)]
+      [(Base-bits: numeric? bits) (add-base! numeric? bits)]
+      [(BaseUnion: bbits* nbits*) (add-base-union! bbits* nbits*)]
+      [(Union: m* b* ts* _)
+       (set! m (mask-union m m*))
+       (add-any-base! b*)
+       (set! ts (append ts* ts))
+       (for ([t* (in-list ts*)])
+         (set-add! elems t*))]
+      [t (set! m (mask-union m (mask t)))
+         (set! ts (cons t ts))
+         (set-add! elems t)]))
   ;; process the input arguments
-  (process-any-base! (f base-arg))
-  (process! args)
+  (process! base-arg)
+  (for-each process! args)
   ;; construct a BaseUnion (or Base or Bottom) based on the
   ;; Base data gathered during processing
   (define bs (make-BaseUnion bbits nbits))
diff --git a/typed-racket-test/unit-tests/remove-intersect-tests.rkt b/typed-racket-test/unit-tests/remove-intersect-tests.rkt
index 15b8833a..01574146 100644
--- a/typed-racket-test/unit-tests/remove-intersect-tests.rkt
+++ b/typed-racket-test/unit-tests/remove-intersect-tests.rkt
@@ -50,6 +50,22 @@
    [(Un (-val "one") (-val "two")) (Un (-val "one") (-val 1)) (-val "one")]
    ;; intersection cases
    [(-v a) -String (-unsafe-intersect (-v a) -String)]
+   [(-v a)
+    (Un -String (-pair Univ Univ))
+    (Un (-unsafe-intersect (-v a) -String)
+        (-unsafe-intersect (-v a) (-pair Univ Univ)))]
+   [(-v a)
+    (Un -String -Symbol (-pair Univ Univ))
+    (Un (-unsafe-intersect (-v a) -String)
+        (-unsafe-intersect (-v a) -Symbol)
+        (-unsafe-intersect (-v a) (-pair Univ Univ)))]
+   [(-v a)
+    (Un -String -Symbol -Zero -One (-pair Univ Univ))
+    (Un (-unsafe-intersect (-v a) -String)
+        (-unsafe-intersect (-v a) -Symbol)
+        (-unsafe-intersect (-v a) -Zero)
+        (-unsafe-intersect (-v a) -One)
+        (-unsafe-intersect (-v a) (-pair Univ Univ)))]
    [-String (-v a) (-unsafe-intersect (-v a) -String)]
    [(-> -Number -Number) (-> -String -String) (-unsafe-intersect (-> -Number -Number)
                                                                  (-> -String -String))]