Permalink
Browse files

First pass at CTYP-61

  • Loading branch information...
c-spencer committed Sep 15, 2013
1 parent 404e960 commit c675662004b03241df596978d897cb254973bd63
Showing with 71 additions and 54 deletions.
  1. +71 −54 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

0 comments on commit c675662

Please sign in to comment.