Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Merge branch 'master' into type-ast

Conflicts:
	src/main/clojure/clojure/core/typed.clj
	src/main/clojure/clojure/core/typed/datatype_ancestor_env.clj
	src/main/clojure/clojure/core/typed/utils.clj
	src/test/clojure/clojure/core/typed/test/core.clj
	src/test/clojure/clojure/core/typed/test/rbt_test.clj
  • Loading branch information...
commit cd7c8a6137f798b0813a8784a7be2b61249dc7df 2 parents 185c52a + 2c96136
@frenchy64 frenchy64 authored
Showing with 1,315 additions and 414 deletions.
  1. +62 −0 CHANGELOG.md
  2. +75 −7 README.md
  3. +1 −1  pom.xml
  4. +122 −96 src/main/clojure/clojure/core/typed.clj
  5. +9 −0 src/main/clojure/clojure/core/typed/base_env.clj
  6. +49 −34 src/main/clojure/clojure/core/typed/check.clj
  7. +1 −1  src/main/clojure/clojure/core/typed/collect_cljs.clj
  8. +2 −2 src/main/clojure/clojure/core/typed/collect_phase.clj
  9. +70 −16 src/main/clojure/clojure/core/typed/cs_gen.clj
  10. +5 −3 src/main/clojure/clojure/core/typed/datatype_ancestor_env.clj
  11. +14 −5 src/main/clojure/clojure/core/typed/parse_unparse.clj
  12. +19 −5 src/main/clojure/clojure/core/typed/profiling.clj
  13. +40 −22 src/main/clojure/clojure/core/typed/subtype.clj
  14. +389 −160 src/main/clojure/clojure/core/typed/type_ctors.clj
  15. +14 −1 src/main/clojure/clojure/core/typed/type_rep.clj
  16. +15 −11 src/main/clojure/clojure/core/typed/utils.clj
  17. +1 −1  src/test/clojure/clojure/core/typed/test/atom.clj
  18. +236 −43 src/test/clojure/clojure/core/typed/test/core.clj
  19. +46 −0 src/test/clojure/clojure/core/typed/test/ctyp105.clj
  20. +6 −0 src/test/clojure/clojure/core/typed/test/duplicate_ann.clj
  21. +24 −0 src/test/clojure/clojure/core/typed/test/forward_variance.clj
  22. +1 −1  src/test/clojure/clojure/core/typed/test/hole.clj
  23. +85 −5 src/test/clojure/clojure/core/typed/test/rec_type.clj
  24. +10 −0 src/test/clojure/clojure/core/typed/test/some_fn.clj
  25. +19 −0 src/test/clojure/clojure/core/typed/test/trampoline.clj
