First pass at CTYP-61

xortle · Sep 15, 2013 · c675662 · c675662
1 parent 404e960
commit c675662
Showing 1 changed file with 71 additions and 54 deletions.
diff --git a/src/main/clojure/clojure/core/typed/check.clj b/src/main/clojure/clojure/core/typed/check.clj
@@ -2084,6 +2084,63 @@
 ;                      )
 ;                    hmap (.types ^HeterogeneousMap update-path-t)))
 
+;supporting assoc function
+(defn update-assoc-hmap [{:keys [expr fexpr target keyvals keypair-types]} init-hmap]
+  (reduce (fn [hmap [kt vt]]
+    (let [is-vec (sub/subtype? hmap (c/RClass-of IPersistentVector [r/-any]))
+          is-map (sub/subtype? hmap (c/RClass-of IPersistentMap [r/-any r/-any]))]
+      ;check that hmap is either a vector or map
+      (assert (and (not= is-vec is-map)
+                   (or is-vec is-map)))
+      (cond
+        ;keep hmap is keyword key and already hmap
+        (and (r/HeterogeneousMap? hmap)
+             (c/keyword-value? kt))
+        (assoc-in hmap [:types kt] vt)
+
+        ;updating a base record key must be a subtype of the record's
+        ;corresponding field, otherwise just ignore any interesting results.
+        (r/Record? hmap)
+        (let [^DataType hmap hmap
+              ^Value kt kt
+              field-type (when (c/keyword-value? kt)
+                           (get (.fields hmap) (symbol (name (.val kt)))))]
+          (when-not (and field-type
+                         (sub/subtype? vt field-type))
+            (u/tc-delayed-error
+              (str "Cannot associate key " (prs/unparse-type kt)
+                   " with value type " (prs/unparse-type vt)
+                   " to record " (prs/unparse-type hmap)
+                   "\n\n" "in: " (u/emit-form-fn expr))))
+          hmap)
+
+        ;keep hvector if number Value key and already hvector
+        (and (r/HeterogeneousVector? hmap)
+             (c/number-value? kt))
+        (let [^Value kt kt] 
+          (assert (integer? (.val kt))
+                  (str "Must associate integer keys to vector, given: " (:val kt)))
+          (assoc-in hmap [:types (.val kt)] vt))
+
+        ;otherwise just make normal map if already a map, or normal vec if already a vec
+        is-map (ret-t 
+                 (check-funapp fexpr (cons target keyvals)
+                               (ret 
+                                 (prs/parse-type '(All [b c] 
+                                                       [(clojure.lang.IPersistentMap b c) b c -> 
+                                                        (clojure.lang.IPersistentMap b c)])))
+                               (mapv ret [hmap kt vt])
+                               nil))
+        :else (ret-t 
+                (check-funapp fexpr (cons target keyvals)
+                              (ret 
+                                (prs/parse-type '(All [c] 
+                                                      [(clojure.lang.IPersistentVector c) c -> 
+                                                       (clojure.lang.IPersistentVector c)])))
+                              (mapv ret [hmap vt])
+                              nil)))))
+  init-hmap keypair-types))
+
 ;assoc
 ; TODO handle unions of hmaps as the target
 ; FIXME needs more tests
@@ -2119,60 +2176,20 @@
 
             ; TODO handle unions of hmaps without promoting to IPersistentMap
             new-hmaps (mapv (fn [init-hmap]
-                              (reduce (fn [hmap [kt vt]]
-                                        (let [is-vec (sub/subtype? hmap (c/RClass-of IPersistentVector [r/-any]))
-                                              is-map (sub/subtype? hmap (c/RClass-of IPersistentMap [r/-any r/-any]))]
-                                          ;check that hmap is either a vector or map
-                                          (assert (and (not= is-vec is-map)
-                                                       (or is-vec is-map)))
-                                          (cond
-                                            ;keep hmap is keyword key and already hmap
-                                            (and (r/HeterogeneousMap? hmap)
-                                                 (c/keyword-value? kt))
-                                            (assoc-in hmap [:types kt] vt)
-
-                                            ;updating a base record key must be a subtype of the record's
-                                            ;corresponding field, otherwise just ignore any interesting results.
-                                            (r/Record? hmap)
-                                            (let [^DataType hmap hmap
-                                                  ^Value kt kt
-                                                  field-type (when (c/keyword-value? kt)
-                                                               (get (.fields hmap) (symbol (name (.val kt)))))]
-                                              (when-not (and field-type
-                                                             (sub/subtype? vt field-type))
-                                                (u/tc-delayed-error
-                                                  (str "Cannot associate key " (prs/unparse-type kt)
-                                                       " with value type " (prs/unparse-type vt)
-                                                       " to record " (prs/unparse-type hmap)
-                                                       "\n\n" "in: " (u/emit-form-fn expr))))
-                                              hmap)
-
-                                            ;keep hvector if number Value key and already hvector
-                                            (and (r/HeterogeneousVector? hmap)
-                                                 (c/number-value? kt))
-                                            (let [^Value kt kt] 
-                                              (assert (integer? (.val kt))
-                                                      (str "Must associate integer keys to vector, given: " (:val kt)))
-                                              (assoc-in hmap [:types (.val kt)] vt))
-
-                                            ;otherwise just make normal map if already a map, or normal vec if already a vec
-                                            is-map (ret-t 
-                                                     (check-funapp fexpr (cons target keyvals)
-                                                                   (ret 
-                                                                     (prs/parse-type '(All [b c] 
-                                                                                           [(clojure.lang.IPersistentMap b c) b c -> 
-                                                                                            (clojure.lang.IPersistentMap b c)])))
-                                                                   (mapv ret [hmap kt vt])
-                                                                   nil))
-                                            :else (ret-t 
-                                                    (check-funapp fexpr (cons target keyvals)
-                                                                  (ret 
-                                                                    (prs/parse-type '(All [c] 
-                                                                                          [(clojure.lang.IPersistentVector c) c -> 
-                                                                                           (clojure.lang.IPersistentVector c)])))
-                                                                  (mapv ret [hmap vt])
-                                                                  nil)))))
-                                      init-hmap keypair-types))
+                              (let [t-hmaps (if (r/Union? init-hmap)
+                                                (:types init-hmap)
+                                                [init-hmap])
+                                    mapped (map
+                                              (partial update-assoc-hmap
+                                                {:expr expr
+                                                :fexpr fexpr
+                                                :target target
+                                                :keyvals keyvals
+                                                :keypair-types keypair-types})
+                                              t-hmaps)]
+                                (if (= (count mapped) 1)
+                                  (first mapped)
+                                  (apply c/Un mapped))))
                             hmaps)
             final-t (apply c/Un new-hmaps)]
         (assoc expr