View
62 CHANGELOG.md
@@ -1,3 +1,65 @@
+# 0.2.33 - Released 22 February 2014
+
+- add clojure.core/trampoline annotation
+- Fix pretty printing of dotted vars in polymorphic
+ binders
+
+# 0.2.32 - Released 19 February 2014
+
+- check-ns and friends support :profile keyword argument that uses
+ Timbre to profile the current type checking run
+- pretty printing a `Fn` type now always prints the `:filters`,
+ unless they are equal to `{:then tt :else tt}`
+- Fix CTYP-105
+ - subtyping fix for HMap optional keys
+
+# 0.2.31 - Released 14 February 2014
+
+## Breaking Changes
+
+### HMap optional keys
+
+There is a subtle change that isn't likely to affect many. Essentially,
+these types are no longer interchangeable:
+
+```clojure
+(HMap :optional {:foo Number})
+!=
+(U (HMap :mandatory {:foo Number}) (HMap :absent-keys #{:foo}))
+```
+
+This subtyping relationship now holds:
+
+```clojure
+(U (HMap :mandatory {:foo Number}) (HMap :absent-keys #{:foo}))
+<:
+(HMap :optional {:foo Number})
+
+(HMap :optional {:foo Number})
+<!:
+(U (HMap :mandatory {:foo Number}) (HMap :absent-keys #{:foo}))
+```
+
+You should prefer the :optional syntax where possible.
+
+## Changes
+
+- Changed the representation of :optional keys on HMap
+ - previously expanded into a combination of :mandatory and :absent-keys
+ - now is an explicit field
+- Type errors show the name of the source file where possible, falls back
+ on the current namespace, or NO_SOURCE_FILE if neither are available
+
+# 0.2.30 - Released 9 February 2014
+
+- Don't try and aggressively eliminate nested intersections and unions
+- check-ns and friends now cleanly catch more type errors (like int-error
+ and tc-error) as "delayed" errors instead of letting them propagate
+
+# 0.2.29 - Released 7 February 2014
+
+- Add support for recursive types in the constraint resolution algorithm
+
# 0.2.28 - Released 5 February 2014
- Don't unfold recursive types while compacting union types
View
82 README.md
@@ -6,12 +6,12 @@ Gradual typing in Clojure, as a library.
## Releases and Dependency Information
-Latest stable release is 0.2.28.
+Latest stable release is 0.2.33.
Leiningen dependency information:
```clojure
-[org.clojure/core.typed "0.2.28"]
+[org.clojure/core.typed "0.2.33"]
...
; for very recent releases
@@ -26,7 +26,7 @@ Maven dependency information:
<dependency>
<groupId>org.clojure</groupId>
<artifactId>core.typed</artifactId>
- <version>0.2.28</version>
+ <version>0.2.33</version>
<!-- slim jar -->
<!-- <classifier>slim</classifier> -->
</dependency>
@@ -35,10 +35,6 @@ Maven dependency information:
The default jars contain AOT files for faster loading. If jar size is a concern, consider
using the slim jar in production.
-## Crowdfunding
-
-[Support full-time core.typed development](http://www.indiegogo.com/projects/typed-clojure/)
-
## [Talk] Clojure Conj 2012
[Video](http://www.youtube.com/watch?v=wNhK8t3uLJU)
@@ -62,6 +58,10 @@ See [wiki](https://github.com/clojure/core.typed/wiki).
[lein-typed](https://github.com/frenchy64/lein-typed)
+## Vim Plugin
+
+[vim-typedclojure](https://github.com/typedclojure/vim-typedclojure)
+
## Quickstart
`(clojure.core.typed/ann v t)` gives var `v` the static type `t`.
@@ -106,6 +106,74 @@ See [wiki](https://github.com/clojure/core.typed/wiki).
* Christopher Spencer (cspencer)
* Reid McKenzie (arrdem)
+## Sponsors
+
+Development is sponsored (via [crowdfunding](http://www.indiegogo.com/projects/typed-clojure)) by
+
+<div>
+ <div>
+ <a href="http://brickalloy.com/">
+ <img src="http://typedclojure.org/images/sponsors/brick_alloy_2_37.png" alt="Brick Alloy">
+ </a>
+ </div>
+ <div class="col-md-2">
+ <a href="http://cognitect.com/">
+ <img src="http://typedclojure.org/images/sponsors/cognitect_black_1_27.png" alt="Cognitect">
+ </a>
+ </div>
+ <div>
+ <a href="http://www.circleci.com/">
+ <img src="http://typedclojure.org/images/sponsors/circleci_logoweb.jpg" alt="CircleCI">
+ </a>
+ </div>
+ <div class="col-md-2">
+ <a href="https://www.hackerschool.com/">
+ <img src="http://typedclojure.org/images/sponsors/hackerschool.png" alt="Hacker School">
+ </a>
+ </div>
+</div>
+<div>
+ <div>
+ <a href="http://snowplowanalytics.com/">
+ <img src="http://typedclojure.org/images/sponsors/snowplow-logo.png" alt="Snowplow Analytics">
+ </a>
+ </div>
+ <div>
+ <a href="http://leonidasoy.fi/">
+ <img src="http://typedclojure.org/images/sponsors/leonidas.png" alt="Leonidas">
+ </a>
+ </div>
+ <div>
+ <a href="http://getprismatic.com/">
+ <img src="http://typedclojure.org/images/sponsors/prismatic-logo.png" alt="Prismatic">
+ </a>
+ </div>
+</div>
+<div>
+ <div style="background-color: #555;">
+ <a href="http://www.thortech-solutions.com/">
+ <img src="http://typedclojure.org/images/sponsors/thortech.png" alt="ThorTech Solutions">
+ </a>
+ </div>
+ <div>
+ <a href="http://sonian.com/">
+ <img src="http://typedclojure.org/images/sponsors/sonian.png" alt="Sonian">
+ </a>
+ </div>
+ <div>
+ <a href="https://twitter.com/srseverance">Shannon Severance</a>
+ </div>
+</div>
+<div>
+ <div>
+ <a href="http://cursiveclojure.com/">
+ <img src="http://typedclojure.org/images/sponsors/cursive.png" alt="Cursive Clojure">
+ </a>
+ </div>
+</div>
+</div>
+
+
## YourKit
YourKit is kindly supporting core.typed and other open source projects with its full-featured Java Profiler.
View
2  pom.xml
@@ -2,7 +2,7 @@
<project xmlns="http://maven.apache.org/POM/4.0.0" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" xsi:schemaLocation="http://maven.apache.org/POM/4.0.0 http://maven.apache.org/maven-v4_0_0.xsd">
<modelVersion>4.0.0</modelVersion>
<artifactId>core.typed</artifactId>
- <version>0.2.29-SNAPSHOT</version>
+ <version>0.2.34-SNAPSHOT</version>
<name>${artifactId}</name>
<description>An optional type system for Clojure</description>
View
218 src/main/clojure/clojure/core/typed.clj
@@ -1641,11 +1641,13 @@ clojure.core.typed/Promise
(every? #(instance? clojure.lang.ExceptionInfo %) errors)]}
(binding [*out* *err*]
(doseq [^Exception e errors]
- (let [{:keys [env] :as data} (ex-data e)]
+ (let [{{:keys [source line column] :as env} :env :as data} (ex-data e)]
(print "Type Error ")
- (print (str "(" (-> env :ns :name) ":" (:line env)
- (when-let [col (:column env)]
- (str ":" col))
+ (print (str "(" (or source (-> env :ns :name) "NO_SOURCE_FILE")
+ (when line
+ (str ":" line
+ (when column
+ (str ":" column))))
") "))
(print (.getMessage e))
(println)
@@ -1751,31 +1753,34 @@ clojure.core.typed/Promise
Options
- :expected Type syntax representing the expected type for this form
type-provided? option must be true to utilise the type.
- - :type-provided? If true, use the expected type to check the form"
- [form & {:keys [expected type-provided?]}]
- (load-if-needed)
- (reset-caches)
- (let [check (impl/v 'clojure.core.typed.check/check)
- expr-type (impl/v 'clojure.core.typed.check/expr-type)
- ast-for-form (impl/v 'clojure.core.typed.analyze-clj/ast-for-form)
- collect-ast (impl/v 'clojure.core.typed.collect-phase/collect-ast)
- ret (impl/v 'clojure.core.typed.type-rep/ret)
- parse-type (impl/v 'clojure.core.typed.parse-unparse/parse-type)]
- (if *currently-checking-clj*
- (throw (Exception. "Found inner call to check-ns or cf"))
- (impl/with-clojure-impl
- (binding [*currently-checking-clj* true
- *delayed-errors* (-init-delayed-errors)
- *collect-on-eval* false]
- (let [expected (when type-provided?
- (ret (parse-type expected)))
- ast (ast-for-form form)
- _ (collect-ast ast)
- _ (reset-caches)
- c-ast (check ast expected)
- res (expr-type c-ast)]
- {:delayed-errors @*delayed-errors*
- :ret res}))))))
+ - :type-provided? If true, use the expected type to check the form
+ - :profile Use Timbre to profile the type checker. Timbre must be
+ added as a dependency."
+ [form & {:keys [expected type-provided? profile]}]
+ (p/profile-if profile
+ (load-if-needed)
+ (reset-caches)
+ (let [check (impl/v 'clojure.core.typed.check/check)
+ expr-type (impl/v 'clojure.core.typed.check/expr-type)
+ ast-for-form (impl/v 'clojure.core.typed.analyze-clj/ast-for-form)
+ collect-ast (impl/v 'clojure.core.typed.collect-phase/collect-ast)
+ ret (impl/v 'clojure.core.typed.type-rep/ret)
+ parse-type (impl/v 'clojure.core.typed.parse-unparse/parse-type)]
+ (if *currently-checking-clj*
+ (throw (Exception. "Found inner call to check-ns or cf"))
+ (impl/with-clojure-impl
+ (binding [*currently-checking-clj* true
+ *delayed-errors* (-init-delayed-errors)
+ *collect-on-eval* false]
+ (let [expected (when type-provided?
+ (ret (parse-type expected)))
+ ast (ast-for-form form)
+ _ (collect-ast ast)
+ _ (reset-caches)
+ c-ast (check ast expected)
+ res (expr-type c-ast)]
+ {:delayed-errors @*delayed-errors*
+ :ret res})))))))
(defn check-ns-info
"Alpha - subject to change
@@ -1783,72 +1788,90 @@ clojure.core.typed/Promise
Same as check-ns, but returns a map of results from type checking the
namespace."
([] (check-ns-info *ns*))
- ([ns-or-syms & {:keys [collect-only trace]}]
- (let [start (. System (nanoTime))]
- (load-if-needed)
- (reset-caches)
- (let [reset-envs! @(ns-resolve (find-ns 'clojure.core.typed.reset-env)
- 'reset-envs!)
- collect-ns @(ns-resolve (find-ns 'clojure.core.typed.collect-phase)
- 'collect-ns)
- check-ns-and-deps @(ns-resolve (find-ns 'clojure.core.typed.check)
- 'check-ns-and-deps)
- vars-with-unchecked-defs @(ns-resolve (find-ns 'clojure.core.typed.var-env)
- 'vars-with-unchecked-defs)
- uri-for-ns (impl/v 'clojure.jvm.tools.analyzer/uri-for-ns)
-
- nsym-coll (map #(if (symbol? %)
- ; namespace might not exist yet, so ns-name is not appropriate
- ; to convert to symbol
- %
- (ns-name %))
- (if ((some-fn symbol? #(instance? clojure.lang.Namespace %))
- ns-or-syms)
- [ns-or-syms]
- ns-or-syms))]
- (cond
- *currently-checking-clj* (throw (Exception. "Found inner call to check-ns or cf"))
-
- :else
- (binding [*currently-checking-clj* true
- *delayed-errors* (-init-delayed-errors)
- *already-collected* (atom #{})
- *already-checked* (atom #{})
- *trace-checker* trace
- *collect-on-eval* false]
- (reset-envs!)
- (impl/with-clojure-impl
- ;; collect
- (let [collect-start (. System (nanoTime))
- _ (doseq [nsym nsym-coll]
- (collect-ns nsym))
- ms (/ (double (- (. System (nanoTime)) start)) 1000000.0)
- collected @*already-collected*]
- (println "Collected" (count collected) "namespaces in" ms "msecs")
- (flush))
- ;(reset-caches)
- ;
- ;; check
- (when-not collect-only
- (doseq [nsym nsym-coll]
- (check-ns-and-deps nsym)))
- (let [vs (vars-with-unchecked-defs)]
- (binding [*out* *err*]
- (doseq [v vs]
- (println "WARNING: Type Checker: Definition missing:" v
- "\nHint: Use :no-check metadata with ann if this is an unchecked var")
- (flush))))
- ; (when-let [errors (seq @*delayed-errors*)]
- ; (print-errors! errors))
- (let [ms (/ (double (- (. System (nanoTime)) start)) 1000000.0)
- checked @*already-checked*
- nlines (p/p :typed/line-count
- (apply + (for [nsym checked]
- (with-open [rdr (io/reader (uri-for-ns nsym))]
- (count (line-seq rdr))))))]
- (println "Checked" (count checked) "namespaces (approx." nlines "lines) in" ms "msecs")
- (flush))
- {:delayed-errors @*delayed-errors*})))))))
+ ([ns-or-syms & {:keys [collect-only trace profile]}]
+ (p/profile-if profile
+ (let [start (. System (nanoTime))]
+ (load-if-needed)
+ (reset-caches)
+ (let [reset-envs! @(ns-resolve (find-ns 'clojure.core.typed.reset-env)
+ 'reset-envs!)
+ collect-ns @(ns-resolve (find-ns 'clojure.core.typed.collect-phase)
+ 'collect-ns)
+ check-ns-and-deps @(ns-resolve (find-ns 'clojure.core.typed.check)
+ 'check-ns-and-deps)
+ vars-with-unchecked-defs @(ns-resolve (find-ns 'clojure.core.typed.var-env)
+ 'vars-with-unchecked-defs)
+ uri-for-ns (impl/v 'clojure.jvm.tools.analyzer/uri-for-ns)
+
+ nsym-coll (map #(if (symbol? %)
+ ; namespace might not exist yet, so ns-name is not appropriate
+ ; to convert to symbol
+ %
+ (ns-name %))
+ (if ((some-fn symbol? #(instance? clojure.lang.Namespace %))
+ ns-or-syms)
+ [ns-or-syms]
+ ns-or-syms))]
+ (cond
+ *currently-checking-clj* (throw (Exception. "Found inner call to check-ns or cf"))
+
+ :else
+ (binding [*currently-checking-clj* true
+ *delayed-errors* (-init-delayed-errors)
+ *already-collected* (atom #{})
+ *already-checked* (atom #{})
+ *trace-checker* trace
+ *collect-on-eval* false]
+ (let [terminal-error (atom nil)]
+ (reset-envs!)
+ (impl/with-clojure-impl
+ ;; collect
+ (let [collect-start (. System (nanoTime))
+ _ (try
+ (doseq [nsym nsym-coll]
+ (collect-ns nsym))
+ (catch clojure.lang.ExceptionInfo e
+ (if (-> e ex-data :type-error)
+ (reset! terminal-error e)
+ (throw e))))]
+ (when-not @terminal-error
+ (let [ms (/ (double (- (. System (nanoTime)) start)) 1000000.0)
+ collected @*already-collected*]
+ (println "Collected" (count collected) "namespaces in" ms "msecs")
+ (flush))))
+ ;(reset-caches)
+ ;
+ ;; check
+ (let [_
+ (when-not @terminal-error
+ (try
+ (when-not collect-only
+ (doseq [nsym nsym-coll]
+ (check-ns-and-deps nsym)))
+ (catch clojure.lang.ExceptionInfo e
+ (if (-> e ex-data :type-error)
+ (reset! terminal-error e)
+ (throw e)))))]
+ (when-not @terminal-error
+ (let [vs (vars-with-unchecked-defs)]
+ (binding [*out* *err*]
+ (doseq [v vs]
+ (println "WARNING: Type Checker: Definition missing:" v
+ "\nHint: Use :no-check metadata with ann if this is an unchecked var")
+ (flush)))))
+ (when-not @terminal-error
+ (let [ms (/ (double (- (. System (nanoTime)) start)) 1000000.0)
+ checked @*already-checked*
+ nlines (p/p :typed/line-count
+ (apply + (for [nsym checked]
+ (with-open [rdr (io/reader (uri-for-ns nsym))]
+ (count (line-seq rdr))))))]
+ (println "Checked" (count checked) "namespaces (approx." nlines "lines) in" ms "msecs")
+ (flush)))
+ {:delayed-errors (vec (concat (when-let [es *delayed-errors*]
+ @es)
+ (when-let [e @terminal-error]
+ [e])))}))))))))))
(defn check-ns
"Type check a namespace/s (a symbol or Namespace, or collection).
@@ -1867,6 +1890,9 @@ clojure.core.typed/Promise
Keyword arguments:
- :collect-only if true, collect type annotations but don't type check code.
Useful for debugging purposes.
+ - :trace if true, print some basic tracing of the type checker
+ - :profile if true, use Timbre to profile type checking. Must include
+ Timbre as a dependency.
If providing keyword arguments, the namespace to check must be provided
as the first argument.
@@ -1884,7 +1910,7 @@ clojure.core.typed/Promise
; collect but don't check the current namespace
(check-ns *ns* :collect-only true)"
([] (check-ns (ns-name *ns*)))
- ([ns-or-syms & {:keys [collect-only trace] :as kw}]
+ ([ns-or-syms & {:keys [collect-only trace profile] :as kw}]
(let [{:keys [delayed-errors]} (apply check-ns-info ns-or-syms (apply concat kw))]
(if-let [errors (seq delayed-errors)]
(print-errors! errors)
View
9 src/main/clojure/clojure/core/typed/base_env.clj
@@ -1213,6 +1213,9 @@ clojure.string/join
(Fn [(Option (Seqable Any)) -> String]
[Any (Option (Seqable Any)) -> String])
+clojure.string/upper-case
+ [CharSequence -> String]
+
clojure.core/interpose (All [x] (Fn [x (Option (Seqable x)) -> (Seq x)]))
clojure.core/interleave (All [x] [(Option (Seqable x)) (Option (Seqable x)) (Option (Seqable x)) * -> (Seq x)])
@@ -1838,6 +1841,12 @@ clojure.core/*print-dup* Boolean
clojure.core/*print-readably* Boolean
clojure.core/*read-eval* (U ':unknown Boolean)
+clojure.core/trampoline
+ (All [r b ...]
+ [[b ... b -> (Rec [f] (U r [-> (U f r)]))]
+ b ... b -> r])
+
+
;; math.numeric-tower
clojure.math.numeric-tower/floor
View
83 src/main/clojure/clojure/core/typed/check.clj
@@ -265,20 +265,21 @@
;{:post [(every? (some-fn nil? r/TCResult?) %)]}
(let [; find the ktype key in each hmap.
- ; - If ktype is present in :types then we either use the entry's val type
- ; - if ktype is explicitly forbidden via :absent-keys or :other-keys
+ ; - If ktype is present in mandatory or optional then we either use the entry's val type
+ ; - otherwise if ktype is explicitly forbidden via :absent-keys or completeness
; we skip the entry.
; - otherwise we give up and don't check this as a hmap, return nil
; that gets propagated up
corresponding-vals
- (reduce (fn [corresponding-vals {:keys [types absent-keys other-keys?] :as hmap}]
- (if-let [v (get types ktype)]
+ (reduce (fn [corresponding-vals {:keys [types absent-keys optional] :as hmap}]
+ (if-let [v (some #(get % ktype) [types optional])]
(conj corresponding-vals v)
(cond
(or (contains? absent-keys ktype)
- (not other-keys?))
- corresponding-vals
- :else (reduced nil))))
+ (c/complete-hmap? hmap))
+ corresponding-vals
+ :else
+ (reduced nil))))
#{} hmaps)
val-expect (when (= 1 (count corresponding-vals))
(ret (first corresponding-vals)))]
@@ -1465,8 +1466,8 @@
(let [protocol (do (when-not (= :var (:op prcl-expr))
(u/int-error "Must reference protocol directly with var in extend"))
(ptl-env/resolve-protocol (u/var->symbol (:var prcl-expr))))
- expected-mmap (c/make-HMap {}
- ;get all combinations
+ expected-mmap (c/make-HMap ;get all combinations
+ :optional
(into {}
(for [[msym mtype] (:methods protocol)]
[(r/-val (keyword (name msym)))
@@ -1644,11 +1645,14 @@
" in heterogeneous map type " (prs/unparse-type t)
" that declares the key always absent.")
(or default r/-nil))
- ; otherwise result is Any
- (do #_(tc-warning "Looking up key " (prs/unparse-type k)
- " in heterogeneous map type " (prs/unparse-type t)
- " which does not declare the key absent ")
- r/-any))))
+ ; if key is optional the result is the val or the default
+ (if-let [opt (get (:optional t) k)]
+ (c/Un opt (or default r/-nil))
+ ; otherwise result is Any
+ (do #_(tc-warning "Looking up key " (prs/unparse-type k)
+ " in heterogeneous map type " (prs/unparse-type t)
+ " which does not declare the key absent ")
+ r/-any)))))
(r/Record? t) (find-val-type (c/Record->HMap t) k default)
@@ -1699,13 +1703,16 @@
(let [{{path-hm :path id-hm :id :as o} :o} target-ret
this-pelem (pe/->KeyPE (:val kwt))
val-type (find-val-type targett kwt defaultt)]
+ (when expected-ret
+ (when-not (sub/subtype? val-type (ret-t expected-ret))
+ (expected-error val-type (ret-t expected-ret))))
(if (not= (c/Un) val-type)
(ret val-type
(fo/-FS (if (obj/Path? o)
(fo/-filter val-type id-hm (concat path-hm [this-pelem]))
fl/-top)
(if (obj/Path? o)
- (fo/-or (fo/-filter (c/-hmap {} #{kwt} true) id-hm path-hm) ; this map doesn't have a kwt key or...
+ (fo/-or (fo/-filter (c/make-HMap :absent-keys #{kwt}) id-hm path-hm) ; this map doesn't have a kwt key or...
(fo/-filter (c/Un r/-nil r/-false) id-hm (concat path-hm [this-pelem]))) ; this map has a false kwt key
fl/-top))
(if (obj/Path? o)
@@ -4256,35 +4263,43 @@
; use this filter to update the right hand side value
next-filter ((if polarity fo/-filter fo/-not-filter)
update-to-type id rstpth)
- present? (c/hmap-present-key? t fpth)
- absent? (c/hmap-absent-key? t fpth)]
+ present? (contains? (:types t) fpth)
+ optional? (contains? (:optional t) fpth)
+ absent? (contains? (:absent-keys t) fpth)]
;updating a KeyPE should consider 3 cases:
; 1. the key is declared present
; 2. the key is declared absent
; 3. the key is not declared present, and is not declared absent
(cond
present?
- ; -hmap simplifies to bottom if an entry is bottom
- (c/-hmap (update-in (:types t) [fpth] update next-filter)
- (:absent-keys t)
- (:other-keys? t))
+ ; -hmap simplifies to bottom if an entry is bottom
+ (c/make-HMap
+ :mandatory (update-in (:types t) [fpth] update next-filter)
+ :optional (:optional t)
+ :absent-keys (:absent-keys t)
+ :complete? (c/complete-hmap? t))
absent?
- t
+ t
; key not declared present or absent
:else
- (c/Un
- (c/-hmap (assoc-in (:types t) [fpth] (update r/-any next-filter))
- (:absent-keys t)
- (:other-keys? t))
- ; if we can prove we only ever update this path to nil,
- ; we can ignore the absent case.
- (let [updated-nil (update r/-nil next-filter)]
- (if-not (r/Bottom? updated-nil)
- (c/-hmap (:types t)
- (conj (:absent-keys t) fpth)
- (:other-keys? t))
- r/-nothing)))))
+ (let [; KeyPE are only used for `get` operations where `nil` is the
+ ; not-found value. If the filter does not hold when updating
+ ; it to nil, then we can assume this key path is present.
+ update-to-mandatory? (r/Bottom? (update r/-nil next-filter))]
+ (if update-to-mandatory?
+ (c/make-HMap
+ :mandatory (assoc-in (:types t) [fpth] (update r/-any next-filter))
+ :optional (:optional t)
+ :absent-keys (:absent-keys t)
+ :complete? (c/complete-hmap? t))
+ (c/make-HMap
+ :mandatory (:types t)
+ :optional (if optional?
+ (update-in (:optional t) [fpth] update next-filter)
+ (assoc-in (:optional t) [fpth] (update r/-any next-filter)))
+ :absent-keys (:absent-keys t)
+ :complete? (c/complete-hmap? t))))))
; nil returns nil on keyword lookups
(and (fl/NotTypeFilter? lo)
View
2  src/main/clojure/clojure/core/typed/collect_cljs.clj
@@ -189,7 +189,7 @@
(r/make-FnIntersection
(r/make-Function (vec (vals fs)) (c/DataType-of s))))
map-ctor (when record?
- (let [hmap-arg (c/-hmap (zipmap (map (comp r/-val keyword) (keys fs))
+ (let [hmap-arg (c/make-HMap :mandatory (zipmap (map (comp r/-val keyword) (keys fs))
(vals fs)))]
(if args
(c/Poly* args bnds
View
4 src/main/clojure/clojure/core/typed/collect_phase.clj
@@ -247,8 +247,8 @@
(r/make-FnIntersection
(r/make-Function (vec (vals fs)) (c/DataType-of s))))
map-ctor (when record?
- (let [hmap-arg (c/-hmap (zipmap (map (comp r/-val keyword) (keys fs))
- (vals fs)))]
+ (let [hmap-arg (c/-partial-hmap (zipmap (map (comp r/-val keyword) (keys fs))
+ (vals fs)))]
(if args
(c/Poly* args bnds
(r/make-FnIntersection
View
86 src/main/clojure/clojure/core/typed/cs_gen.clj
@@ -376,6 +376,18 @@
(r/Name? T)
(cs-gen V X Y S (c/resolve-Name T))
+ ; copied from TR's infer-unit
+ ;; if we have two mu's, we rename them to have the same variable
+ ;; and then compare the bodies
+ ;; This relies on (B 0) only unifying with itself, and thus only hitting the first case of this `match'
+ (and (r/Mu? S)
+ (r/Mu? T))
+ (cs-gen V X Y (r/Mu-body-unsafe S) (r/Mu-body-unsafe T))
+
+ ;; other mu's just get unfolded
+ (r/Mu? S) (cs-gen V X Y (c/unfold S) T)
+ (r/Mu? T) (cs-gen V X Y S (c/unfold T))
+
(and (r/TApp? S)
(not (r/F? (.rator ^TApp S))))
(cs-gen V X Y (c/resolve-TApp S) T)
@@ -529,19 +541,61 @@
(and (r/HeterogeneousMap? S)
(r/HeterogeneousMap? T))
+ ; assumes optional/mandatory/absent keys are disjoint
(let [Skeys (set (keys (:types S)))
- Tkeys (set (keys (:types T)))]
+ Tkeys (set (keys (:types T)))
+ Soptk (set (keys (:optional S)))
+ Toptk (set (keys (:optional T)))
+ Sabsk (:absent-keys S)
+ Tabsk (:absent-keys T)]
; All keys must be values
- (when-not (every? r/Value? (set/union Skeys Tkeys))
+ (when-not (every? r/Value?
+ (concat
+ Skeys Tkeys
+ Soptk Toptk
+ Sabsk Tabsk))
+ (fail! S T))
+ ; If the right is complete, the left must also be complete
+ (when (c/complete-hmap? T)
+ (when-not (c/complete-hmap? S)
+ (fail! S T)))
+ ; check mandatory keys
+ (if (c/complete-hmap? T)
+ ; If right is complete, mandatory keys must be identical
+ (when-not (= Tkeys Skeys)
+ (fail! S T))
+ ; If right is partial, all mandatory keys on the right must also appear mandatory on the left
+ (when-not (empty? (set/difference Tkeys
+ Skeys))
+ (fail! S T)))
+ ; All optional keys on the right must appear either absent, mandatory or optional
+ ; on the left
+ (when-not (empty? (set/difference Toptk
+ (set/union Skeys
+ Soptk
+ Sabsk)))
(fail! S T))
- ; All keys on the left must appear on the right
- (when-not (empty? (set/difference Skeys Tkeys))
+ ; All absent keys on the right must appear absent on the left
+ (when-not (empty? (set/difference Tabsk
+ Sabsk))
(fail! S T))
- (let [nocheck-keys (set/difference Tkeys Skeys)
- STvals (vals (merge-with vector (:types S) (apply dissoc (:types T) nocheck-keys)))
- Svals (map first STvals)
- Tvals (map second STvals)]
- (cs-gen-list V X Y Svals Tvals)))
+ ; now check the values with cs-gen
+ (let [;only check mandatory entries that appear on the right
+ check-mandatory-keys Tkeys
+ Svals (map (:types S) check-mandatory-keys)
+ Tvals (map (:types T) check-mandatory-keys)
+ _ (assert (every? r/Type? Svals))
+ _ (assert (every? r/Type? Tvals))
+ ;only check optional entries that appear on the right
+ ; and also appear as mandatory or optional on the left
+ check-optional-keys (set/intersection
+ Toptk (set/union Skeys Soptk))
+ Sopts (map (some-fn (:types S) (:optional S)) check-optional-keys)
+ Topts (map (:optional S) check-optional-keys)
+ _ (assert (every? r/Type? Sopts))
+ _ (assert (every? r/Type? Topts))]
+ (cset-meet* [(cs-gen-list V X Y Svals Tvals)
+ (cs-gen-list V X Y Sopts Topts)])))
; Completeness matters:
@@ -577,8 +631,8 @@
(fail! S T))
;; Isolate the entries of Assoc in a new HMap, with a corresponding expected HMap.
; keys on the right overwrite those on the left.
- assoc-args-hmap (c/-hmap (into {} entries))
- expected-assoc-args-hmap (c/-hmap (select-keys (:types assoc-args-hmap) (set Assoc-keys)))
+ assoc-args-hmap (c/make-HMap :mandatory (into {} entries))
+ expected-assoc-args-hmap (c/make-HMap :mandatory (select-keys (:types assoc-args-hmap) (set Assoc-keys)))
;; The target of the Assoc needs all the keys not explicitly Assoc'ed.
expected-target-hmap
@@ -624,11 +678,11 @@
(let [^HeterogeneousMap S S]
; Partial HMaps do not record absence of fields, only subtype to (APersistentMap Any Any)
(let [new-S (if (c/complete-hmap? S)
- (impl/impl-case
- :clojure (c/RClass-of APersistentMap [(apply c/Un (keys (.types S)))
- (apply c/Un (vals (.types S)))])
- :cljs (c/Protocol-of 'cljs.core/IMap [(apply c/Un (keys (.types S)))
- (apply c/Un (vals (.types S)))]))
+ (let [kt (apply c/Un (mapcat keys [(.types S) (.optional S)]))
+ vt (apply c/Un (mapcat vals [(.types S) (.optional S)]))]
+ (impl/impl-case
+ :clojure (c/RClass-of APersistentMap [kt vt])
+ :cljs (c/Protocol-of 'cljs.core/IMap [kt vt])))
(impl/impl-case
:clojure (c/RClass-of APersistentMap [r/-any r/-any])
View
8 src/main/clojure/clojure/core/typed/datatype_ancestor_env.clj
@@ -8,7 +8,9 @@
(:import (clojure.lang Symbol)
(clojure.core.typed.type_rep DataType)))
+(t/tc-ignore
(alter-meta! *ns* assoc :skip-wiki true)
+ )
(t/typed-deps clojure.core.typed.type-ctors
clojure.core.typed.subst)
@@ -18,7 +20,7 @@
(t/def-alias DTAncestorEnv
"Environment mapping datatype names to sets of ancestor types."
- (t/Map Symbol (t/Set (U r/Type r/ScopedType))))
+ (t/Map Symbol (t/Set r/ScopedType)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Predicates
@@ -46,14 +48,14 @@
assert-dt-ancestors []
(assert *current-dt-ancestors* "No datatype ancestor environment bound"))
-(defn ^:private ^{:ann '[DataType (U nil (t/Seqable Symbol)) -> (t/Set r/Type)]}
+(defn ^:private ^{:ann '[DataType (U nil (t/Seqable r/Type)) -> (t/Set r/Type)]}
inst-ancestors
"Given a datatype, return its instantiated ancestors"
[{poly :poly? :as dt} anctrs]
{:pre [(r/DataType? dt)]
:post [((u/set-c? r/Type?) %)]}
(set (t/for> :- r/Type
- [u :- Symbol, anctrs]
+ [u :- r/Type, anctrs]
(c/inst-and-subst u poly))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
View
19 src/main/clojure/clojure/core/typed/parse_unparse.clj
@@ -493,7 +493,8 @@
optional (mapt optional)
_ (when-not (every? keyword? absent-keys) (u/int-error "HMap's absent keys must be keywords"))
absent-keys (set (map r/-val absent-keys))]
- (c/make-HMap mandatory optional complete? :absent-keys absent-keys))))
+ (c/make-HMap :mandatory mandatory :optional optional
+ :complete? complete? :absent-keys absent-keys))))
(defn parse-quoted-hvec [syn]
(let [{:keys [fixed drest rest]} (parse-hvec-types syn)]
@@ -1078,8 +1079,7 @@
(defn unparse-result [{:keys [t fl o] :as rng}]
{:pre [(r/Result? rng)]}
(concat [(unparse-type t)]
- (when (not (and ((some-fn f/TopFilter? f/BotFilter?) (:then fl))
- ((some-fn f/TopFilter? f/BotFilter?) (:else fl))))
+ (when-not (every? f/TopFilter? [(:then fl) (:else fl)])
[:filters (unparse-filter-set fl)])
(when (not ((some-fn orep/NoObject? orep/EmptyObject?) o))
[:object (unparse-object o)])))
@@ -1172,7 +1172,9 @@
binder (vec (concat (map unparse-poly-bounds-entry
(butlast free-and-dotted-names)
bbnds)
- [(last free-and-dotted-names) '...]))
+ [(-> (last free-and-dotted-names)
+ r/make-F r/F-original-name)
+ '...]))
body (c/PolyDots-body* free-and-dotted-names p)]
(list 'All binder (unparse-type body))))
@@ -1235,7 +1237,14 @@
[^HeterogeneousMap v]
(list* 'HMap
(concat
- [:mandatory (unparse-map-of-types (.types v))]
+ ; only elide if other information is present
+ (when (or (seq (:types v))
+ (not (or (seq (:optional v))
+ (seq (:absent-keys v))
+ (c/complete-hmap? v))))
+ [:mandatory (unparse-map-of-types (.types v))])
+ (when (seq (:optional v))
+ [:optional (unparse-map-of-types (:optional v))])
(when-let [ks (and (not (c/complete-hmap? v))
(seq (.absent-keys v)))]
[:absent-keys (set (map :val ks))])
View
24 src/main/clojure/clojure/core/typed/profiling.clj
@@ -9,9 +9,12 @@
;; only available with lein (development time). Needs a few helpers
;; to achieve this.
-(try
- (require '[taoensso.timbre.profiling])
- (catch Exception e))
+(def loaded-timbre?
+ (try
+ (require '[taoensso.timbre.profiling])
+ true
+ (catch Throwable e
+ false)))
; use our own version of pspy that can be type checked
(defmacro p [name & body]
@@ -44,5 +47,16 @@
(defmacro profile
"Usage: (profile :info :foo ...)"
- [& body]
- `(taoensso.timbre.profiling/profile ~@body))
+ [a1 a2 & body]
+ (if (find-ns 'taoensso.timbre.profiling)
+ `(taoensso.timbre.profiling/profile ~a1 ~a2 ~@body)
+ `(do (prn "WARNING: Cannot profile, timbre must be added as a dependency")
+ nil
+ ~@body)))
+
+(defmacro profile-if
+ "Usage (profile-if p? :info :foo)"
+ [p? & body]
+ `(if ~p?
+ (profile :info :foo ~@body)
+ (do ~@body)))
View
62 src/main/clojure/clojure/core/typed/subtype.clj
@@ -476,10 +476,26 @@
(let [; convention: prefix things on left with l, right with r
{ltypes :types labsent :absent-keys :as s} s
{rtypes :types rabsent :absent-keys :as t} t]
- (if (and ; if t is complete, s must be complete with the same keys
+ (if (and ; if t is complete, s must be complete ..
(if (c/complete-hmap? t)
(if (c/complete-hmap? s)
- (= (set (keys ltypes)) (set (keys rtypes)))
+ ; mandatory keys on the right must appear as
+ ; mandatory on the left, but extra keys may appear
+ ; on the left
+ (and (let [right-mkeys (set (keys rtypes))
+ left-mkeys (set (keys ltypes))]
+ (set/subset? right-mkeys
+ left-mkeys))
+ ; extra mandatory keys on the left must appear
+ ; as optional on the right
+ (let [left-extra-mkeys (set/difference (set (keys ltypes))
+ (set (keys rtypes)))
+ right-optional-keys (set (keys (:optional t)))]
+ (set/subset? left-extra-mkeys
+ right-optional-keys)))
+ ;Note:
+ ; optional key keys on t must be optional or mandatory or absent in s,
+ ; which is always the case so we don't need to check.
false)
true)
; all absent keys in t should be absent in s
@@ -496,26 +512,30 @@
(map (fn [[k v]]
(when-let [t (get ltypes k)]
(subtype? t v)))
- rtypes)))
+ rtypes))
+ ; all optional keys in t should match optional/mandatory entries in s
+ (every? identity
+ (map (fn [[k v]]
+ (let [matches-entry?
+ (if-let [actual-v
+ ((merge-with c/In
+ (:types s)
+ (:optional s))
+ k)]
+ (subtype? actual-v v)
+ (c/complete-hmap? s))]
+ (cond
+ (c/partial-hmap? s)
+ (or (contains? (:absent-keys s) k)
+ matches-entry?)
+ :else matches-entry?)))
+ (:optional t)))
+ )
*sub-current-seen*
(fail! s t)))
(r/HeterogeneousMap? s)
- (let [^HeterogeneousMap s s]
- ; Partial HMaps do not record absence of fields, only subtype to (APersistentMap Any Any)
- (if (c/complete-hmap? s)
- (subtype (c/In (impl/impl-case
- :clojure (c/RClass-of APersistentMap [(apply c/Un (keys (.types s)))
- (apply c/Un (vals (.types s)))])
- :cljs (c/Protocol-of 'cljs.core/IMap [(apply c/Un (keys (.types s)))
- (apply c/Un (vals (.types s)))]))
- (r/make-ExactCountRange (count (:types s))))
- t)
- (subtype (c/In (impl/impl-case
- :clojure (c/RClass-of APersistentMap [r/-any r/-any])
- :cljs (c/Protocol-of 'cljs.core/IMap [r/-any r/-any]))
- (r/make-CountRange (count (:types s))))
- t)))
+ (subtype (c/upcast-hmap s) t)
(r/KwArgsSeq? s)
(subtype (c/Un r/-nil
@@ -874,8 +894,7 @@
(pth-rep/KeyPE? fpth)
(simplify-type-filter
(fops/-filter
- (c/make-HMap {(r/-val (:val fpth)) (:type f)}
- {})
+ (c/make-HMap :mandatory {(r/-val (:val fpth)) (:type f)})
(:id f)
rstpth))
:else f)))
@@ -901,8 +920,7 @@
(fops/-not-filter
; keys is optional
(c/make-HMap
- {}
- {(r/-val (:val fpth)) (:type f)})
+ :optional {(r/-val (:val fpth)) (:type f)})
(:id f)
rstpth))
:else f)))
View
549 src/main/clojure/clojure/core/typed/type_ctors.clj
@@ -32,8 +32,7 @@
(t/typed-deps clojure.core.typed.name-env)
-(t/ann ^:no-check with-original-names [r/Type (U Symbol (Seqable Symbol))
- -> r/Type])
+(t/ann ^:no-check with-original-names [r/Type (U Symbol (Seqable Symbol)) -> r/Type])
(defn- with-original-names [t names]
(with-meta t {::names names}))
@@ -86,93 +85,147 @@
;; Heterogeneous maps
-(t/ann ^:no-check -hmap (Fn [(Seqable r/Type) -> r/Type]
- [(Seqable r/Type) Boolean -> r/Type]
- [(Seqable r/Type) (IPersistentSet r/Type) Boolean -> r/Type]))
-(defn -hmap
- ([types] (-hmap types #{} true))
- ([types other-keys?] (-hmap types #{} other-keys?))
- ([types absent-keys other-keys?]
- (if (or ; simplify to bottom if an entry is bottom
- (some #{bottom} (concat (keys types) (vals types) absent-keys))
- ; contradictory overlap in present/absent keys
- (seq (set/intersection (set (keys types)) (set absent-keys))))
- bottom
- (r/HeterogeneousMap-maker types absent-keys other-keys?))))
-
-(t/ann -complete-hmap [(Seqable r/Type) -> r/Type])
+(declare make-HMap)
+
+(t/ann -complete-hmap [(t/Map r/Type r/Type) -> r/Type])
(defn -complete-hmap [types]
- (-hmap types false))
+ (make-HMap
+ :mandatory types
+ :complete? true))
-(t/ann -partial-hmap (Fn [(Seqable r/Type) -> r/Type]
- [(Seqable r/Type) (IPersistentSet r/Type) -> r/Type]))
+(t/ann -partial-hmap (Fn [(t/Map r/Type r/Type) -> r/Type]
+ [(t/Map r/Type r/Type) (t/Set r/Type) -> r/Type]))
(defn -partial-hmap
([types] (-partial-hmap types #{}))
- ([types absent-keys] (-hmap types absent-keys true)))
-
-(t/ann hmap-present-key? [HeterogeneousMap r/Type -> Boolean])
-(defn hmap-present-key?
- "Returns true if hmap always has a keyt entry."
- [hmap keyt]
- {:pre [(r/HeterogeneousMap? hmap)
- (r/Type? keyt)]}
- (contains? (:types hmap) keyt))
-
-(t/ann hmap-absent-key? [HeterogeneousMap r/Type -> Boolean])
-(defn hmap-absent-key?
- "Returns true if hmap never has a keyt entry."
- [hmap keyt]
- {:pre [(r/HeterogeneousMap? hmap)
- (r/Type? keyt)]}
- (boolean
- (when-not (hmap-present-key? hmap keyt)
- (or ; absent if in :absent-keys
- (contains? (:absent-keys hmap) keyt)
- ; absent if no other keys
- (not (:other-keys? hmap))))))
+ ([types absent-keys] (make-HMap
+ :mandatory types
+ :absent-keys absent-keys)))
(t/def-alias TypeMap
"A regular map with types as keys and vals."
- (IPersistentMap r/Type r/Type))
-
-(t/ann ^:no-check make-HMap (Fn [TypeMap TypeMap -> r/Type]
- [TypeMap TypeMap Any -> r/Type]))
+ (t/Map r/Type r/Type))
+
+(declare In keyword-value? RClass-of Protocol-of complete-hmap?)
+
+(t/ann ^:no-check allowed-hmap-key? [r/Type -> Boolean])
+(defn allowed-hmap-key? [k]
+ (keyword-value? k))
+
+; Partial HMaps do not record absence of fields, only subtype to (APersistentMap Any Any)
+(t/ann ^:no-check upcast-hmap*
+ [(t/Map r/Type r/Type) (t/Map r/Type r/Type) (t/Set r/Type) Boolean -> r/Type])
+(defn upcast-hmap* [mandatory optional absent-keys complete?]
+ (if complete?
+ (In (let [ks (apply Un (mapcat keys [mandatory optional]))
+ vs (apply Un (mapcat vals [mandatory optional]))]
+ (impl/impl-case
+ :clojure (RClass-of 'clojure.lang.APersistentMap [ks vs])
+ :cljs (Protocol-of 'cljs.core/IMap [ks vs])))
+ (r/make-CountRange
+ ; assume all optional entries are absent
+ #_:lower
+ (count mandatory)
+ ; assume all optional entries are present
+ #_:upper
+ (+ (count mandatory)
+ (count optional))))
+ (In (impl/impl-case
+ :clojure (RClass-of 'clojure.lang.APersistentMap [r/-any r/-any])
+ :cljs (Protocol-of 'cljs.core/IMap [r/-any r/-any]))
+ (r/make-CountRange
+ ; assume all optional entries are absent
+ #_:lower
+ (count mandatory)
+ ; partial hmap can be infinite count
+ #_:upper
+ nil))))
+
+(t/ann ^:no-check upcast-hmap [HeterogeneousMap -> r/Type])
+(defn upcast-hmap [hmap]
+ {:pre [(r/HeterogeneousMap? hmap)]
+ :post [(r/Type? %)]}
+ (upcast-hmap* (:types hmap)
+ (:optional hmap)
+ (:absent-keys hmap)
+ (complete-hmap? hmap)))
+
+(t/ann ^:no-check make-HMap [& :optional {:mandatory (t/Map r/Type r/Type) :optional (t/Map r/Type r/Type)
+ :absent-keys (t/Set r/Type) :complete? Boolean}
+ -> r/Type])
(defn make-HMap
- "Generate a type which is every possible combination of mandatory
- and optional key entries. Takes an optional third parameter which
- is true if the entries are complete (ie. we know there are no more entries),
- and false otherwise. Defaults to false.
+ "Make a heterogeneous map type for the given options.
+ Handles duplicate keys between map properties.
Options:
- - :absent-keys a set of types that are not keys this/these maps"
- ([mandatory optional]
- (make-HMap mandatory optional false))
- ([mandatory optional complete? & {:keys [absent-keys]}]
- ; simplifies to bottom with contradictory options
- (if (seq (set/intersection (-> mandatory keys set)
- (-> optional keys set)
- (set absent-keys)))
- (make-Union [])
- (make-Union
- (remove
- #{(make-Union [])}
- (for [ss (map #(into {} %) (comb/subsets optional))]
- (let [new-mandatory (merge mandatory ss)
- ;other optional keys cannot appear...
- new-absent (set/union
- (set/difference (set (keys optional))
- (set (keys ss)))
- (set absent-keys))
- ;...but we don't know about other keys
- new-other-keys? (not complete?)]
- (-hmap new-mandatory new-absent new-other-keys?))))))))
+ - :mandatory a map of mandatory entries
+ Default: {}
+ - :optional a map of optional entries
+ Default: {}
+ - :absent-keys a set of types that are not keys this/these maps
+ Default: #{}
+ - :complete? creates a complete map if true, or a partial map if false
+ Default: false"
+ [& {:keys [mandatory optional complete? absent-keys]
+ :or {mandatory {} optional {} complete? false absent-keys #{}}
+ :as opt}]
+ {:post [(r/Type? %)]}
+ (assert (set/subset? (set (keys opt))
+ #{:mandatory :optional :complete? :absent-keys})
+ (set (keys opt)))
+ (assert ((u/hash-c? r/Type? r/Type?) mandatory)
+ (pr-str mandatory))
+ (assert ((u/hash-c? r/Type? r/Type?) optional)
+ (pr-str optional))
+ (assert ((u/set-c? r/Type?) absent-keys)
+ (pr-str absent-keys))
+ (assert (u/boolean? complete?)
+ (pr-str complete?))
+ ; simplifies to bottom with contradictory keys
+ (cond
+ (or (seq (set/intersection (set (keys mandatory))
+ (set absent-keys)))
+ (some #{bottom} (concat (vals mandatory)
+ (vals optional))))
+ bottom
+
+ (not
+ (every? allowed-hmap-key?
+ (concat (keys mandatory)
+ (keys optional)
+ absent-keys)))
+ (upcast-hmap* mandatory optional absent-keys complete?)
+
+ :else
+ (let [optional-now-mandatory (set/intersection
+ (set (keys optional))
+ (set (keys mandatory)))
+ optional-now-absent (set/intersection
+ (set (keys optional))
+ absent-keys)
+ _ (assert (empty?
+ (set/intersection optional-now-mandatory
+ optional-now-absent)))]
+ (r/HeterogeneousMap-maker
+ (merge-with In mandatory (select-keys optional optional-now-mandatory))
+ (apply dissoc optional (set/union optional-now-absent
+ optional-now-mandatory))
+ ; throw away absents if complete
+ (if complete?
+ #{}
+ (set/union absent-keys optional-now-absent))
+ (not complete?)))))
;TODO to type check this, need to un-munge instance field names
-(t/ann complete-hmap? [HeterogeneousMap -> Any])
+(t/ann complete-hmap? [HeterogeneousMap -> Boolean])
(defn complete-hmap? [^HeterogeneousMap hmap]
{:pre [(r/HeterogeneousMap? hmap)]}
(not (.other-keys? hmap)))
+(t/ann partial-hmap? [HeterogeneousMap -> Boolean])
+(defn partial-hmap? [^HeterogeneousMap hmap]
+ {:pre [(r/HeterogeneousMap? hmap)]}
+ (.other-keys? hmap))
+
;; Unions
(t/tc-ignore
@@ -274,12 +327,40 @@
(declare RClass-of)
+(t/ann ^:no-check HMap-with-Value-keys? [HeterogeneousMap * -> Boolean])
+(defn HMap-with-Value-keys? [& args]
+ {:pre [(every? r/HeterogeneousMap? args)]}
+ (every? r/Value?
+ (apply concat
+ (mapcat (juxt (comp keys :types)
+ (comp keys :optional)
+ :absent-keys)
+ args))))
+
+(t/ann ^:no-check intersect-HMap [HeterogeneousMap HeterogeneousMap -> r/Type])
+(defn ^:private intersect-HMap
+ [t1 t2]
+ {:pre [(r/HeterogeneousMap? t1)
+ (r/HeterogeneousMap? t2)
+ (HMap-with-Value-keys? t1 t2)]
+ :post [(r/Type? %)]}
+ ; make-HMap handles duplicates
+ (make-HMap
+ :mandatory
+ (apply merge-with In (map :types [t1 t2]))
+ :optional
+ (apply merge-with In (map :optional [t1 t2]))
+ :absent-keys
+ (apply set/union (map :absent-keys [t1 t2]))
+ :complete?
+ (not-any? :other-keys? [t1 t2])))
+
(t/ann ^:no-check intersect [r/Type r/Type -> r/Type])
(defn intersect [t1 t2]
{:pre [(r/Type? t1)
(r/Type? t2)
- (not (r/Union? t1))
- (not (r/Union? t2))]
+ #_(not (r/Union? t1))
+ #_(not (r/Union? t2))]
:post [(r/Type? %)]}
(let [subtype? @(subtype?-var)]
;(prn "intersect" (map unparse-type [t1 t2]))
@@ -292,14 +373,7 @@
t (cond
(and (r/HeterogeneousMap? t1)
(r/HeterogeneousMap? t2))
- (-hmap
- (merge-with In
- (:types t1)
- (:types t2))
- (set/union (:absent-keys t1)
- (:absent-keys t2))
- (or (:other-keys? t1)
- (:other-keys? t2)))
+ (intersect-HMap t1 t2)
;RClass's with the same base, intersect args pairwise
(and (r/RClass? t1)
@@ -609,7 +683,7 @@
:post [(r/Type? %)]}
(let [kf (zipmap (map (comp r/-val keyword) (keys (.fields r)))
(vals (.fields r)))]
- (-hmap kf)))
+ (make-HMap :mandatory kf)))
(t/ann RClass-of-cache (t/Atom1 (t/Map Any r/Type)))
(defonce ^:private RClass-of-cache (atom {}))
@@ -640,10 +714,11 @@
(let [rc ((some-fn dtenv/get-datatype rcls/get-rclass)
sym)
_ (assert ((some-fn r/TypeFn? r/RClass? r/DataType? nil?) rc))
- _ (assert (or (r/TypeFn? rc) (empty? args))
- (str "Cannot instantiate non-polymorphic RClass " sym
- (when *current-RClass-super*
- (str " when checking supertypes of RClass " *current-RClass-super*))))
+ _ (when-not (or (r/TypeFn? rc) (empty? args))
+ (u/int-error
+ (str "Cannot instantiate non-polymorphic RClass " sym
+ (when *current-RClass-super*
+ (str " when checking supertypes of RClass " *current-RClass-super*)))))
res (cond
(r/TypeFn? rc) (instantiate-typefn rc args)
((some-fn r/DataType? r/RClass?) rc) rc
@@ -1356,14 +1431,22 @@
t2 (fully-resolve-type t2)
eq (= t1 t2)
hmap-and-seq? (fn [h s] (and (r/HeterogeneousMap? h)
- (r/RClass? s)
- (= (u/Class->symbol clojure.lang.ISeq) (:the-class s))))
+ (impl/impl-case
+ :clojure (and (r/RClass? s)
+ ('#{clojure.lang.ISeq} (:the-class s)))
+ :cljs (and (r/Protocol? s)
+ ('#{cljs.core/ISeq} (:the-var s))))))
hvec-and-seq? (fn [h s] (and (r/HeterogeneousVector? h)
- (r/RClass? s)
- (= (u/Class->symbol clojure.lang.ISeq) (:the-class s))))
+ (impl/impl-case
+ :clojure (and (r/RClass? s)
+ ('#{clojure.lang.ISeq} (:the-class s)))
+ :cljs (and (r/Protocol? s)
+ ('#{cljs.core/ISeq} (:the-var s))))))
record-and-iseq? (fn [r s]
(and (r/Record? r)
- (subtype? s (RClass-of clojure.lang.ISeq [r/-any]))))]
+ (subtype? s (impl/impl-case
+ :clojure (RClass-of clojure.lang.ISeq [r/-any])
+ :cljs (Protocol-of 'cljs.core/ISeq [r/-any])))))]
(cond
eq eq
@@ -1412,7 +1495,8 @@
; (subtype? t2 t1))
(and (r/RClass? t1)
(r/RClass? t2))
- (let [{t1-flags :flags} (reflect/type-reflect (r/RClass->Class t1))
+ (let [_ (impl/assert-clojure)
+ {t1-flags :flags} (reflect/type-reflect (r/RClass->Class t1))
{t2-flags :flags} (reflect/type-reflect (r/RClass->Class t2))]
; there is only an overlap if a class could have both classes as parents
(or (subtype? t1 t2)
@@ -1448,12 +1532,20 @@
(and (r/HeterogeneousMap? t1)
(r/HeterogeneousMap? t2))
- (and (= (set (-> t1 :types keys))
- (set (-> t2 :types keys)))
- (every? true?
- (for [[k1 v1] (:types t1)]
- (let [v2 ((:types t2) k1)]
- (overlap v1 v2)))))
+ (let [common-mkeys (set/intersection
+ (set (-> t1 :types keys))
+ (set (-> t2 :types keys)))]
+ (cond
+ ; if there is an intersection in the mandatory keys
+ ; each entry in common should overlap
+ (not (empty? common-mkeys))
+ (every? identity
+ (for [[k1 v1] (select-keys (:types t1) common-mkeys)]
+ (let [v2 ((:types t2) k1)]
+ (assert v2)
+ (overlap v1 v2))))
+ ;TODO more cases. incorporate completeness
+ :else true))
;for map destructuring mexpansion
(or (hmap-and-seq? t1 t2)
@@ -1791,13 +1883,13 @@
[r/no-bounds]
(r/make-FnIntersection
(r/make-Function
- [(-hmap {(r/-val kw) (r/make-F 'x)})]
+ [(-partial-hmap {(r/-val kw) (r/make-F 'x)})]
(r/make-F 'x)
nil nil
:object (or/->Path [(path/->KeyPE kw)] 0))
(r/make-Function
- [(Un (-hmap {(r/-val kw) (r/make-F 'x)})
- (-hmap {} #{(r/-val kw)} true)
+ [(Un (make-HMap
+ :optional {(r/-val kw) (r/make-F 'x)})
r/-nil)]
(Un r/-nil (r/make-F 'x))
nil nil
@@ -1837,7 +1929,8 @@
(defn KwArgsSeq->HMap [^KwArgsSeq kws]
{:pre [(r/KwArgsSeq? kws)]
:post [(r/Type? %)]}
- (make-HMap (.mandatory kws) (.optional kws)))
+ (make-HMap :mandatory (.mandatory kws)
+ :optional (.optional kws)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Heterogenous type ops
@@ -1903,7 +1996,9 @@
(let [bnd (free-ops/free-with-name-bnds name)
_ (when-not bnd
(u/int-error (str "No bounds for type variable: " name bnds/*current-tvar-bnds*)))]
- (when (subtype? (:upper-bound bnd) (RClass-of IPersistentMap [r/-any r/-any]))
+ (when (subtype? (:upper-bound bnd) (impl/impl-case
+ :clojure (RClass-of IPersistentMap [r/-any r/-any])
+ :cljs (Protocol-of 'cljs.core/IMap [r/-any r/-any])))
(r/AssocType-maker f [(mapv r/ret-t assoc-entry)] nil))))
Value
@@ -1913,17 +2008,19 @@
(let [rkt (-> kt :t fully-resolve-type)]
(if (keyword-value? rkt)
(-complete-hmap {rkt (:t vt)})
- (RClass-of IPersistentMap [rkt (:t vt)])
- ))))
+ (impl/impl-case
+ :clojure (RClass-of IPersistentMap [rkt (:t vt)])
+ :cljs (Protocol-of 'cljs.core/IMap [rkt (:t vt)]))))))
RClass
(-assoc-pair
[rc [kt vt]]
- (let [rkt (-> kt :t fully-resolve-type)]
+ (let [_ (impl/assert-clojure)
+ rkt (-> kt :t fully-resolve-type)]
(cond
(= (:the-class rc) 'clojure.lang.IPersistentMap)
(RClass-of IPersistentMap [(Un (:t kt) (nth (:poly? rc) 0))
- (Un (:t vt) (nth (:poly? rc) 1))])
+ (Un (:t vt) (nth (:poly? rc) 1))])
(and (= (:the-class rc) 'clojure.lang.IPersistentVector)
(r/Value? rkt))
@@ -1937,21 +2034,27 @@
[hmap [kt vt]]
(let [rkt (-> kt :t fully-resolve-type)]
(if (keyword-value? rkt)
- (-> (assoc-in hmap [:types rkt] (:t vt))
- (update-in [:absent-keys] disj rkt))
+ (make-HMap
+ :mandatory (assoc-in (:types hmap) [rkt] (:t vt))
+ :optional (:optional hmap)
+ :absent-keys (-> (:absent-keys hmap)
+ (disj rkt))
+ :complete? (complete-hmap? hmap))
; devolve the map
;; todo: probably some machinery I can reuse here?
- (RClass-of IPersistentMap [(apply Un (concat [rkt] (keys (:types hmap))))
- (apply Un (concat [(:t vt)] (vals (:types hmap))))])
- )))
+ (let [ks (apply Un (concat [rkt] (mapcat keys [(:types hmap) (:optional hmap)])))
+ vs (apply Un (concat [(:t vt)] (mapcat vals [(:types hmap) (:optional hmap)])))]
+ (impl/impl-case
+ :clojure (RClass-of IPersistentMap [ks vs])
+ :cljs (Protocol-of 'cljs.core/IMap [ks vs]))))))
HeterogeneousVector
(-assoc-pair
[v [kt vt]]
(let [rkt (-> kt :t fully-resolve-type)]
(when (r/Value? rkt)
- (let [^Value kt rkt
- k (.val kt)]
+ (let [kt rkt
+ k (:val kt)]
(when (and (integer? k) (<= k (count (:types v))))
(r/-hvec (assoc (:types v) k (:t vt))
:filters (assoc (:fs v) k (:fl vt))
@@ -2001,12 +2104,18 @@
t
(and (r/HeterogeneousMap? t) (keyword-value? rtype))
- (if (:other-keys? t)
- (-> (update-in t [:types] dissoc rtype)
- (update-in [:absent-keys] conj rtype))
- (update-in t [:types] dissoc rtype))
+ (make-HMap
+ :mandatory
+ (dissoc (:types t) rtype)
+ :optional
+ (dissoc (:optional t) rtype)
+ :absent-keys
+ (conj (:absent-keys t) rtype)
+ :complete? (complete-hmap? t))
- (subtype? t (RClass-of IPersistentMap [r/-any r/-any]))
+ (subtype? t (impl/impl-case
+ :clojure (RClass-of IPersistentMap [r/-any r/-any])
+ :cljs (Protocol-of 'cljs.core/IMap [r/-any r/-any])))
t
))))
@@ -2025,43 +2134,157 @@
down to an IPersistentMap.
For example:
- (merge {:a 4 :b 6} '{:b 5}) -> '{:a Any :b 5}"
+ (merge '{:a 4 :b 6} '{:b 5}) -> '{:a Any :b 5}"
[left right]
{:pre [(r/HeterogeneousMap? left)
(r/HeterogeneousMap? right)]}
-
- (let [; update lhs with known types
- first-pass (apply assoc-type-pairs left (map (fn [[k t]]
- [(r/ret k) (r/ret t)])
- (:types right)))
- ; clear missing types when incomplete rhs and lhs still hmap
- second-pass (if (and (r/HeterogeneousMap? first-pass) (:other-keys? right))
- (reduce
- (fn [t [lk lv]]
- (if (and t
- ; left type not in right and not absent
- (not (get (:types right) lk))
- (not (get (:absent-keys right) lk)))
- (assoc-type-pairs t [(r/ret lk)
- (r/ret r/-any)])
- t))
- first-pass
- (:types left))
- first-pass)
- ; ensure :other-keys? updated appropriately
- final-pass (when (r/HeterogeneousMap? second-pass)
- (update-in second-pass [:other-keys?]
- #(or % (:other-keys? right))))]
- final-pass))
+ (make-HMap
+ :mandatory
+ (let [m (:types left)
+ ; optional keys on the right may or may not overwrite mandatory
+ ; entries, so we union the common mandatory and optional val types together.
+ ;
+ ; eg. (merge (HMap :mandatory {:a Number}) (HMap :optional {:a Symbol}))
+ ; => (HMap :mandatory {:a (U Number Symbol)})
+ m (merge-with Un
+ m
+ (select-keys (:optional right) (keys (:types left))))
+ ;_ (prn "after first mandatory pass" m)
+
+ ; combine left+right mandatory entries.
+ ; If right is partial, we can only update the entries common to both
+ ; and give any entries type Any.
+ ;
+ ; eg. (merge (HMap :mandatory {:a Number}) (HMap :mandatory {:b Number}))
+ ; ;=> (HMap :mandatory {:a Any :b Number})
+ ;
+ ; If right is complete, it's safe to merge both mandatory maps.
+ ; right-most wins on duplicates.
+ m (merge m
+ (cond
+ (partial-hmap? right)
+ (merge (:types right)
+ (zipmap (set/difference
+ (set (keys (:types left)))
+ (set (keys (:types right)))
+ (set (keys (:optional right)))
+ (:absent-keys right))
+ (repeat r/-any)))
+ :else
+ (:types right)))]
+ ;(prn "after final mandatory pass" m)
+ m)
+ :optional
+ (let [o (:optional left)
+ ;_ (prn "before first optional pass" o)
+ ; dissoc keys that end up in the mandatory map
+ o (apply dissoc o
+ (concat (keys (:types right))
+ ; entries mandatory on the left and optional
+ ; on the right are always in the mandatory map
+ (set/intersection
+ (set (keys (:optional right)))
+ (set (keys (:types left))))))
+ ;_ (prn "after first optional pass" o)
+ ; now we merge any new :optional entries
+ o (merge-with Un
+ o
+ ; if the left is partial then we only add optional entries
+ ; common to both maps.
+ ; if left is complete, we are safe to merge both maps.
+ ;
+ ; (merge (HMap :optional {:a Number})
+ ; (HMap :optional {:b Number}))
+ ; => (HMap)
+ ;
+ ; (merge (HMap :mandatory {:a '5})
+ ; (HMap :optional {:a '10}))
+ ; => (HMap :mandatory {:a (U '5 '10)})
+ ;
+ ; (merge (HMap :optional {:a Number})
+ ; (HMap :optional {:a Symbol}))
+ ; => (HMap :optional {:a (U Number Symbol)})
+ ;
+ ; (merge (HMap :optional {:a Number})
+ ; (HMap :optional {:b Number} :complete? true))
+ ; => (HMap :optional {:a Number :b Number})
+ ;
+ ; (merge (HMap :optional {:a Number} :complete? true)
+ ; (HMap :optional {:b Number}))
+ ; => (HMap :optional {:a Number :b Number})
+ ;
+ ; (merge (HMap :optional {:a Number} :complete? true)
+ ; (HMap :optional {:b Number} :complete? true))
+ ; => (HMap :optional {:a Number :b Number})
+ (select-keys (:optional right)
+ (set/difference
+ (set (keys (:optional right)))
+ ;remove keys that will be mandatory in the result
+ (set (keys (:types left)))
+ (if (partial-hmap? left)
+ ; remove keys that give no new information.
+ ; If left is partial, we remove optional
+ ; keys in right that are not mentioned in left.
+ (set/difference
+ (set (keys (:optional right)))
+ (set (keys (:types left)))
+ (set (keys (:optional left)))
+ (:absent-keys left))
+ #{}))))]
+ ;(prn "after final optional pass" o)
+ o)
+ :absent-keys
+ (cond
+ ; (merge (HMap :absent-keys [:a :b :c]) (HMap :optional {:a Foo} :mandatory {:b Bar} :absent-keys [:c]))
+ ; => (HMap :absent-keys [:c] :optional {:a Foo} :mandatory {:b Bar})
+ ; (merge (HMap :absent-keys [:a :b :c]) (HMap :optional {:a Foo} :mandatory {:b Bar}))
+ ; => (HMap :absent-keys [] :optional {:a Foo} :mandatory {:b Bar})
+ (and (partial-hmap? left)
+ (partial-hmap? right))
+ (set/intersection
+ (set/difference (:absent-keys left)
+ (set (keys (:optional right)))
+ (set (keys (:types right))))
+ (:absent-keys right))
+
+ ; (merge (HMap :absent-keys [:a :b :c])
+ ; (HMap :optional {:a Foo} :mandatory {:b Bar} :complete? true))
+ ; => (HMap :absent-keys [:c] :optional {:a Foo} :mandatory {:b Bar})
+ (and (partial-hmap? left)
+ (complete-hmap? right))
+ (set/difference (:absent-keys left)
+ (set (keys (:optional right)))
+ (set (keys (:types right))))
+
+ ; (merge (HMap :complete? true)
+ ; (HMap :absent-keys [:c] :optional {:a Foo} :mandatory {:b Bar}))
+ ; => (HMap :absent-keys [:c] :optional {:a Foo} :mandatory {:b Bar})
+ (and (complete-hmap? left)
+ (partial-hmap? right))
+ (:absent-keys right)
+
+ ; (merge (HMap :absent-keys [:a :b :c] :complete? true)
+ ; (HMap :optional {:a Foo} :mandatory {:b Bar} :absent-keys [:c] :complete? true))
+ ; => (HMap :optional {:a Foo} :mandatory {:b Bar} :complete? true)
+ (and (complete-hmap? left)
+ (complete-hmap? right))
+ #{}
+ :else (throw (Exception. "should never get here")))
+ :complete?
+ (and (complete-hmap? left)
+ (complete-hmap? right))))
(defn- merge-pair
[left right]
{:pre [(r/Type? left)
(r/TCResult? right)]
:post [((some-fn nil? r/Type?) %)]}
- (let [sub-class? #(subtype? %1 (RClass-of %2 %3))
- left-map (sub-class? left IPersistentMap [r/-any r/-any])
- right-map (sub-class? (ret-t right) IPersistentMap [r/-any r/-any])]
+ (let [left-map (subtype? left (impl/impl-case
+ :clojure (RClass-of IPersistentMap [r/-any r/-any])
+ :cljs (Protocol-of 'cljs.core/IMap [r/-any r/-any])))
+ right-map (subtype? (ret-t right) (impl/impl-case
+ :clojure (RClass-of IPersistentMap [r/-any r/-any])
+ :cljs (Protocol-of 'cljs.core/IMap [r/-any r/-any])))]
(cond
; preserve the rhand alias when possible
(and (r/Nil? left) right-map)
@@ -2073,20 +2296,29 @@
(cond
(and (or left-map (r/Nil? left))
(r/Nil? rtype))
- left
+ left
- (and (r/Nil? left) (sub-class? rtype IPersistentMap [r/-any r/-any]))
- rtype
+ (and (r/Nil? left)
+ (subtype? rtype (impl/impl-case
+ :clojure (RClass-of IPersistentMap [r/-any r/-any])
+ :cljs (Protocol-of 'cljs.core/IMap [r/-any r/-any]))))
+ rtype
(and (r/HeterogeneousMap? left) (r/HeterogeneousMap? rtype))
- (merge-hmaps left rtype)
+ (merge-hmaps left rtype)
- (and (not (sub-class? left IPersistentVector [r/-any]))
+ (and (not (subtype? left (impl/impl-case
+ :clojure (RClass-of IPersistentVector [r/-any])
+ :cljs (Protocol-of 'cljs.core/IVector [r/-any]))))
(satisfies? AssocableType left)
(r/HeterogeneousMap? rtype))
- (apply assoc-type-pairs left (map (fn [[k t]]
- [(r/ret k) (r/ret t)])
- (:types rtype)))
+ (do
+ ;TODO
+ (assert (empty? (:optional rtype)))
+ (apply assoc-type-pairs left (map (fn [[k t]]
+ [(r/ret k) (r/ret t)])
+ (:types rtype)))
+ )
))))))
(defn merge-types [left & r-tcresults]
@@ -2186,7 +2418,4 @@
;no bounds provided, default to Nothing <: Any
:else {:upper r/-any :lower r/-nothing})]
(r/Bounds-maker upper lower nil)))
-
-(defn -any-meta []
- (Un r/-nil (RClass-of clojure.lang.IPersistentMap r/-any r/-any)))
)
View
15 src/main/clojure/clojure/core/typed/type_rep.clj
@@ -394,6 +394,12 @@
p/IMu
(mu-scope [_] scope)])
+(t/ann Mu-body-unsafe [Mu -> Type])
+(defn Mu-body-unsafe [mu]
+ {:pre [(Mu? mu)]
+ :post [(Type? %)]}
+ (-> mu :scope :body))
+
(u/ann-record Value [val :- Any])
(u/def-type Value [val]
"A Clojure value"
@@ -426,13 +432,20 @@
(declare Result?)
(u/ann-record HeterogeneousMap [types :- (t/Map Type Type),
+ optional :- (t/Map Type Type),
absent-keys :- (t/Set Type),
other-keys? :- Boolean])
-(u/def-type HeterogeneousMap [types absent-keys other-keys?]
+(u/def-type HeterogeneousMap [types optional absent-keys other-keys?]
"A constant map, clojure.lang.IPersistentMap"
[((u/hash-c? Value? (some-fn Type? Result?))
types)
+ ((u/hash-c? Value? (some-fn Type? Result?))
+ optional)
((u/set-c? Value?) absent-keys)
+ (empty? (set/intersection
+ (set (keys types))
+ (set (keys optional))
+ absent-keys))
(u/boolean? other-keys?)]
:methods
[p/TCType])
View
26 src/main/clojure/clojure/core/typed/utils.clj
@@ -48,6 +48,10 @@
(declare emit-form-fn)
+(t/ann ^:no-check env-for-error [Any -> Any])
+(defn env-for-error [env]
+ env)
+
(t/ann ^:no-check nat? (predicate t/AnyInteger))
(t/ann ^:no-check hash-c? [[Any -> Any] [Any -> Any] -> [Any -> Any]])
;can't express the alternating args
@@ -106,8 +110,7 @@
{:form (if (contains? opt :form)
form
(emit-form-fn uvs/*current-expr*))})
- (when-let [env *current-env*]
- {:env env})))]
+ {:env (env-for-error *current-env*)}))]
(cond
;can't delay here
(not (bound? #'clojure.core.typed/*delayed-errors*))
@@ -140,7 +143,9 @@
(str ":"col))
") "
estr)
- {:type-error tc-error-parent}))))
+ (merge
+ {:type-error tc-error-parent}
+ {:env (env-for-error env)})))))
(defn deprecated-warn
[msg]
@@ -153,16 +158,14 @@
msg)
(flush)))
+
(defn int-error
[estr]
(let [env *current-env*]
- (throw (ex-info (str "Internal Error "
- "(" (-> env :ns :name) ":" (or (:line env) "<NO LINE>")
- (when-let [col (:column env)]
- (str ":" col))
- ") "
- estr)
- {:type-error int-error-kw}))))
+ (throw (ex-info estr
+ (merge
+ {:type-error int-error-kw}
+ {:env (env-for-error env)})))))
(defn nyi-error
[estr]
@@ -173,7 +176,8 @@
(str ":"col))
") "
estr)
- {:type-error nyi-error-kw}))))
+ (merge {:type-error nyi-error-kw}
+ {:env (env-for-error env)})))))
(defmacro with-ex-info-handlers
"Handle an ExceptionInfo e thrown in body. The first handler whos left hand
View
2  src/test/clojure/clojure/core/typed/test/atom.clj
@@ -1,5 +1,5 @@
(ns clojure.core.typed.test.atom
- (:require [clojure.core.typed :refer [ann ann-form check-ns cf Atom1 fn> def-alias]]
+ (:require [clojure.core.typed :as t :refer [ann ann-form check-ns cf Atom1 fn> def-alias]]
[clojure.repl :refer [pst]])
(:import (clojure.lang IPersistentMap Symbol)))
View
279 src/test/clojure/clojure/core/typed/test/core.clj
@@ -391,12 +391,12 @@
a)))
(ret (make-FnIntersection
(Function-maker
- [(Un (-hmap {(-val :op) (-val :if)})
- (-hmap {(-val :op) (-val :var)}))]
- (make-Result (Un -nil (-hmap {(-val :op) (-val :if)}))
+ [(Un (make-HMap :mandatory {(-val :op) (-val :if)})
+ (make-HMap :mandatory {(-val :op) (-val :var)}))]
+ (make-Result (Un -nil (make-HMap :mandatory {(-val :op) (-val :if)}))
(-FS (-and (-filter (-val :if) 0 [(->KeyPE :op)])
(-not-filter (Un -false -nil) 0)
- (-filter (-hmap {(-val :op) (-val :if)}) 0))
+ (-filter (make-HMap :mandatory {(-val :op) (-val :if)}) 0))
; what are these filters doing here?
(-or (-and (-filter (-val :if) 0 [(->KeyPE :op)])
(-filter (Un -false -nil) 0))
@@ -476,20 +476,20 @@
;update a from (U (HMap :mandatory {:op :if}) (HMap :mandatory {:op :var})) => (HMap :mandatory {:op :if})
(is-clj (let [props [(-filter (-val :if) 'a [(->KeyPE :op)])]
flag (atom true)]
- (and (= (let [env {'a (Un (-hmap {(-val :op) (-val :if)})
- (-hmap {(-val :op) (-val :var)}))}
+ (and (= (let [env {'a (Un (make-HMap :mandatory {(-val :op) (-val :if)})
+ (make-HMap :mandatory {(-val :op) (-val :var)}))}
lenv (-PropEnv env props)]
(env+ lenv [] flag))
- (-PropEnv {'a (-hmap {(-val :op) (-val :if)})} props))
+ (-PropEnv {'a (make-HMap :mandatory {(-val :op) (-val :if)})} props))
@flag)))
;test negative KeyPE
(is-clj (let [props [(-not-filter (-val :if) 'a [(->KeyPE :op)])]
flag (atom true)]
- (and (= (let [env {'a (Un (-hmap {(-val :op) (-val :if)})
- (-hmap {(-val :op) (-val :var)}))}
+ (and (= (let [env {'a (Un (make-HMap :mandatory {(-val :op) (-val :if)})
+ (make-HMap :mandatory {(-val :op) (-val :var)}))}
lenv (-PropEnv env props)]
(env+ lenv [] flag))
- (-PropEnv {'a (-hmap {(-val :op) (-val :var)})} props))
+ (-PropEnv {'a (make-HMap :mandatory {(-val :op) (-val :var)})} props))
@flag)))
;test impfilter
(is-clj (let [{:keys [l props]}
@@ -541,7 +541,7 @@
(is-clj (= (tc-t (clojure.core.typed/fn> [{a :a} :- (HMap :mandatory {:a (Value 1)})]
a))
(ret (make-FnIntersection
- (Function-maker [(-hmap {(-val :a) (-val 1)})]
+ (Function-maker [(make-HMap :mandatory {(-val :a) (-val 1)})]
(make-Result (-val 1)
(-FS -top -top) ; have to throw out filters whos id's go out of scope
;(->Path [(->KeyPE :a)] 0) ; requires 'equivalence' filters
@@ -569,7 +569,7 @@
#_(is-clj (= (tc-t (clojure.core.typed/fn> [a :- (HMap :mandatory {:a (Value 1)})]
(seq? a)))
(ret (make-FnIntersection
- (Function-maker [(-hmap {(-val :a) (-val 1)})]
+ (Function-maker [(make-HMap :mandatory {(-val :a) (-val 1)})]
(make-Result -false (-false-filter) -empty)
nil nil nil))
(-FS -top -bot)
@@ -607,8 +607,8 @@
a))
ret-t)
(make-FnIntersection
- (make-Function [(Un (-hmap {(-val :a) (-val 1)})
- (-hmap {(-val :b) (-val 2)}))]
+ (make-Function [(Un (make-HMap :mandatory {(-val :a) (-val 1)})
+ (make-HMap :mandatory {(-val :b) (-val 2)}))]
(Un (-val 1) -any))))))
(deftest Name-resolve-test
@@ -625,7 +625,7 @@
(let [{e :a} tmap]
(assoc e :c :b))))
(ret (make-FnIntersection (Function-maker [(Name-maker 'clojure.core.typed.test.util-aliases/MapName)]
- (make-Result (-hmap {(-val :a) (-val 1)
+ (make-Result (make-HMap :mandatory {(-val :a) (-val 1)
(-val :c) (-val :b)})
(-FS -top -bot) -empty)
nil nil nil))
@@ -650,7 +650,7 @@
:filter (let [t (-val :MapStruct1)
path [(->KeyPE :type)]]
(-FS (-and
- (-filter (-hmap {(-val :type) (-val :MapStruct1)
+ (-filter (make-HMap :mandatory {(-val :type) (-val :MapStruct1)
(-val :a) (Name-maker 'clojure.core.typed.test.util-aliases/MyName)})
0)
(-filter (-val :MapStruct1) 0 path)
@@ -686,7 +686,7 @@
1)))
(ret (make-FnIntersection (Function-maker [(Name-maker 'clojure.core.typed.test.util-aliases/UnionName)]
(let [t (Un (-val 1)
- (-hmap {(-val :type) (-val :MapStruct1)
+ (make-HMap :mandatory {(-val :type) (-val :MapStruct1)
(-val :c) (-val :d)
(-val :a) (Name-maker 'clojure.core.typed.test.util-aliases/MyName)}))]
(make-Result t (-FS -top -bot) -empty))
@@ -733,10 +733,10 @@
; :t :types first :rng :fl unparse-filter-set pprint)
(deftest update-test
- (is-clj (= (update (Un (-hmap {(-val :type) (-val :Map1)})
- (-hmap {(-val :type) (-val :Map2)}))
+ (is-clj (= (update (Un (make-HMap :mandatory {(-val :type) (-val :Map1)})
+ (make-HMap :mandatory {(-val :type) (-val :Map2)}))
(-filter (-val :Map1) 'tmap [(->KeyPE :type)]))
- (-hmap {(-val :type) (-val :Map1)})))
+ (make-HMap :mandatory {(-val :type) (-val :Map1)})))
;test that update resolves Names properly
(is-with-aliases (= (update (Name-maker 'clojure.core.typed.test.util-aliases/MapStruct2)
(-filter (-val :MapStruct1) 'tmap [(->KeyPE :type)]))
@@ -746,11 +746,11 @@
; with test (= :MapStruct1 (:type tmap))
(is-with-aliases (= (update (Name-maker 'clojure.core.typed.test.util-aliases/UnionName)
(-filter (-val :MapStruct1) 'tmap [(->KeyPE :type)]))
- (-hmap {(-val :type) (-val :MapStruct1)
+ (make-HMap :mandatory {(-val :type) (-val :MapStruct1)
(-val :a) (Name-maker 'clojure.core.typed.test.util-aliases/MyName)})))
(is-with-aliases (= (update (Name-maker 'clojure.core.typed.test.util-aliases/UnionName)
(-not-filter (-val :MapStruct1) 'tmap [(->KeyPE :type)]))
- (-hmap {(-val :type) (-val :MapStruct2)
+ (make-HMap :mandatory {(-val :type) (-val :MapStruct2)
(-val :b) (Name-maker 'clojure.core.typed.test.util-aliases/MyName)})))
(is-clj (= (update (Un -true -false) (-filter (Un -false -nil) 'a nil))
-false)))
@@ -780,9 +780,9 @@
(clojure.core.typed/ann-form [clojure.core.typed.test.core/SomeMap -> (U '{:a ':b :c '1}
'{:b ':c :c '1})])))
ret-t :types first :rng)
- (make-Result (Un (-hmap {(-val :a) (-val :b)
+ (make-Result (Un (make-HMap :mandatory {(-val :a) (-val :b)
(-val :c) (-val 1)})
- (-hmap {(-val :b) (-val :c)
+ (make-HMap :mandatory {(-val :b) (-val :c)
(-val :c) (-val 1)}))
(-FS -top -bot)
-empty))))
@@ -1168,7 +1168,7 @@
(is-clj (subtype? (-complete-hmap {})
(parse-type '(clojure.lang.APersistentMap Nothing Nothing))))
(is-clj (not
- (subtype? (-hmap {})
+ (subtype? (make-HMap :mandatory {})
(parse-type '(clojure.lang.APersistentMap Nothing Nothing)))))
(is-clj (subtype? (-> (tc-t {}) ret-t)
(parse-type '(clojure.lang.APersistentMap Nothing Nothing)))))
@@ -1360,17 +1360,17 @@
(deftest path-update-test
(is-clj
- (both-subtype? (clj (update (Un -nil (-hmap {(-val :foo) (RClass-of Number)}))
+ (both-subtype? (clj (update (Un -nil (make-HMap :mandatory {(-val :foo) (RClass-of Number)}))
(-filter (Un -false -nil) 'id [(->KeyPE :foo)])))
-nil))
(is-clj
- (both-subtype? (update (Un -nil (-hmap {(-val :foo) (RClass-of Number)}))
+ (both-subtype? (update (Un -nil (make-HMap :mandatory {(-val :foo) (RClass-of Number)}))
(-not-filter (Un -false -nil) 'id [(->KeyPE :foo)]))
- (-hmap {(-val :foo) (RClass-of Number)})))
+ (make-HMap :mandatory {(-val :foo) (RClass-of Number)})))
; if (:foo a) is nil, either a has a :foo entry with nil, or no :foo entry
- (is-clj (both-subtype? (update (-hmap {})
+ (is-clj (both-subtype? (update (make-HMap)
(-filter -nil 'id [(->KeyPE :foo)]))
- (make-HMap {} {(-val :foo) -nil}))))
+ (make-HMap :optional {(-val :foo) -nil}))))
(deftest multimethod-test
(is (check-ns 'clojure.core.typed.test.mm)))
@@ -1388,7 +1388,7 @@
(deftest HMap-syntax-test
(is (= (parse-type '(HMap :absent-keys #{:op}))
- (-hmap {} #{(-val :op)} true))))
+ (make-HMap :absent-keys #{(-val :op)} :complete? false))))
(deftest map-filter-test
(is-cf (clojure.core.typed/ann-form (fn [a] (:op a))
@@ -2010,9 +2010,8 @@
(assert (nil? (:foo m)))
m))
(parse-clj '[(HMap :mandatory {:bar Any}) ->
- (U (HMap :mandatory {:bar Any, :foo nil})
- (HMap :mandatory {:bar Any}
- :absent-keys #{:foo}))
+ (HMap :mandatory {:bar Any}
+ :optional {:foo nil})
:filters {:then (! (U nil false) 0)
:else (is (U nil false) 0)}
:object {:id 0}])))
@@ -2025,8 +2024,7 @@
m))
(parse-clj '[(HMap) ->
; not sure if this should simplify to (HMap)
- (U (HMap :mandatory {:foo Any})
- (HMap :absent-keys #{:foo}))
+ (HMap :optional {:foo Any})
:filters {:then (! (U nil false) 0)
:else (is (U nil false) 0)}
:object {:id 0}])))
@@ -2236,7 +2234,8 @@
(clojure.core.typed/ann-form {} (U nil (HMap :optional {:b String} :complete? true))))
(U nil (HMap :optional {:a Number :b String} :complete? true)))
- ; this merge doesn't actually give us any information about :b
+ ; this merge doesn't actually give us any information about :b because
+ ; the second map might not have a :b key, and the first map is partial.
(equal-types (merge (clojure.core.typed/ann-form {} (HMap :optional {:a Number} :complete? false))
(clojure.core.typed/ann-form {} (HMap :optional {:b String} :complete? true)))
(HMap :optional {:a Number}))
@@ -2271,16 +2270,13 @@
; incomplete covering optional
(equal-types (merge {:a 5}
(clojure.core.typed/ann-form {} (HMap :optional {:a (Value 10)})))
- (U '{:a (Value 5)}
- '{:a (Value 10)}))
+ '{:a (U (Value 5) (Value 10))})
; both incomplete optionals
(equal-types (merge (clojure.core.typed/ann-form {} (HMap :optional {:a '5}))
(clojure.core.typed/ann-form {} (HMap :optional {:a '10})))
- (U '{:a '5}
- '{:a '10}
- (HMap :mandatory {} :absent-keys #{:a} :complete? false)))
+ (HMap :optional {:a (U '5 '10)}))
; (Option HMap) first argument incomplete
(equal-types (merge (clojure.core.typed/ann-form {:a 5} (U nil '{:a '5}))
@@ -2610,7 +2606,8 @@
(is (= (clj (unparse-type (parse-type '(TFn [[a :variance :covariant]] a))))
(quote (TFn [[a :variance :covariant]] a))))
- (is (= '[(All [a b] (Fn [Any Any -> (Fn [a b -> nil])])) {:then tt, :else ff}]
+ (is (= '[(All [a b] (Fn [Any Any -> (Fn [a b -> nil :filters {:then ff :else tt}])
+ :filters {:then tt :else ff}])) {:then tt, :else ff}]
(cf
(fn [f coll]
(clojure.core.typed/fn>
@@ -2787,6 +2784,151 @@
(deftest demunged-protocol-method-test
(is (check-ns 'clojure.core.typed.test.protocol-munge)))
+(deftest csgen-hmap-test
+ ; (HMap :mandatory {:a Number :b Number} :complete? true) :!< (HMap :mandatory {:a x} :complete? true)
+ (is
+ (u/top-level-error-thrown?
+ (cf (clojure.core.typed/letfn>
+ [take-map :- (All [x] [(HMap :mandatory {:a x} :complete? true) -> x])
+ (take-map [a] (:a a))]
+ (take-map {:a 1 :b 2})))))
+ ; (HMap :mandatory {:a Number}) :!< (HMap :mandatory {:a x} :complete? true)
+ (is
+ (u/top-level-error-thrown?
+ (cf (clojure.core.typed/letfn>
+ [take-map :- (All [x] [(HMap :mandatory {:a x} :complete? true) -> x])
+ (take-map [a] (:a a))]
+ (take-map (clojure.core.typed/ann-form
+ {:a 1}
+ '{:a Number})))))))
+
+(deftest subtype-hmap-optional-test
+ (is (sub?
+ (HMap :mandatory {:a Number})
+ (U (HMap :mandatory {:a Number})
+ (HMap :absent-keys [:a]))))
+ (is (sub?
+ (HMap :mandatory {:a Number})
+ (HMap :optional {:a Number})))
+ (is (not
+ (sub?
+ (HMap :complete? true :mandatory {:a Number :b Any})
+ (HMap :complete? true :mandatory {:a Number}))))
+ (is (sub?
+ (HMap :complete? true :optional {:a Number :b Any})
+ (HMap :complete? true :optional {:a Number})))
+ (is (not
+ (sub?
+ (HMap :optional {:a Number})
+ (HMap :mandatory {:a Number}))))
+ (is (not
+ (sub?
+ (HMap :optional {:b Number})
+ (HMap :optional {:a Number}))))
+ (is (not
+ (sub?
+ (HMap :optional {:a Any})
+ (HMap :optional {:a Number}))))
+ (is (not
+ (sub?
+ (HMap :mandatory {:a Number})
+ (ExactCount 1))))
+ (is (sub?
+ (HMap :complete? true :mandatory {:a Number})
+ (ExactCount 1)))
+ (is (not
+ (sub?
+ (HMap :complete? true
+ :mandatory {:foo Any}
+ :optional {:a Number})
+ (ExactCount 1))))
+ (is (sub?
+ (HMap :complete? true
+ :mandatory {:foo Number})
+ (clojure.lang.IPersistentMap Any Number)))
+ (is (not
+ (sub?
+ (HMap :complete? true
+ :mandatory {:foo Number}
+ :optional {:bar Any})
+ (clojure.lang.IPersistentMap Any Number))))
+
+ (is (sub? (U (HMap :mandatory {:foo Number}
+ :complete? true)
+ (HMap :complete? true))
+ (HMap :optional {:foo Number})))
+ (is (sub? (U (HMap :mandatory {:c Number}
+ :optional {:b Number :a Number}
+ :complete? true)
+ (HMap :optional {:b Number :c Number}
+ :complete? true))
+ (HMap :optional {:a Number :b Number :c Number})))
+ (is (sub?
+ (U (HMap :mandatory {:c (Value 5)}
+ :complete? true)
+ (HMap :complete? true))
+ (HMap :optional {:c (Value 5)} :complete? true)))
+ (is (sub?
+ (U (HMap :mandatory {:c (Value 5)}
+ :optional {:b java