From fefeb2d4ea982f6366c40470b06e982b2dc8acc9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 16 Mar 2018 22:39:17 -0400 Subject: [PATCH 001/810] Fix `educe` --- .../quantum/untyped/core/collections.cljc | 17 ++++++++++------- src-untyped/quantum/untyped/core/reducers.cljc | 7 +++---- .../quantum/untyped/core/type/predicates.cljc | 4 ++++ 3 files changed, 17 insertions(+), 11 deletions(-) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index 858f8f4a..bb91723e 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -17,13 +17,16 @@ [quantum.untyped.core.reducers :as ur :refer [defeager def-transducer>eager transducer->transformer educe]] [quantum.untyped.core.type.predicates - :refer [array? val?]])) + :refer [array? val? transient?]])) (ucore/log-this-ns) (def count core/count) (def lrange core/range) +(defn ?persistent! [x] + (if (transient? x) (persistent! x) x)) + ;; ===== SOCIATIVE ===== ;; (defn get @@ -298,17 +301,17 @@ [f coll] (let [frequencies-0 (educe - (aritoid nil persistent! + (aritoid (fn' (transient {})) persistent! (fn [counts x] (let [gotten (f x) freq (inc (get counts gotten 0))] (assoc! counts gotten freq)))) - (transient {}) coll) + coll) frequencies-f (educe - (aritoid nil persistent! + (aritoid (fn' (transient {})) persistent! (fn [ret elem] (assoc! ret elem (get frequencies-0 (f elem))))) - (transient {}) coll)] + coll)] frequencies-f)) (defn group-by @@ -326,11 +329,11 @@ "Like `clojure.core/distinct?` except operates on reducibles." [xs] (->> xs - (educe (aritoid (fn' #{}) identity + (educe (aritoid (fn' (transient #{})) ?persistent! (fn [distincts x] (if (contains? distincts x) (reduced false) - (conj distincts x))))) + (conj! distincts x))))) boolean)) ;; ===== ZIPPER ===== ;; diff --git a/src-untyped/quantum/untyped/core/reducers.cljc b/src-untyped/quantum/untyped/core/reducers.cljc index b6ea97fe..5be42a67 100644 --- a/src-untyped/quantum/untyped/core/reducers.cljc +++ b/src-untyped/quantum/untyped/core/reducers.cljc @@ -91,10 +91,9 @@ a reduction (unlike `reduce`)." ([f xs] (educe f (f) xs)) ([f init xs] - (let [ret (if (satisfies? PEduceInit xs) - (-educe-init xs f init) - (reduce f init xs))] - (f ret)))) + (if (satisfies? PEduceInit xs) + (-educe-init xs f init) + (f (reduce f init xs))))) (defn join "Like `into`, but internally uses `educe`, and creates as little data diff --git a/src-untyped/quantum/untyped/core/type/predicates.cljc b/src-untyped/quantum/untyped/core/type/predicates.cljc index d4736d0c..d47475a8 100644 --- a/src-untyped/quantum/untyped/core/type/predicates.cljc +++ b/src-untyped/quantum/untyped/core/type/predicates.cljc @@ -63,3 +63,7 @@ (defn array? [x] #?(:clj (-> x class .isArray) ; must be reflective :cljs (core/array? x))) + +(defn transient? [x] + #?(:clj (instance? clojure.lang.ITransientCollection x) + :cljs (satisfies? cljs.core/ITransientCollection x))) From 40c33abe3207e28520f2e5d23937a32940dbfe9f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Mar 2018 00:51:05 -0400 Subject: [PATCH 002/810] Some improvements --- doc/naming.md | 3 ++- src-untyped/quantum/untyped/core/error.cljc | 5 +++-- src-untyped/quantum/untyped/core/type.cljc | 4 ++++ src-untyped/quantum/untyped/core/type/core.cljc | 2 +- test/quantum/test/core/defnt_equivalences.cljc | 12 ++++++++++++ 5 files changed, 22 insertions(+), 4 deletions(-) diff --git a/doc/naming.md b/doc/naming.md index 1300fd1a..c6e32256 100644 --- a/doc/naming.md +++ b/doc/naming.md @@ -5,11 +5,12 @@ - `->`+ : constructor : 'convert to' - +`->` : 'convert from' +- `a=>b` : map from `a` to `b` - `<`+ : calculate/compute (of functions) — as if to "take off the chan" of computed vals - `:` : specificity relationship; of type - +`?` : predicate - `?`+ : 'maybe' — if null, return null, otherwise do something -- +`*` : 'variant' — as ambiguous as it sounds +- +`*` : 'variant' — as ambiguous as it sounds ; TODO phase out : 'relaxed' — in the context of numerics - +`'` : 'strict' — esp. if numeric : 'prime'/'next' diff --git a/src-untyped/quantum/untyped/core/error.cljc b/src-untyped/quantum/untyped/core/error.cljc index f1ff8808..8ce2cc2f 100644 --- a/src-untyped/quantum/untyped/core/error.cljc +++ b/src-untyped/quantum/untyped/core/error.cljc @@ -200,8 +200,9 @@ ;; ===== Specific error types ===== ;; (defn todo - ([] (err! :todo "This feature has not yet been implemented." nil)) - ([msg] (err! :todo (str "This feature has not yet been implemented: " msg) nil))) + ([] (err! :todo "This feature has not yet been implemented." nil)) + ([msg] (todo msg nil)) + ([msg data] (err! :todo (str "This feature has not yet been implemented: " msg) data))) (defalias TODO todo) (defn not-supported [name- x] (>err (str "`" name- "` not supported on") {:x (type x)})) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index f6f010af..b40059b3 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -1134,6 +1134,10 @@ (value-spec? spec) (let [v (value-spec>value spec)] {:class (type v) :nilable? (c/nil? v)}) + (c/= spec universal-set) + {:class #?(:clj java.lang.Object + :cljs (TODO "Not sure what to do in the case of universal CLJS set")) + :nilable? true} (c/or (and-spec? spec) (or-spec? spec)) (let [classes (spec>classes spec) nilable? (contains? classes nil)] diff --git a/src-untyped/quantum/untyped/core/type/core.cljc b/src-untyped/quantum/untyped/core/type/core.cljc index b527f467..2a065e30 100644 --- a/src-untyped/quantum/untyped/core/type/core.cljc +++ b/src-untyped/quantum/untyped/core/type/core.cljc @@ -205,4 +205,4 @@ (->> boxed-types (r/filter #(isa? % c)) (r/map boxed->unboxed) - set)))) + (into #{}))))) diff --git a/test/quantum/test/core/defnt_equivalences.cljc b/test/quantum/test/core/defnt_equivalences.cljc index 75d6291d..853b06bf 100644 --- a/test/quantum/test/core/defnt_equivalences.cljc +++ b/test/quantum/test/core/defnt_equivalences.cljc @@ -344,6 +344,18 @@ ;; =====|=====|=====|=====|===== ;; +(macroexpand ' +(defnt >long* + {:source "clojure.lang.RT.uncheckedLongCast"} + > t/long? + ([x (t/isa? Number)] (.longValue x)) + ([x (t/or t/byte? t/char? t/short? t/int? t/long? t/float? t/double?)] + (Primitive/uncheckedLongCast x)))) + +;; ----- expanded code ----- ;; + +;; =====|=====|=====|=====|===== ;; + (macroexpand ' (defnt !str ([] #?(:clj (StringBuilder.) :cljs (StringBuffer.))) From 1b02a1a6dc0d4a77751438edcf7a0531f2783d84 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 16 Mar 2018 23:22:21 -0600 Subject: [PATCH 003/810] Fix some bugs --- src-dev/quantum/core/defnt.cljc | 54 +++++++++++-------- src-untyped/quantum/untyped/core/core.cljc | 21 ++++---- src-untyped/quantum/untyped/core/type.cljc | 42 +++------------ .../quantum/untyped/core/type/core.cljc | 2 +- .../quantum/test/core/defnt_equivalences.cljc | 4 ++ 5 files changed, 55 insertions(+), 68 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 072ad42b..556df280 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -185,33 +185,32 @@ (defn class>simplest-class "This ensures that special overloads are not created for non-primitive subclasses of java.lang.Object (e.g. String, etc.)." - [c #_(t/? t/class?)] + [c #_t/class?] (if (t/primitive-class? c) c (or (tcore/boxed->unboxed c) java.lang.Object)))) #?(:clj -(defn class-data>most-primitive-class - "Assumes class is not `::t/multiple`" - [{:keys [nilable?] c :class}] +(defn class>most-primitive-class + [c #_t/class? nilable?] (if nilable? c (or (tcore/boxed->unboxed c) c)))) #?(:clj -(defn spec>most-primitive-class [spec & [throw?]] - (let [{:as class-data c :class} (t/spec>class spec)] - (if (= c ::t/multiple) - (if throw? - (err! "Found multiple classes corresponding to spec; don't know how to handle yet" - {:spec spec :class-data class-data}) - c) - (class-data>most-primitive-class class-data))))) +(defn spec>most-primitive-class [spec #_t/spec?] + (let [cs (t/spec>classes spec) cs' (disj cs nil)] + (if (-> cs' count (> 1)) + (err! "Found multiple classes corresponding to spec; don't know how to handle yet" + {:spec spec :classes cs}) + (class>most-primitive-class (first cs') (contains? cs nil)))))) #?(:clj -(defn out-spec>class [spec] - (let [{:as class-data c :class} (t/spec>class spec)] - (ifs ;; NOTE: we don't need to vary the output class if there are multiple output possibilities - (= c ::t/multiple) java.lang.Object - (-> class-data class-data>most-primitive-class class>simplest-class))))) +(defn out-spec>class [spec #_t/spec?] + (let [cs (t/spec>classes spec) cs' (disj cs nil)] + (if (-> cs' count (not= 1)) + ;; NOTE: we don't need to vary the output class if there are multiple output possibilities or just nil + java.lang.Object + (-> (class>most-primitive-class (first cs') (contains? cs nil)) + class>simplest-class))))) (defn fns|code [kind lang args] (assert (= lang #?(:clj :clj :cljs :cljs)) lang) @@ -221,7 +220,7 @@ (fn [{{:keys [args varargs pre post]} ::fnt|arglist body :body}] (let [spec-code>?class - (fn [spec] (some-> spec eval t/>spec (spec>most-primitive-class true))) + (fn [spec] (some-> spec eval t/>spec spec>most-primitive-class)) arg-spec>validation (fn [{[k spec] ::fnt|arg-spec :keys [arg-binding]}] ;; TODO this validation is purely temporary until destructuring is supported @@ -613,6 +612,15 @@ :field field-form :spec (-> field .getType t/>spec)})) +(defn classes>class + "Ensure that given a set of classes, that set consists of at most a class C and nil. + If so, returns C. Otherwise, throws." + [cs #_(set-of class?)] + (let [cs' (disj cs nil)] + (if (-> cs' count (= 1)) + (first cs') + (err! "Found more than one class" cs)))) + ;; TODO spec these arguments; e.g. check that ?method||field, if present, is an unqualified symbol (defn analyze-seq|dot [env form [target-form ?method-or-field & ?args]] {:pre [(prl! env form target-form ?method-or-field ?args)] @@ -626,8 +634,10 @@ ;; necessarily rely on all e.g. "@nonNull" annotations {:as ?target-static-class-map target-static-class :class target-static-class-nilable? :nilable?} (-> target :spec t/spec>?class-value) - {target-class :class target-class-nilable? :nilable?} - (or ?target-static-class-map (-> target :spec t/spec>class))] + target-classes + (or ?target-static-class-map (-> target :spec t/spec>classes)) + target-class-nilable? (contains? target-classes nil) + target-class (classes>class target-classes)] ;; TODO determine how to handle `target-class-nilable?`; for now we will just let it slip through ;; to `NullPointerException` at runtime rather than create a potentially more helpful custom ;; exception @@ -802,7 +812,7 @@ (defn arg-specs>arg-classes-seq|primitivized [arg-specs] (->> arg-specs (c/lmap (fn [spec] - (let [c (spec>most-primitive-class spec true)] + (let [c (spec>most-primitive-class spec)] (if (nil? c) [java.lang.Object] (->> c tcore/class>prim-subclasses @@ -826,7 +836,7 @@ [arg-binding (ast/unbound nil arg-binding arg-spec)]))) analyzed (analyze env (ufgen/?wrap-do body-codelist|pre-analyze)) arg-specs (->> arg-bindings (mapv #(:spec (c/get (:env analyzed) %)))) - arg-classes (->> arg-specs (c/map (fn1 spec>most-primitive-class true))) + arg-classes (->> arg-specs (c/map spec>most-primitive-class)) arg-classes|simplest (->> arg-classes (c/map class>simplest-class)) hint-arg|fn (fn [i arg-binding] (ufth/with-type-hint arg-binding diff --git a/src-untyped/quantum/untyped/core/core.cljc b/src-untyped/quantum/untyped/core/core.cljc index 50fdcd86..409626b2 100644 --- a/src-untyped/quantum/untyped/core/core.cljc +++ b/src-untyped/quantum/untyped/core/core.cljc @@ -52,16 +52,17 @@ "Ensures that two pieces of code are equivalent. This means ensuring that seqs, vectors, and maps are only allowed to be compared with each other, and that metadata is equivalent." - [code0 code1] - (if (metable? code0) - (and (metable? code1) - (= (meta code0) (meta code1)) - (cond (seq? code0) (and (seq? code1) (seq= code0 code1 code=)) - (vector? code0) (and (vector? code1) (seq= (seq code0) (seq code1) code=)) - (map? code0) (and (map? code1) (seq= (seq code0) (seq code1) code=)) - :else (= code0 code1))) - (and (not (metable? code1)) - (= code0 code1)))) + ([code0 code1] + (if (metable? code0) + (and (metable? code1) + (= (meta code0) (meta code1)) + (cond (seq? code0) (and (seq? code1) (seq= code0 code1 code=)) + (vector? code0) (and (vector? code1) (seq= (seq code0) (seq code1) code=)) + (map? code0) (and (map? code1) (seq= (seq code0) (seq code1) code=)) + :else (= code0 code1))) + (and (not (metable? code1)) + (= code0 code1)))) + ([code0 code1 & codes] (and (code= code0 code1) (every? #(code= code0 %) codes)))) ;; From `quantum.untyped.core.form.evaluate` — used below in `defalias` diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index b40059b3..0ecd3616 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -1114,6 +1114,11 @@ (conj classes (class-spec>class spec)) (value-spec? spec) (conj classes (value-spec>value spec)) + (c/= spec universal-set) + #?(:clj #{nil java.lang.Object} + :cljs (TODO "Not sure what to do in the case of universal CLJS set")) + (c/= spec empty-set) + #{} (and-spec? spec) (reduce (fn [classes' spec'] (-spec>classes spec' classes')) classes (and-spec>args spec)) @@ -1123,43 +1128,11 @@ :else (err! "Not sure how to handle spec" spec))) -(defn spec>classes +(defn spec>classes #_> set? "Outputs the set of all the classes ->`spec` can embody according to its various conditional branches, if any. Ignores nils, treating in Clojure simply as a `java.lang.Object`." [spec] (-spec>classes spec #{})) -(defn- -spec>class [spec spec-nilable?] - (cond (class-spec? spec) - {:class (class-spec>class spec) :nilable? spec-nilable?} - (value-spec? spec) - (let [v (value-spec>value spec)] - {:class (type v) :nilable? (c/nil? v)}) - (c/= spec universal-set) - {:class #?(:clj java.lang.Object - :cljs (TODO "Not sure what to do in the case of universal CLJS set")) - :nilable? true} - (c/or (and-spec? spec) (or-spec? spec)) - (let [classes (spec>classes spec) - nilable? (contains? classes nil)] - (if nilable? - {:nilable? true - :class (ifs (-> classes count (c/= 1)) nil - (-> classes count (c/= 2)) (-> classes (disj nil) seq first) - (TODO "Need to handle possibly-related classes" classes))} - {:nilable? false - :class (if (-> classes count (c/= 1)) - (-> classes seq first) - (TODO "Need to handle possibly-related classes" classes))})) - :else - (err! "Don't know how to handle spec" spec))) - -(defn spec>class - "Outputs the single class embodied by ->`spec`. - Outputs `{:class :nilable? }` if the spec embodies only one (possibly nilable) class. - Outputs `{:class nil :nilable? true }` if the spec embodies the value `nil`. - Outputs `{:class ::multiple :nilable? nil }` if the spec embodies multiple classes." - [spec] (-spec>class spec false)) - #?(:clj (defn- -spec>?class-value [spec spec-nilable?] (if (value-spec? spec) @@ -1170,8 +1143,7 @@ #?(:clj (defn spec>?class-value "Outputs the single class value embodied by ->`spec`. - Differs from `spec>class` in that if a spec is a extensionally equal of the *value* of a class, - outputs that class. + If a spec is extensionally equal the *value* of a class, outputs that class. However, if a spec does not embody the value of a class but rather merely embodies (as all specs) an extensional subset of the set of all objects conforming to a class, outputs nil." diff --git a/src-untyped/quantum/untyped/core/type/core.cljc b/src-untyped/quantum/untyped/core/type/core.cljc index 2a065e30..d360e5ab 100644 --- a/src-untyped/quantum/untyped/core/type/core.cljc +++ b/src-untyped/quantum/untyped/core/type/core.cljc @@ -201,7 +201,7 @@ {:examples '{(class>prim-subclasses Number) #{utdef/long utdef/int utdef/short utdef/byte utdef/float utdef/double}}} [^Class c] - (let [boxed-types (get utdef/types 'primitive-boxed?)] + (let [boxed-types (get-in utdef/types [:clj 'primitive-boxed?])] (->> boxed-types (r/filter #(isa? % c)) (r/map boxed->unboxed) diff --git a/test/quantum/test/core/defnt_equivalences.cljc b/test/quantum/test/core/defnt_equivalences.cljc index 853b06bf..788a9e2b 100644 --- a/test/quantum/test/core/defnt_equivalences.cljc +++ b/test/quantum/test/core/defnt_equivalences.cljc @@ -65,6 +65,10 @@ (is (code= +(macroexpand ' +(defnt identity|gen|uninlined ([x _] x)) +) + ;; ----- implementation ----- ;; (macroexpand ' From 3082b40de17b0a9db7b0f1a8a9a1326b4c468a43 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Mar 2018 09:34:34 -0600 Subject: [PATCH 004/810] Improve naming --- doc/naming.md | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/doc/naming.md b/doc/naming.md index c6e32256..7bdec158 100644 --- a/doc/naming.md +++ b/doc/naming.md @@ -3,11 +3,15 @@ ## Symbols - `->`+ : constructor - : 'convert to' -- +`->` : 'convert from' -- `a=>b` : map from `a` to `b` + : 'convert to' ; TODO phase out +; `>`+ : 'convert to' +- +`->` : 'convert from' ; TODO phase out +- +`>` : 'convert from' +- `=>` : map from to ; TODO phase out +- `->` : map from to - `<`+ : calculate/compute (of functions) — as if to "take off the chan" of computed vals -- `:` : specificity relationship; of type +- `:` : specificity relationship; of type ; TODO phase out +- `|` : specificity relationship; of type - +`?` : predicate - `?`+ : 'maybe' — if null, return null, otherwise do something - +`*` : 'variant' — as ambiguous as it sounds ; TODO phase out From 4987dfcf6c6d332f6ae3ae416bf1e37fa66e9c8d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Mar 2018 09:35:19 -0600 Subject: [PATCH 005/810] More defnt equivalences working! --- src-dev/quantum/core/defnt.cljc | 68 +++---- .../quantum/untyped/core/analyze/expr.cljc | 12 +- .../quantum/untyped/core/collections.cljc | 2 + .../untyped/core/collections/logic.cljc | 24 +-- .../quantum/untyped/core/form/type_hint.cljc | 28 ++- src-untyped/quantum/untyped/core/type.cljc | 19 +- src/quantum/core/collections.cljc | 4 +- src/quantum/core/collections/core.cljc | 7 +- src/quantum/core/collections/logic.cljc | 3 - src/quantum/core/collections/selective.cljc | 2 +- src/quantum/core/convert/primitive.cljc | 68 +++---- src/quantum/core/macros/defnt.cljc | 10 +- .../quantum/test/core/defnt_equivalences.cljc | 181 +++++++++++++----- test/quantum/test/core/logic.cljc | 4 - 14 files changed, 266 insertions(+), 166 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 556df280..b61c7289 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -27,7 +27,7 @@ [quantum.untyped.core.analyze.expr :as xp] [quantum.untyped.core.analyze.rewrite :as ana-rw] [quantum.untyped.core.collections :as c - :refer [dissoc-if dissoc* lcat subview >vec + :refer [dissoc-if dissoc* lcat subview >vec >set lmap map+ map-vals+ mapcat+ filter+ remove+ partition-all+]] [quantum.untyped.core.collections.logic :as ucl :refer [seq-and seq-or]] @@ -196,12 +196,11 @@ (if nilable? c (or (tcore/boxed->unboxed c) c)))) #?(:clj -(defn spec>most-primitive-class [spec #_t/spec?] - (let [cs (t/spec>classes spec) cs' (disj cs nil)] - (if (-> cs' count (> 1)) - (err! "Found multiple classes corresponding to spec; don't know how to handle yet" - {:spec spec :classes cs}) - (class>most-primitive-class (first cs') (contains? cs nil)))))) +(defn spec>most-primitive-classes [spec #_t/spec?] #_> #_(set-of (? class?)) + (let [cs (t/spec>classes spec) nilable? (contains? cs nil)] + (->> cs + (c/map+ #(class>most-primitive-class % nilable?)) + (join #{}))))) #?(:clj (defn out-spec>class [spec #_t/spec?] @@ -556,9 +555,7 @@ "A note will be made of what methods match the argument types. If only one method is found, that is noted too. If no matching method is found, an exception is thrown." - {:params-doc '{methods "A reducible of all static/instance `Method`s with the given name, - `method-form`, in the given `target`'s class."}} - [env form target target-class static? #_t/boolean? method-form #_t/unqualified-symbol? args-forms] + [env form target target-class #_class? static? #_boolean? method-form #_unqualified-symbol? args-forms #_(seq-of form?)] ;; TODO cache spec by method (if-not-let [methods-for-name (-> target-class class->methods|with-cache (c/get (name method-form)))] (if (empty? args-forms) @@ -591,11 +588,11 @@ (update with-arg-specs :spec (fn [ret-spec] (let [arg-specs (->> with-arg-specs :args (mapv :spec))] - (if (seq arg-specs) - (do (err! "TODO arg spec") - #_(if (t/infer? arg-spec) - (swap! arg-spec t/and (get ret-spec i)) - ((get ret-spec i) arg-spec))) + (if (seq-or t/infer? arg-specs) + (err! "TODO arg spec" (kw-map arg-specs ret-spec (ret-spec arg-specs))) + #_(if (t/infer? arg-spec) + (swap! arg-spec t/and (get ret-spec i)) + ((get ret-spec i) arg-spec)) (ret-spec arg-specs))))) ?cast-spec (?cast-call->spec target-class method-form) _ (when ?cast-spec @@ -604,7 +601,7 @@ with-ret-spec)))))) (defns analyze-seq|dot|field-access - [env _, form _, target _, field-form _ #_t/unqualified-symbol?, field Field] + [env _, form _, target _, field-form _ #_t/unqualified-symbol?, field java.lang.reflect.Field] (ast/field-access {:env env :form form @@ -635,7 +632,9 @@ {:as ?target-static-class-map target-static-class :class target-static-class-nilable? :nilable?} (-> target :spec t/spec>?class-value) target-classes - (or ?target-static-class-map (-> target :spec t/spec>classes)) + (if ?target-static-class-map + (cond-> #{target-static-class} target-static-class-nilable? (conj nil)) + (-> target :spec t/spec>classes)) target-class-nilable? (contains? target-classes nil) target-class (classes>class target-classes)] ;; TODO determine how to handle `target-class-nilable?`; for now we will just let it slip through @@ -797,7 +796,7 @@ (s/validate ~'out ~(update-meta post-spec dissoc* :runtime?)))) #?(:clj -(var/def sort-guide "for use in sorting" +(var/def sort-guide "for use in arity sorting, in increasing conceptual size" {Object 0 tdef/boolean 1 tdef/byte 2 @@ -809,16 +808,20 @@ tdef/double 8})) #?(:clj -(defn arg-specs>arg-classes-seq|primitivized [arg-specs] +(defn arg-specs>arg-classes-seq|primitivized + [arg-specs #_(t/seq-of t/spec?)] #_> #_(t/seq-of (t/vec-of t/class?)) (->> arg-specs (c/lmap (fn [spec] - (let [c (spec>most-primitive-class spec)] - (if (nil? c) - [java.lang.Object] - (->> c tcore/class>prim-subclasses - (set/union #{(class>simplest-class c)}) - ;; for purposes of cleanliness and reproducibility in tests - (sort-by sort-guide)))))) + (if (-> spec meta :ref?) + (-> spec t/spec>classes (disj nil) seq) + (let [cs (spec>most-primitive-classes spec)] + + (let [base-classes (->> cs (c/map+ class>simplest-class) >set) + base-classes (cond-> base-classes (contains? cs nil) (conj java.lang.Object))] + (->> cs (c/map+ tcore/class>prim-subclasses) + (educe (aritoid nil identity set/union) base-classes) + ;; for purposes of cleanliness and reproducibility in tests + (sort-by sort-guide))))))) (apply combo/cartesian-product) (c/lmap >vec)))) @@ -931,10 +934,11 @@ (defn fnt-overload>interface [args-classes out-class] (let [interface-sym (fnt-overload>interface-sym args-classes out-class) - hinted-method-sym (ufth/with-type-hint fnt-method-sym (ufth/>arglist-embeddable-tag out-class)) - interface-code `(~'definterface ~interface-sym (~hinted-method-sym ~(ufgen/gen-args (count args-classes))))] - (log/pr ::debug "Creating interface" interface-sym "...") - (eval interface-code))) + hinted-method-sym (ufth/with-type-hint fnt-method-sym (ufth/>interface-method-tag out-class)) + hinted-args (ufth/hint-arglist-with + (ufgen/gen-args (count args-classes)) + (map ufth/>interface-method-tag args-classes))] + `(~'definterface ~interface-sym (~hinted-method-sym ~hinted-args)))) #?(:clj (defn fnt|overload>reify-overload #_> #_(seq-of ::reify|overload) @@ -943,7 +947,7 @@ (let [interface-k {:out out-class :in arg-classes} interface (-> *interfaces - (swap! update interface-k #(or % (fnt-overload>interface arg-classes out-class))) + (swap! update interface-k #(or % (eval (fnt-overload>interface arg-classes out-class)))) (c/get interface-k)) arglist-code (>vec (concat ['_] @@ -1162,7 +1166,7 @@ [fn|name] []) [overloads|code])) - :defn `(~'do ~register-spec + :defn `(~'do #_~register-spec ; elide for now ~@fn-codelist))] code)) diff --git a/src-untyped/quantum/untyped/core/analyze/expr.cljc b/src-untyped/quantum/untyped/core/analyze/expr.cljc index 06fc6422..30a59224 100644 --- a/src-untyped/quantum/untyped/core/analyze/expr.cljc +++ b/src-untyped/quantum/untyped/core/analyze/expr.cljc @@ -81,12 +81,12 @@ (#?(:clj invoke :cljs -invoke) [_ x] (let [v (f x)] (if-let [[_ then :as matching-clause] - (seq-or (fn [clause] - (if (-> clause count (= 1)) - clause - (let [[condition then] clause] - (when (pred v condition) - clause)))) clauses)] + (->> clauses + (filter (fn [clause] + (or (-> clause count (= 1)) + (let [[condition then] clause] + (pred v condition))))) + first)] (if (icall? then) (then x) then) (err! "No matching clause found" {:v v})))) fipp.ednize/IOverride diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index bb91723e..b7cfdeef 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -265,6 +265,8 @@ (defn >vec [xs] (ur/join xs)) +(defn >set [xs] (if (set? xs) xs (ur/join #{} xs))) + (def ensure-set (condf1 nil? (fn' #{}) diff --git a/src-untyped/quantum/untyped/core/collections/logic.cljc b/src-untyped/quantum/untyped/core/collections/logic.cljc index b1f30dc3..e62784f7 100644 --- a/src-untyped/quantum/untyped/core/collections/logic.cljc +++ b/src-untyped/quantum/untyped/core/collections/logic.cljc @@ -16,9 +16,9 @@ (ucore/log-this-ns) -;; `seq-or` +;; ----- `seq-or` ----- ;; -(defn seq-or|rf #_> #_boolean? +(defn seq-or|rf ([] (seq-or|rf identity)) ([pred] (fn ([] false) @@ -26,7 +26,7 @@ ([_ x] (and (pred x) (reduced true))) ([_ k v] (and (pred k v) (reduced true)))))) -(defn seq-or +(defn seq-or #_> #_boolean? "∃: A faster version of `some` using `educe` instead of `seq`." ([xs] (educe (seq-or|rf) xs)) ([pred xs] (educe (seq-or|rf pred) xs))) @@ -35,9 +35,7 @@ (defalias some seq-or) -(defn apply-or [xs] (seq-or xs)) - -;; `seq-nor` +;; ----- `seq-nor` ----- ;; #_(def seq-nor|rf ...) @@ -47,9 +45,9 @@ (defalias not-any? seq-nor) -;; `seq-and` +;; ----- `seq-and` ----- ;; -(defn seq-and|rf #_> #_boolean? +(defn seq-and|rf ([] (seq-and|rf identity)) ([pred] (fn ([] true) ; vacuously @@ -57,7 +55,7 @@ ([_ x] (or (pred x) (reduced false))) ([_ k v] (or (pred k v) (reduced false)))))) -(defn seq-and +(defn seq-and #_> #_boolean? "∀: A faster version of `every?` using `educe` instead of `seq`." ([xs] (educe (seq-and|rf) xs)) ([pred xs] (educe (seq-and|rf pred) xs))) @@ -66,18 +64,16 @@ (defalias every? seq-and) -(defn apply-and [xs] (seq-and xs)) - -;; `seq-and-2` +;; ----- `seq-and-2` ----- ;; (defn seq-and-2 "`seq-and` for pairwise comparisons." - ([pred xs] + ([pred xs #_seqable?] (reduce (fn [a b] (or (pred a b) (reduced false))) (first xs) (rest xs)))) (defalias every?-2 seq-and-2) -;; `seq-nand` +;; ----- `seq-nand` ----- ;; #_(def seq-nand|rf ...) diff --git a/src-untyped/quantum/untyped/core/form/type_hint.cljc b/src-untyped/quantum/untyped/core/form/type_hint.cljc index 11701c61..e25cb8ba 100644 --- a/src-untyped/quantum/untyped/core/form/type_hint.cljc +++ b/src-untyped/quantum/untyped/core/form/type_hint.cljc @@ -5,6 +5,10 @@ :refer [>name]] [quantum.untyped.core.error :refer [err!]] + [quantum.untyped.core.logic + :refer [ifs]] + [quantum.untyped.core.loops + :refer [reduce-2]] [quantum.untyped.core.type.core :as utcore] [quantum.untyped.core.vars :refer [update-meta]])) @@ -132,11 +136,19 @@ The compiler seems to ignore hints that are not strings or symbols, and does not allow primitive hints. This fn accommodates these requirements." - [tag #_(t/or string? class? symbol?)] - #?(:clj (if (class? tag) - (.getName ^Class tag) - tag) - :cljs tag)) + [tag #_(t/or string? symbol? class?)] + (ifs (or (string? tag) (symbol? tag)) tag + #?@(:clj [(class? tag) (.getName ^Class tag)]))) + +#?(:clj +(defn >interface-method-tag + "Outputs a tag usable as an interface method return type or arg type. + For primitive classes, the method must be tagged with the class itself (not a string etc.). + For all other classes, `>arglist-embeddable-tag` will suffice." + [tag #_(t/or string? symbol? class?)] + (if (and (class? tag) (.isPrimitive ^Class tag)) + tag + (>arglist-embeddable-tag tag)))) (defn static-cast|code "`(with-meta (list 'do expr) {:tag class-sym})` isn't enough" @@ -169,3 +181,9 @@ binding-sym)])) uc/cat) form))) + +(defn hint-arglist-with + [arglist #_seqable? hints #_seqable?] + (reduce-2 (fn [arglist' arg hint] + (conj arglist' (with-type-hint arg hint))) + [] arglist hints)) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 0ecd3616..c99730f2 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -9,7 +9,7 @@ nil? any? class? tagged-literal? #?(:cljs object?) number? decimal? bigdec? integer? ratio? keyword? string? symbol? - meta]) + meta ref]) (:require [clojure.core :as c] [quantum.untyped.core.analyze.expr :as xp @@ -212,11 +212,22 @@ (-def spec? PSpec) -(defn * [spec] +(defn * + "Denote on a spec that it must be enforced at runtime. + For use with `defnt`." + [spec] (if (spec? spec) (update-meta spec assoc :runtime? true) (err! "Input must be spec" spec))) +(defn ref + "Denote on a spec that it must not be expanded to use primitive values. + For use with `defnt`." + [spec] + (if (spec? spec) + (update-meta spec assoc :ref? true) + (err! "Input must be spec" spec))) + (udt/deftype DeducibleSpec [*spec #_(t/atom-of t/spec?)] {PSpec nil fipp.ednize/IOverride nil @@ -631,6 +642,8 @@ fipp.ednize/IEdn {-edn ([this] `?)}}) +(defn infer? [x] (instance? InferSpec x)) + ;; ===== Comparison ===== ;; (def ^:const > unboxed-symbol->type-meta vals (uc/map+ :unboxed) (join #{})))) -(defn- -spec>classes [spec classes] +(defn- -spec>classes [spec #_t/spec? classes #_set?] #_> set? (cond (class-spec? spec) (conj classes (class-spec>class spec)) (value-spec? spec) diff --git a/src/quantum/core/collections.cljc b/src/quantum/core/collections.cljc index 7e68e90b..f337acd5 100644 --- a/src/quantum/core/collections.cljc +++ b/src/quantum/core/collections.cljc @@ -133,7 +133,7 @@ `(~accessor ~x ~v))))) (defaliases clog - seq-or some seq-nor not-any? seq-and every? seq-nand not-every? apply-and apply-or) + seq-or some seq-nor not-any? seq-and every? seq-nand not-every?) ; KV ; @@ -1007,7 +1007,7 @@ :todo ["Make it not output HashMaps but preserve records"] :contributors ["Alex Gunnarson"]} [f & maps] - (when (apply-or maps) + (when (seq-or maps) (let [merge-entry (fn [m e] (let [k (key e) v (val e)] diff --git a/src/quantum/core/collections/core.cljc b/src/quantum/core/collections/core.cljc index c6b46523..581d50d1 100644 --- a/src/quantum/core/collections/core.cljc +++ b/src/quantum/core/collections/core.cljc @@ -52,7 +52,8 @@ [quantum.core.vars :as var :refer [defalias #?(:clj defmalias) def-]] [quantum.untyped.core.data - :refer [kw-map]]) + :refer [kw-map]] + [quantum.untyped.core.form.type-hint :as ufth]) #?(:cljs (:require-macros [quantum.core.collections.core @@ -509,7 +510,7 @@ kind '#{boolean byte char short int long float double Object}] (let [arglist (vec (repeatedly arglength gensym)) hints (vec (repeat arglength kind ))] - `(~(defnt/hint-arglist-with arglist hints) + `(~(ufth/hint-arglist-with arglist hints) (. quantum.core.data.Array ~(symbol (str "new1dArray")) ~@arglist))))))) #?(:clj (gen-arr<>)) @@ -534,7 +535,7 @@ ~@(for [dim (range 1 11)] (let [arglist (vec (repeatedly dim gensym)) hints (apply core/vector 'long (repeat (dec dim) 'int))] ; first one should be long for protocol dispatch purposes - `(~(defnt/hint-arglist-with arglist hints) + `(~(ufth/hint-arglist-with arglist hints) (. quantum.core.data.Array ~(symbol (str "newInitializedNd" (str/capitalize kind) "Array")) ~@arglist))))))))) diff --git a/src/quantum/core/collections/logic.cljc b/src/quantum/core/collections/logic.cljc index ecf20f15..8129957b 100644 --- a/src/quantum/core/collections/logic.cljc +++ b/src/quantum/core/collections/logic.cljc @@ -39,9 +39,6 @@ (defalias not-every? seq-nand) -(defn apply-and [xs] (seq-and xs)) -(defn apply-or [xs] (seq-or xs)) - (defn seq-and-2 "`seq-and` for pairwise comparisons." ([pred xs] diff --git a/src/quantum/core/collections/selective.cljc b/src/quantum/core/collections/selective.cljc index f764617b..4120022d 100644 --- a/src/quantum/core/collections/selective.cljc +++ b/src/quantum/core/collections/selective.cljc @@ -97,7 +97,7 @@ ; ; index-of-from [o val index-from] - index-of, starting at index-from ; (defn contains-or? [coll elems] -; (apply-or (map (partial contains? coll) elems))) +; (seq-or (map (partial contains? coll) elems))) (defn get-keys {:attribution "alexandergunnarson"} [m obj] diff --git a/src/quantum/core/convert/primitive.cljc b/src/quantum/core/convert/primitive.cljc index ce0a7398..7bc75551 100644 --- a/src/quantum/core/convert/primitive.cljc +++ b/src/quantum/core/convert/primitive.cljc @@ -1,15 +1,16 @@ (ns quantum.core.convert.primitive (:require - #_(:cljs [com.gfredericks.goog.math.Integer :as int]) - [clojure.core :as core] - [quantum.core.data.bits :as bits + #?(:cljs [com.gfredericks.goog.math.Integer :as int]) + [clojure.core :as core] + [quantum.core.data.bits :as bits :refer [&&]] - [quantum.core.error :as err + [quantum.core.error :as err :refer [>ex-info]] - [quantum.core.macros :as macros - :refer [defnt #?@(:clj [defnt'])]] - [quantum.core.vars :as var - :refer [defalias]]) + [quantum.core.defnt :as macros + :refer [defnt]] + [quantum.core.vars :as var + :refer [defalias]] + [quantum.untyped.core.type :as t]) #?(:cljs (:require-macros [quantum.core.convert.primitive])) @@ -28,34 +29,37 @@ `(throw (>ex-info :illegal-argument (str "Value out of range for long: " ~x))))) #?(:clj -(defnt ^long ->long* +(defnt >long* {:source "clojure.lang.RT.uncheckedLongCast"} - ([^Number x] (.longValue x)) - ([#{byte char short int long float double} x] (Primitive/uncheckedLongCast x)))) + > t/long? + ([x (t/or t/byte? t/char? t/short? t/int? t/long? t/float? t/double?)] + (Primitive/uncheckedLongCast x)) + ([x (t/ref (t/isa? Number))] (.longValue x))))) #?(:clj - (defnt ^long ->long - {:source "clojure.lang.RT.longCast"} - ([^clojure.lang.BigInt x] - (if (nil? (.bipart x)) - (.lpart x) - (long-out-of-range x))) - ([^java.math.BigInteger x] - (if (< (.bitLength x) 64) - (.longValue x) - (long-out-of-range x))) - ([^clojure.lang.Ratio x] (->long (.bigIntegerValue x))) - ([#{char byte short int long} x] (->long* x)) - ([#{float} x] (clojure.lang.RT/longCast x)) ; Because primitive casting in Clojure is not supported ; TODO fix - ([#{double} x] (clojure.lang.RT/longCast x)) ; TODO fix - ([#{boolean} x] (if x 1 0)) - ([^string? x] (-> x Long/parseLong ->long)) - ([^string? x radix] (Long/parseLong x radix))) + (defnt >long + {:source "clojure.lang.RT.longCast"} + > t/long? + ([x (t/isa? clojure.lang.BigInt)] + (if (nil? (.bipart x)) + (.lpart x) + (long-out-of-range x))) + ([x (t/isa? java.math.BigInteger)] + (if (< (.bitLength x) 64) + (.longValue x) + (long-out-of-range x))) + ([x t/ratio?] (->long (.bigIntegerValue x))) + ([x (t/or t/char? t/byte? t/short? t/int? t/long?)] (>long* x)) + ([x t/float?] (clojure.lang.RT/longCast x)) ; Because primitive casting in Clojure is not supported ; TODO fix + ([x t/double?] (clojure.lang.RT/longCast x)) ; TODO fix + ([x t/boolean?] (if x 1 0)) + ([x t/string?] (-> x Long/parseLong >long)) + ([x t/string?, radix t/int?] (Long/parseLong x radix))) :cljs - (defnt ->long - ([^number? x] (js/Math.trunc x)) - ([^string? x] (-> x int/fromString ->long)) - ([^boolean? x] (if x 1 0)))) + (defnt >long > (t/range-of t/long?) + ([x t/double?] (js/Math.trunc x)) + ([x t/string?] (-> x int/fromString >long)) + ([x t/boolean?] (if x 1 0)))) #?(:clj (defmacro cast-via-long [class- x] diff --git a/src/quantum/core/macros/defnt.cljc b/src/quantum/core/macros/defnt.cljc index 2a3728e1..a8519fc5 100644 --- a/src/quantum/core/macros/defnt.cljc +++ b/src/quantum/core/macros/defnt.cljc @@ -132,14 +132,6 @@ ;nil? (fn' #{'Object}) #(throw (>ex-info "Not a type hint." %))))) -(defn hint-arglist-with - [arglist hints] - (reducei ; technically reduce-pair - (fn [arglist-f arg i] - (conj arglist-f (th/with-type-hint arg (get hints i)))) - [] - arglist)) - (def defnt-remove-hints (fn->> (into []) (<- (update 0 (fn->> (filter symbol?) (into [])))))) @@ -345,7 +337,7 @@ (let [body (list* 'do body) hints (map (whenf1 string? symbol) hints) hints (hints->with-replace-special-kws (merge env (kw-map arglist hints))) - arglist-hinted (hint-arglist-with arglist hints) + arglist-hinted (ufth/hint-arglist-with arglist hints) ;_ (log/ppr-hints :macro-expand "TYPE HINTS FOR ARGLIST" (->> arglist-hinted (map type-hint))) explicit-ret-type (>explicit-ret-type (merge env (kw-map ret-type-0 hints arglist))) ; TODO cache the result of postwalking the body like this, for protocol purposes diff --git a/test/quantum/test/core/defnt_equivalences.cljc b/test/quantum/test/core/defnt_equivalences.cljc index 788a9e2b..80887dde 100644 --- a/test/quantum/test/core/defnt_equivalences.cljc +++ b/test/quantum/test/core/defnt_equivalences.cljc @@ -49,7 +49,7 @@ ;; ----- expanded code ----- ;; -($ (do (swap! *fn->spec assoc `pid +($ (do #_(swap! *fn->spec assoc `pid (xp/>expr (fn [args##] (case (count args##) 0 nil)))) @@ -77,7 +77,7 @@ ;; ----- expanded code ----- ;; -($ (do (swap! *fn->spec assoc `identity|gen|uninlined +($ (do #_(swap! *fn->spec assoc `identity|gen|uninlined (xp/>expr (fn [args##] (case (count args##) 1 nil #_(fn-> first t/->spec))))) @@ -96,10 +96,11 @@ long>long (~(tag "long" 'invoke) [~'_ ~(tag "long" 'x)] ~'x) float>float (~(tag "float" 'invoke) [~'_ ~(tag "float" 'x)] ~'x) double>double (~(tag "double" 'invoke) [~'_ ~(tag "double" 'x)] ~'x))) + ;; TODO implement this ;; Dynamic dispatch (invoked only if incomplete type information (incl. in untyped context)) ;; in this case no protocol is necessary because it boxes arguments anyway ;; Var indirection may be avoided by making and using static fields via the Clojure 1.8 flag - (defn ~'identity|gen|uninlined [~'x] (.invoke identity|gen|uninlined|__0 ~'x))]) + #_(defn ~'identity|gen|uninlined [~'x] (.invoke identity|gen|uninlined|__0 ~'x))]) :cljs ;; Direct dispatch will be simple functions, not `reify`s; not necessary here ;; Dynamic dispatch will be approached later; not clear yet whether there is a huge savings ($ [(defn ~'identity|gen|uninlined [~'x] ~'x)]))))) @@ -122,7 +123,6 @@ (is (code= ;; TODO don't ignore `:inline` -;; TODO `.getName` returns `(? string?)` so we need to add an assertion to guarantee (macroexpand ' (defnt #_:inline name|gen ([x t/string? > t/string? ] x) @@ -132,10 +132,10 @@ ;; ----- expanded code ----- ;; -($ (do (swap! *fn->spec assoc #'name|gen +($ (do #_(swap! *fn->spec assoc #'name|gen (xp/casef count 1 (xp/condpf-> t/<= (xp/get 0) - t/string? (fn-> t/->spec) ; TODO fix this + t/string? (fn-> t/->spec) ~(case (env-lang) :clj `Named :cljs `INamed) t/string?))) ~@(case (env-lang) @@ -153,19 +153,19 @@ (let* [~(tag "clojure.lang.Named" 'x) ~'x] (let [~'out (.getName ~'x)] (s/validate ~'out t/string?)))))) - + ;; TODO implement this ;; This protocol is so suffixed because of the position of the argument on which ;; it dispatches - (defprotocol name|gen__Protocol__0 + #_(defprotocol name|gen__Protocol__0 (name|gen [~'x])) - (extend-protocol name|gen__Protocol__0 + #_(extend-protocol name|gen__Protocol__0 java.lang.String (name|gen [x] (.invoke name|gen|__0 x)) ;; this is part of the protocol because even though `Named` is an interface, ;; `String` is final, so they're mutually exclusive clojure.lang.Named (name|gen [x] (.invoke name|gen|__1 x)))]) :cljs ($ [;; No protocol in ClojureScript; consider adding this if a performance increase is ;; demonstrated when using a protocol - (defn name|gen [~'x] + (defn ~'name|gen [~'x] (ifs (string? x) x (satisfies? INamed x) (-name x) (err! "Not supported for type" {:fn `name|gen :type (type x)})))])))) @@ -174,6 +174,8 @@ ;; =====|=====|=====|=====|===== ;; +(is (code= + ;; Perhaps silly in ClojureScript, but avoids boxing in Clojure (macroexpand ' (defnt #_:inline some?|gen @@ -183,17 +185,17 @@ ;; ----- expanded code ----- ;; -($ (do (swap! fn->spec assoc #'some?|gen +($ (do #_(swap! fn->spec assoc #'some?|gen (xp/casef c/count 1 (xp/condpf-> t/<= (xp/get 0) t/nil? (t/value false) t/any? (t/value true )))) ~@(case (env-lang) - :clj ($ [(def some?|gen|__0 ; `[x t/nil?]` + :clj ($ [(def ~'some?|gen|__0 ; `[x t/nil?]` (reify Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] false))) - (def some?|gen|__1 ; `[x t/any?]` + (def ~'some?|gen|__1 ; `[x t/any?]` (reify Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] true) boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] true) @@ -204,16 +206,21 @@ long>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "long" 'x)] true) float>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "float" 'x)] true) double>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "double" 'x)] true))) + ;; TODO implement this ;; Dynamic dispatch - (defn some?|gen [~'x] + #_(defn ~'some?|gen [~'x] (ifs (nil? x) (.invoke some?|gen|__0 x) (.invoke some?|gen|__1 x)))]) - :cljs ($ [(defn some?|gen [~'x] + :cljs ($ [(defn ~'some?|gen [~'x] (ifs (nil? x) false true))])))) +)) + ;; =====|=====|=====|=====|===== ;; +(is (code= + ;; Perhaps silly in ClojureScript, but avoids boxing in Clojure (macroexpand ' (defnt #_:inline reduced?|gen @@ -223,19 +230,19 @@ ;; ----- expanded code ----- ;; -($ (do (swap! fn->spec assoc #'reduced?|gen +($ (do #_(swap! fn->spec assoc #'reduced?|gen (xp/casef c/count 1 (xp/condpf-> t/<= (xp/get 0) t/reduced? (t/value true) t/any? (t/value false)))) ~@(case (env-lang) - :clj ($ [(def reduced?|gen|__0 ; `[x Reduced]` + :clj ($ [(def ~'reduced?|gen|__0 ; `[x Reduced]` (reify Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] (let* [~(tag "clojure.lang.Reduced" 'x) ~'x] true)))) - (def reduced?|gen|__1 ; `[x t/any?]` + (def ~'reduced?|gen|__1 ; `[x t/any?]` (reify Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] false) boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] false) @@ -246,15 +253,20 @@ long>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "long" 'x)] false) float>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "float" 'x)] false) double>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "double" 'x)] false))) + ;; TODO implement ;; No protocol because just one class; TODO evaluate whether this is better performance-wise? probably is - (defn reduced?|gen [~'x] - (ifs (instance? Reduced x) (.invoke reduced?|gen|__0 x) - (.invoke reduced?|gen|__1 x)))]) - :cljs ($ [(defn reduced?|gen [~'x] + #_(defn ~'reduced?|gen [~'x] + (ifs (instance? Reduced x) (.invoke reduced?|gen|__0 ~'x) + (.invoke reduced?|gen|__1 ~'x)))]) + :cljs ($ [(defn ~'reduced?|gen [~'x] (ifs (instance? Reduced x) true false))])))) +)) + ;; =====|=====|=====|=====|===== ;; +(is (code= + (macroexpand ' (defnt #_:inline >boolean ([x t/boolean?] x) @@ -264,7 +276,7 @@ ;; ----- expanded code ----- ;; -($ (do (swap! fn->spec assoc #'>boolean|gen +($ (do #_(swap! fn->spec assoc #'>boolean|gen (xp/casef c/count 1 (xp/condpf-> t/<= (xp/get 0) t/boolean? (fn-> t/->spec) ; TODO fix this @@ -272,13 +284,13 @@ t/any? (t/value true )))) ~@(case (env-lang) - :clj ($ [(def >boolean|gen|__0 ; `[x t/boolean?]` + :clj ($ [(def ~'>boolean|__0 ; `[x t/boolean?]` (reify - boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] x))) - (def >boolean|gen|__1 ; `[x t/nil?]` + boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] ~'x))) + (def ~'>boolean|__1 ; `[x t/nil?]` (reify Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] false))) - (def >boolean|gen|__2 ; `[x t/any?]` + (def ~'>boolean|__2 ; `[x t/any?]` (reify Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] true) boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] true) @@ -289,21 +301,25 @@ long>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "long" 'x)] true) float>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "float" 'x)] true) double>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "double" 'x)] true))) - - (defprotocol >boolean|gen__Protocol - (>boolean|gen [~'x])) - (extend-protocol >boolean|gen__Protocol - java.lang.Boolean (>boolean|gen [^java.lang.Boolean x] (.invoke >boolean|gen|__0 x)) - java.lang.Object (>boolean|gen [x] - (ifs (nil? x) (.invoke >boolean|gen|__1 x) - (.invoke >boolean|gen|__2 x))))]) - :cljs ($ [(defn >boolean|gen [~'x] + ;; TODO implement this + #_(defprotocol >boolean__Protocol + (>boolean [~'x])) + #_(extend-protocol >boolean__Protocol + java.lang.Boolean (>boolean [^java.lang.Boolean x] (.invoke >boolean|__0 x)) + java.lang.Object (>boolean [x] + (ifs (nil? x) (.invoke >boolean|__1 x) + (.invoke >boolean|__2 x))))]) + :cljs ($ [(defn ~'>boolean [~'x] (ifs (boolean? x) x (nil? x) false true))])))) +)) + ;; =====|=====|=====|=====|===== ;; +(is (code= + ;; auto-upcasts to long or double (because 64-bit) unless you tell it otherwise ;; will error if not all return values can be safely converted to the return spec (macroexpand ' @@ -315,14 +331,14 @@ ;; ----- expanded code ----- ;; #?(:clj -`(do (swap! fn->spec assoc #'>int*|gen +`(do #_(swap! fn->spec assoc #'>int*|gen (xp/casef c/count 1 (xp/condpf-> t/<= (xp/get 0) (s/and primitive? (s/not boolean?)) t/int? Number t/int?))) ~@(case (env-lang) - :clj ($ [(def >int*|gen|__0 ; `(s/and primitive? (s/not boolean?))` + :clj ($ [(def ~'>int*|__0 ; `(s/and primitive? (s/not boolean?))` (reify byte>int (~(tag "int" 'invoke) [~'_ ~(tag "byte" 'x)] (Primitive/uncheckedIntCast x)) short>int (~(tag "int" 'invoke) [~'_ ~(tag "short" 'x)] (Primitive/uncheckedIntCast x)) char>int (~(tag "int" 'invoke) [~'_ ~(tag "char" 'x)] (Primitive/uncheckedIntCast x)) @@ -330,34 +346,95 @@ long>int (~(tag "int" 'invoke) [~'_ ~(tag "long" 'x)] (Primitive/uncheckedIntCast x)) float>int (~(tag "int" 'invoke) [~'_ ~(tag "float" 'x)] (Primitive/uncheckedIntCast x)) double>int (~(tag "int" 'invoke) [~'_ ~(tag "double" 'x)] (Primitive/uncheckedIntCast x)))) - (def >int*|gen|__1 ; `Number` + (def ~'>int*|__1 ; `Number` (reify Object>int (~(tag "int" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] (let* [~(tag "java.lang.Number" 'x) ~'x] (.intValue x))))) - - (defprotocol >int*|gen__Protocol + ;; TODO implement this + #_(defprotocol >int*_Protocol (>int*|gen [~'x])) - (extend-protocol >int*|gen__Protocol - java.lang.Byte (>int*|gen [~(tag "java.lang.Byte" x)] (.invoke >int*|gen|__0 x)) - java.lang.Short (>int*|gen [~(tag "java.lang.Short" x)] (.invoke >int*|gen|__0 x)) - java.lang.Character (>int*|gen [~(tag "java.lang.Character" x)] (.invoke >int*|gen|__0 x)) - java.lang.Integer (>int*|gen [~(tag "java.lang.Integer" x)] (.invoke >int*|gen|__0 x)) - java.lang.Long (>int*|gen [~(tag "java.lang.Long" x)] (.invoke >int*|gen|__0 x)) - java.lang.Float (>int*|gen [~(tag "java.lang.Float" x)] (.invoke >int*|gen|__0 x)) - java.lang.Double (>int*|gen [~(tag "java.lang.Double" x)] (.invoke >int*|gen|__0 x)) - java.lang.Number (>int*|gen [~(tag "java.lang.Object" x)] (.invoke >int*|gen|__1 x)))])))) + #_(extend-protocol >int*__Protocol + java.lang.Byte (>int* [~(tag "java.lang.Byte" x)] (.invoke >int*|__0 x)) + java.lang.Short (>int* [~(tag "java.lang.Short" x)] (.invoke >int*|__0 x)) + java.lang.Character (>int* [~(tag "java.lang.Character" x)] (.invoke >int*|__0 x)) + java.lang.Integer (>int* [~(tag "java.lang.Integer" x)] (.invoke >int*|__0 x)) + java.lang.Long (>int* [~(tag "java.lang.Long" x)] (.invoke >int*|__0 x)) + java.lang.Float (>int* [~(tag "java.lang.Float" x)] (.invoke >int*|__0 x)) + java.lang.Double (>int* [~(tag "java.lang.Double" x)] (.invoke >int*|__0 x)) + java.lang.Number (>int* [~(tag "java.lang.Object" x)] (.invoke >int*|__1 x)))])))) + +)) ;; =====|=====|=====|=====|===== ;; +(is (code= + (macroexpand ' (defnt >long* {:source "clojure.lang.RT.uncheckedLongCast"} > t/long? - ([x (t/isa? Number)] (.longValue x)) ([x (t/or t/byte? t/char? t/short? t/int? t/long? t/float? t/double?)] - (Primitive/uncheckedLongCast x)))) + (Primitive/uncheckedLongCast x)) + ([x (t/ref (t/isa? Number))] (.longValue x)))) + +;; ----- expanded code ----- ;; + +`(do ~@(case (env-lang) + :clj ($ [(def ~'>long*|__0 ; `(t/or t/byte? t/char? t/short? t/int? t/long? t/float? t/double?)` + (reify byte>long (~(tag "long" 'invoke) [~'_ ~(tag "byte" 'x)] (~'Primitive/uncheckedLongCast ~'x)) + short>long (~(tag "long" 'invoke) [~'_ ~(tag "short" 'x)] (~'Primitive/uncheckedLongCast ~'x)) + char>long (~(tag "long" 'invoke) [~'_ ~(tag "char" 'x)] (~'Primitive/uncheckedLongCast ~'x)) + int>long (~(tag "long" 'invoke) [~'_ ~(tag "int" 'x)] (~'Primitive/uncheckedLongCast ~'x)) + long>long (~(tag "long" 'invoke) [~'_ ~(tag "long" 'x)] (~'Primitive/uncheckedLongCast ~'x)) + float>long (~(tag "long" 'invoke) [~'_ ~(tag "float" 'x)] (~'Primitive/uncheckedLongCast ~'x)) + double>long (~(tag "long" 'invoke) [~'_ ~(tag "double" 'x)] (~'Primitive/uncheckedLongCast ~'x)))) + (def ~'>long*|__1 ; `Number` + (reify Object>long (~(tag "long" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] + (let* [~(tag "java.lang.Number" 'x) ~'x] (.longValue ~'x))))) + ;; TODO implement this + #_(defprotocol >long*__Protocol + (>long* [~'x])) + #_(extend-protocol >int*|__Protocol + java.lang.Byte (>long* [~(tag "java.lang.Byte" x)] (.invoke >long*__0 x)) + java.lang.Short (>long* [~(tag "java.lang.Short" x)] (.invoke >long*__0 x)) + java.lang.Character (>long* [~(tag "java.lang.Character" x)] (.invoke >long*__0 x)) + java.lang.Integer (>long* [~(tag "java.lang.Integer" x)] (.invoke >long*__0 x)) + java.lang.Long (>long* [~(tag "java.lang.Long" x)] (.invoke >long*__0 x)) + java.lang.Float (>long* [~(tag "java.lang.Float" x)] (.invoke >long*__0 x)) + java.lang.Double (>long* [~(tag "java.lang.Double" x)] (.invoke >long*__0 x)) + java.lang.Number (>long* [~(tag "java.lang.Object" x)] (.invoke >long*__1 x)))]))) + +)) + +;; =====|=====|=====|=====|===== ;; + +(is (code= + +(macroexpand ' +(defnt >long + {:source "clojure.lang.RT.longCast"} + > t/long? + ([x (t/isa? clojure.lang.BigInt)] + (if (nil? (.bipart x)) + (.lpart x) + (long-out-of-range x))) + ([x (t/isa? java.math.BigInteger)] + (if (< (.bitLength x) 64) + (.longValue x) + (long-out-of-range x))) + ([x t/ratio?] (->long (.bigIntegerValue x))) + ([x (t/or t/char? t/byte? t/short? t/int? t/long?)] (>long* x)) + ([x t/float?] (clojure.lang.RT/longCast x)) ; Because primitive casting in Clojure is not supported ; TODO fix + ([x t/double?] (clojure.lang.RT/longCast x)) ; TODO fix + ([x t/boolean?] (if x 1 0)) + ([x t/string?] (-> x Long/parseLong >long)) + ([x t/string?, radix t/int?] (Long/parseLong x radix)))) ;; ----- expanded code ----- ;; + + +)) + ;; =====|=====|=====|=====|===== ;; (macroexpand ' diff --git a/test/quantum/test/core/logic.cljc b/test/quantum/test/core/logic.cljc index 8d7479b5..41cb1954 100644 --- a/test/quantum/test/core/logic.cljc +++ b/test/quantum/test/core/logic.cljc @@ -44,10 +44,6 @@ (defn test:every? [pred args]) -(defn test:apply-and [arg-list]) - -(defn test:apply-or [arg-list]) - (defn test:dor [& args]) (defn test:fn-logic-base From 7ad46cf7d5a1c5ca1002163d2055f4ce5c441871 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Mar 2018 10:39:25 -0600 Subject: [PATCH 006/810] `if`, `throw`, `new` now analyzable --- src-dev/quantum/core/defnt.cljc | 139 ++++++++++-------- .../quantum/untyped/core/analyze/ast.cljc | 39 +++++ src-untyped/quantum/untyped/core/type.cljc | 6 +- .../quantum/test/core/defnt_equivalences.cljc | 6 +- 4 files changed, 122 insertions(+), 68 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index b61c7289..f4e956cf 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -13,7 +13,7 @@ :refer [aritoid fn1 fnl fn', fn-> fn->> <-, rcomp firsta seconda]] [quantum.core.log :as log - :refer [ppr! prl! prlm!]] + :refer [ppr! ppr prl! prlm!]] [quantum.core.logic :as l :refer [fn= fn-and fn-or fn-not ifs if-not-let]] [quantum.core.macros @@ -342,7 +342,7 @@ :instance))])) (join {}))) ; TODO !hash-map -(defonce class->fields|with-cache +(def class->fields|with-cache (memoize (fn [c] (class->fields c)))) (def ^:dynamic *conditional-branch-pruning?* true) @@ -356,7 +356,7 @@ (defn persistent!-and-add-file-context [form ast-ret] (update ast-ret :form (fn-> persistent! (add-file-context form)))) -(def special-symbols '#{do let* deftype* fn* def . if quote new}) ; TODO make more complete +(def special-symbols '#{do let* deftype* fn* def . if quote new throw}) ; TODO make more complete (deftype WatchableMutable [^:unsynchronized-mutable v ^:unsynchronized-mutable ^clojure.lang.IFn watch] @@ -379,24 +379,6 @@ ([v] (->WatchableMutable v nil)) ([v watch] (->WatchableMutable v watch))) -(defn truthy-type? [t] - (when (#{Boolean Boolean/TYPE} t) - (TODO "Don't yet known how to handle booleans")) - (if (= t :nil) - false - true)) - -(defn truthy-expr? [expr] - (when (-> expr :constraints some?) - (TODO "Don't yet know how to handle constraints")) - (if-let [classes (->> expr :type-info ?deref :reifieds (lmap truthy-type?) seq)] - (ucl/every-val ::unknown classes) - ::unknown)) - -(defn union|type-info [ti0 ti1] - (prl! ti0 ti1) - (TODO)) - (declare analyze*) (defn analyze-non-map-seqable @@ -601,13 +583,13 @@ with-ret-spec)))))) (defns analyze-seq|dot|field-access - [env _, form _, target _, field-form _ #_t/unqualified-symbol?, field java.lang.reflect.Field] + [env _, form _, target _, field-form _ #_t/unqualified-symbol?, field Field] (ast/field-access {:env env :form form :target target :field field-form - :spec (-> field .getType t/>spec)})) + :spec (-> field :type t/>spec)})) (defn classes>class "Ensure that given a set of classes, that set consists of at most a class C and nil. @@ -646,39 +628,76 @@ (analyze-seq|dot|method-call env form target target-class (boolean ?target-static-class-map) method-or-field args-forms)))))) +;; TODO move this +(defn truthy-expr? [{:as expr :keys [spec]}] + (ifs (or (t/= spec t/nil?) + (t/= spec t/false?)) false + (or (t/> spec t/nil?) + (t/> spec t/false?)) nil ; representing "unknown" + true)) + (defn analyze-seq|if "If `*conditional-branch-pruning?*` is falsey, the dead branch's original form will be retained, but it will not be type-analyzed." - [env form [pred true-form false-form :as body]] + [env form [pred-form true-form false-form :as body]] {:post [(prl! %)]} - (when (-> body count (not= 3)) - (err! "`if` accepts exactly 3 arguments: one predicate test and two branches; received" {:body body})) - (let [pred-expr (analyze* env pred) - true-expr (delay (analyze* env true-form)) - false-expr (delay (analyze* env false-form)) - whole-expr - (delay - (do (TODO "fix `if` analysis") - #_(->expr-info - {:env env - :form (list 'if pred (:form @true-expr) (:form @false-expr)) - :type-info (union|type-info (:type-info @true-expr) (:type-info @false-expr))})))] - (case (truthy-expr? pred-expr) - ::unknown @whole-expr - true (-> @true-expr (assoc :env env) - (cond-> (not *conditional-branch-pruning?*) - (assoc :form (list 'if pred (:form @true-expr) false-form)))) - false (-> @false-expr (assoc :env env) - (cond-> (not *conditional-branch-pruning?*) - (assoc :form (list 'if pred true-form (:form @false-expr)))))))) + (if (-> body count (not= 3)) + (err! "`if` accepts exactly 3 arguments: one predicate test and two branches; received" {:body body}) + (let [pred-expr (analyze* env pred-form) + true-expr (delay (analyze* env true-form)) + false-expr (delay (analyze* env false-form)) + whole-expr + (delay + (ast/if-expr + {:env env + :form (list 'if (:form pred-expr) (:form @true-expr) (:form @false-expr)) + :pred-expr pred-expr + :true-expr @true-expr + :false-expr @false-expr + :spec (apply t/or (->> [(:spec @true-expr) (:spec @false-expr)] (remove nil?)))}))] + (case (truthy-expr? pred-expr) + true (do (ppr ::warn "Predicate in `if` expression is always true" {:pred pred-form}) + (-> @true-expr (assoc :env env) + (cond-> (not *conditional-branch-pruning?*) + (assoc :form (list 'if pred-form (:form @true-expr) false-form))))) + false (do (ppr ::warn "Predicate in `if` expression is always false" {:pred pred-form}) + (-> @false-expr (assoc :env env) + (cond-> (not *conditional-branch-pruning?*) + (assoc :form (list 'if pred-form true-form (:form @false-expr)))))) + nil @whole-expr)))) (defn analyze-seq|quote [env form body] {:post [(prl! %)]} (ast/quoted env form (tcore/most-primitive-class-of body))) -(defn analyze-seq|new [env form body] +(defn analyze-seq|new [env form [c|form #_class? & args :as body]] + {:pre [(prl! env form body)]} + (let [c|analyzed (analyze* env c|form)] + (if-not (and (-> c|analyzed :spec t/value-spec?) + (-> c|analyzed :spec t/value-spec>value class?)) + (err! "Supplied non-class to `new` expression" {:x c|form}) + (let [c (-> c|analyzed :spec t/value-spec>value) + args|analyzed (mapv (fn [arg] (analyze* env arg)) args)] + (ast/new-expr {:env env + :form (list* 'new c|form (map :form args|analyzed)) + :class c + :args args|analyzed + :spec (t/isa? c)}))))) + +(defn analyze-seq|throw [env form [arg :as body]] {:pre [(prl! env form body)]} - (TODO "Don't know how to handle")) + (if (-> body count (not= 1)) + (err! "Must supply exactly one input to `throw`; supplied" {:body body}) + (let [arg|analyzed (analyze* env arg)] + ;; TODO this is not quite true for CLJS but it's nice at least + (if-not (-> arg|analyzed :spec (t/<= t/throwable?)) + (err! "`throw` requires a throwable; received" {:arg arg :spec (:spec arg|analyzed)}) + (ast/throw-expr {:env env + :form (list 'throw (:form arg|analyzed)) + :arg arg|analyzed + ;; `nil` because nothing is actually returned + ;; TODO This needs to be handled in other analysis places + :spec nil}))))) (defn analyze-seq* "Analyze a seq after it has been macro-expanded. @@ -687,24 +706,16 @@ (ppr! {'expanded-form form}) (if (special-symbols sym) (case sym - do - (analyze-seq|do env form body) - let* - (analyze-seq|let* env form body) - deftype* - (TODO "deftype*") - fn* - (TODO "fn*") - def - (TODO "def") - . - (analyze-seq|dot env form body) - if - (analyze-seq|if env form body) - quote - (analyze-seq|quote env form body) - new - (analyze-seq|new env form body)) + do (analyze-seq|do env form body) + let* (analyze-seq|let* env form body) + deftype* (TODO "deftype*") + fn* (TODO "fn*") + def (TODO "def") + . (analyze-seq|dot env form body) + if (analyze-seq|if env form body) + quote (analyze-seq|quote env form body) + new (analyze-seq|new env form body) + throw (analyze-seq|throw env form body)) (if-let [sym-resolved (resolve sym)] ; See note above on typed function return types (TODO) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 48956e8b..1e745ed2 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -113,6 +113,20 @@ (defn macro-call [m] (-> m map->MacroCall (assoc :spec (-> m :expanded :spec)))) +(defrecord IfExpr + [env #_::env + form #_::t/form + pred-expr #_::node + true-expr #_::node + false-expr #_::node + spec #_::t/spec] + INode + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (list `if-expr (into (array-map) this)))) + +(defn if-expr [m] (map->IfExpr m)) + ;; ===== RUNTIME CALLS ===== ;; (defrecord FieldAccess @@ -142,4 +156,29 @@ (defn method-call [m] (map->MethodCall m)) +(defrecord NewExpr + [env #_::env + form #_::t/form + class #_t/class? + args #_(t/and t/sequential? t/indexed? (t/every? ::node)) + spec #_::t/spec] + INode + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (list `new-expr (into (array-map) this)))) + +(defn new-expr [m] (map->NewExpr m)) + +(defrecord ThrowExpr + [env #_::env + form #_::t/form + arg #_::node + spec #_t/nil?] + INode + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (list `throw-expr (into (array-map) this)))) + +(defn throw-expr [m] (map->ThrowExpr m)) + ) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index c99730f2..f4b3c9a1 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -9,6 +9,7 @@ nil? any? class? tagged-literal? #?(:cljs object?) number? decimal? bigdec? integer? ratio? keyword? string? symbol? + true? false? meta ref]) (:require [clojure.core :as c] @@ -1141,7 +1142,7 @@ :else (err! "Not sure how to handle spec" spec))) -(defn spec>classes #_> set? +(defn spec>classes #_> #_set? "Outputs the set of all the classes ->`spec` can embody according to its various conditional branches, if any. Ignores nils, treating in Clojure simply as a `java.lang.Object`." [spec] (-spec>classes spec #{})) @@ -1239,6 +1240,9 @@ #?(:clj (-def throwable? java.lang.Throwable)) #?(:clj (-def comparable? java.lang.Comparable)) #?(:clj (-def iterable? java.lang.Iterable)) + + (-def true? (value true)) + (-def false? (value false)) #_(t/def ::form (t/or ::literal t/list? t/vector? ...)) ) diff --git a/test/quantum/test/core/defnt_equivalences.cljc b/test/quantum/test/core/defnt_equivalences.cljc index 80887dde..9ba0e43f 100644 --- a/test/quantum/test/core/defnt_equivalences.cljc +++ b/test/quantum/test/core/defnt_equivalences.cljc @@ -416,12 +416,12 @@ ([x (t/isa? clojure.lang.BigInt)] (if (nil? (.bipart x)) (.lpart x) - (long-out-of-range x))) + (throw (Exception. "Long out of range")))) ([x (t/isa? java.math.BigInteger)] (if (< (.bitLength x) 64) (.longValue x) - (long-out-of-range x))) - ([x t/ratio?] (->long (.bigIntegerValue x))) + (throw (Exception. "Long out of range")))) + ([x t/ratio?] (>long (.bigIntegerValue x))) ([x (t/or t/char? t/byte? t/short? t/int? t/long?)] (>long* x)) ([x t/float?] (clojure.lang.RT/longCast x)) ; Because primitive casting in Clojure is not supported ; TODO fix ([x t/double?] (clojure.lang.RT/longCast x)) ; TODO fix From 2ed4523a9016bd74e99d73646d9c4d2d9b93eccd Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Mar 2018 10:57:43 -0600 Subject: [PATCH 007/810] Add some notes --- src-dev/quantum/core/defnt.cljc | 7 +++---- test/quantum/test/core/defnt_equivalences.cljc | 9 ++++++--- test/quantum/test/core/untyped/type.cljc | 2 +- 3 files changed, 10 insertions(+), 8 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index f4e956cf..dfd29b1f 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -578,7 +578,7 @@ (ret-spec arg-specs))))) ?cast-spec (?cast-call->spec target-class method-form) _ (when ?cast-spec - (err! "TODO cast spec") + (ppr :warn "Not yet able to statically validate whether primitive cast will succeed at runtime" {:form form}) #_(s/validate (-> with-ret-spec :args first :spec) #(t/>= % (t/numerically ?cast-spec))))] with-ret-spec)))))) @@ -656,11 +656,11 @@ :false-expr @false-expr :spec (apply t/or (->> [(:spec @true-expr) (:spec @false-expr)] (remove nil?)))}))] (case (truthy-expr? pred-expr) - true (do (ppr ::warn "Predicate in `if` expression is always true" {:pred pred-form}) + true (do (ppr :warn "Predicate in `if` expression is always true" {:pred pred-form}) (-> @true-expr (assoc :env env) (cond-> (not *conditional-branch-pruning?*) (assoc :form (list 'if pred-form (:form @true-expr) false-form))))) - false (do (ppr ::warn "Predicate in `if` expression is always false" {:pred pred-form}) + false (do (ppr :warn "Predicate in `if` expression is always false" {:pred pred-form}) (-> @false-expr (assoc :env env) (cond-> (not *conditional-branch-pruning?*) (assoc :form (list 'if pred-form true-form (:form @false-expr)))))) @@ -703,7 +703,6 @@ "Analyze a seq after it has been macro-expanded. The ->`form` is post- incremental macroexpansion." [env [sym & body :as form]] - (ppr! {'expanded-form form}) (if (special-symbols sym) (case sym do (analyze-seq|do env form body) diff --git a/test/quantum/test/core/defnt_equivalences.cljc b/test/quantum/test/core/defnt_equivalences.cljc index 9ba0e43f..c151ce0f 100644 --- a/test/quantum/test/core/defnt_equivalences.cljc +++ b/test/quantum/test/core/defnt_equivalences.cljc @@ -421,12 +421,15 @@ (if (< (.bitLength x) 64) (.longValue x) (throw (Exception. "Long out of range")))) - ([x t/ratio?] (>long (.bigIntegerValue x))) - ([x (t/or t/char? t/byte? t/short? t/int? t/long?)] (>long* x)) + ;; TODO handle recursion + #_([x t/ratio?] (>long (.bigIntegerValue x))) + ;; TODO handle calling of other `defnt`s + #_([x (t/or t/char? t/byte? t/short? t/int? t/long?)] (>long* x)) ([x t/float?] (clojure.lang.RT/longCast x)) ; Because primitive casting in Clojure is not supported ; TODO fix ([x t/double?] (clojure.lang.RT/longCast x)) ; TODO fix ([x t/boolean?] (if x 1 0)) - ([x t/string?] (-> x Long/parseLong >long)) + ;; TODO handle recursion + #_([x t/string?] (-> x Long/parseLong >long)) ([x t/string?, radix t/int?] (Long/parseLong x radix)))) ;; ----- expanded code ----- ;; diff --git a/test/quantum/test/core/untyped/type.cljc b/test/quantum/test/core/untyped/type.cljc index 16cb8cae..4a802250 100644 --- a/test/quantum/test/core/untyped/type.cljc +++ b/test/quantum/test/core/untyped/type.cljc @@ -95,7 +95,7 @@ (def ><1 t/short?) (def ><2 t/long?)) -(def Uc (t/isa? t/universal-class)) +(def Uc (t/isa? java.lang.Object)) ;; ----- Example protocols ----- ;; From 1def75111002ae54064d755ff41f5a2071095976 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Mar 2018 22:47:46 -0600 Subject: [PATCH 008/810] ClassSpec + OrSpec combo fixed! --- src-untyped/quantum/untyped/core/type.cljc | 8 +- test/quantum/test/core/untyped/type.cljc | 171 +++++++++++++++------ 2 files changed, 127 insertions(+), 52 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index f4b3c9a1..bf69645d 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -764,10 +764,12 @@ found' (-> found (ubit/conj ret') c/long)] (ifs (c/or (ubit/contains? found' ident) - (reduced [2 nil]) + (c/or (ubit/contains? found' >ident) + (ubit/contains? found' <>ident))) + [2 found'] [ret' found']))) [3 ubit/empty] diff --git a/test/quantum/test/core/untyped/type.cljc b/test/quantum/test/core/untyped/type.cljc index 4a802250..78fab200 100644 --- a/test/quantum/test/core/untyped/type.cljc +++ b/test/quantum/test/core/untyped/type.cljc @@ -154,6 +154,39 @@ (is= c (t/compare a* b*)) (is= (t/inverse c) (t/compare b* a*)))) +(def comparison-combinations + ["#{<}" + "#{< =}" + "#{< = >}" + "#{< = > ><}" + "#{< = > >< <>}" + "#{< = > <>}" + "#{< = ><}" + "#{< = >< <>}" + "#{< = <>}" + "#{< >}" + "#{< > ><}" + "#{< > >< <>}" + "#{< > <>}" + "#{< ><}" + "#{< >< <>}" + "#{< <>}" + "#{=}" + "#{= >}" + "#{= > ><}" + "#{= > >< <>}" + "#{= > <>}" + "#{= ><}" + "#{= >< <>}" + "#{= <>}" + "#{>}" + "#{> ><}" + "#{> >< <>}" + "#{> <>}" + "#{><}" + "#{>< <>}" + "#{<>}"]) + (deftest test|in|compare (testing "UniversalSetSpec" (testing "+ UniversalSetSpec" @@ -266,6 +299,7 @@ ;; Comparison annotations achieved by first comparing each element of the first/left ;; to the entire second/right, then comparing each element of the second/right to the ;; entire first/left + ;; TODO add complete comparisons via `comparison-combinations` (testing "#{<}, #{<}" ;; comparisons: < < < < (test-comparison 0 (| a b) (| a b)) @@ -391,37 +425,64 @@ (testing "+ InferSpec") (testing "+ Expression") (testing "+ ProtocolSpec") - ;; TODO fix impl (testing "+ ClassSpec" - (testing "#{<+} -> <" + (testing "#{<}" (test-comparison -1 i|a+b i|>a0 i|>a1))) - (testing "#{><+} -> ><" - (test-comparison 2 i|a (| i|><0 i|><1))) - (testing "#{<>+} -> <>" - (test-comparison 3 a (| ><0 ><1))) - (testing "#{<+ ><+} -> <" + #_(testing "#{< =}") ; Impossible for `OrSpec` + #_(testing "#{< = >}") ; Impossible for `OrSpec` + #_(testing "#{< = > ><}") ; Impossible for `OrSpec` + #_(testing "#{< = > >< <>}") ; Impossible for `OrSpec` + #_(testing "#{< = > <>}") ; Impossible for `OrSpec` + #_(testing "#{< = ><}") ; Impossible for `OrSpec` + #_(testing "#{< = >< <>}") ; Impossible for `OrSpec` + #_(testing "#{< = <>}") ; Impossible for `OrSpec` + #_(testing "#{< >}") ; Impossible for `OrSpec` + #_(testing "#{< > ><}") ; Impossible for `OrSpec` + #_(testing "#{< > >< <>}") ; Impossible for `OrSpec` + #_(testing "#{< > <>}") ; Impossible for `OrSpec` + (testing "#{< ><}" (test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1)) - (test-comparison -1 i|>a0 (| i|>a+b i|>a0))) ; TODO fix impl - (testing "#{<+ <>+} -> <" + (test-comparison -1 i|>a0 (| i|>a+b i|>a0))) + (testing "#{< >< <>}" + (test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1 t/string?))) + (testing "#{< <>}" (test-comparison -1 a (| >a ><0 ><1))) - (testing "#{=+ ><+} -> ><" - (test-comparison 2 i|a (| i|a i|><0 i|><1))) - (testing "#{=+ <>+} -> <" + #_(testing "#{=}") ; Impossible for `OrSpec` + #_(testing "#{= >}") ; Impossible for `OrSpec` + #_(testing "#{= > ><}") ; Impossible for `OrSpec` + #_(testing "#{= > >< <>}") ; Impossible for `OrSpec` + #_(testing "#{= > <>}") ; Impossible for `OrSpec` + (testing "#{= ><}" + (test-comparison -1 i|a (| i|a i|><0 i|><1))) + (testing "#{= >< <>}" + (test-comparison -1 i|a (| i|a i|><0 i|><1 t/string?))) + (testing "#{= <>}" (test-comparison -1 a (| a ><0 ><1))) - (testing "#{>+ ><+} -> ><" + (testing "#{>}" + (test-comparison 1 a (| ><}" (test-comparison 2 i|a (| i|<0 i|><1))) - (testing "#{>+ <>+} -> ><" + (testing "#{> >< <>}" + (test-comparison 2 i|a (| i|<0 i|><1 t/string?))) + (testing "#{> <>}" (test-comparison 2 a (| <0 ><1))) + (testing "#{><}" + (test-comparison 2 i|a (| i|><0 i|><1))) + (testing "#{>< <>}" + (test-comparison 2 i|a (| i|><0 i|><1 t/string?))) + (testing "#{<>}" + (test-comparison 3 a (| ><0 ><1))) (testing "Nilable" - (testing "= nilabled" - (test-comparison -1 t/long? (t/? t/long?))) - (testing "< nilabled" + (testing "< nilabled: #{< <>}" (test-comparison -1 t/long? (t/? t/object?))) - (testing "> nilabled" + (testing "= nilabled: #{= <>}" + (test-comparison -1 t/long? (t/? t/long?))) + (testing "> nilabled: #{> <>}" (test-comparison 2 t/object? (t/? t/long?))) - (testing ">< nilabled" - (test-comparison 2 t/iterable? (t/? t/comparable?))) ; TODO fix impl - (testing "<> nilabled" + (testing ">< nilabled: #{>< <>}" + (test-comparison 2 t/iterable? (t/? t/comparable?))) + (testing "<> nilabled: #{<>}" (test-comparison 3 t/long? (t/? t/string?))))) (testing "+ ValueSpec" (testing "arg <" @@ -461,13 +522,20 @@ (test-comparison -1 (t/isa? java.util.AbstractMap$SimpleEntry) (& (t/isa? java.util.Map$Entry) (t/isa? java.io.Serializable)))) (testing "Interface" (test-comparison -1 i|a (& i|>a0 i|>a1)))) - #_(testing "#{< =}") ; not possible for `AndSpec` - #_(testing "#{< = >}") ; not possible for `AndSpec` - #_(testing "#{< = > ><}") ; not possible for `AndSpec` - #_(testing "#{< = > >< <>}") ; not possible for `AndSpec` - #_(testing "#{< >}") ; not possible for `AndSpec` - #_(testing "#{< > ><}") ; not possible for `AndSpec` - #_(testing "#{< > >< <>}") ; not possible for `AndSpec` + (testing "#{<}" + (test-comparison -1 i|a (& i|>a0 i|>a1))) + #_(testing "#{< =}") ; Impossible for `AndSpec` + #_(testing "#{< = >}") ; Impossible for `AndSpec` + #_(testing "#{< = > ><}") ; Impossible for `AndSpec` + #_(testing "#{< = > >< <>}") ; Impossible for `AndSpec` + #_(testing "#{< = > <>}") ; Impossible for `AndSpec` + #_(testing "#{< = ><}") ; Impossible for `AndSpec` + #_(testing "#{< = >< <>}") ; Impossible for `AndSpec` + #_(testing "#{< = <>}") ; Impossible for `AndSpec` + #_(testing "#{< >}") ; Impossible for `AndSpec` + #_(testing "#{< > ><}") ; Impossible for `AndSpec` + #_(testing "#{< > >< <>}") ; Impossible for `AndSpec` + #_(testing "#{< > <>}") ; Impossible for `AndSpec` (testing "#{< ><}" (test-comparison 2 i|a (& i|>a+b i|>a0 i|>a1 i|><0 i|><1))) (testing "#{< >< <>}" @@ -475,14 +543,16 @@ (testing "#{< <>}" (test-comparison 3 t/string? (& t/char-seq? t/java-set?)) (test-comparison 3 ><0 (& (! ><1) (! ><0)))) - #_(testing "#{= >}") ; not possible for `AndSpec` - #_(testing "#{= > ><}") ; not possible for `AndSpec` - #_(testing "#{= > >< <>}") ; not possible for `AndSpec` + #_(testing "#{=}") ; Impossible for `AndSpec` + #_(testing "#{= >}") ; Impossible for `AndSpec` + #_(testing "#{= > ><}") ; Impossible for `AndSpec` + #_(testing "#{= > >< <>}") ; Impossible for `AndSpec` + #_(testing "#{= > <>}") ; Impossible for `AndSpec` (testing "#{= ><}" (test-comparison 1 i|a (& i|a i|><0 i|><1)) (test-comparison 1 t/char-seq? (& t/char-seq? t/java-set?)) (test-comparison 1 t/char-seq? (& t/char-seq? t/java-set? t/array-list?))) - (testing "#{= >< <>}") ; <- comparison should be 1 + (testing "#{= >< <>}") ; <- TODO comparison should be 1 (testing "#{= <>}" (test-comparison 1 t/array-list? (& t/array-list? t/java-set?))) (testing "#{>}" @@ -493,42 +563,47 @@ (test-comparison 2 t/comparable? (& (t/isa? java.nio.ByteBuffer) t/java-set?))) (testing "#{> >< <>}" (test-comparison 2 i|a (& i|<0 t/array-list?))) - (testing "#{> <>}") ; <- comparison should be 1 + (testing "#{> <>}") ; <- TODO comparison should be 1 (testing "#{><}" (test-comparison 2 i|a (& i|><0 i|><1)) (test-comparison 2 t/char-seq? (& t/java-set? t/array-list?))) - (testing "#{>< <>}") ; <- comparison should be 3 + (testing "#{>< <>}") ; <- TODO comparison should be 3 (testing "#{<>}" (test-comparison 3 t/string? (& t/array-list? t/java-set?)))) (testing "+ ValueSpec" (testing "#{<}" (test-comparison -1 (t/value "a") (& t/char-seq? t/comparable?))) #_(testing "#{< =}") ; not possible for `AndSpec` - #_(testing "#{< >}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` - #_(testing "#{< =}") ; not possible for `AndSpec` #_(testing "#{< = >}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` #_(testing "#{< = > ><}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` #_(testing "#{< = > >< <>}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` + #_(testing "#{< = > <>}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` + #_(testing "#{< = ><}") ; not possible for `AndSpec`; `><` not possible for `ValueSpec` + #_(testing "#{< = >< <>}") ; not possible for `AndSpec`; `><` not possible for `ValueSpec` + #_(testing "#{< = <>}") ; not possible for `AndSpec` #_(testing "#{< >}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` #_(testing "#{< > ><}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` #_(testing "#{< > >< <>}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` + #_(testing "#{< > <>}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` #_(testing "#{< ><}") ; `><` not possible for `ValueSpec` #_(testing "#{< >< <>}") ; `><` not possible for `ValueSpec` (testing "#{< <>}" (test-comparison 3 (t/value "a") (& t/char-seq? t/array-list?)) (test-comparison 3 (t/value "a") (& t/char-seq? t/java-set?))) - #_(testing "#{= >}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` - #_(testing "#{= > ><}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` - #_(testing "#{= > >< <>}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` - #_(testing "#{= ><}") ; `><` not possible for `ValueSpec` - #_(testing "#{= >< <>}") ; `><` not possible for `ValueSpec` + #_(testing "#{=}") ; not possible for `AndSpec` + #_(testing "#{= >}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` + #_(testing "#{= > ><}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` + #_(testing "#{= > >< <>}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` + #_(testing "#{= > <>}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` + #_(testing "#{= ><}") ; `><` not possible for `ValueSpec` + #_(testing "#{= >< <>}") ; `><` not possible for `ValueSpec` (testing "#{= <>}") - #_(testing "#{>}") ; `>` not possible for `ValueSpec` - #_(testing "#{> ><}") ; `>` and `><` not possible for `ValueSpec` - #_(testing "#{> >< <>}") ; `>` and `><` not possible for `ValueSpec` - #_(testing "#{> <>}") ; `>` not possible for `ValueSpec` - #_(testing "#{><}") ; `><` not possible for `ValueSpec` - #_(testing "#{>< <>}") ; `><` not possible for `ValueSpec` + #_(testing "#{>}") ; `>` not possible for `ValueSpec` + #_(testing "#{> ><}") ; `>` and `><` not possible for `ValueSpec` + #_(testing "#{> >< <>}") ; `>` and `><` not possible for `ValueSpec` + #_(testing "#{> <>}") ; `>` not possible for `ValueSpec` + #_(testing "#{><}") ; `><` not possible for `ValueSpec` + #_(testing "#{>< <>}") ; `><` not possible for `ValueSpec` (testing "#{<>}" (test-comparison 3 (t/value "a") (& t/array-list? t/java-set?))))) (testing "InferSpec" @@ -866,6 +941,4 @@ (! t/boolean?))) (test-comparison 0 t/any? t/universal-set) (testing "universal class(-set) identity" - (is (not= t/val? (& t/any? t/val?))) - ;; TODO fix impl (is (t/= t/val? (& t/any? t/val?))))) From 47edc4fe0fb5aa8fc142991f4127755b63edbc46 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 18 Mar 2018 09:26:14 -0600 Subject: [PATCH 009/810] call expressions now largely handled! --- src-dev/quantum/core/defnt.cljc | 100 ++++++++++++------ .../quantum/untyped/core/analyze/ast.cljc | 17 ++- src-untyped/quantum/untyped/core/type.cljc | 83 +++++++++------ .../quantum/untyped/core/type/predicates.cljc | 2 + .../quantum/test/core/defnt_equivalences.cljc | 4 +- 5 files changed, 139 insertions(+), 67 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index dfd29b1f..da802a16 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -41,24 +41,25 @@ :refer [istr]] [quantum.untyped.core.data :refer [kw-map]] - [quantum.untyped.core.data.map :as map] - [quantum.untyped.core.data.set :as set] - [quantum.untyped.core.form :as uform] - [quantum.untyped.core.form.evaluate :as ufeval] - [quantum.untyped.core.form.generate :as ufgen + [quantum.untyped.core.data.map :as map] + [quantum.untyped.core.data.set :as set] + [quantum.untyped.core.form :as uform] + [quantum.untyped.core.form.evaluate :as ufeval] + [quantum.untyped.core.form.generate :as ufgen :refer [unify-gensyms]] - [quantum.untyped.core.form.type-hint :as ufth] - [quantum.untyped.core.loops :as loops + [quantum.untyped.core.form.type-hint :as ufth] + [quantum.untyped.core.loops :as loops :refer [reduce-2]] [quantum.untyped.core.numeric.combinatorics :as combo] - [quantum.untyped.core.qualify :as qual :refer [qualify]] - [quantum.untyped.core.reducers :as r + [quantum.untyped.core.qualify :as qual :refer [qualify]] + [quantum.untyped.core.reducers :as r :refer [join reducei educe]] - [quantum.untyped.core.refs :as ref + [quantum.untyped.core.refs :as ref :refer [?deref]] - [quantum.untyped.core.type :as t + [quantum.untyped.core.type :as t :refer [?]] - [quantum.untyped.core.vars :as var + [quantum.untyped.core.type.predicates :as utpred] + [quantum.untyped.core.vars :as var :refer [update-meta]] [quantum.format.clojure.core ; TODO temporary :refer [reformat-string]]) @@ -677,7 +678,7 @@ (-> c|analyzed :spec t/value-spec>value class?)) (err! "Supplied non-class to `new` expression" {:x c|form}) (let [c (-> c|analyzed :spec t/value-spec>value) - args|analyzed (mapv (fn [arg] (analyze* env arg)) args)] + args|analyzed (mapv #(analyze* env %) args)] (ast/new-expr {:env env :form (list* 'new c|form (map :form args|analyzed)) :class c @@ -702,23 +703,54 @@ (defn analyze-seq* "Analyze a seq after it has been macro-expanded. The ->`form` is post- incremental macroexpansion." - [env [sym & body :as form]] - (if (special-symbols sym) - (case sym - do (analyze-seq|do env form body) - let* (analyze-seq|let* env form body) - deftype* (TODO "deftype*") - fn* (TODO "fn*") - def (TODO "def") - . (analyze-seq|dot env form body) - if (analyze-seq|if env form body) - quote (analyze-seq|quote env form body) - new (analyze-seq|new env form body) - throw (analyze-seq|throw env form body)) - (if-let [sym-resolved (resolve sym)] - ; See note above on typed function return types - (TODO) - (err! "Form should be a special symbol but isn't" {:form sym})))) + [env [caller|form & body :as form]] + (ifs (special-symbols caller|form) + (case caller|form + do (analyze-seq|do env form body) + let* (analyze-seq|let* env form body) + deftype* (TODO "deftype*") + fn* (TODO "fn*") + def (TODO "def") + . (analyze-seq|dot env form body) + if (analyze-seq|if env form body) + quote (analyze-seq|quote env form body) + new (analyze-seq|new env form body) + throw (analyze-seq|throw env form body)) + ;; TODO support recursion + (let [caller|expr (analyze* env caller|form) + caller|spec (:spec caller|expr) + args-ct (count body)] + (case (t/compare spec t/callable?) + (1 2) (err! "It is not known whether expression be called" {:expr caller|expr}) + 3 (err! "Expression cannot be called" {:expr caller|expr}) + (-1 0) (let [assert-valid-args-ct + ;; For keywords or persistent maps, must be exactly one or two args + (ifs (or (t/<= caller|spec t/keyword?) (t/<= caller|spec t/+map?)) + (when-not (or (= args-ct 1) (= args-ct 2)) + (err! "Keywords and persistent maps must be provided with exactly one or two args when calling them" + {:args-ct args-ct :caller caller|expr})) + ;; For persistent vectors or sets, must be exactly one arg + (or (t/<= caller|spec t/+vector?) (t/<= caller|spec t/+set?)) + (when-not (= args-ct 1) + (err! "Persistent vectors and persistent sets must be provided with exactly one arg when calling them" + {:args-ct args-ct :caller caller|expr})) + ;; For spec'ed fns, depends on the spec + (t/<= caller|spec t/fnt?) + (TODO "Don't know how to handle spec'ed fns yet" {:caller caller|expr}) + ;; For non-speced fns, unknown; we will have to risk runtime exception + ;; because we can't necessarily rely on metadata to tell us the whole truth + (t/<= caller|spec t/fn?) + nil + ;; If it's ifn but not fn, we might have missed something in this dispatch so for now we throw + (err! "Don't know how how to handle non-fn ifn" {:caller caller|expr}))] + ;; TODO incrementally check by analyzing each arg in `reduce` and pruning branches of what the + ;; spec could be, and throwing if it's found something that's an impossible combination + (ast/call-expr + {:env env + :form form + :caller caller|expr + :args args|analyzed + :spec ...})))))) (defn analyze-seq [env form] {:post [(prl! %)]} @@ -738,7 +770,13 @@ (:spec resolved) (or (t/literal? resolved) (t/class? resolved)) (t/value resolved) - (err! "Unsure of what to do in this case" (kw-map env form resolved))))))) + (var? resolved) + (or (-> resolved meta :spec) + (t/value @resolved)) + (utpred/unbound? resolved) + ;; Because the var could be anything and cannot have metadata (spec or otherwise) + t/any? + (TODO "Unsure of what to do in this case" (kw-map env form resolved))))))) (defn analyze* [env form] (prl! env form) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 1e745ed2..7369c3fe 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -147,7 +147,7 @@ form #_::t/form target #_::node method #_::t/unqualified-symbol? - args #_(t/and t/sequential? t/indexed? (t/every? ::node)) + args #_(t/and t/sequential? t/indexed? (t/seq-and ::node)) spec #_::t/spec] INode fipp.ednize/IOverride @@ -156,11 +156,24 @@ (defn method-call [m] (map->MethodCall m)) +(defrecord CallExpr ; by a `t/callable?` + [env #_::env + form #_::t/form + caller #_::node + args #_(t/and t/sequential? t/indexed? (t/seq-and ::node)) + spec #_::t/spec] + INode + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (list `call-expr (into (array-map) this)))) + +(defn call-expr [m] (map->CallExpr m)) + (defrecord NewExpr [env #_::env form #_::t/form class #_t/class? - args #_(t/and t/sequential? t/indexed? (t/every? ::node)) + args #_(t/and t/sequential? t/indexed? (t/seq-and ::node)) spec #_::t/spec] INode fipp.ednize/IOverride diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index bf69645d..f8e1359c 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -8,8 +8,8 @@ isa? nil? any? class? tagged-literal? #?(:cljs object?) number? decimal? bigdec? integer? ratio? - keyword? string? symbol? - true? false? + true? false? keyword? string? symbol? + fn? ifn? meta ref]) (:require [clojure.core :as c] @@ -124,7 +124,7 @@ name #_(t/? t/symbol?)] {PSpec nil fipp.ednize/IOverride nil - fipp.ednize/IEdn {-edn ([this] (c/or name (list `isa|protocol? p)))} + fipp.ednize/IEdn {-edn ([this] (c/or name (list `isa|protocol? (:on p))))} ?Fn {invoke ([_ x] (satisfies? p x))} ?Meta {meta ([this] meta) with-meta ([this meta'] (ProtocolSpec. meta' p name))}}) @@ -191,9 +191,16 @@ ;; ===== DEFINITION ===== ;; +(defn register-spec! [sym spec] + (assert (satisfies? PSpec spec) spec) + (TODO)) + #?(:clj -(defmacro define [sym specable] - `(~'def ~sym (>spec ~specable '~(qual/qualify sym))))) +(defmacro define [sym spec] + `(~'def ~sym (let [spec# ~spec] + (assert (satisfies? PSpec spec#) spec#) + #_(register-spec! '~(qual/qualify sym) spec#) + spec#)))) (defn undef [reg sym] (if-let [spec (get reg sym)] @@ -205,13 +212,13 @@ (defn undef! [sym] (swap! *spec-registry undef sym)) -#?(:clj +#_(:clj (defmacro defalias [sym spec] `(~'def ~sym (>spec ~spec)))) #?(:clj (uvar/defalias -def define)) -(-def spec? PSpec) +(-def spec? (isa?|protocol PSpec)) (defn * "Denote on a spec that it must be enforced at runtime. @@ -358,8 +365,6 @@ E.g. `(>logical-complement (and a b))` -> `(or (not a) (not b))` `(>logical-complement (or a b))` -> `(and (not a) (not b))`.")) -(-def spec? PSpec) - (udt/deftype ^{:doc "Equivalent to `(constantly false)`"} EmptySetSpec [] {PSpec nil fipp.ednize/IOverride nil @@ -956,7 +961,7 @@ InferSpec compare|todo Expression compare|expr+expr ProtocolSpec compare|todo - ClassSpec compare|todo + ClassSpec fn<> ; TODO not entirely true ValueSpec compare|expr+value} ProtocolSpec {UniversalSetSpec (inverted compare|universal+protocol) @@ -995,13 +1000,11 @@ ClassSpec (inverted compare|class+value) ValueSpec compare|value+value}})) - - ;; ===== GENERAL ===== ;; (-def nil? (value nil)) (-def object? (isa? #?(:clj java.lang.Object :cljs js/Object))) - (-def val|by-class? (or object? #?@(:cljs [js/String js/Symbol]))) + (-def val|by-class? (or object? #?@(:cljs [(isa? js/String) (isa? js/Symbol)]))) (-def val? (not nil?)) (-def none? empty-set) @@ -1170,25 +1173,25 @@ ;; ===== META ===== ;; #?(:clj (-def class? (isa? java.lang.Class))) -#?(:clj (-def primitive-class? (fn [x] (c/and (uclass/primitive? x) (not== Void/TYPE x))))) +#?(:clj (-def primitive-class? (>expr (fn [x] (c/and (uclass/primitive? x) (not== Void/TYPE x)))))) #?(:clj (-def protocol? (>expr (ufn/fn-> :on-interface class?)))) ;; ===== NUMBERS ===== ;; - (-def bigint? (or #?@(:clj [clojure.lang.BigInt java.math.BigInteger] - :cljs [com.gfredericks.goog.math.Integer]))) + (-def bigint? (or #?@(:clj [(isa? clojure.lang.BigInt) (isa? java.math.BigInteger)] + :cljs [(isa? com.gfredericks.goog.math.Integer)]))) (-def integer? (or #?@(:clj [byte? short? int? long?]) bigint?)) -#?(:clj (-def bigdec? java.math.BigDecimal)) ; TODO CLJS may have this +#?(:clj (-def bigdec? (isa? java.math.BigDecimal))) ; TODO CLJS may have this (-def decimal? (or #?@(:clj [float?]) double? #?(:clj bigdec?))) - (-def ratio? #?(:clj clojure.lang.Ratio - :cljs quantum.core.numeric.types.Ratio)) ; TODO add this CLJS entry to the predicate after the fact + (-def ratio? (isa? #?(:clj clojure.lang.Ratio + :cljs quantum.core.numeric.types.Ratio))) ; TODO add this CLJS entry to the predicate after the fact #?(:clj (-def primitive-number? (or short? int? long? float? double?))) - (-def number? (or #?@(:clj [Number] + (-def number? (or #?@(:clj [(isa? Number)] :cljs [integer? decimal? ratio?]))) ;; ----- NUMBER LIKENESSES ----- ;; @@ -1227,21 +1230,35 @@ ;;"java.lang.Double" numerically-double? (err! "Could not find numerical range spec for class" {:c c})))) -#?(:clj (-def char-seq? java.lang.CharSequence)) -#?(:clj (-def comparable? java.lang.Comparable)) - (-def string? #?(:clj java.lang.String :cljs js/String)) - (-def keyword? #?(:clj clojure.lang.Keyword :cljs cljs.core/Keyword)) - (-def symbol? #?(:clj clojure.lang.Symbol :cljs cljs.core/Symbol)) -#?(:clj (-def tagged-literal? clojure.lang.TaggedLiteral)) +#?(:clj (-def char-seq? (isa? java.lang.CharSequence))) +#?(:clj (-def comparable? (isa? java.lang.Comparable))) + (-def string? (isa? #?(:clj java.lang.String :cljs js/String))) + (-def keyword? (isa? #?(:clj clojure.lang.Keyword :cljs cljs.core/Keyword))) + (-def symbol? (isa? #?(:clj clojure.lang.Symbol :cljs cljs.core/Symbol))) +#?(:clj (-def tagged-literal? (isa? clojure.lang.TaggedLiteral))) (-def literal? (or nil? boolean? symbol? keyword? string? #?(:clj long?) double? #?(:clj tagged-literal?))) -#?(:clj (-def array-list? java.util.ArrayList)) -#?(:clj (-def java-coll? java.util.Collection)) -#?(:clj (-def java-set? java.util.Set)) -#?(:clj (-def thread? java.lang.Thread)) -#?(:clj (-def throwable? java.lang.Throwable)) -#?(:clj (-def comparable? java.lang.Comparable)) -#?(:clj (-def iterable? java.lang.Iterable)) + + (-def +map? #?(:clj (isa? clojure.lang.IPersistentMap) + :cljs (isa?|protocol cljs.core/IMap))) + (-def +vector? #?(:clj (isa? clojure.lang.IPersistentVector) + :cljs (isa?|protocol cljs.core/IVector))) + (-def +set? #?(:clj (isa? clojure.lang.IPersistentSet) + :cljs (isa?|protocol cljs.core/ISet))) + +#?(:clj (-def array-list? (isa? java.util.ArrayList))) +#?(:clj (-def java-coll? (isa? java.util.Collection))) +#?(:clj (-def java-set? (isa? java.util.Set))) +#?(:clj (-def thread? (isa? java.lang.Thread))) +#?(:clj (-def throwable? (isa? java.lang.Throwable))) +#?(:clj (-def comparable? (isa? java.lang.Comparable))) +#?(:clj (-def iterable? (isa? java.lang.Iterable))) + + (-def fn? (isa? #?(:clj clojure.lang.Fn :cljs js/Function))) + (-def ifn? (isa? #?(:clj clojure.lang.IFn :cljs cljs.core/IFn))) + (-def fnt? (and fn? (>expr (fn-> c/meta :spec)))) + ;; I.e., can you call/invoke it by being in functor position (first element of an unquoted list)? + (-def callable? (or ifn? fnt?)) (-def true? (value true)) (-def false? (value false)) diff --git a/src-untyped/quantum/untyped/core/type/predicates.cljc b/src-untyped/quantum/untyped/core/type/predicates.cljc index d47475a8..c50d9179 100644 --- a/src-untyped/quantum/untyped/core/type/predicates.cljc +++ b/src-untyped/quantum/untyped/core/type/predicates.cljc @@ -67,3 +67,5 @@ (defn transient? [x] #?(:clj (instance? clojure.lang.ITransientCollection x) :cljs (satisfies? cljs.core/ITransientCollection x))) + +#?(:clj (defn unbound? [x] (instance? clojure.lang.Var$Unbound x))) diff --git a/test/quantum/test/core/defnt_equivalences.cljc b/test/quantum/test/core/defnt_equivalences.cljc index c151ce0f..a5b9dc8d 100644 --- a/test/quantum/test/core/defnt_equivalences.cljc +++ b/test/quantum/test/core/defnt_equivalences.cljc @@ -434,7 +434,9 @@ ;; ----- expanded code ----- ;; - +`(do ~@(case (env-lang) + :clj ($ [ + ]))) )) From 353b2aa7c6a8b32ad70667a8cbb1e3b68f8db2d0 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 19 Mar 2018 10:31:56 -0600 Subject: [PATCH 010/810] Transition from type defs to type specs --- src-dev/quantum/core/defnt.cljc | 30 +- .../quantum/untyped/core/collections.cljc | 9 +- src-untyped/quantum/untyped/core/type.cljc | 522 ++++++++++++++---- .../quantum/untyped/core/type/defs.cljc | 442 +-------------- test/quantum/test/core/untyped/type.cljc | 6 +- 5 files changed, 458 insertions(+), 551 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index da802a16..5fc3322f 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -696,9 +696,8 @@ (ast/throw-expr {:env env :form (list 'throw (:form arg|analyzed)) :arg arg|analyzed - ;; `nil` because nothing is actually returned - ;; TODO This needs to be handled in other analysis places - :spec nil}))))) + ;; `t/none?` because nothing is actually returned + :spec t/none?}))))) (defn analyze-seq* "Analyze a seq after it has been macro-expanded. @@ -720,21 +719,22 @@ (let [caller|expr (analyze* env caller|form) caller|spec (:spec caller|expr) args-ct (count body)] - (case (t/compare spec t/callable?) + (case (t/compare caller|spec t/callable?) (1 2) (err! "It is not known whether expression be called" {:expr caller|expr}) 3 (err! "Expression cannot be called" {:expr caller|expr}) (-1 0) (let [assert-valid-args-ct - ;; For keywords or persistent maps, must be exactly one or two args - (ifs (or (t/<= caller|spec t/keyword?) (t/<= caller|spec t/+map?)) + (ifs (or (t/<= caller|spec t/keyword?) (t/<= caller|spec t/+map|built-in?)) (when-not (or (= args-ct 1) (= args-ct 2)) - (err! "Keywords and persistent maps must be provided with exactly one or two args when calling them" + (err! (str "Keywords and `clojure.core` persistent maps must be provided " + "with exactly one or two args when calling them") {:args-ct args-ct :caller caller|expr})) - ;; For persistent vectors or sets, must be exactly one arg - (or (t/<= caller|spec t/+vector?) (t/<= caller|spec t/+set?)) + + (or (t/<= caller|spec t/+vector|built-in?) (t/<= caller|spec t/+set|built-in?)) (when-not (= args-ct 1) - (err! "Persistent vectors and persistent sets must be provided with exactly one arg when calling them" + (err! (str "`clojure.core` persistent vectors and `clojure.core` persistent " + "sets must be provided with exactly one arg when calling them") {:args-ct args-ct :caller caller|expr})) - ;; For spec'ed fns, depends on the spec + (t/<= caller|spec t/fnt?) (TODO "Don't know how to handle spec'ed fns yet" {:caller caller|expr}) ;; For non-speced fns, unknown; we will have to risk runtime exception @@ -742,7 +742,13 @@ (t/<= caller|spec t/fn?) nil ;; If it's ifn but not fn, we might have missed something in this dispatch so for now we throw - (err! "Don't know how how to handle non-fn ifn" {:caller caller|expr}))] + (err! "Don't know how how to handle non-fn ifn" {:caller caller|expr})) + {:keys [args spec]} + (->> body + (c/map+ #(analyze* env %)) + (reduce (fn [{:keys [args spec]} arg|analyzed] + (conj args))))] + ;; TODO incrementally check by analyzing each arg in `reduce` and pruning branches of what the ;; spec could be, and throwing if it's found something that's an impossible combination (ast/call-expr diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index b7cfdeef..3bcb0c57 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -1,6 +1,6 @@ (ns quantum.untyped.core.collections (:refer-clojure :exclude - [#?(:cljs array?) assoc-in cat contains? count distinct distinct? get group-by filter + [#?(:cljs array?) assoc-in cat contains? count distinct distinct? first get group-by filter flatten last map map-indexed mapcat partition-all pmap remove zipmap]) (:require [clojure.core :as core] @@ -27,6 +27,13 @@ (defn ?persistent! [x] (if (transient? x) (persistent! x) x)) +(def first|rf (aritoid ufn/fn-nil identity (fn [_ x] (reduced x)))) + +(defn first [xs] + (if (ur/transformer? xs) + (educe first|rf) + (core/first xs))) + ;; ===== SOCIATIVE ===== ;; (defn get diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index f8e1359c..1efd379b 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -1,7 +1,8 @@ (ns quantum.untyped.core.type "Essentially, set-theoretic definitions and operations on types." + {:todo "Maybe reduce dependencies and distribute predicates to other namespaces"} (:refer-clojure :exclude - [< <= = not= >= > == compare * + [< <= = not= >= > == compare * - and or not boolean byte char short int long float double boolean? byte? char? short? int? long? float? double? @@ -9,6 +10,7 @@ nil? any? class? tagged-literal? #?(:cljs object?) number? decimal? bigdec? integer? ratio? true? false? keyword? string? symbol? + list? map? map-entry? seq? seqable? sorted? vector? fn? ifn? meta ref]) (:require @@ -39,11 +41,13 @@ :refer [educe join]] [quantum.untyped.core.refs :refer [?deref]] + [quantum.untyped.core.data.tuple] [quantum.untyped.core.type.core :as utcore] [quantum.untyped.core.type.predicates :as utpred] [quantum.untyped.core.vars :as uvar :refer [def- update-meta]]) - #?(:clj (:import quantum.untyped.core.analyze.expr.Expression)) + #?(:clj (:import quantum.untyped.core.analyze.expr.Expression + quantum.untyped.core.data.tuple.Tuple)) #?(:cljs (:require-macros [quantum.untyped.core.type :as self @@ -61,8 +65,6 @@ #_(defmacro range-of) -#_(defn instance? []) - (do (defonce *spec-registry (atom {})) @@ -96,9 +98,9 @@ ;; ----- (udt/deftype ClassSpec - [meta #_(t/? ::meta) - ^Class c #_t/class? - name #_(t/? t/symbol?)] + [ meta #_(t/? ::meta) + ^Class c #_t/class? + name #_(t/? t/symbol?)] {PSpec nil fipp.ednize/IOverride nil fipp.ednize/IEdn @@ -124,7 +126,7 @@ name #_(t/? t/symbol?)] {PSpec nil fipp.ednize/IOverride nil - fipp.ednize/IEdn {-edn ([this] (c/or name (list `isa|protocol? (:on p))))} + fipp.ednize/IEdn {-edn ([this] (c/or name (list `isa?|protocol (:on p))))} ?Fn {invoke ([_ x] (satisfies? p x))} ?Meta {meta ([this] meta) with-meta ([this meta'] (ProtocolSpec. meta' p name))}}) @@ -136,13 +138,18 @@ (.-p ^ProtocolSpec spec) (err! "Cannot cast to ProtocolSpec" {:x spec}))) -(defn isa?|protocol [p] +(defn- isa?|protocol [p] (assert (utpred/protocol? p)) (ProtocolSpec. nil p nil)) (defn isa? [x] - (ifs #?@(:clj [(c/class? x) (ClassSpec. nil x nil)]) - (utpred/protocol? x) (isa?|protocol x))) + (ifs #?(:clj (utpred/protocol? x) + ;; Unfortunately there's no better check in CLJS, at least as of 03/18/2018 + :cljs (c/and (c/fn? x) (c/= (str x) "function (){}"))) + (isa?|protocol x) + + (#?(:clj c/class? c/fn?) x) + (ClassSpec. nil x nil))) ;; ===== CREATION ===== ;; @@ -573,7 +580,7 @@ (uvar/defalias ! not) (defn - - "Computes the difference of `s0` from `s1` (& A (! B)) + "Computes the difference of `s0` from `s1`: (& s0 (! s1)) If `s0` = `s1`, `∅` If `s0` < `s1`, `∅` If `s0` <> `s1`, `s0` @@ -600,11 +607,53 @@ 1 (first args) (OrSpec. args (atom nil)))))))))) -#?(:clj -(defmacro spec - "Creates a spec function" - [arglist & body] ; TODO spec this - `(FnSpec. nil (fn ~arglist ~@body) (list* `spec '~arglist '~body)))) +(udt/deftype SequentialSpec) + +(defn of + "Creates a spec that. + `pred` must be `t/<=` iterable" + [pred spec]) + +(udt/deftype FnSpec + [name #_(t/? t/symbol?) + lookup #_(t/map-of t/integer? + (t/or (spec spec? "output-spec") + (t/vec-of (t/tuple (spec spec? "input-spec") + (spec spec? "output-spec"))))) + spec #_spec? + meta] + {PSpec nil + ;; Outputs whether the args match any input spec + ?Fn {invoke ([this args] + (if-let [arity-specs (get lookup (count args))] + (->> arity-specs (uc/map+ first) (seq-or #(% args))) + false))} + ?Meta {meta ([this] meta) + with-meta ([this meta'] (FnSpec. name lookup spec meta'))} + fipp.ednize/IOverride nil + fipp.ednize/IEdn + {-edn ([this] (list `fn name lookup))}}) + +(defn fn|args>out-spec + "Returns nil if args do not match any input spec" + [^FnSpec spec args] + (when-let [spec-or-arity-specs (get (.-lookup spec) (count args))] + (if (spec? spec-or-arity-specs) + spec-or-arity-specs + (->> spec-or-arity-specs (uc/filter+ #((first %) args)) uc/first second)))) + +(defn fn-spec + [name- #_(t/? t/symbol?) + lookup #_(t/map-of t/integer? + (t/or (spec spec? "output-spec") + (t/vec-of (t/tuple (t/vec-of (spec spec? "input-spec")) + (spec spec? "output-spec")))))] + (let [spec (->> lookup vals + (uc/map+ (fn [spec-or-arity-specs] + (if (spec? spec-or-arity-specs) + spec-or-arity-specs + (->> spec-or-arity-specs (map ))))))] + (FnSpec. name- lookup spec nil))) (deftype FnConstantlySpec [name #_(t/? t/symbol?) @@ -1000,47 +1049,6 @@ ClassSpec (inverted compare|class+value) ValueSpec compare|value+value}})) -;; ===== GENERAL ===== ;; - - (-def nil? (value nil)) - (-def object? (isa? #?(:clj java.lang.Object :cljs js/Object))) - (-def val|by-class? (or object? #?@(:cljs [(isa? js/String) (isa? js/Symbol)]))) - (-def val? (not nil?)) - - (-def none? empty-set) - (-def any? universal-set) - -;; ===== PRIMITIVES ===== ;; - - (-def boolean? (isa? #?(:clj Boolean :cljs js/Boolean))) - (-def ?boolean? (? boolean?)) - -#?(:clj (-def byte? (isa? Byte))) -#?(:clj (-def ?byte? (? byte?))) - -#?(:clj (-def char? (isa? Character))) -#?(:clj (-def ?char? (? char?))) - -#?(:clj (-def short? (isa? Short))) -#?(:clj (-def ?short? (? short?))) - -#?(:clj (-def int? (isa? Integer))) -#?(:clj (-def ?int? (? int?))) - -#?(:clj (-def long? (isa? Long))) -#?(:clj (-def ?long? (? long?))) - -#?(:clj (-def float? (isa? Float))) -#?(:clj (-def ?float? (? float?))) - - (-def double? (isa? #?(:clj Double :cljs js/Number))) - (-def ?double? (? double?)) - - (-def primitive? (or boolean? #?@(:clj [byte? char? short? int? long? float?]) double?)) - -#_(:clj (-def comparable-primitive? (and primitive? (not boolean?)))) - - #?(:clj (def boxed-class->unboxed-symbol {Boolean 'boolean @@ -1173,28 +1181,123 @@ ;; ===== META ===== ;; #?(:clj (-def class? (isa? java.lang.Class))) -#?(:clj (-def primitive-class? (>expr (fn [x] (c/and (uclass/primitive? x) (not== Void/TYPE x)))))) +#?(:clj (-def primitive-class? (or (value Boolean/TYPE) + (value Byte/TYPE) + (value Character/TYPE) + (value Short/TYPE) + (value Integer/TYPE) + (value Long/TYPE) + (value Float/TYPE) + (value Double/TYPE)))) #?(:clj (-def protocol? (>expr (ufn/fn-> :on-interface class?)))) -;; ===== NUMBERS ===== ;; - (-def bigint? (or #?@(:clj [(isa? clojure.lang.BigInt) (isa? java.math.BigInteger)] - :cljs [(isa? com.gfredericks.goog.math.Integer)]))) - (-def integer? (or #?@(:clj [byte? short? int? long?]) bigint?)) -#?(:clj (-def bigdec? (isa? java.math.BigDecimal))) ; TODO CLJS may have this - (-def decimal? (or #?@(:clj [float?]) double? #?(:clj bigdec?))) - (-def ratio? (isa? #?(:clj clojure.lang.Ratio - :cljs quantum.core.numeric.types.Ratio))) ; TODO add this CLJS entry to the predicate after the fact +#?(:clj (-def comparable? (isa? java.lang.Comparable))) + (-def keyword? (isa? #?(:clj clojure.lang.Keyword :cljs cljs.core/Keyword))) + (-def symbol? (isa? #?(:clj clojure.lang.Symbol :cljs cljs.core/Symbol))) +#?(:clj (-def tagged-literal? (isa? clojure.lang.TaggedLiteral))) + + (-def literal? (or nil? boolean? symbol? keyword? string? #?(:clj long?) double? #?(:clj tagged-literal?))) + + (-def +map|built-in? (or (isa? #?(:clj clojure.lang.PersistentHashMap :cljs cljs.core/PersistentHashMap)) + (isa? #?(:clj clojure.lang.PersistentArrayMap :cljs cljs.core/PersistentArrayMap)) + (isa? #?(:clj clojure.lang.PersistentTreeMap :cljs cljs.core/PersistentTreeMap)))) + + (-def +map? #?(:clj (isa? clojure.lang.IPersistentMap) + :cljs (isa?|protocol cljs.core/IMap))) + + (-def map? #?(:clj (isa? java.util.Map) + :cljs (TODO))) + + (-def +set? #?(:clj (isa? clojure.lang.IPersistentSet) + :cljs (isa?|protocol cljs.core/ISet))) + + (-def +set|built-in? (or (isa? #?(:clj clojure.lang.PersistentHashSet :cljs cljs.core/PersistentHashSet)) + (isa? #?(:clj clojure.lang.PersistentTreeSet :cljs cljs.core/PersistentTreeSet)))) + +#?(:clj (-def array-list? (isa? java.util.ArrayList))) +#?(:clj (-def java-coll? (isa? java.util.Collection))) +#?(:clj (-def java-set? (isa? java.util.Set))) +#?(:clj (-def thread? (isa? java.lang.Thread))) + (-def throwable? #?(:clj (isa? java.lang.Throwable) :cljs any?)) +#?(:clj (-def comparable? (isa? java.lang.Comparable))) +#?(:clj (-def java-iterable? (isa? java.lang.Iterable))) + +;; ---------------------- ;; +;; ===== Predicates ===== ;; +;; ---------------------- ;; + +;; ===== General ===== ;; + + (-def none? empty-set) + (-def any? universal-set) + + (-def nil? (value nil)) + (-def object? (isa? #?(:clj java.lang.Object :cljs js/Object))) + + ;; TODO this is incomplete for CLJS base classes, I think + (-def val|by-class? (or object? #?@(:cljs [(isa? js/String) (isa? js/Symbol)]))) + (-def val? (not nil?)) + +;; ===== Primitives ===== ;; + + (-def boolean? (isa? #?(:clj Boolean :cljs js/Boolean))) + (-def ?boolean? (? boolean?)) + +#?(:clj (-def byte? (isa? Byte))) +#?(:clj (-def ?byte? (? byte?))) + +#?(:clj (-def char? (isa? Character))) +#?(:clj (-def ?char? (? char?))) + +#?(:clj (-def short? (isa? Short))) +#?(:clj (-def ?short? (? short?))) -#?(:clj (-def primitive-number? (or short? int? long? float? double?))) +#?(:clj (-def int? (isa? Integer))) +#?(:clj (-def ?int? (? int?))) - (-def number? (or #?@(:clj [(isa? Number)] - :cljs [integer? decimal? ratio?]))) +#?(:clj (-def long? (isa? Long))) +#?(:clj (-def ?long? (? long?))) -;; ----- NUMBER LIKENESSES ----- ;; +#?(:clj (-def float? (isa? Float))) +#?(:clj (-def ?float? (? float?))) + + (-def double? (isa? #?(:clj Double :cljs js/Number))) + (-def ?double? (? double?)) + + (-def primitive? (or boolean? #?@(:clj [byte? char? short? int? long? float?]) double?)) + +#_(:clj (-def comparable-primitive? (and primitive? (not boolean?)))) + +;; ===== Numbers ===== ;; + +;; ----- Integers ----- ;; + + (-def bigint? #?(:clj (or (isa? clojure.lang.BigInt) (isa? java.math.BigInteger)) + :cljs (isa? com.gfredericks.goog.math.Integer))) + + (-def integer? (or #?@(:clj [byte? short? int? long?]) bigint?)) + +;; ----- Decimals ----- ;; + +#?(:clj (-def bigdec? (isa? java.math.BigDecimal))) ; TODO CLJS may have this + + (-def decimal? (or #?(:clj float?) double? #?(:clj bigdec?))) + +;; ----- General ----- ;; + + (-def ratio? (isa? #?(:clj clojure.lang.Ratio + :cljs quantum.core.numeric.types.Ratio))) ; TODO add this CLJS entry to the predicate after the fact + + (-def primitive-number? (or #?@(:clj [short? int? long? float?]) double?))) + + (-def number? (or #?@(:clj [(isa? java.lang.Number)] + :cljs [integer? decimal? ratio?]))) + +;; ----- Likenesses ----- ;; #_(-def integer-value? (or integer? (and decimal? (>expr unum/integer-value?)))) @@ -1230,38 +1333,253 @@ ;;"java.lang.Double" numerically-double? (err! "Could not find numerical range spec for class" {:c c})))) -#?(:clj (-def char-seq? (isa? java.lang.CharSequence))) -#?(:clj (-def comparable? (isa? java.lang.Comparable))) - (-def string? (isa? #?(:clj java.lang.String :cljs js/String))) - (-def keyword? (isa? #?(:clj clojure.lang.Keyword :cljs cljs.core/Keyword))) - (-def symbol? (isa? #?(:clj clojure.lang.Symbol :cljs cljs.core/Symbol))) -#?(:clj (-def tagged-literal? (isa? clojure.lang.TaggedLiteral))) - - (-def literal? (or nil? boolean? symbol? keyword? string? #?(:clj long?) double? #?(:clj tagged-literal?))) - - (-def +map? #?(:clj (isa? clojure.lang.IPersistentMap) - :cljs (isa?|protocol cljs.core/IMap))) - (-def +vector? #?(:clj (isa? clojure.lang.IPersistentVector) - :cljs (isa?|protocol cljs.core/IVector))) - (-def +set? #?(:clj (isa? clojure.lang.IPersistentSet) - :cljs (isa?|protocol cljs.core/ISet))) - -#?(:clj (-def array-list? (isa? java.util.ArrayList))) -#?(:clj (-def java-coll? (isa? java.util.Collection))) -#?(:clj (-def java-set? (isa? java.util.Set))) -#?(:clj (-def thread? (isa? java.lang.Thread))) -#?(:clj (-def throwable? (isa? java.lang.Throwable))) -#?(:clj (-def comparable? (isa? java.lang.Comparable))) -#?(:clj (-def iterable? (isa? java.lang.Iterable))) - - (-def fn? (isa? #?(:clj clojure.lang.Fn :cljs js/Function))) - (-def ifn? (isa? #?(:clj clojure.lang.IFn :cljs cljs.core/IFn))) - (-def fnt? (and fn? (>expr (fn-> c/meta :spec)))) - ;; I.e., can you call/invoke it by being in functor position (first element of an unquoted list)? - (-def callable? (or ifn? fnt?)) +;; ========== Collections ========== ;; + +;; ===== Tuples ===== ;; + + (-def tuple? ;; clojure.lang.Tuple was discontinued; we won't support it for now + (isa? quantum.untyped.core.data.tuple.Tuple)) +#?(:clj (-def map-entry? (isa? java.util.Map$Entry))) + +;; ===== Sequences ===== ;; Sequential (generally not efficient Lookup / RandomAccess) + + (-def cons? (isa? #?(:clj clojure.lang.Cons :cljs cljs.core/Cons))) + (-def lseq? (isa? #?(:clj clojure.lang.LazySeq :cljs cljs.core/LazySeq))) + (-def misc-seq? (or (isa? #?(:clj clojure.lang.APersistentMap$KeySeq :cljs cljs.core/KeySeq)) + (isa? #?(:clj clojure.lang.APersistentMap$ValSeq :cljs cljs.core/ValSeq)) + (isa? #?(:clj clojure.lang.PersistentVector$ChunkedSeq :cljs cljs.core/ChunkedSeq)) + (isa? #?(:clj clojure.lang.IndexedSeq :cljs cljs.core/IndexedSeq)))) + + (-def non-list-seq? (or cons? lseq? misc-seq?)) + +;; ----- Lists ----- ;; Not extremely different from Sequences ; TODO clean this up + + (-def cdlist? none? #_(:clj (or (isa? clojure.data.finger_tree.CountedDoubleList) + (isa? quantum.core.data.finger_tree.CountedDoubleList)) + :cljs (isa? quantum.core.data.finger-tree/CountedDoubleList))) + (-def dlist? none? #_(:clj (or (isa? clojure.data.finger_tree.CountedDoubleList) + (isa? quantum.core.data.finger_tree.CountedDoubleList)) + :cljs (isa? quantum.core.data.finger-tree/CountedDoubleList))) + (-def +list? (isa? #?(:clj clojure.lang.IPersistentList :cljs cljs.core/IList))) + (-def !list? #?(:clj (isa? java.util.LinkedList))) + (-def list? #?(:clj (isa? java.util.List) + :cljs +list?)) + +;; ----- Generic ----- ;; + + (-def seq? #?(:clj clojure.lang.ISeq :cljs cljs.core/ISeq)) - (-def true? (value true)) - (-def false? (value false)) +;; TODO add maps in here + +;; ===== Arrays ===== ;; Sequential, Associative (specifically, whose keys are sequential, + ;; dense integer values), not extensible + +;; ----- String ----- ;; A special wrapper for char array where different encodings, etc. are possible + + ;; Mutable String + (-def !string? (isa? #?(:clj java.lang.StringBuilder :cljs goog.string.StringBuffer))) + ;; Immutable String + (-def string? (isa? #?(:clj java.lang.String :cljs js/String))) + +#?(:clj (-def char-seq? (isa? java.lang.CharSequence))) + +;; ===== Vectors ===== ;; Sequential, Associative (specifically, whose keys are sequential, + ;; dense integer values), extensible + + (-def !array-list? #?(:clj (or (isa? java.util.ArrayList) + ;; indexed and associative, but not extensible + (isa? java.util.Arrays$ArrayList)) + :cljs (or ;; not used + #_(isa? cljs.core/ArrayList) + ;; because supports .push etc. + (isa? js/Array)))) + ;; svec = "spliceable vector" + (-def svector? (isa? clojure.core.rrb_vector.rrbt.Vector)) + + (-def +vector? #?(:clj (isa? clojure.lang.IPersistentVector) + :cljs (isa?|protocol cljs.core/IVector))) + + (-def +vector|built-in? (isa? #?(:clj clojure.lang.PersistentVector + :cljs cljs.core/PersistentVector))) + + (-def !+vector? #?(:clj (isa? clojure.lang.ITransientVector) + :cljs (isa?|protocol cljs.core/ITransientVector))) + (-def ?!+vector? (or +vector? ?!+vector?)) +#?(:clj (-def !vector|long? (isa? it.unimi.dsi.fastutil.longs.LongArrayList))) + (-def !vector|ref? (isa? #?(:clj java.util.ArrayList + ;; because supports .push etc. + :cljs js/Array))) + (-def !vector? (or !vector|long? !vector|ref?)) + + ;; java.util.Vector is deprecated, because you can + ;; just create a synchronized wrapper over an ArrayList + ;; via java.util.Collections +#?(:clj (-def !!vector? none?)) + (-def vector? (or ?!+vector? !vector? #?(:clj !!vector?))) + +;; ===== Queues ===== ;; Particularly FIFO queues, as LIFO = stack = any vector + + (-def +queue? (isa? #?(:clj clojure.lang.PersistentQueue + :cljs cljs.core/PersistentQueue))) + (-def !+queue? none?) + (-def ?!+queue? (or +queue? !+queue?)) +#?(:clj (-def !!queue? (or (isa? java.util.concurrent.BlockingQueue) + (isa? java.util.concurrent.TransferQueue) + (isa? java.util.concurrent.ConcurrentLinkedQueue)))) + (-def !queue? #?(:clj ;; Considered single-threaded mutable unless otherwise noted + (- (isa? java.util.Queue) (or ?!+queue? !!queue?)) + :cljs (isa? goog.structs.Queue))) + (-def queue? (or ?!+queue? !queue? #?(:clj !!queue?))) + +;; ===== Generic ===== ;; + + ;; Standard "uncuttable" types + (-def integral? (or primitive? number?)) + +;; ----- Collections ----- ;; + + (-def sorted? #?(:clj (or (isa? clojure.lang.Sorted) + (isa? java.util.SortedMap) + (isa? java.util.SortedSet)) + :cljs (or (isa? cljs.core/ISorted) + (isa? goog.structs.AvlTree)))) + + (-def transient? (isa? #?(:clj clojure.lang.ITransientCollection + :cljs cljs.core/ITransientCollection))) + + (-def editable? (isa? #?(:clj clojure.lang.IEditableCollection + :cljs cljs.core/IEditableCollection))) + +;; ===== Functions ===== ;; + + (-def fn? (isa? #?(:clj clojure.lang.Fn :cljs js/Function))) + + (-def ifn? (isa? #?(:clj clojure.lang.IFn :cljs cljs.core/IFn))) + + (-def fnt? (and fn? (>expr (fn-> c/meta :spec)))) + + (-def multimethod? (isa? #?(:clj clojure.lang.MultiFn :cljs cljs.core/IMultiFn))) + + ;; I.e., can you call/invoke it by being in functor position (first element of an unquoted list)? + ;; TODO should we allow java.lang.Runnable, java.util.concurrent.Callable to be `callable?`? + (-def callable? (or ifn? fnt?)) + +;; ===== Miscellaneous ===== ;; + + (-def regex? (isa? #?(:clj java.util.regex.Pattern :cljs js/RegExp))) + + (-def atom? (isa? #?(:clj clojure.lang.IAtom :cljs cljs.core/IAtom))) + + (-def volatile? (isa? #?(:clj clojure.lang.Volatile :cljs cljs.core/Volatile))) + +#?(:clj (-def atomic? (or atom? volatile? + java.util.concurrent.atomic.AtomicReference + ;; From the java.util.concurrent package: + ;; "Additionally, classes are provided only for those + ;; types that are commonly useful in intended applications. + ;; For example, there is no atomic class for representing + ;; byte. In those infrequent cases where you would like + ;; to do so, you can use an AtomicInteger to hold byte + ;; values, and cast appropriately. You can also hold floats + ;; using Float.floatToIntBits and Float.intBitstoFloat + ;; conversions, and doubles using Double.doubleToLongBits + ;; and Double.longBitsToDouble conversions. + java.util.concurrent.atomic.AtomicBoolean + #_java.util.concurrent.atomic.AtomicByte + #_java.util.concurrent.atomic.AtomicShort + java.util.concurrent.atomic.AtomicInteger + java.util.concurrent.atomic.AtomicLong + #_java.util.concurrent.atomic.AtomicFloat + #_java.util.concurrent.atomic.AtomicDouble + com.google.common.util.concurrent.AtomicDouble))) + +;; TODO finish this below + +(-def m2m-chan? '{:clj #{clojure.core.async.impl.channels.ManyToManyChannel} + :cljs #{cljs.core.async.impl.channels/ManyToManyChannel}}) + +(-def chan? '{:clj #{clojure.core.async.impl.protocols.Channel} + :cljs #{cljs.core.async.impl.channels/ManyToManyChannel + #_"TODO more?"}}) + +(-def keyword? '{:clj #{clojure.lang.Keyword} + :cljs #{cljs.core/Keyword}}) + +(-def symbol? '{:clj #{clojure.lang.Symbol} + :cljs #{cljs.core/Symbol}}) + +(-def file? '{:clj #{java.io.File} + :cljs #{#_js/File}}) ; isn't always available! Use an abstraction + +(-def any? {:clj (uset/union (:clj (preds>types 'prim?)) #{'java.lang.Object}) + :cljs '#{(quote default)}}) + +(-def comparable? {:clj (uset/union '#{byte char short int long float double} '#{Comparable}) + :cljs (:cljs (preds>types 'number?))}) + +(-def record? '{:clj #{clojure.lang.IRecord} + #_:cljs #_#{cljs.core/IRecord}}) ; because can't protocol-dispatch on protocols in CLJS + +(-def transformer? '{:clj #{#_clojure.core.protocols.CollReduce ; no, in order to find most specific type + quantum.untyped.core.reducers.Transformer} + :cljs #{#_cljs.core/IReduce ; CLJS problems with dispatching on protocol + quantum.untyped.core.reducers.Transformer}}) + +#_(-def reducible? (preds>types + 'array? + 'string? + 'record? + 'reducer? + 'chan? + {:cljs (:cljs (preds>types '+map?))} + {:cljs (:cljs (preds>types '+set?))} + 'integer? + {:clj '#{clojure.lang.IReduce + clojure.lang.IReduceInit + clojure.lang.IKVReduce + #_clojure.core.protocols.CollReduce} ; no, in order to find most specific type + #_:cljs #_'#{cljs.core/IReduce}} ; because can't protocol-dispatch on protocols in CLJS + {:clj '#{fast_zip.core.ZipperLocation} + :cljs '#{fast-zip.core/ZipperLocation}})) + +; ----- COLLECTIONS ----- ; + + ;; TODO clojure.lang.Indexed / cljs.core/IIndexed? + (-def indexed? (preds>types string? vector? (isa? clojure.lang.IndexedSeq) array?)) + ;; TODO this might be ambiguous + ;; TODO clojure.lang.Associative / cljs.core/IAssociative? + (-def associative? (preds>types 'map? 'set? 'indexed?)) + ;; TODO this might be ambiguous + ;; TODO clojure.lang.Sequential / cljs.core/ISequential? + (-def sequential? (preds>types 'seq? 'list? 'indexed?)) + ;; TODO this might be ambiguous + ;; TODO clojure.lang.ICollection / cljs.core/ICollection? + (-def counted? (preds>types 'array? 'string? + {:clj (uset/union (:clj (preds>types '!vector? '!!vector? + '!map? '!!map? + '!set? '!!set?)) + '#{clojure.lang.Counted}) + :cljs (:clj (preds>types 'vector? 'map? 'set?))})) + + (-def coll? (preds>types 'sequential? 'associative?)) + + (-def sequential? #?(:clj (or (isa? clojure.lang.Sequential) + (isa? java.util.List)) + )) + + (-def seqable? #?(:clj (or (isa? clojure.lang.ISeq) + (isa? clojure.lang.Seqable) + java-iterable? + char-seq? + map? + array?))) + + ;; Able to be iterated over in some fashion, whether by `first`/`next` seq recursion, reduction, etc. + (-def iterable? (or seqable? reducible?)) + + + (-def true? (value true)) + (-def false? (value false)) #_(t/def ::form (t/or ::literal t/list? t/vector? ...)) ) diff --git a/src-untyped/quantum/untyped/core/type/defs.cljc b/src-untyped/quantum/untyped/core/type/defs.cljc index 1c0ba9df..75901ac1 100644 --- a/src-untyped/quantum/untyped/core/type/defs.cljc +++ b/src-untyped/quantum/untyped/core/type/defs.cljc @@ -46,79 +46,13 @@ #?(:clj (def float Float/TYPE)) #?(:clj (def double Double/TYPE)) -(def ^{:doc "Could do /MAX_VALUE for the maxes in Java but JS doesn't like it of course - In JavaScript, all numbers are 64-bit floating point numbers. - This means you can't represent in JavaScript all the Java longs - Max 'safe' int: (dec (Math/pow 2 53))"} - primitive-type-meta - {'boolean {:bits 1 - :min 0 - :max 1 - #?@(:clj [:array-ident "Z" - :outer-type "[Z" - :boxed 'java.lang.Boolean - :unboxed 'Boolean/TYPE])} - 'byte {:bits 8 - :min -128 - :max 127 - #?@(:clj [:array-ident "B" - :outer-type "[B" - :boxed 'java.lang.Byte - :unboxed 'Byte/TYPE])} - 'short {:bits 16 - :min -32768 - :max 32767 - #?@(:clj [:array-ident "S" - :outer-type "[S" - :boxed 'java.lang.Short - :unboxed 'Short/TYPE])} - 'char {:bits 16 - :min 0 - :max 65535 - #?@(:clj [:array-ident "C" - :outer-type "[C" - :boxed 'java.lang.Character - :unboxed 'Character/TYPE])} - 'int {:bits 32 - :min -2147483648 - :max 2147483647 - #?@(:clj [:array-ident "I" - :outer-type "[I" - :boxed 'java.lang.Integer - :unboxed 'Integer/TYPE])} - 'long {:bits 64 - :min -9223372036854775808 - :max 9223372036854775807 - #?@(:clj [:array-ident "J" - :outer-type "[J" - :boxed 'java.lang.Long - :unboxed 'Long/TYPE])} - ; Technically with floating-point nums, "min" isn't the most negative; - ; it's the smallest absolute - 'float {:bits 32 - :min 1.4E-45 - :max 3.4028235E38 - #?@(:clj [:array-ident "F" - :outer-type "[F" - :boxed 'java.lang.Float - :unboxed 'Float/TYPE])} - 'double {:bits 64 - ; Because: - ; Double/MIN_VALUE = 4.9E-324 - ; (.-MIN_VALUE js/Number) = 5e-324 - :min #?(:clj Double/MIN_VALUE - :cljs (.-MIN_VALUE js/Number)) - :max 1.7976931348623157E308 ; Max number in JS - #?@(:clj [:array-ident "D" - :outer-type "[D" - :boxed 'java.lang.Double - :unboxed 'Double/TYPE])}}) +(def primitive-type-meta quantum.untyped.core.type/unboxed-symbol->type-meta) (def array-ident->primitive-sym - (->> primitive-type-meta (map (juxt (rcomp val :array-ident) key)) (into {}))) + (->> unboxed-symbol->type-meta (map (juxt (rcomp val :array-ident) key)) (into {}))) (def elem-types-clj - (->> primitive-type-meta + (->> unboxed-symbol->type-meta (map (fn [[k v]] [(:outer-type v) k])) (reduce (fn [m [k v]] @@ -127,7 +61,7 @@ #?(:clj (def boxed-types - (->> primitive-type-meta + (->> unboxed-symbol->type-meta (map (fn [[k v]] [k (:boxed v)])) (into {})))) @@ -136,10 +70,10 @@ (zipmap (vals boxed-types) (keys boxed-types)))) #?(:clj -(def boxed->unboxed-types-evaled (->> primitive-type-meta vals (map (juxt :boxed :unboxed)) (into {}) eval))) +(def boxed->unboxed-types-evaled (->> unboxed-symbol->type-meta vals (map (juxt :boxed :unboxed)) (into {}) eval))) (def max-values - (->> primitive-type-meta + (->> unboxed-symbol->type-meta (map (fn [[k v]] [k (:max v)])) (into {}))) @@ -204,156 +138,6 @@ {:clj (->> lang->types (map :clj) (apply uset/union)) :cljs (->> lang->types (map :cljs) (apply uset/union))}) -(reg-pred! 'default '{:clj #{Object} - :cljs #{(quote default)}}) - -; ______________________ ; -; ===== PRIMITIVES ===== ; -; •••••••••••••••••••••• ; - -(reg-pred! 'nil? '{:clj #{nil} :cljs #{nil}}) - -; ===== NON-NUMERIC PRIMITIVES ===== ; ; TODO CLJS - -(reg-pred! 'unboxed-bool? '{:clj #{boolean} - :cljs #{js/Boolean}}) -(reg-pred! 'unboxed-boolean? (preds>types 'unboxed-bool?)) -(reg-pred! 'boxed-bool? '{:clj #{java.lang.Boolean} - :cljs #{js/Boolean}}) -(reg-pred! 'boxed-boolean? (preds>types 'boxed-bool?)) -(reg-pred! '?bool? (preds>types 'boxed-bool?)) -(reg-pred! '?boolean? (preds>types '?bool?)) -(reg-pred! 'bool? (preds>types 'unboxed-bool? 'boxed-bool?)) -(reg-pred! 'boolean? (preds>types 'bool?)) - -(reg-pred! 'unboxed-byte? '{:clj #{byte}}) -(reg-pred! 'boxed-byte? '{:clj #{java.lang.Byte}}) -(reg-pred! '?byte? (preds>types 'boxed-byte?)) -(reg-pred! 'byte? (preds>types 'unboxed-byte? 'boxed-byte?)) - -(reg-pred! 'unboxed-char? '{:clj #{char}}) -(reg-pred! 'boxed-char? '{:clj #{java.lang.Character}}) -(reg-pred! '?char? (preds>types 'boxed-char?)) -(reg-pred! 'char? (preds>types 'unboxed-char? 'boxed-char?)) - -; ===== NUMBERS ===== ; ; TODO CLJS - -; ----- INTEGERS ----- ; - -(reg-pred! 'unboxed-short? '{:clj #{short}}) -(reg-pred! 'boxed-short? '{:clj #{java.lang.Short}}) -(reg-pred! '?short? (preds>types 'boxed-short?)) -(reg-pred! 'short? (preds>types 'unboxed-short? 'boxed-short?)) - -(reg-pred! 'unboxed-int? '{:clj #{int} - ;; because the integral values representable by JS numbers are in the - ;; range of Java ints, though technically one needs to ensure that - ;; there is only an integral value, no decimal value - :cljs #{js/Number}}) -(reg-pred! 'boxed-int? '{:clj #{java.lang.Integer} - :cljs #{js/Number}}) -(reg-pred! '?int? (preds>types 'boxed-int?)) -(reg-pred! 'int? (preds>types 'unboxed-int? 'boxed-int?)) - -(reg-pred! 'unboxed-long? '{:clj #{long}}) -(reg-pred! 'boxed-long? '{:clj #{java.lang.Long}}) -(reg-pred! '?long? (preds>types 'boxed-long?)) -(reg-pred! 'long? (preds>types 'unboxed-long? 'boxed-long?)) - -(reg-pred! 'bigint? '{:clj #{clojure.lang.BigInt java.math.BigInteger} - :cljs #{com.gfredericks.goog.math.Integer}}) - -(reg-pred! 'integer? (preds>types 'unboxed-short? 'unboxed-int? 'unboxed-long? 'bigint?)) - -; ----- DECIMALS ----- ; - -(reg-pred! 'unboxed-float? '{:clj #{float}}) -(reg-pred! 'boxed-float? '{:clj #{java.lang.Float}}) -(reg-pred! '?float? (preds>types 'boxed-float?)) -(reg-pred! 'float? (preds>types 'unboxed-float? 'boxed-float?)) - -(reg-pred! 'unboxed-double? '{:clj #{double} - :cljs #{js/Number}}) -(reg-pred! 'boxed-double? '{:clj #{java.lang.Double} - :cljs #{js/Number}}) -(reg-pred! '?double? (preds>types 'boxed-double?)) -(reg-pred! 'double? (preds>types 'unboxed-double? 'boxed-double?)) - -(reg-pred! 'bigdec? '{:clj #{java.math.BigDecimal}}) - -(reg-pred! 'decimal? (preds>types 'unboxed-float? 'unboxed-double? 'bigdec?)) - -; ----- GENERAL ----- ; - -(reg-pred! 'ratio? '{:clj #{clojure.lang.Ratio} - :cljs #{quantum.core.numeric.types.Ratio}}) - -(reg-pred! 'number? {:clj (uset/union - (:clj (preds>types 'unboxed-short? 'unboxed-int? 'unboxed-long? - 'unboxed-float? 'unboxed-double?)) - '#{java.lang.Number}) - :cljs (:cljs (preds>types 'integer? 'decimal? 'ratio?))}) - -;; 'Platform number' -(reg-pred! 'pnumber? '{:cljs #{js/Number}}) - -;; The closest thing to a native int the platform has -(reg-pred! 'nat-int? '{:clj #{int} - :cljs #{js/Number}}) - -;; The closest thing to a native long the platform has -(reg-pred! 'nat-long? '{:clj #{long} - :cljs #{js/Number}}) - -; _______________________ ; -; ===== COLLECTIONS ===== ; -; ••••••••••••••••••••••• ; - -; ===== TUPLES ===== ; - -(reg-pred! 'tuple? '{:clj #{quantum.untyped.core.data.tuple.Tuple} ; clojure.lang.Tuple was discontinued; we won't support it for now - :cljs #{quantum.untyped.core.data.tuple.Tuple}}) -(reg-pred! 'map-entry? '{:clj #{java.util.Map$Entry}}) - -; ===== SEQUENCES ===== ; Sequential (generally not efficient Lookup / RandomAccess) - -(reg-pred! 'cons? '{:clj #{clojure.lang.Cons} - :cljs #{cljs.core/Cons}}) -(reg-pred! 'lseq? '{:clj #{clojure.lang.LazySeq} - :cljs #{cljs.core/LazySeq}}) -(reg-pred! 'misc-seq? '{:clj #{clojure.lang.APersistentMap$ValSeq - clojure.lang.APersistentMap$KeySeq - clojure.lang.PersistentVector$ChunkedSeq - clojure.lang.IndexedSeq} - :cljs #{cljs.core/ValSeq - cljs.core/KeySeq - cljs.core/IndexedSeq - cljs.core/ChunkedSeq}}) - -(reg-pred! 'non-list-seq? (preds>types 'cons? 'lseq? 'misc-seq?)) - -; ----- LISTS ----- ; Not extremely different from Sequences ; TODO clean this up - -(reg-pred! 'cdlist? {} - #_'{:clj #{clojure.data.finger_tree.CountedDoubleList - quantum.core.data.finger_tree.CountedDoubleList} - :cljs #{quantum.core.data.finger-tree/CountedDoubleList}}) -(reg-pred! 'dlist? {} - #_'{:clj #{clojure.data.finger_tree.CountedDoubleList - quantum.core.data.finger_tree.CountedDoubleList} - :cljs #{quantum.core.data.finger-tree/CountedDoubleList}}) -(reg-pred! '+list? {:clj '#{clojure.lang.IPersistentList} - :cljs (uset/union (:cljs (preds>types 'dlist? 'cdlist?)) - '#{cljs.core/List cljs.core/EmptyList})}) -(reg-pred! '!list? '{:clj #{java.util.LinkedList}}) -(reg-pred! 'list? {:clj '#{java.util.List} - :cljs (:cljs (preds>types '+list?))}) - -; ----- GENERIC ----- ; - -(reg-pred! 'seq? {:clj '#{clojure.lang.ISeq} - :cljs (:cljs (preds>types 'non-list-seq? 'list?))}) - ; ===== MAPS ===== ; Associative ; ----- Generators ----- ; @@ -377,7 +161,7 @@ >lang->type #_(t/spec t/fn? "Generates the `lang->type` corresponding to key and value map types") ref->ref #_::lang->type] (let [?prefix (when prefix (str prefix "-")) - base-types (conj (keys primitive-type-meta) 'ref) + base-types (conj (keys unboxed-symbol->type-meta) 'ref) type-combos (->> base-types (<- (combo/selections 2)) ;; No `boolean->*` maps exist in fastutil, for obvious reasons @@ -449,7 +233,7 @@ lang->type|ref #_::lang->type] (let [?prefix (when prefix (str prefix "-")) pred->lang->type|base - (->> (conj (keys primitive-type-meta) 'ref) + (->> (conj (keys unboxed-symbol->type-meta) 'ref) ;; No `boolean` sets exist in fastutil, for obvious reasons (remove (fn= 'boolean)) (map (fn [t] @@ -611,8 +395,7 @@ java.util.Set}) :cljs (:clj (preds>types '?!+set? '!set? '!!set?))}) -; ===== ARRAYS ===== ; Sequential, Associative (specifically, whose keys are sequential, - ; dense integer values), not extensible +; ===== ARRAYS ===== ; ; TODO do e.g. {:clj {0 {:byte ...}}} (def array-1d-types {:clj {:boolean (symbol "[Z") :byte (symbol "[B") @@ -657,213 +440,6 @@ (->> array-9d-types (map (fn [[k v]] [k (-> v vals set)])) (into {})) (->> array-10d-types (map (fn [[k v]] [k (-> v vals set)])) (into {})))) -; String: A special wrapper for char array where different encodings, etc. are possible - -;; Mutable String -(reg-pred! '!string? '{:clj #{StringBuilder} - :cljs #{goog.string.StringBuffer}}) -;; Immutable String -(reg-pred! 'string? '{:clj #{String} - :cljs #{js/String}}) - -(reg-pred! 'char-seq? '{:clj #{CharSequence}}) - -; ===== VECTORS ===== ; Sequential, Associative (specifically, whose keys are sequential, - ; dense integer values), extensible - -(reg-pred! '!array-list? '{:clj #{java.util.ArrayList - java.util.Arrays$ArrayList} ; indexed and associative, but not extensible - :cljs #_cljs.core.ArrayList ; not used - #{js/Array}}) ; because supports .push etc. -;; svec = "spliceable vector" -(reg-pred! 'svector? '{:clj #{clojure.core.rrb_vector.rrbt.Vector} - :cljs #{clojure.core.rrb_vector.rrbt.Vector}}) -(reg-pred! '+vector? {:clj '#{clojure.lang.IPersistentVector} - :cljs (uset/union (:cljs (preds>types 'svector?)) - '#{cljs.core/PersistentVector})}) -(reg-pred! '!+vector? '{:clj #{clojure.lang.ITransientVector} - :cljs #{cljs.core/TransientVector}}) -(reg-pred! '?!+vector? (preds>types '+vector? '!+vector?)) -(reg-pred! '!vector|long? '{:clj #{it.unimi.dsi.fastutil.longs.LongArrayList}}) -(reg-pred! '!vector|ref? '{:clj #{java.util.ArrayList} - :cljs #{js/Array}}) ; because supports .push etc. -(reg-pred! '!vector? (preds>types '!vector|long? '!vector|ref?)) - ;; java.util.Vector is deprecated, because you can - ;; just create a synchronized wrapper over an ArrayList - ;; via java.util.Collections -(reg-pred! '!!vector? {}) -(reg-pred! 'vector? (preds>types '?!+vector? '!vector? '!!vector?)) - -; ===== QUEUES ===== ; Particularly FIFO queues, as LIFO = stack = any vector - -(reg-pred! '+queue? '{:clj #{clojure.lang.PersistentQueue} - :cljs #{cljs.core/PersistentQueue}}) -(reg-pred! '!+queue? {}) -(reg-pred! '?!+queue? (preds>types '+queue? '!+queue?)) -(reg-pred! '!queue? '{:clj #{java.util.ArrayDeque} ; TODO *MANY* more here - :cljs #{goog.structs.Queue}}) -(reg-pred! '!!queue? {}) ; TODO *MANY* more here -(reg-pred! 'queue? {:clj (uset/union (:clj (preds>types '?!+queue?)) - '#{java.util.Queue}) - :cljs (:cljs (preds>types '?!+queue? '!queue? '!!queue?))}) - -; ===== GENERIC ===== ; - -; ----- PRIMITIVES ----- ; - -(reg-pred! 'primitive-unboxed? (preds>types 'unboxed-bool? 'unboxed-byte? 'unboxed-char? - 'unboxed-short? 'unboxed-int? 'unboxed-long? - 'unboxed-float? 'unboxed-double?)) - -(reg-pred! 'prim? (preds>types 'primitive-unboxed?)) - -(reg-pred! 'prim-comparable? (preds>types 'unboxed-byte? 'unboxed-char? - 'unboxed-short? 'unboxed-int? 'unboxed-long? - 'unboxed-float? 'unboxed-double?)) - -;; Possibly can't check for boxedness in Java because it does auto-(un)boxing, but it's nice to have -(reg-pred! 'primitive-boxed? (preds>types 'boxed-bool? 'boxed-byte? 'boxed-char? - 'boxed-short? 'boxed-int? 'boxed-long? - 'boxed-float? 'boxed-double?)) - -(reg-pred! 'primitive? (preds>types 'bool? 'byte? 'char? - 'short? 'int? 'long? - 'float? 'double? - #_{:cljs #{js/String}})) - -;; Standard "uncuttable" types -(reg-pred! 'integral? (preds>types 'bool? 'byte? 'char? 'number?)) - -; ----- COLLECTIONS ----- ; - - ;; TODO this might be ambiguous - ;; TODO clojure.lang.Indexed / cljs.core/IIndexed? -(reg-pred! 'indexed? (preds>types 'array? 'string? 'vector? - '{:clj #{clojure.lang.APersistentVector$RSeq}})) - ;; TODO this might be ambiguous - ;; TODO clojure.lang.Associative / cljs.core/IAssociative? -(reg-pred! 'associative? (preds>types 'map? 'set? 'indexed?)) - ;; TODO this might be ambiguous - ;; TODO clojure.lang.Sequential / cljs.core/ISequential? -(reg-pred! 'sequential? (preds>types 'seq? 'list? 'indexed?)) - ;; TODO this might be ambiguous - ;; TODO clojure.lang.ICollection / cljs.core/ICollection? -(reg-pred! 'counted? (preds>types 'array? 'string? - {:clj (uset/union (:clj (preds>types '!vector? '!!vector? - '!map? '!!map? - '!set? '!!set?)) - '#{clojure.lang.Counted}) - :cljs (:clj (preds>types 'vector? 'map? 'set?))})) - -(reg-pred! 'coll? (preds>types 'sequential? 'associative?)) - -(reg-pred! 'sorted? {:clj '#{clojure.lang.Sorted java.util.SortedMap java.util.SortedSet} - :cljs (:cljs (preds>types 'sorted-set? 'sorted-map?))}) ; TODO add in `cljs.core/ISorted - -(reg-pred! 'transient? '{:clj #{clojure.lang.ITransientCollection} - :cljs #{cljs.core/TransientVector - cljs.core/TransientHashSet - cljs.core/TransientArrayMap - cljs.core/TransientHashMap}}) - -;; Collections that have Transient counterparts -(reg-pred! 'transientizable? (preds>types #_core-tuple? - '{:clj #{clojure.lang.PersistentArrayMap - clojure.lang.PersistentHashMap - clojure.lang.PersistentHashSet - clojure.lang.PersistentVector} - :cljs #{cljs.core/PersistentArrayMap - cljs.core/PersistentHashMap - cljs.core/PersistentHashSet - cljs.core/PersistentVector}})) - -(reg-pred! 'editable? {:clj '#{clojure.lang.IEditableCollection} - :cljs #_#{cljs.core/IEditableCollection} ; can't dispatch on a protocol - (:cljs (preds>types 'transientizable?))}) - -; ===== FUNCTIONS ===== ; - -(reg-pred! 'fn? '{:clj #{clojure.lang.Fn} :cljs #{js/Function}}) -(reg-pred! 'ifn? '{:clj #{clojure.lang.IFn} :cljs #{js/Function}}) ; TODO keyword types? -(reg-pred! 'multimethod? '{:clj #{clojure.lang.MultiFn}}) - -; ===== MISCELLANEOUS ===== ; - -(reg-pred! 'regex? '{:clj #{java.util.regex.Pattern} - :cljs #{js/RegExp}}) - -(reg-pred! 'atom? '{:clj #{clojure.lang.IAtom} - :cljs #{cljs.core/Atom}}) -(reg-pred! 'volatile? '{:clj #{clojure.lang.Volatile} - :cljs #{cljs.core/Volatile}}) -(reg-pred! 'atomic? {:clj (uset/union (:clj (preds>types 'atom? 'volatile?)) - '#{java.util.concurrent.atomic.AtomicReference - ; From the java.util.concurrent package: - ; "Additionally, classes are provided only for those - ; types that are commonly useful in intended applications. - ; For example, there is no atomic class for representing - ; byte. In those infrequent cases where you would like - ; to do so, you can use an AtomicInteger to hold byte - ; values, and cast appropriately. You can also hold floats - ; using Float.floatToIntBits and Float.intBitstoFloat - ; conversions, and doubles using Double.doubleToLongBits - ; and Double.longBitsToDouble conversions. - java.util.concurrent.atomic.AtomicBoolean - #_java.util.concurrent.atomic.AtomicByte - #_java.util.concurrent.atomic.AtomicShort - java.util.concurrent.atomic.AtomicInteger - java.util.concurrent.atomic.AtomicLong - #_java.util.concurrent.atomic.AtomicFloat - #_java.util.concurrent.atomic.AtomicDouble - com.google.common.util.concurrent.AtomicDouble})}) - -(reg-pred! 'm2m-chan? '{:clj #{clojure.core.async.impl.channels.ManyToManyChannel} - :cljs #{cljs.core.async.impl.channels/ManyToManyChannel}}) - -(reg-pred! 'chan? '{:clj #{clojure.core.async.impl.protocols.Channel} - :cljs #{cljs.core.async.impl.channels/ManyToManyChannel - #_"TODO more?"}}) - -(reg-pred! 'keyword? '{:clj #{clojure.lang.Keyword} - :cljs #{cljs.core/Keyword}}) - -(reg-pred! 'symbol? '{:clj #{clojure.lang.Symbol} - :cljs #{cljs.core/Symbol}}) - -(reg-pred! 'file? '{:clj #{java.io.File} - :cljs #{#_js/File}}) ; isn't always available! Use an abstraction - -(reg-pred! 'any? {:clj (uset/union (:clj (preds>types 'prim?)) #{'java.lang.Object}) - :cljs '#{(quote default)}}) - -(reg-pred! 'comparable? {:clj (uset/union '#{byte char short int long float double} '#{Comparable}) - :cljs (:cljs (preds>types 'number?))}) - -(reg-pred! 'record? '{:clj #{clojure.lang.IRecord} - #_:cljs #_#{cljs.core/IRecord}}) ; because can't protocol-dispatch on protocols in CLJS - -(reg-pred! 'transformer? '{:clj #{#_clojure.core.protocols.CollReduce ; no, in order to find most specific type - quantum.untyped.core.reducers.Transformer} - :cljs #{#_cljs.core/IReduce ; CLJS problems with dispatching on protocol - quantum.untyped.core.reducers.Transformer}}) - -#_(reg-pred! 'reducible? (preds>types - 'array? - 'string? - 'record? - 'reducer? - 'chan? - {:cljs (:cljs (preds>types '+map?))} - {:cljs (:cljs (preds>types '+set?))} - 'integer? - {:clj '#{clojure.lang.IReduce - clojure.lang.IReduceInit - clojure.lang.IKVReduce - #_clojure.core.protocols.CollReduce} ; no, in order to find most specific type - #_:cljs #_'#{cljs.core/IReduce}} ; because can't protocol-dispatch on protocols in CLJS - {:clj '#{fast_zip.core.ZipperLocation} - :cljs '#{fast-zip.core/ZipperLocation}})) - (reg-pred! 'booleans? {:clj #{(-> array-1d-types :clj :boolean)}}) (reg-pred! 'boolean-array? (preds>types 'booleans?)) (reg-pred! 'bytes? {:clj #{(-> array-1d-types :clj :byte )} :cljs #{(-> array-1d-types :cljs :byte )}}) diff --git a/test/quantum/test/core/untyped/type.cljc b/test/quantum/test/core/untyped/type.cljc index 78fab200..3b1cff57 100644 --- a/test/quantum/test/core/untyped/type.cljc +++ b/test/quantum/test/core/untyped/type.cljc @@ -481,7 +481,7 @@ (testing "> nilabled: #{> <>}" (test-comparison 2 t/object? (t/? t/long?))) (testing ">< nilabled: #{>< <>}" - (test-comparison 2 t/iterable? (t/? t/comparable?))) + (test-comparison 2 t/java-iterable? (t/? t/comparable?))) (testing "<> nilabled: #{<>}" (test-comparison 3 t/long? (t/? t/string?))))) (testing "+ ValueSpec" @@ -517,7 +517,7 @@ (testing "Final Concrete" (test-comparison -1 t/string? (& t/char-seq? t/comparable?))) (testing "Extensible Concrete" - (test-comparison -1 t/array-list? (& t/iterable? (t/isa? java.util.RandomAccess)))) + (test-comparison -1 t/array-list? (& t/java-iterable? (t/isa? java.util.RandomAccess)))) (testing "Abstract" (test-comparison -1 (t/isa? java.util.AbstractMap$SimpleEntry) (& (t/isa? java.util.Map$Entry) (t/isa? java.io.Serializable)))) (testing "Interface" @@ -698,7 +698,7 @@ (test-comparison 2 (t/isa? java.util.AbstractCollection) t/comparable?))) (testing "Interface + Interface" (testing "< , >" - (test-comparison -1 t/java-coll? t/iterable?)) + (test-comparison -1 t/java-coll? t/java-iterable?)) (testing "><" (test-comparison 2 t/char-seq? t/comparable?)))) (testing "+ ValueSpec" From ebf19cdaae27cb8f3e83d763abd1263c486a81be Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 20 Mar 2018 20:10:12 -0600 Subject: [PATCH 011/810] `pairwise-seq-(or|and)` --- src/quantum/core/collections/logic.cljc | 15 ++++----------- src/quantum/core/reducers.cljc | 16 ++++++++++++---- 2 files changed, 16 insertions(+), 15 deletions(-) diff --git a/src/quantum/core/collections/logic.cljc b/src/quantum/core/collections/logic.cljc index 8129957b..d6be5a51 100644 --- a/src/quantum/core/collections/logic.cljc +++ b/src/quantum/core/collections/logic.cljc @@ -7,16 +7,13 @@ [quantum.core.fn :as fn :refer [rcomp]] [quantum.core.vars :as var - :refer [defalias]])) + :refer [defalias]] + [quantum.untyped.core.collections.logic :as u])) (defn seq-or "∃: A faster version of |some| using |reduce| instead of |seq|." ([xs] (seq-or identity xs)) - ([pred xs] - (transduce (fn ([] true) ; vacuously - ([ret] ret) - ([_ x] (and (pred x ) (reduced x))) - ([_ k v] (and (pred k v) (reduced [k v])))) xs))) + ([pred xs] (transduce (u/seq-or|rf pred) xs))) (defalias some seq-or) @@ -27,11 +24,7 @@ (defn seq-and "∀: A faster version of |every?| using |reduce| instead of |seq|." ([xs] (seq-and identity xs)) - ([pred xs] - (transduce (fn ([] true) ; vacuously - ([ret] ret) - ([_ x] (or (pred x ) (reduced false))) - ([_ k v] (or (pred k v) (reduced [k v])))) xs))) + ([pred xs] (transduce (u/seq-and|rf pred) xs))) (defalias every? seq-and) diff --git a/src/quantum/core/reducers.cljc b/src/quantum/core/reducers.cljc index 7619a7ca..647351aa 100644 --- a/src/quantum/core/reducers.cljc +++ b/src/quantum/core/reducers.cljc @@ -46,6 +46,7 @@ [quantum.core.reducers.fold :as fold] [quantum.core.vars :as var :refer [defalias def-]] + [quantum.untyped.core.collections.logic :as ucoll&] [quantum.untyped.core.qualify :as qual] [quantum.untyped.core.reducers :as ur] [quantum.untyped.core.form.generate @@ -139,8 +140,7 @@ (let [ret (reduce (fn ([ret] ret) - ([ret x] - (if (identical? ret sentinel) (f x) (f ret x)))) + ([ret x] (if (identical? ret sentinel) (f x) (f ret x)))) sentinel xs)] (if (identical? ret sentinel) (f) ret))) @@ -151,12 +151,20 @@ (let [ret (red/reducei (fn ([ret] ret) - ([ret x i] - (if (identical? ret sentinel) (f x) (f ret x i)))) + ([ret x i] (if (identical? ret sentinel) (f x) (f ret x i)))) sentinel xs)] (if (identical? ret sentinel) (f) ret))) +(defn pairwise-seq-or + ([pred] (fn [xs] (pairwise-seq-or pred xs))) + ([pred xs] (red-apply (ucoll&/seq-or|rf pred)))) + +;; Useful for e.g. comparison operators like `<=` +(defn pairwise-seq-and + ([pred] (fn [xs] (pairwise-seq-and pred xs))) + ([pred xs] (red-apply (ucoll&/seq-and|rf pred)))) + (defn reduce-sentinel "Calls `reduce` with a sentinel. Useful for e.g. `max` and `min`." From 2cfdab5d3d7e7b5d6763c37200e138e8cae486f5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 17 Apr 2018 09:33:33 -0600 Subject: [PATCH 012/810] Supersede org.flatland/ordered with frankiesardo/linked --- project-base.clj | 4 +++- src-untyped/quantum/untyped/core/data/map.cljc | 12 ++++++------ src-untyped/quantum/untyped/core/data/set.cljc | 8 ++++---- src/quantum/core/data/set.cljc | 6 +++--- 4 files changed, 16 insertions(+), 14 deletions(-) diff --git a/project-base.clj b/project-base.clj index 66c3fa51..f0db9120 100644 --- a/project-base.clj +++ b/project-base.clj @@ -97,7 +97,9 @@ [quantum/org.clojure.core.rrb-vector "0.0.12"] [org.clojure/data.finger-tree "0.0.2"] ; MAP / SET - [org.flatland/ordered "1.5.3"] + ;; Superseded by `frankiesardo/linked` + #_[org.flatland/ordered "1.5.3"] + [frankiesardo/linked "1.2.9"] [org.clojure/data.avl "0.0.13"] [org.clojure/data.int-map "0.2.4"] ; ==== COMPLEX ==== diff --git a/src-untyped/quantum/untyped/core/data/map.cljc b/src-untyped/quantum/untyped/core/data/map.cljc index b862989a..5f434eef 100644 --- a/src-untyped/quantum/untyped/core/data/map.cljc +++ b/src-untyped/quantum/untyped/core/data/map.cljc @@ -7,9 +7,9 @@ (:require [clojure.core :as core] [clojure.data.avl :as avl ] + [linked.core :as linked] #?@(:clj [[clojure.data.int-map :as imap] - [flatland.ordered.map :as omap] [seqspert.hash-map]]) [quantum.untyped.core.convert :as uconv] [quantum.untyped.core.data :as udata] @@ -33,13 +33,13 @@ ;; - Alex Miller: "We have seen it and will probably investigate some of these ideas after 1.8." ;; ======================= -#?(:clj (def int-map imap/int-map )) +#?(:clj (def int-map imap/int-map)) #?(:clj (defalias hash-map|long->ref int-map)) -(defalias array-map core/array-map) -(defalias hash-map core/hash-map ) + (defalias array-map core/array-map) + (defalias hash-map core/hash-map) -(defalias ordered-map #?(:clj omap/ordered-map :cljs array-map)) -(defalias om ordered-map) + (defalias ordered-map linked/map) + (defalias om ordered-map) #?(:clj (defn ^java.util.LinkedHashMap !ordered-map [] (java.util.LinkedHashMap.))) diff --git a/src-untyped/quantum/untyped/core/data/set.cljc b/src-untyped/quantum/untyped/core/data/set.cljc index 2759f9b2..33a808c2 100644 --- a/src-untyped/quantum/untyped/core/data/set.cljc +++ b/src-untyped/quantum/untyped/core/data/set.cljc @@ -2,18 +2,18 @@ (:refer-clojure :exclude [not]) (:require #?@(:clj - [[flatland.ordered.set :as oset] - [seqspert.hash-set]]) + [[seqspert.hash-set]]) [clojure.core :as core] [clojure.set :as set] + [linked.core :as linked] [quantum.untyped.core.core :as ucore])) (ucore/log-this-ns) #?(:clj (def hash-set? (partial instance? clojure.lang.PersistentHashSet))) -#?(:clj (def ordered-set oset/ordered-set)) ; insertion-ordered set -#?(:clj (def oset ordered-set)) +(def ordered-set linked/set) ; insertion-ordered set +(def oset ordered-set) (def not complement) diff --git a/src/quantum/core/data/set.cljc b/src/quantum/core/data/set.cljc index 782c9acb..9f17957a 100644 --- a/src/quantum/core/data/set.cljc +++ b/src/quantum/core/data/set.cljc @@ -9,6 +9,7 @@ [clojure.core :as core] [clojure.set :as set] [clojure.data.avl :as avl] + [linked.core :as linked] [quantum.core.vars :as var :refer [defalias]] [quantum.core.error :as err @@ -17,7 +18,6 @@ [quantum.untyped.core.data.set :as uset] #?@(:clj [[clojure.data.finger-tree :as ftree] - [flatland.ordered.set :as oset] [seqspert.hash-set] [clojure.data.int-map :as imap]])) (:import @@ -31,8 +31,8 @@ ; ============ STRUCTURES ============ -#?(:clj (defalias ordered-set oset/ordered-set)) ; insertion-ordered set -#?(:clj (defalias oset ordered-set)) + (defalias ordered-set linked/set) ; insertion-ordered set + (defalias oset ordered-set) #?(:clj (defalias c-sorted-set ftree/counted-sorted-set)) ; sorted set that provides log-n nth (defalias sorted-rank-set avl/sorted-set ) (defalias sorted-rank-set-by avl/sorted-set-by) From 387d8f04d6db4df997d09837f801387e57c39489 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 17 Apr 2018 09:33:39 -0600 Subject: [PATCH 013/810] The great migration from type defs is nearly complete --- src-untyped/quantum/untyped/core/type.cljc | 1309 +++++++++++++---- .../quantum/untyped/core/type/core.cljc | 66 +- .../quantum/untyped/core/type/defs.cljc | 515 +------ 3 files changed, 1140 insertions(+), 750 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 1efd379b..0a970757 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -10,11 +10,12 @@ nil? any? class? tagged-literal? #?(:cljs object?) number? decimal? bigdec? integer? ratio? true? false? keyword? string? symbol? - list? map? map-entry? seq? seqable? sorted? vector? + associative? coll? indexed? list? map? map-entry? record? seq? seqable? set? sorted? vector? fn? ifn? - meta ref]) + meta ref volatile?]) (:require [clojure.core :as c] + [clojure.string :as str] [quantum.untyped.core.analyze.expr :as xp :refer [>expr #?(:cljs Expression)]] [quantum.untyped.core.classes :as uclass] @@ -43,9 +44,10 @@ :refer [?deref]] [quantum.untyped.core.data.tuple] [quantum.untyped.core.type.core :as utcore] + [quantum.untyped.core.type.defs :as utdef] [quantum.untyped.core.type.predicates :as utpred] [quantum.untyped.core.vars :as uvar - :refer [def- update-meta]]) + :refer [def- defmacro- update-meta]]) #?(:clj (:import quantum.untyped.core.analyze.expr.Expression quantum.untyped.core.data.tuple.Tuple)) #?(:cljs @@ -225,7 +227,7 @@ #?(:clj (uvar/defalias -def define)) -(-def spec? (isa?|protocol PSpec)) +(-def spec? (isa? PSpec)) (defn * "Denote on a spec that it must be enforced at runtime. @@ -286,9 +288,7 @@ (== (utcore/boxed->unboxed c0) c1) 1 (== c0 (utcore/boxed->unboxed c1)) -1 ;; we'll consider the two unrelated - ;; TODO this uses reflection so each class comparison is slowish - (c/or (utcore/primitive-array-type? c0) - (utcore/primitive-array-type? c1)) 3 + (c/not (utcore/array-depth-equal? c0 c1)) 3 (.isAssignableFrom c0 c1) 1 (.isAssignableFrom c1 c0) -1 ;; multiple inheritance of interfaces @@ -607,7 +607,7 @@ 1 (first args) (OrSpec. args (atom nil)))))))))) -(udt/deftype SequentialSpec) +#_(udt/deftype SequentialSpec) (defn of "Creates a spec that. @@ -1060,79 +1060,7 @@ Float 'float Double 'double})) -(def ^{:doc "Could do /MAX_VALUE for the maxes in Java but JS doesn't like it of course - In JavaScript, all numbers are 64-bit floating point numbers. - This means you can't represent in JavaScript all the Java longs - Max 'safe' int: (dec (Math/pow 2 53))"} - unboxed-symbol->type-meta - {'boolean {:bits 1 - :min 0 - :max 1 - #?@(:clj [:array-ident "Z" - :outer-type "[Z" - :boxed java.lang.Boolean - :unboxed Boolean/TYPE])} - 'byte {:bits 8 - :min -128 - :max 127 - #?@(:clj [:array-ident "B" - :outer-type "[B" - :boxed java.lang.Byte - :unboxed Byte/TYPE])} - 'short {:bits 16 - :min -32768 - :max 32767 - #?@(:clj [:array-ident "S" - :outer-type "[S" - :boxed java.lang.Short - :unboxed Short/TYPE])} - 'char {:bits 16 - :min 0 - :max 65535 - #?@(:clj [:array-ident "C" - :outer-type "[C" - :boxed java.lang.Character - :unboxed Character/TYPE])} - 'int {:bits 32 - :min -2147483648 - :max 2147483647 - #?@(:clj [:array-ident "I" - :outer-type "[I" - :boxed java.lang.Integer - :unboxed Integer/TYPE])} - 'long {:bits 64 - :min -9223372036854775808 - :max 9223372036854775807 - #?@(:clj [:array-ident "J" - :outer-type "[J" - :boxed java.lang.Long - :unboxed Long/TYPE])} - ; Technically with floating-point nums, "min" isn't the most negative; - ; it's the smallest absolute - 'float {:bits 32 - :min-absolute 1.4E-45 - :min -3.4028235E38 - :max 3.4028235E38 - :min-int -16777216 ; -2^24 - :max-int 16777216 ; 2^24 - #?@(:clj [:array-ident "F" - :outer-type "[F" - :boxed java.lang.Float - :unboxed Float/TYPE])} - 'double {:bits 64 - ; Because: - ; Double/MIN_VALUE = 4.9E-324 - ; (.-MIN_VALUE js/Number) = 5e-324 - :min-absolute #?(:clj Double/MIN_VALUE - :cljs (.-MIN_VALUE js/Number)) - :min -1.7976931348623157E308 - :max 1.7976931348623157E308 ; Max number in JS - :min-int -9007199254740992 ; -2^53 - :max-int 9007199254740992 ; 2^53 - #?@(:clj [:array-ident "D" - :outer-type "[D" - :boxed java.lang.Double - :unboxed Double/TYPE])}}) +(uvar/defalias utdef/unboxed-symbol->type-meta) #?(:clj (def primitive-classes (->> unboxed-symbol->type-meta vals (uc/map+ :unboxed) (join #{})))) @@ -1178,57 +1106,34 @@ (spec>?class-value (isa? String)) nil}} [spec] (-spec>?class-value spec false))) -;; ===== META ===== ;; - -#?(:clj (-def class? (isa? java.lang.Class))) -#?(:clj (-def primitive-class? (or (value Boolean/TYPE) - (value Byte/TYPE) - (value Character/TYPE) - (value Short/TYPE) - (value Integer/TYPE) - (value Long/TYPE) - (value Float/TYPE) - (value Double/TYPE)))) -#?(:clj (-def protocol? (>expr (ufn/fn-> :on-interface class?)))) - - - - - -#?(:clj (-def comparable? (isa? java.lang.Comparable))) - (-def keyword? (isa? #?(:clj clojure.lang.Keyword :cljs cljs.core/Keyword))) - (-def symbol? (isa? #?(:clj clojure.lang.Symbol :cljs cljs.core/Symbol))) -#?(:clj (-def tagged-literal? (isa? clojure.lang.TaggedLiteral))) - - (-def literal? (or nil? boolean? symbol? keyword? string? #?(:clj long?) double? #?(:clj tagged-literal?))) - - (-def +map|built-in? (or (isa? #?(:clj clojure.lang.PersistentHashMap :cljs cljs.core/PersistentHashMap)) - (isa? #?(:clj clojure.lang.PersistentArrayMap :cljs cljs.core/PersistentArrayMap)) - (isa? #?(:clj clojure.lang.PersistentTreeMap :cljs cljs.core/PersistentTreeMap)))) - - (-def +map? #?(:clj (isa? clojure.lang.IPersistentMap) - :cljs (isa?|protocol cljs.core/IMap))) +;; ---------------------- ;; +;; ===== Predicates ===== ;; +;; ---------------------- ;; - (-def map? #?(:clj (isa? java.util.Map) - :cljs (TODO))) + (def basic-type-syms '[boolean byte char short int long float double ref]) - (-def +set? #?(:clj (isa? clojure.lang.IPersistentSet) - :cljs (isa?|protocol cljs.core/ISet))) +#?(:clj (defn- >v-sym [prefix #_symbol? kind #_symbol?] (symbol (str prefix "|" kind "?")))) - (-def +set|built-in? (or (isa? #?(:clj clojure.lang.PersistentHashSet :cljs cljs.core/PersistentHashSet)) - (isa? #?(:clj clojure.lang.PersistentTreeSet :cljs cljs.core/PersistentTreeSet)))) +#?(:clj (defn- >kv-sym [prefix #_symbol? from-type #_symbol? to-type #_symbol?] + (symbol (str prefix "|" from-type "->" to-type "?")))) -#?(:clj (-def array-list? (isa? java.util.ArrayList))) -#?(:clj (-def java-coll? (isa? java.util.Collection))) -#?(:clj (-def java-set? (isa? java.util.Set))) -#?(:clj (-def thread? (isa? java.lang.Thread))) - (-def throwable? #?(:clj (isa? java.lang.Throwable) :cljs any?)) -#?(:clj (-def comparable? (isa? java.lang.Comparable))) -#?(:clj (-def java-iterable? (isa? java.lang.Iterable))) +#?(:clj (defmacro- def-preds|map|same-types [prefix #_symbol?] + `(do ~@(for [kind (conj basic-type-syms 'any)] + (list `-def (>v-sym prefix kind) (>kv-sym prefix kind kind)))))) -;; ---------------------- ;; -;; ===== Predicates ===== ;; -;; ---------------------- ;; +#?(:clj (defmacro- def-preds|map|any [prefix #_symbol?] + (let [anys (->> (for [kind basic-type-syms] + [(list `-def (>kv-sym prefix kind 'any) + (->> basic-type-syms (map #(>kv-sym prefix kind %)) (list* `or))) + (list `-def (>kv-sym prefix 'any kind) + (->> basic-type-syms (map #(>kv-sym prefix % kind)) (list* `or)))]) + (apply concat)) + any->any (list `-def (>kv-sym prefix 'any 'any) + (->> basic-type-syms + (map #(vector (>kv-sym prefix 'any %) (>kv-sym prefix % 'any))) + (apply concat) + (list* `or)))] + `(do ~@(concat anys [any->any]))))) ;; ===== General ===== ;; @@ -1242,36 +1147,54 @@ (-def val|by-class? (or object? #?@(:cljs [(isa? js/String) (isa? js/Symbol)]))) (-def val? (not nil?)) +;; ===== Meta ===== ;; + +#?(:clj (-def class? (isa? java.lang.Class))) +#?(:clj (-def primitive-class? (or (value Boolean/TYPE) + (value Byte/TYPE) + (value Character/TYPE) + (value Short/TYPE) + (value Integer/TYPE) + (value Long/TYPE) + (value Float/TYPE) + (value Double/TYPE)))) +#?(:clj (-def protocol? (>expr (ufn/fn-> :on-interface class?)))) + ;; ===== Primitives ===== ;; - (-def boolean? (isa? #?(:clj Boolean :cljs js/Boolean))) + (-def boolean? (isa? #?(:clj Boolean :cljs js/Boolean))) (-def ?boolean? (? boolean?)) -#?(:clj (-def byte? (isa? Byte))) +#?(:clj (-def byte? (isa? Byte))) #?(:clj (-def ?byte? (? byte?))) -#?(:clj (-def char? (isa? Character))) +#?(:clj (-def char? (isa? Character))) #?(:clj (-def ?char? (? char?))) -#?(:clj (-def short? (isa? Short))) +#?(:clj (-def short? (isa? Short))) #?(:clj (-def ?short? (? short?))) -#?(:clj (-def int? (isa? Integer))) +#?(:clj (-def int? (isa? Integer))) #?(:clj (-def ?int? (? int?))) -#?(:clj (-def long? (isa? Long))) +#?(:clj (-def long? (isa? Long))) #?(:clj (-def ?long? (? long?))) -#?(:clj (-def float? (isa? Float))) +#?(:clj (-def float? (isa? Float))) #?(:clj (-def ?float? (? float?))) - (-def double? (isa? #?(:clj Double :cljs js/Number))) + (-def double? (isa? #?(:clj Double :cljs js/Number))) (-def ?double? (? double?)) (-def primitive? (or boolean? #?@(:clj [byte? char? short? int? long? float?]) double?)) #_(:clj (-def comparable-primitive? (and primitive? (not boolean?)))) +;; ===== Booleans ===== ;; + + (-def true? (value true)) + (-def false? (value false)) + ;; ===== Numbers ===== ;; ;; ----- Integers ----- ;; @@ -1292,7 +1215,7 @@ (-def ratio? (isa? #?(:clj clojure.lang.Ratio :cljs quantum.core.numeric.types.Ratio))) ; TODO add this CLJS entry to the predicate after the fact - (-def primitive-number? (or #?@(:clj [short? int? long? float?]) double?))) + (-def primitive-number? (or #?@(:clj [short? int? long? float?]) double?)) (-def number? (or #?@(:clj [(isa? java.lang.Number)] :cljs [integer? decimal? ratio?]))) @@ -1367,13 +1290,97 @@ ;; ----- Generic ----- ;; - (-def seq? #?(:clj clojure.lang.ISeq :cljs cljs.core/ISeq)) - -;; TODO add maps in here - ;; ===== Arrays ===== ;; Sequential, Associative (specifically, whose keys are sequential, ;; dense integer values), not extensible +#?(:clj +(defn >array-nd-type [kind n] + (let [prefix (apply str (repeat n \[)) + letter (case kind + boolean "Z" + byte "B" + char "C" + short "S" + int "I" + long "J" + float "F" + double "D" + object "Ljava.lang.Object;")] + (isa? (Class/forName (str prefix letter)))))) + +#?(:clj +(defn >array-nd-types [n] + (->> '[boolean byte char short int long float double object] + (map #(>array-nd-type % n)) + (apply or))) + + (-def booleans? #?(:clj (>array-nd-type 'boolean 1) :cljs none?)) + (-def bytes? #?(:clj (>array-nd-type 'byte 1) :cljs (isa? js/Int8Array))) + (-def ubytes? #?(:clj none? :cljs (isa? js/Uint8Array))) + (-def ubytes-clamped? #?(:clj none? :cljs (isa? js/Uint8ClampedArray))) + (-def chars? #?(:clj (>array-nd-type 'char 1) :cljs (isa? js/Uint16Array))) ; kind of + (-def shorts? #?(:clj (>array-nd-type 'short 1) :cljs (isa? js/Int16Array))) + (-def ushorts? #?(:clj none? :cljs (isa? js/Uint16Array))) + (-def ints? #?(:clj (>array-nd-type 'int 1) :cljs (isa? js/Int32Array))) + (-def uints? #?(:clj none? :cljs (isa? js/Uint32Array))) + (-def longs? #?(:clj (>array-nd-type 'long 1) :cljs none?)) + (-def floats? #?(:clj (>array-nd-type 'float 1) :cljs (isa? js/Float32Array))) + (-def doubles? #?(:clj (>array-nd-type 'double 1) :cljs (isa? js/Float64Array))) + (-def objects? #?(:clj (>array-nd-type 'object 1) :cljs (isa? js/Array))) + + (-def numeric-1d? (or bytes? ubytes? ubytes-clamped? + chars? + shorts? ushorts? ints? uints? longs? + floats? doubles?)) + + (-def array-1d? (or booleans? bytes? ubytes? ubytes-clamped? + chars? + shorts? ushorts? ints? uints? longs? + floats? doubles? objects?)) + +#?(:clj (-def booleans-2d? (>array-nd-type 'boolean 2))) +#?(:clj (-def bytes-2d? (>array-nd-type 'byte 2))) +#?(:clj (-def chars-2d? (>array-nd-type 'char 2))) +#?(:clj (-def shorts-2d? (>array-nd-type 'short 2))) +#?(:clj (-def ints-2d? (>array-nd-type 'int 2))) +#?(:clj (-def longs-2d? (>array-nd-type 'long 2))) +#?(:clj (-def floats-2d? (>array-nd-type 'float 2))) +#?(:clj (-def doubles-2d? (>array-nd-type 'double 2))) +#?(:clj (-def objects-2d? (>array-nd-type 'object 2))) + +#?(:clj (-def numeric-2d? (or bytes-2d? + chars-2d? + shorts-2d? ints-2d? longs-2d? + floats-2d? doubles-2d?))) + +#?(:clj (-def array-2d? (>array-nd-types 2 ))) + +#?(:clj (-def array-3d? (>array-nd-types 3 ))) +#?(:clj (-def array-4d? (>array-nd-types 4 ))) +#?(:clj (-def array-5d? (>array-nd-types 5 ))) +#?(:clj (-def array-6d? (>array-nd-types 6 ))) +#?(:clj (-def array-7d? (>array-nd-types 7 ))) +#?(:clj (-def array-8d? (>array-nd-types 8 ))) +#?(:clj (-def array-9d? (>array-nd-types 9 ))) +#?(:clj (-def array-10d? (>array-nd-types 10))) + + ;; TODO differentiate between "all supported n-D arrays" and "all n-D arrays" + (-def objects-nd? (or objects? + #?@(:clj [(>array-nd-type 'object 2) + (>array-nd-type 'object 3) + (>array-nd-type 'object 4) + (>array-nd-type 'object 5) + (>array-nd-type 'object 6) + (>array-nd-type 'object 7) + (>array-nd-type 'object 8) + (>array-nd-type 'object 9) + (>array-nd-type 'object 10)]))) + + ;; TODO differentiate between "all supported n-D arrays" and "all n-D arrays" + (-def array? (or array-1d? + #?@(:clj [array-2d? array-3d? array-4d? array-5d? + array-6d? array-7d? array-8d? array-9d? array-10d?]))) + ;; ----- String ----- ;; A special wrapper for char array where different encodings, etc. are possible ;; Mutable String @@ -1394,28 +1401,30 @@ ;; because supports .push etc. (isa? js/Array)))) ;; svec = "spliceable vector" - (-def svector? (isa? clojure.core.rrb_vector.rrbt.Vector)) + (-def svector? (isa? clojure.core.rrb_vector.rrbt.Vector)) + + (-def +vector? (isa? #?(:clj clojure.lang.IPersistentVector + :cljs cljs.core/IVector))) - (-def +vector? #?(:clj (isa? clojure.lang.IPersistentVector) - :cljs (isa?|protocol cljs.core/IVector))) + (-def +vector|built-in? (isa? #?(:clj clojure.lang.PersistentVector + :cljs cljs.core/PersistentVector))) - (-def +vector|built-in? (isa? #?(:clj clojure.lang.PersistentVector - :cljs cljs.core/PersistentVector))) + (-def !+vector? (isa? #?(:clj clojure.lang.ITransientVector + :cljs cljs.core/ITransientVector))) + (-def ?!+vector? (or +vector? ?!+vector?)) - (-def !+vector? #?(:clj (isa? clojure.lang.ITransientVector) - :cljs (isa?|protocol cljs.core/ITransientVector))) - (-def ?!+vector? (or +vector? ?!+vector?)) -#?(:clj (-def !vector|long? (isa? it.unimi.dsi.fastutil.longs.LongArrayList))) - (-def !vector|ref? (isa? #?(:clj java.util.ArrayList - ;; because supports .push etc. - :cljs js/Array))) - (-def !vector? (or !vector|long? !vector|ref?)) + ;; TODO complete this +#?(:clj (-def !vector|long? (isa? it.unimi.dsi.fastutil.longs.LongArrayList))) + (-def !vector|ref? (isa? #?(:clj java.util.ArrayList + ;; because supports .push etc. + :cljs js/Array))) + (-def !vector? (or !vector|long? !vector|ref?)) - ;; java.util.Vector is deprecated, because you can - ;; just create a synchronized wrapper over an ArrayList - ;; via java.util.Collections -#?(:clj (-def !!vector? none?)) - (-def vector? (or ?!+vector? !vector? #?(:clj !!vector?))) + ;; java.util.Vector is deprecated, because you can + ;; just create a synchronized wrapper over an ArrayList + ;; via java.util.Collections +#?(:clj (-def !!vector? none?)) + (-def vector? (or ?!+vector? !vector? #?(:clj !!vector?))) ;; ===== Queues ===== ;; Particularly FIFO queues, as LIFO = stack = any vector @@ -1426,29 +1435,720 @@ #?(:clj (-def !!queue? (or (isa? java.util.concurrent.BlockingQueue) (isa? java.util.concurrent.TransferQueue) (isa? java.util.concurrent.ConcurrentLinkedQueue)))) + (-def !queue? #?(:clj ;; Considered single-threaded mutable unless otherwise noted (- (isa? java.util.Queue) (or ?!+queue? !!queue?)) :cljs (isa? goog.structs.Queue))) - (-def queue? (or ?!+queue? !queue? #?(:clj !!queue?))) -;; ===== Generic ===== ;; - - ;; Standard "uncuttable" types - (-def integral? (or primitive? number?)) - -;; ----- Collections ----- ;; - - (-def sorted? #?(:clj (or (isa? clojure.lang.Sorted) - (isa? java.util.SortedMap) - (isa? java.util.SortedSet)) - :cljs (or (isa? cljs.core/ISorted) - (isa? goog.structs.AvlTree)))) - - (-def transient? (isa? #?(:clj clojure.lang.ITransientCollection - :cljs cljs.core/ITransientCollection))) + (-def queue? (or ?!+queue? !queue? #?(:clj !!queue?))) - (-def editable? (isa? #?(:clj clojure.lang.IEditableCollection - :cljs cljs.core/IEditableCollection))) +;; ===== Maps ===== ;; Associative + +;; ----- Hash Maps ----- ;; + + (-def +hash-map? (isa? #?(:clj clojure.lang.PersistentHashMap + :cljs cljs.core/PersistentHashMap))) + + (-def !+hash-map? (isa? #?(:clj clojure.lang.PersistentHashMap$TransientHashMap + :cljs cljs.core/TransientHashMap))) + + (-def ?!+hash-map? (or !+hash-map? +hash-map?)) + + (-def !hash-map|boolean->boolean? none?) + (-def !hash-map|boolean->byte? none?) + (-def !hash-map|boolean->char? none?) + (-def !hash-map|boolean->short? none?) + (-def !hash-map|boolean->int? none?) + (-def !hash-map|boolean->long? none?) + (-def !hash-map|boolean->float? none?) + (-def !hash-map|boolean->double? none?) + (-def !hash-map|boolean->ref? none?) + + (-def !hash-map|byte->boolean? #?(:clj (or (isa? it.unimi.dsi.fastutil.bytes.Byte2BooleanOpenHashMap) (isa? it.unimi.dsi.fastutil.bytes.Byte2BooleanOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|byte->byte? #?(:clj (or (isa? it.unimi.dsi.fastutil.bytes.Byte2ByteOpenHashMap) (isa? it.unimi.dsi.fastutil.bytes.Byte2ByteOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|byte->char? #?(:clj (or (isa? it.unimi.dsi.fastutil.bytes.Byte2CharOpenHashMap) (isa? it.unimi.dsi.fastutil.bytes.Byte2CharOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|byte->short? #?(:clj (or (isa? it.unimi.dsi.fastutil.bytes.Byte2ShortOpenHashMap) (isa? it.unimi.dsi.fastutil.bytes.Byte2ShortOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|byte->int? #?(:clj (or (isa? it.unimi.dsi.fastutil.bytes.Byte2IntOpenHashMap) (isa? it.unimi.dsi.fastutil.bytes.Byte2IntOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|byte->long? #?(:clj (or (isa? it.unimi.dsi.fastutil.bytes.Byte2LongOpenHashMap) (isa? it.unimi.dsi.fastutil.bytes.Byte2LongOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|byte->float? #?(:clj (or (isa? it.unimi.dsi.fastutil.bytes.Byte2FloatOpenHashMap) (isa? it.unimi.dsi.fastutil.bytes.Byte2FloatOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|byte->double? #?(:clj (or (isa? it.unimi.dsi.fastutil.bytes.Byte2DoubleOpenHashMap) (isa? it.unimi.dsi.fastutil.bytes.Byte2DoubleOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|byte->ref? #?(:clj (or (isa? it.unimi.dsi.fastutil.bytes.Byte2ReferenceOpenHashMap) (isa? it.unimi.dsi.fastutil.bytes.Byte2ReferenceOpenCustomHashMap)) :cljs none?)) + + (-def !hash-map|char->ref? #?(:clj (or (isa? it.unimi.dsi.fastutil.chars.Char2ReferenceOpenHashMap) (isa? it.unimi.dsi.fastutil.chars.Char2ReferenceOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|char->boolean? #?(:clj (or (isa? it.unimi.dsi.fastutil.chars.Char2BooleanOpenHashMap) (isa? it.unimi.dsi.fastutil.chars.Char2BooleanOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|char->byte? #?(:clj (or (isa? it.unimi.dsi.fastutil.chars.Char2ByteOpenHashMap) (isa? it.unimi.dsi.fastutil.chars.Char2ByteOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|char->char? #?(:clj (or (isa? it.unimi.dsi.fastutil.chars.Char2CharOpenHashMap) (isa? it.unimi.dsi.fastutil.chars.Char2CharOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|char->short? #?(:clj (or (isa? it.unimi.dsi.fastutil.chars.Char2ShortOpenHashMap) (isa? it.unimi.dsi.fastutil.chars.Char2ShortOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|char->int? #?(:clj (or (isa? it.unimi.dsi.fastutil.chars.Char2IntOpenHashMap) (isa? it.unimi.dsi.fastutil.chars.Char2IntOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|char->long? #?(:clj (or (isa? it.unimi.dsi.fastutil.chars.Char2LongOpenHashMap) (isa? it.unimi.dsi.fastutil.chars.Char2LongOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|char->float? #?(:clj (or (isa? it.unimi.dsi.fastutil.chars.Char2FloatOpenHashMap) (isa? it.unimi.dsi.fastutil.chars.Char2FloatOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|char->double? #?(:clj (or (isa? it.unimi.dsi.fastutil.chars.Char2DoubleOpenHashMap) (isa? it.unimi.dsi.fastutil.chars.Char2DoubleOpenCustomHashMap)) :cljs none?)) + + (-def !hash-map|short->boolean? #?(:clj (or (isa? it.unimi.dsi.fastutil.shorts.Short2BooleanOpenHashMap) (isa? it.unimi.dsi.fastutil.shorts.Short2BooleanOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|short->byte? #?(:clj (or (isa? it.unimi.dsi.fastutil.shorts.Short2ByteOpenHashMap) (isa? it.unimi.dsi.fastutil.shorts.Short2ByteOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|short->char? #?(:clj (or (isa? it.unimi.dsi.fastutil.shorts.Short2CharOpenHashMap) (isa? it.unimi.dsi.fastutil.shorts.Short2CharOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|short->short? #?(:clj (or (isa? it.unimi.dsi.fastutil.shorts.Short2ShortOpenHashMap) (isa? it.unimi.dsi.fastutil.shorts.Short2ShortOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|short->int? #?(:clj (or (isa? it.unimi.dsi.fastutil.shorts.Short2IntOpenHashMap) (isa? it.unimi.dsi.fastutil.shorts.Short2IntOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|short->long? #?(:clj (or (isa? it.unimi.dsi.fastutil.shorts.Short2LongOpenHashMap) (isa? it.unimi.dsi.fastutil.shorts.Short2LongOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|short->float? #?(:clj (or (isa? it.unimi.dsi.fastutil.shorts.Short2FloatOpenHashMap) (isa? it.unimi.dsi.fastutil.shorts.Short2FloatOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|short->double? #?(:clj (or (isa? it.unimi.dsi.fastutil.shorts.Short2DoubleOpenHashMap) (isa? it.unimi.dsi.fastutil.shorts.Short2DoubleOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|short->ref? #?(:clj (or (isa? it.unimi.dsi.fastutil.shorts.Short2ReferenceOpenHashMap) (isa? it.unimi.dsi.fastutil.shorts.Short2ReferenceOpenCustomHashMap)) :cljs none?)) + + (-def !hash-map|int->boolean? #?(:clj (or (isa? it.unimi.dsi.fastutil.ints.Int2BooleanOpenHashMap) (isa? it.unimi.dsi.fastutil.ints.Int2BooleanOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|int->byte? #?(:clj (or (isa? it.unimi.dsi.fastutil.ints.Int2ByteOpenHashMap) (isa? it.unimi.dsi.fastutil.ints.Int2ByteOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|int->char? #?(:clj (or (isa? it.unimi.dsi.fastutil.ints.Int2CharOpenHashMap) (isa? it.unimi.dsi.fastutil.ints.Int2CharOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|int->short? #?(:clj (or (isa? it.unimi.dsi.fastutil.ints.Int2ShortOpenHashMap) (isa? it.unimi.dsi.fastutil.ints.Int2ShortOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|int->int? #?(:clj (or (isa? it.unimi.dsi.fastutil.ints.Int2IntOpenHashMap) (isa? it.unimi.dsi.fastutil.ints.Int2IntOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|int->long? #?(:clj (or (isa? it.unimi.dsi.fastutil.ints.Int2LongOpenHashMap) (isa? it.unimi.dsi.fastutil.ints.Int2LongOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|int->float? #?(:clj (or (isa? it.unimi.dsi.fastutil.ints.Int2FloatOpenHashMap) (isa? it.unimi.dsi.fastutil.ints.Int2FloatOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|int->double? #?(:clj (or (isa? it.unimi.dsi.fastutil.ints.Int2DoubleOpenHashMap) (isa? it.unimi.dsi.fastutil.ints.Int2DoubleOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|int->ref? #?(:clj (or (isa? it.unimi.dsi.fastutil.ints.Int2ReferenceOpenHashMap) (isa? it.unimi.dsi.fastutil.ints.Int2ReferenceOpenCustomHashMap)) :cljs none?)) + + (-def !hash-map|long->boolean? #?(:clj (or (isa? it.unimi.dsi.fastutil.longs.Long2BooleanOpenHashMap) (isa? it.unimi.dsi.fastutil.longs.Long2BooleanOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|long->byte? #?(:clj (or (isa? it.unimi.dsi.fastutil.longs.Long2ByteOpenCustomHashMap) (isa? it.unimi.dsi.fastutil.longs.Long2ByteOpenHashMap)) :cljs none?)) + (-def !hash-map|long->char? #?(:clj (or (isa? it.unimi.dsi.fastutil.longs.Long2CharOpenHashMap) (isa? it.unimi.dsi.fastutil.longs.Long2CharOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|long->short? #?(:clj (or (isa? it.unimi.dsi.fastutil.longs.Long2ShortOpenHashMap) (isa? it.unimi.dsi.fastutil.longs.Long2ShortOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|long->int? #?(:clj (or (isa? it.unimi.dsi.fastutil.longs.Long2IntOpenHashMap) (isa? it.unimi.dsi.fastutil.longs.Long2IntOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|long->long? #?(:clj (or (isa? it.unimi.dsi.fastutil.longs.Long2LongOpenHashMap) (isa? it.unimi.dsi.fastutil.longs.Long2LongOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|long->float? #?(:clj (or (isa? it.unimi.dsi.fastutil.longs.Long2FloatOpenHashMap) (isa? it.unimi.dsi.fastutil.longs.Long2FloatOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|long->double? #?(:clj (or (isa? it.unimi.dsi.fastutil.longs.Long2DoubleOpenHashMap) (isa? it.unimi.dsi.fastutil.longs.Long2DoubleOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|long->ref? #?(:clj (or (isa? it.unimi.dsi.fastutil.longs.Long2ReferenceOpenHashMap) (isa? it.unimi.dsi.fastutil.longs.Long2ReferenceOpenCustomHashMap)) :cljs none?)) + + (-def !hash-map|float->boolean? #?(:clj (or (isa? it.unimi.dsi.fastutil.floats.Float2BooleanOpenHashMap) (isa? it.unimi.dsi.fastutil.floats.Float2BooleanOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|float->byte? #?(:clj (or (isa? it.unimi.dsi.fastutil.floats.Float2ByteOpenHashMap) (isa? it.unimi.dsi.fastutil.floats.Float2ByteOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|float->char? #?(:clj (or (isa? it.unimi.dsi.fastutil.floats.Float2CharOpenHashMap) (isa? it.unimi.dsi.fastutil.floats.Float2CharOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|float->short? #?(:clj (or (isa? it.unimi.dsi.fastutil.floats.Float2ShortOpenHashMap) (isa? it.unimi.dsi.fastutil.floats.Float2ShortOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|float->int? #?(:clj (or (isa? it.unimi.dsi.fastutil.floats.Float2IntOpenHashMap) (isa? it.unimi.dsi.fastutil.floats.Float2IntOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|float->long? #?(:clj (or (isa? it.unimi.dsi.fastutil.floats.Float2LongOpenHashMap) (isa? it.unimi.dsi.fastutil.floats.Float2LongOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|float->float? #?(:clj (or (isa? it.unimi.dsi.fastutil.floats.Float2FloatOpenHashMap) (isa? it.unimi.dsi.fastutil.floats.Float2FloatOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|float->double? #?(:clj (or (isa? it.unimi.dsi.fastutil.floats.Float2DoubleOpenHashMap) (isa? it.unimi.dsi.fastutil.floats.Float2DoubleOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|float->ref? #?(:clj (or (isa? it.unimi.dsi.fastutil.floats.Float2ReferenceOpenHashMap) (isa? it.unimi.dsi.fastutil.floats.Float2ReferenceOpenCustomHashMap)) :cljs none?)) + + (-def !hash-map|double->boolean? #?(:clj (or (isa? it.unimi.dsi.fastutil.doubles.Double2BooleanOpenHashMap) (isa? it.unimi.dsi.fastutil.doubles.Double2BooleanOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|double->byte? #?(:clj (or (isa? it.unimi.dsi.fastutil.doubles.Double2ByteOpenHashMap) (isa? it.unimi.dsi.fastutil.doubles.Double2ByteOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|double->char? #?(:clj (or (isa? it.unimi.dsi.fastutil.doubles.Double2CharOpenHashMap) (isa? it.unimi.dsi.fastutil.doubles.Double2CharOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|double->short? #?(:clj (or (isa? it.unimi.dsi.fastutil.doubles.Double2ShortOpenHashMap) (isa? it.unimi.dsi.fastutil.doubles.Double2ShortOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|double->int? #?(:clj (or (isa? it.unimi.dsi.fastutil.doubles.Double2IntOpenHashMap) (isa? it.unimi.dsi.fastutil.doubles.Double2IntOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|double->long? #?(:clj (or (isa? it.unimi.dsi.fastutil.doubles.Double2LongOpenHashMap) (isa? it.unimi.dsi.fastutil.doubles.Double2LongOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|double->float? #?(:clj (or (isa? it.unimi.dsi.fastutil.doubles.Double2FloatOpenHashMap) (isa? it.unimi.dsi.fastutil.doubles.Double2FloatOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|double->double? #?(:clj (or (isa? it.unimi.dsi.fastutil.doubles.Double2DoubleOpenHashMap) (isa? it.unimi.dsi.fastutil.doubles.Double2DoubleOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|double->ref? #?(:clj (or (isa? it.unimi.dsi.fastutil.doubles.Double2ReferenceOpenHashMap) (isa? it.unimi.dsi.fastutil.doubles.Double2ReferenceOpenCustomHashMap)) :cljs none?)) + + (-def !hash-map|ref->boolean? #?(:clj (or (isa? it.unimi.dsi.fastutil.objects.Reference2BooleanOpenHashMap) (isa? it.unimi.dsi.fastutil.objects.Reference2BooleanOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|ref->byte? #?(:clj (or (isa? it.unimi.dsi.fastutil.objects.Reference2ByteOpenHashMap) (isa? it.unimi.dsi.fastutil.objects.Reference2ByteOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|ref->char? #?(:clj (or (isa? it.unimi.dsi.fastutil.objects.Reference2CharOpenHashMap) (isa? it.unimi.dsi.fastutil.objects.Reference2CharOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|ref->short? #?(:clj (or (isa? it.unimi.dsi.fastutil.objects.Reference2ShortOpenHashMap) (isa? it.unimi.dsi.fastutil.objects.Reference2ShortOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|ref->int? #?(:clj (or (isa? it.unimi.dsi.fastutil.objects.Reference2IntOpenHashMap) (isa? it.unimi.dsi.fastutil.objects.Reference2IntOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|ref->long? #?(:clj (or (isa? it.unimi.dsi.fastutil.objects.Reference2LongOpenHashMap) (isa? it.unimi.dsi.fastutil.objects.Reference2LongOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|ref->float? #?(:clj (or (isa? it.unimi.dsi.fastutil.objects.Reference2FloatOpenHashMap) (isa? it.unimi.dsi.fastutil.objects.Reference2FloatOpenCustomHashMap)) :cljs none?)) + (-def !hash-map|ref->double? #?(:clj (or (isa? it.unimi.dsi.fastutil.objects.Reference2DoubleOpenHashMap) (isa? it.unimi.dsi.fastutil.objects.Reference2DoubleOpenCustomHashMap)) :cljs none?)) + + (-def !hash-map|ref->ref? (or #?@(:clj [(isa? java.util.HashMap) + ;; Because this has different semantics + #_(isa? java.util.IdentityHashMap) + (isa? it.unimi.dsi.fastutil.objects.Reference2ReferenceOpenHashMap) + (isa? it.unimi.dsi.fastutil.objects.Reference2ReferenceOpenCustomHashMap)] + :cljs [(isa? goog.structs.Map)]))) + + (def-preds|map|any !hash-map) + + (def-preds|map|same-types !hash-map) + + (-def !hash-map? !hash-map|any?) + +#?(:clj (-def !!hash-map? (isa? java.util.concurrent.ConcurrentHashMap))) + (-def hash-map? (or ?!+hash-map? #?(:clj !!hash-map?) !hash-map?)) + +;; ----- Array Maps ----- ;; + + (-def +array-map? (isa? #?(:clj clojure.lang.PersistentArrayMap + :cljs cljs.core/PersistentArrayMap))) + + (-def !+array-map? (isa? #?(:clj clojure.lang.PersistentArrayMap$TransientArrayMap + :cljs cljs.core/TransientArrayMap))) + + (-def ?!+array-map? (or !+array-map? +array-map?)) + + (-def !array-map|boolean->boolean? none?) + (-def !array-map|boolean->byte? none?) + (-def !array-map|boolean->char? none?) + (-def !array-map|boolean->short? none?) + (-def !array-map|boolean->int? none?) + (-def !array-map|boolean->long? none?) + (-def !array-map|boolean->float? none?) + (-def !array-map|boolean->double? none?) + (-def !array-map|boolean->ref? none?) + + (-def !array-map|byte->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2BooleanArrayMap) :cljs none?)) + (-def !array-map|byte->byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ByteArrayMap) :cljs none?)) + (-def !array-map|byte->char? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2CharArrayMap) :cljs none?)) + (-def !array-map|byte->short? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ShortArrayMap) :cljs none?)) + (-def !array-map|byte->int? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2IntArrayMap) :cljs none?)) + (-def !array-map|byte->long? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2LongArrayMap) :cljs none?)) + (-def !array-map|byte->float? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2FloatArrayMap) :cljs none?)) + (-def !array-map|byte->double? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2DoubleArrayMap) :cljs none?)) + (-def !array-map|byte->ref? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ReferenceArrayMap) :cljs none?)) + + (-def !array-map|char->ref? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ReferenceArrayMap) :cljs none?)) + (-def !array-map|char->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2BooleanArrayMap) :cljs none?)) + (-def !array-map|char->byte? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ByteArrayMap) :cljs none?)) + (-def !array-map|char->char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2CharArrayMap) :cljs none?)) + (-def !array-map|char->short? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ShortArrayMap) :cljs none?)) + (-def !array-map|char->int? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2IntArrayMap) :cljs none?)) + (-def !array-map|char->long? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2LongArrayMap) :cljs none?)) + (-def !array-map|char->float? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2FloatArrayMap) :cljs none?)) + (-def !array-map|char->double? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2DoubleArrayMap) :cljs none?)) + + (-def !array-map|short->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2BooleanArrayMap) :cljs none?)) + (-def !array-map|short->byte? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ByteArrayMap) :cljs none?)) + (-def !array-map|short->char? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2CharArrayMap) :cljs none?)) + (-def !array-map|short->short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ShortArrayMap) :cljs none?)) + (-def !array-map|short->int? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2IntArrayMap) :cljs none?)) + (-def !array-map|short->long? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2LongArrayMap) :cljs none?)) + (-def !array-map|short->float? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2FloatArrayMap) :cljs none?)) + (-def !array-map|short->double? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2DoubleArrayMap) :cljs none?)) + (-def !array-map|short->ref? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ReferenceArrayMap) :cljs none?)) + + (-def !array-map|int->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2BooleanArrayMap) :cljs none?)) + (-def !array-map|int->byte? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2ByteArrayMap) :cljs none?)) + (-def !array-map|int->char? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2CharArrayMap) :cljs none?)) + (-def !array-map|int->short? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2ShortArrayMap) :cljs none?)) + (-def !array-map|int->int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2IntArrayMap) :cljs none?)) + (-def !array-map|int->long? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2LongArrayMap) :cljs none?)) + (-def !array-map|int->float? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2FloatArrayMap) :cljs none?)) + (-def !array-map|int->double? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2DoubleArrayMap) :cljs none?)) + (-def !array-map|int->ref? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2ReferenceArrayMap) :cljs none?)) + + (-def !array-map|long->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2BooleanArrayMap) :cljs none?)) + (-def !array-map|long->byte? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2ByteArrayMap) :cljs none?)) + (-def !array-map|long->char? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2CharArrayMap) :cljs none?)) + (-def !array-map|long->short? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2ShortArrayMap) :cljs none?)) + (-def !array-map|long->int? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2IntArrayMap) :cljs none?)) + (-def !array-map|long->long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2LongArrayMap) :cljs none?)) + (-def !array-map|long->float? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2FloatArrayMap) :cljs none?)) + (-def !array-map|long->double? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2DoubleArrayMap) :cljs none?)) + (-def !array-map|long->ref? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2ReferenceArrayMap) :cljs none?)) + + (-def !array-map|float->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2BooleanArrayMap) :cljs none?)) + (-def !array-map|float->byte? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2ByteArrayMap) :cljs none?)) + (-def !array-map|float->char? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2CharArrayMap) :cljs none?)) + (-def !array-map|float->short? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2ShortArrayMap) :cljs none?)) + (-def !array-map|float->int? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2IntArrayMap) :cljs none?)) + (-def !array-map|float->long? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2LongArrayMap) :cljs none?)) + (-def !array-map|float->float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2FloatArrayMap) :cljs none?)) + (-def !array-map|float->double? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2DoubleArrayMap) :cljs none?)) + (-def !array-map|float->ref? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2ReferenceArrayMap) :cljs none?)) + + (-def !array-map|double->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2BooleanArrayMap) :cljs none?)) + (-def !array-map|double->byte? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2ByteArrayMap) :cljs none?)) + (-def !array-map|double->char? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2CharArrayMap) :cljs none?)) + (-def !array-map|double->short? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2ShortArrayMap) :cljs none?)) + (-def !array-map|double->int? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2IntArrayMap) :cljs none?)) + (-def !array-map|double->long? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2LongArrayMap) :cljs none?)) + (-def !array-map|double->float? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2FloatArrayMap) :cljs none?)) + (-def !array-map|double->double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2DoubleArrayMap) :cljs none?)) + (-def !array-map|double->ref? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2ReferenceArrayMap) :cljs none?)) + + (-def !array-map|ref->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2BooleanArrayMap) :cljs none?)) + (-def !array-map|ref->byte? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2ByteArrayMap) :cljs none?)) + (-def !array-map|ref->char? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2CharArrayMap) :cljs none?)) + (-def !array-map|ref->short? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2ShortArrayMap) :cljs none?)) + (-def !array-map|ref->int? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2IntArrayMap) :cljs none?)) + (-def !array-map|ref->long? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2LongArrayMap) :cljs none?)) + (-def !array-map|ref->float? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2FloatArrayMap) :cljs none?)) + (-def !array-map|ref->double? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2DoubleArrayMap) :cljs none?)) + (-def !array-map|ref->ref? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2ReferenceArrayMap) :cljs none?)) + + (def-preds|map|any !array-map) + + (def-preds|map|same-types !array-map) + + (-def !array-map? !array-map|any?) + +#?(:clj (-def !!array-map? none?)) + + (-def array-map? (or ?!+array-map? #?(:clj !!array-map?) !array-map?)) + +;; ----- Unsorted Maps ----- ;; TODO Perhaps the concept of unsortedness is `(- map sorted?)`? + + (-def +unsorted-map? (or +hash-map? +array-map?)) + (-def !+unsorted-map? (or !+hash-map? !+array-map?)) + (-def ?!+unsorted-map? (or ?!+hash-map? ?!+array-map?)) + + (-def !unsorted-map|boolean->boolean? (or !hash-map|boolean->boolean? !array-map|boolean->boolean?)) + (-def !unsorted-map|boolean->byte? (or !hash-map|boolean->byte? !array-map|boolean->byte?)) + (-def !unsorted-map|boolean->char? (or !hash-map|boolean->char? !array-map|boolean->char?)) + (-def !unsorted-map|boolean->short? (or !hash-map|boolean->short? !array-map|boolean->short?)) + (-def !unsorted-map|boolean->int? (or !hash-map|boolean->int? !array-map|boolean->int?)) + (-def !unsorted-map|boolean->long? (or !hash-map|boolean->long? !array-map|boolean->long?)) + (-def !unsorted-map|boolean->float? (or !hash-map|boolean->float? !array-map|boolean->float?)) + (-def !unsorted-map|boolean->double? (or !hash-map|boolean->double? !array-map|boolean->double?)) + (-def !unsorted-map|boolean->ref? (or !hash-map|boolean->ref? !array-map|boolean->ref?)) + + (-def !unsorted-map|byte->boolean? (or !hash-map|byte->boolean? !array-map|byte->boolean?)) + (-def !unsorted-map|byte->byte? (or !hash-map|byte->byte? !array-map|byte->byte?)) + (-def !unsorted-map|byte->char? (or !hash-map|byte->char? !array-map|byte->char?)) + (-def !unsorted-map|byte->short? (or !hash-map|byte->short? !array-map|byte->short?)) + (-def !unsorted-map|byte->int? (or !hash-map|byte->int? !array-map|byte->int?)) + (-def !unsorted-map|byte->long? (or !hash-map|byte->long? !array-map|byte->long?)) + (-def !unsorted-map|byte->float? (or !hash-map|byte->float? !array-map|byte->float?)) + (-def !unsorted-map|byte->double? (or !hash-map|byte->double? !array-map|byte->double?)) + (-def !unsorted-map|byte->ref? (or !hash-map|byte->ref? !array-map|byte->ref?)) + + (-def !unsorted-map|char->boolean? (or !hash-map|char->boolean? !array-map|char->boolean?)) + (-def !unsorted-map|char->byte? (or !hash-map|char->byte? !array-map|char->byte?)) + (-def !unsorted-map|char->char? (or !hash-map|char->char? !array-map|char->char?)) + (-def !unsorted-map|char->short? (or !hash-map|char->short? !array-map|char->short?)) + (-def !unsorted-map|char->int? (or !hash-map|char->int? !array-map|char->int?)) + (-def !unsorted-map|char->long? (or !hash-map|char->long? !array-map|char->long?)) + (-def !unsorted-map|char->float? (or !hash-map|char->float? !array-map|char->float?)) + (-def !unsorted-map|char->double? (or !hash-map|char->double? !array-map|char->double?)) + (-def !unsorted-map|char->ref? (or !hash-map|char->ref? !array-map|char->ref?)) + + (-def !unsorted-map|short->boolean? (or !hash-map|short->boolean? !array-map|short->boolean?)) + (-def !unsorted-map|short->byte? (or !hash-map|short->byte? !array-map|short->byte?)) + (-def !unsorted-map|short->char? (or !hash-map|short->char? !array-map|short->char?)) + (-def !unsorted-map|short->short? (or !hash-map|short->short? !array-map|short->short?)) + (-def !unsorted-map|short->int? (or !hash-map|short->int? !array-map|short->int?)) + (-def !unsorted-map|short->long? (or !hash-map|short->long? !array-map|short->long?)) + (-def !unsorted-map|short->float? (or !hash-map|short->float? !array-map|short->float?)) + (-def !unsorted-map|short->double? (or !hash-map|short->double? !array-map|short->double?)) + (-def !unsorted-map|short->ref? (or !hash-map|short->ref? !array-map|short->ref?)) + + (-def !unsorted-map|int->boolean? (or !hash-map|int->boolean? !array-map|int->boolean?)) + (-def !unsorted-map|int->byte? (or !hash-map|int->byte? !array-map|int->byte?)) + (-def !unsorted-map|int->char? (or !hash-map|int->char? !array-map|int->char?)) + (-def !unsorted-map|int->short? (or !hash-map|int->short? !array-map|int->short?)) + (-def !unsorted-map|int->int? (or !hash-map|int->int? !array-map|int->int?)) + (-def !unsorted-map|int->long? (or !hash-map|int->long? !array-map|int->long?)) + (-def !unsorted-map|int->float? (or !hash-map|int->float? !array-map|int->float?)) + (-def !unsorted-map|int->double? (or !hash-map|int->double? !array-map|int->double?)) + (-def !unsorted-map|int->ref? (or !hash-map|int->ref? !array-map|int->ref?)) + + (-def !unsorted-map|long->boolean? (or !hash-map|long->boolean? !array-map|long->boolean?)) + (-def !unsorted-map|long->byte? (or !hash-map|long->byte? !array-map|long->byte?)) + (-def !unsorted-map|long->char? (or !hash-map|long->char? !array-map|long->char?)) + (-def !unsorted-map|long->short? (or !hash-map|long->short? !array-map|long->short?)) + (-def !unsorted-map|long->int? (or !hash-map|long->int? !array-map|long->int?)) + (-def !unsorted-map|long->long? (or !hash-map|long->long? !array-map|long->long?)) + (-def !unsorted-map|long->float? (or !hash-map|long->float? !array-map|long->float?)) + (-def !unsorted-map|long->double? (or !hash-map|long->double? !array-map|long->double?)) + (-def !unsorted-map|long->ref? (or !hash-map|long->ref? !array-map|long->ref?)) + + (-def !unsorted-map|float->boolean? (or !hash-map|float->boolean? !array-map|float->boolean?)) + (-def !unsorted-map|float->byte? (or !hash-map|float->byte? !array-map|float->byte?)) + (-def !unsorted-map|float->char? (or !hash-map|float->char? !array-map|float->char?)) + (-def !unsorted-map|float->short? (or !hash-map|float->short? !array-map|float->short?)) + (-def !unsorted-map|float->int? (or !hash-map|float->int? !array-map|float->int?)) + (-def !unsorted-map|float->long? (or !hash-map|float->long? !array-map|float->long?)) + (-def !unsorted-map|float->float? (or !hash-map|float->float? !array-map|float->float?)) + (-def !unsorted-map|float->double? (or !hash-map|float->double? !array-map|float->double?)) + (-def !unsorted-map|float->ref? (or !hash-map|float->ref? !array-map|float->ref?)) + + (-def !unsorted-map|double->boolean? (or !hash-map|double->boolean? !array-map|double->boolean?)) + (-def !unsorted-map|double->byte? (or !hash-map|double->byte? !array-map|double->byte?)) + (-def !unsorted-map|double->char? (or !hash-map|double->char? !array-map|double->char?)) + (-def !unsorted-map|double->short? (or !hash-map|double->short? !array-map|double->short?)) + (-def !unsorted-map|double->int? (or !hash-map|double->int? !array-map|double->int?)) + (-def !unsorted-map|double->long? (or !hash-map|double->long? !array-map|double->long?)) + (-def !unsorted-map|double->float? (or !hash-map|double->float? !array-map|double->float?)) + (-def !unsorted-map|double->double? (or !hash-map|double->double? !array-map|double->double?)) + (-def !unsorted-map|double->ref? (or !hash-map|double->ref? !array-map|double->ref?)) + + (-def !unsorted-map|ref->boolean? (or !hash-map|ref->boolean? !array-map|ref->boolean?)) + (-def !unsorted-map|ref->byte? (or !hash-map|ref->byte? !array-map|ref->byte?)) + (-def !unsorted-map|ref->char? (or !hash-map|ref->char? !array-map|ref->char?)) + (-def !unsorted-map|ref->short? (or !hash-map|ref->short? !array-map|ref->short?)) + (-def !unsorted-map|ref->int? (or !hash-map|ref->int? !array-map|ref->int?)) + (-def !unsorted-map|ref->long? (or !hash-map|ref->long? !array-map|ref->long?)) + (-def !unsorted-map|ref->float? (or !hash-map|ref->float? !array-map|ref->float?)) + (-def !unsorted-map|ref->double? (or !hash-map|ref->double? !array-map|ref->double?)) + (-def !unsorted-map|ref->ref? (or !hash-map|ref->ref? !array-map|ref->ref?)) + + (def-preds|map|any !unsorted-map) + + (def-preds|map|same-types !unsorted-map) + + (-def !unsorted-map? !unsorted-map|any?) + +#?(:clj (-def !!unsorted-map? (or !!hash-map? !!array-map?))) + (-def unsorted-map? (or ?!+unsorted-map? !unsorted-map? #?(:clj !!unsorted-map?))) + +;; ----- Sorted Maps ----- ;; + + (-def +map? (isa? #?(:clj clojure.lang.IPersistentMap + :cljs cljs.core/IMap))) + (-def !+map? (isa? #?(:clj clojure.lang.ITransientMap + :cljs cljs.core/ITransientMap))) + + (-def +sorted-map? (and (isa? #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) + +map?)) + (-def !+sorted-map? (and (isa? #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) + !+map?)) + (-def ?!+sorted-map? (or +sorted-map? !+sorted-map?)) + + (-def !sorted-map|boolean->boolean? none?) + (-def !sorted-map|boolean->byte? none?) + (-def !sorted-map|boolean->char? none?) + (-def !sorted-map|boolean->short? none?) + (-def !sorted-map|boolean->int? none?) + (-def !sorted-map|boolean->long? none?) + (-def !sorted-map|boolean->float? none?) + (-def !sorted-map|boolean->double? none?) + (-def !sorted-map|boolean->ref? none?) + + (-def !sorted-map|byte->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2BooleanSortedMap) :cljs none?)) + (-def !sorted-map|byte->byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ByteSortedMap) :cljs none?)) + (-def !sorted-map|byte->char? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2CharSortedMap) :cljs none?)) + (-def !sorted-map|byte->short? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ShortSortedMap) :cljs none?)) + (-def !sorted-map|byte->int? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2IntSortedMap) :cljs none?)) + (-def !sorted-map|byte->long? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2LongSortedMap) :cljs none?)) + (-def !sorted-map|byte->float? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2FloatSortedMap) :cljs none?)) + (-def !sorted-map|byte->double? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2DoubleSortedMap) :cljs none?)) + (-def !sorted-map|byte->ref? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ReferenceSortedMap) :cljs none?)) + + (-def !sorted-map|char->ref? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ReferenceSortedMap) :cljs none?)) + (-def !sorted-map|char->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2BooleanSortedMap) :cljs none?)) + (-def !sorted-map|char->byte? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ByteSortedMap) :cljs none?)) + (-def !sorted-map|char->char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2CharSortedMap) :cljs none?)) + (-def !sorted-map|char->short? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ShortSortedMap) :cljs none?)) + (-def !sorted-map|char->int? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2IntSortedMap) :cljs none?)) + (-def !sorted-map|char->long? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2LongSortedMap) :cljs none?)) + (-def !sorted-map|char->float? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2FloatSortedMap) :cljs none?)) + (-def !sorted-map|char->double? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2DoubleSortedMap) :cljs none?)) + + (-def !sorted-map|short->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2BooleanSortedMap) :cljs none?)) + (-def !sorted-map|short->byte? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ByteSortedMap) :cljs none?)) + (-def !sorted-map|short->char? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2CharSortedMap) :cljs none?)) + (-def !sorted-map|short->short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ShortSortedMap) :cljs none?)) + (-def !sorted-map|short->int? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2IntSortedMap) :cljs none?)) + (-def !sorted-map|short->long? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2LongSortedMap) :cljs none?)) + (-def !sorted-map|short->float? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2FloatSortedMap) :cljs none?)) + (-def !sorted-map|short->double? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2DoubleSortedMap) :cljs none?)) + (-def !sorted-map|short->ref? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ReferenceSortedMap) :cljs none?)) + + (-def !sorted-map|int->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2BooleanSortedMap) :cljs none?)) + (-def !sorted-map|int->byte? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2ByteSortedMap) :cljs none?)) + (-def !sorted-map|int->char? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2CharSortedMap) :cljs none?)) + (-def !sorted-map|int->short? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2ShortSortedMap) :cljs none?)) + (-def !sorted-map|int->int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2IntSortedMap) :cljs none?)) + (-def !sorted-map|int->long? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2LongSortedMap) :cljs none?)) + (-def !sorted-map|int->float? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2FloatSortedMap) :cljs none?)) + (-def !sorted-map|int->double? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2DoubleSortedMap) :cljs none?)) + (-def !sorted-map|int->ref? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2ReferenceSortedMap) :cljs none?)) + + (-def !sorted-map|long->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2BooleanSortedMap) :cljs none?)) + (-def !sorted-map|long->byte? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2ByteSortedMap) :cljs none?)) + (-def !sorted-map|long->char? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2CharSortedMap) :cljs none?)) + (-def !sorted-map|long->short? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2ShortSortedMap) :cljs none?)) + (-def !sorted-map|long->int? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2IntSortedMap) :cljs none?)) + (-def !sorted-map|long->long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2LongSortedMap) :cljs none?)) + (-def !sorted-map|long->float? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2FloatSortedMap) :cljs none?)) + (-def !sorted-map|long->double? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2DoubleSortedMap) :cljs none?)) + (-def !sorted-map|long->ref? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2ReferenceSortedMap) :cljs none?)) + + (-def !sorted-map|float->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2BooleanSortedMap) :cljs none?)) + (-def !sorted-map|float->byte? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2ByteSortedMap) :cljs none?)) + (-def !sorted-map|float->char? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2CharSortedMap) :cljs none?)) + (-def !sorted-map|float->short? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2ShortSortedMap) :cljs none?)) + (-def !sorted-map|float->int? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2IntSortedMap) :cljs none?)) + (-def !sorted-map|float->long? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2LongSortedMap) :cljs none?)) + (-def !sorted-map|float->float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2FloatSortedMap) :cljs none?)) + (-def !sorted-map|float->double? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2DoubleSortedMap) :cljs none?)) + (-def !sorted-map|float->ref? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2ReferenceSortedMap) :cljs none?)) + + (-def !sorted-map|double->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2BooleanSortedMap) :cljs none?)) + (-def !sorted-map|double->byte? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2ByteSortedMap) :cljs none?)) + (-def !sorted-map|double->char? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2CharSortedMap) :cljs none?)) + (-def !sorted-map|double->short? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2ShortSortedMap) :cljs none?)) + (-def !sorted-map|double->int? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2IntSortedMap) :cljs none?)) + (-def !sorted-map|double->long? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2LongSortedMap) :cljs none?)) + (-def !sorted-map|double->float? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2FloatSortedMap) :cljs none?)) + (-def !sorted-map|double->double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2DoubleSortedMap) :cljs none?)) + (-def !sorted-map|double->ref? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2ReferenceSortedMap) :cljs none?)) + + (-def !sorted-map|ref->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2BooleanSortedMap) :cljs none?)) + (-def !sorted-map|ref->byte? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2ByteSortedMap) :cljs none?)) + (-def !sorted-map|ref->char? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2CharSortedMap) :cljs none?)) + (-def !sorted-map|ref->short? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2ShortSortedMap) :cljs none?)) + (-def !sorted-map|ref->int? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2IntSortedMap) :cljs none?)) + (-def !sorted-map|ref->long? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2LongSortedMap) :cljs none?)) + (-def !sorted-map|ref->float? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2FloatSortedMap) :cljs none?)) + (-def !sorted-map|ref->double? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2DoubleSortedMap) :cljs none?)) + + (-def !sorted-map|ref->ref? (or #?@(:clj [(isa? java.util.TreeMap) + (isa? it.unimi.dsi.fastutil.objects.Reference2ReferenceSortedMap)] + :cljs [(isa? goog.structs.AvlTree)]))) + + (def-preds|map|any !sorted-map) + + (def-preds|map|same-types !sorted-map) + + (-def !sorted-map? !sorted-map|any?) + +#?(:clj (-def !!sorted-map? (isa? java.util.concurrent.ConcurrentNavigableMap))) + (-def sorted-map? (or ?!+sorted-map? #?@(:clj [!!sorted-map? (isa? java.util.SortedMap)]) !sorted-map?)) + +;; ----- Other Maps ----- ;; + + (-def +insertion-ordered-map? (or (isa? linked.map.LinkedMap) + ;; This is true, but we have replaced OrderedMap with LinkedMap + #_(:clj (isa? flatland.ordered.map.OrderedMap)))) + (-def !+insertion-ordered-map? none? + ;; This is true, but we have replaced OrderedMap with LinkedMap + #_(isa? flatland.ordered.map.TransientOrderedMap)) + (-def ?!+insertion-ordered-map? (or +insertion-ordered-map? !+insertion-ordered-map?)) + + (-def !insertion-ordered-map? #?(:clj (isa? java.util.LinkedHashMap) :cljs none?)) + + ;; See https://github.com/ben-manes/concurrentlinkedhashmap (and links therefrom) for good implementation +#?(:clj (-def !!insertion-ordered-map? none?)) + + (-def insertion-ordered-map? (or ?!+insertion-ordered-map? !insertion-ordered-map? #?(:clj !!insertion-ordered-map?))) + +;; ----- General Maps ----- ;; + + (-def +map|built-in? (or (isa? #?(:clj clojure.lang.PersistentHashMap :cljs cljs.core/PersistentHashMap)) + (isa? #?(:clj clojure.lang.PersistentArrayMap :cljs cljs.core/PersistentArrayMap)) + (isa? #?(:clj clojure.lang.PersistentTreeMap :cljs cljs.core/PersistentTreeMap)))) + + ;; `+map?` and `!+map?` defined above + (-def ?!+map? (or !+map? +map?)) + + (-def !map|boolean->boolean? none?) + (-def !map|boolean->byte? none?) + (-def !map|boolean->char? none?) + (-def !map|boolean->short? none?) + (-def !map|boolean->int? none?) + (-def !map|boolean->long? none?) + (-def !map|boolean->float? none?) + (-def !map|boolean->double? none?) + (-def !map|boolean->ref? none?) + + (-def !map|byte->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2BooleanMap) :cljs none?)) + (-def !map|byte->byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ByteMap) :cljs none?)) + (-def !map|byte->char? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2CharMap) :cljs none?)) + (-def !map|byte->short? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ShortMap) :cljs none?)) + (-def !map|byte->int? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2IntMap) :cljs none?)) + (-def !map|byte->long? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2LongMap) :cljs none?)) + (-def !map|byte->float? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2FloatMap) :cljs none?)) + (-def !map|byte->double? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2DoubleMap) :cljs none?)) + (-def !map|byte->ref? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ReferenceMap) :cljs none?)) + + (-def !map|char->ref? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ReferenceMap) :cljs none?)) + (-def !map|char->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2BooleanMap) :cljs none?)) + (-def !map|char->byte? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ByteMap) :cljs none?)) + (-def !map|char->char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2CharMap) :cljs none?)) + (-def !map|char->short? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ShortMap) :cljs none?)) + (-def !map|char->int? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2IntMap) :cljs none?)) + (-def !map|char->long? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2LongMap) :cljs none?)) + (-def !map|char->float? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2FloatMap) :cljs none?)) + (-def !map|char->double? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2DoubleMap) :cljs none?)) + + (-def !map|short->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2BooleanMap) :cljs none?)) + (-def !map|short->byte? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ByteMap) :cljs none?)) + (-def !map|short->char? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2CharMap) :cljs none?)) + (-def !map|short->short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ShortMap) :cljs none?)) + (-def !map|short->int? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2IntMap) :cljs none?)) + (-def !map|short->long? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2LongMap) :cljs none?)) + (-def !map|short->float? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2FloatMap) :cljs none?)) + (-def !map|short->double? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2DoubleMap) :cljs none?)) + (-def !map|short->ref? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ReferenceMap) :cljs none?)) + + (-def !map|int->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2BooleanMap) :cljs none?)) + (-def !map|int->byte? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2ByteMap) :cljs none?)) + (-def !map|int->char? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2CharMap) :cljs none?)) + (-def !map|int->short? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2ShortMap) :cljs none?)) + (-def !map|int->int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2IntMap) :cljs none?)) + (-def !map|int->long? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2LongMap) :cljs none?)) + (-def !map|int->float? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2FloatMap) :cljs none?)) + (-def !map|int->double? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2DoubleMap) :cljs none?)) + (-def !map|int->ref? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2ReferenceMap) :cljs none?)) + + (-def !map|long->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2BooleanMap) :cljs none?)) + (-def !map|long->byte? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2ByteMap) :cljs none?)) + (-def !map|long->char? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2CharMap) :cljs none?)) + (-def !map|long->short? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2ShortMap) :cljs none?)) + (-def !map|long->int? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2IntMap) :cljs none?)) + (-def !map|long->long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2LongMap) :cljs none?)) + (-def !map|long->float? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2FloatMap) :cljs none?)) + (-def !map|long->double? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2DoubleMap) :cljs none?)) + (-def !map|long->ref? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2ReferenceMap) :cljs none?)) + + (-def !map|float->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2BooleanMap) :cljs none?)) + (-def !map|float->byte? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2ByteMap) :cljs none?)) + (-def !map|float->char? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2CharMap) :cljs none?)) + (-def !map|float->short? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2ShortMap) :cljs none?)) + (-def !map|float->int? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2IntMap) :cljs none?)) + (-def !map|float->long? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2LongMap) :cljs none?)) + (-def !map|float->float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2FloatMap) :cljs none?)) + (-def !map|float->double? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2DoubleMap) :cljs none?)) + (-def !map|float->ref? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2ReferenceMap) :cljs none?)) + + (-def !map|double->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2BooleanMap) :cljs none?)) + (-def !map|double->byte? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2ByteMap) :cljs none?)) + (-def !map|double->char? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2CharMap) :cljs none?)) + (-def !map|double->short? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2ShortMap) :cljs none?)) + (-def !map|double->int? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2IntMap) :cljs none?)) + (-def !map|double->long? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2LongMap) :cljs none?)) + (-def !map|double->float? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2FloatMap) :cljs none?)) + (-def !map|double->double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2DoubleMap) :cljs none?)) + (-def !map|double->ref? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2ReferenceMap) :cljs none?)) + + (-def !map|ref->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2BooleanMap) :cljs none?)) + (-def !map|ref->byte? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2ByteMap) :cljs none?)) + (-def !map|ref->char? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2CharMap) :cljs none?)) + (-def !map|ref->short? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2ShortMap) :cljs none?)) + (-def !map|ref->int? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2IntMap) :cljs none?)) + (-def !map|ref->long? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2LongMap) :cljs none?)) + (-def !map|ref->float? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2FloatMap) :cljs none?)) + (-def !map|ref->double? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2DoubleMap) :cljs none?)) + + (-def !map|ref->ref? (or #?@(:clj [;; perhaps just `(- !map? )` ? + !unsorted-map|ref->ref? + !sorted-map|ref->ref? + (isa? it.unimi.dsi.fastutil.objects.Reference2ReferenceMap)] + :cljs [(isa? goog.structs.AvlTree)]))) + + (def-preds|map|any !map) + + (def-preds|map|same-types !map) + + (-def !map? !map|any?) + +#?(:clj (-def !!map? (or !!unsorted-map? !!sorted-map?))) + + (-def map? (or ?!+map? !map? #?@(:clj [!!map? (isa? java.util.Map)]))) + +;; ===== Sets ===== ;; Associative; A special type of Map whose keys and vals are identical + +#?(:clj (-def java-set? (isa? java.util.Set))) + +;; ----- Hash Sets ----- ;; + + (-def +hash-set? (isa? #?(:clj clojure.lang.PersistentHashSet + :cljs cljs.core/PersistentHashSet))) + (-def !+hash-set? (isa? #?(:clj clojure.lang.PersistentHashSet$TransientHashSet + :cljs cljs.core/TransientHashSet))) + (-def ?!+hash-set? (or +hash-set? !+hash-set?)) + + (-def !hash-set|byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.ByteOpenHashSet) :cljs none?)) + (-def !hash-set|char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.CharOpenHashSet) :cljs none?)) + (-def !hash-set|short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.ShortOpenHashSet) :cljs none?)) + (-def !hash-set|int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.IntOpenHashSet) :cljs none?)) + (-def !hash-set|long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.LongOpenHashSet) :cljs none?)) + (-def !hash-set|float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.FloatOpenHashSet) :cljs none?)) + (-def !hash-set|double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.DoubleOpenHashSet) :cljs none?)) + (-def !hash-set|ref? #?(:clj (or (isa? java.util.HashSet) + ;; Because this has different semantics + #_(isa? java.util.IdentityHashSet) + (isa? it.unimi.dsi.fastutil.objects.ReferenceOpenHashSet)) + :cljs (isa? goog.structs.Set))) + + (-def !hash-set? (or !hash-set|ref? + #?@(:clj [!hash-set|byte? !hash-set|short? !hash-set|char? + !hash-set|int? !hash-set|long? + !hash-set|float? !hash-set|double?]))) + + ;; CLJ technically can have via ConcurrentHashMap with same KVs but this hasn't been implemented yet +#?(:clj (-def !!hash-set? none?)) + (-def hash-set? (or ?!+hash-set? !hash-set? #?(:clj !!hash-set?))) + +;; ----- Unsorted Sets ----- ;; + + (-def +unsorted-set? +hash-set?) + (-def !+unsorted-set? !+hash-set?) + (-def ?!+unsorted-set? ?!+hash-set?) + +#?(:clj (-def !unsorted-set|byte? !hash-set|byte?)) +#?(:clj (-def !unsorted-set|short? !hash-set|char?)) +#?(:clj (-def !unsorted-set|char? !hash-set|short?)) +#?(:clj (-def !unsorted-set|int? !hash-set|int?)) +#?(:clj (-def !unsorted-set|long? !hash-set|long?)) +#?(:clj (-def !unsorted-set|float? !hash-set|float?)) +#?(:clj (-def !unsorted-set|double? !hash-set|double?)) + (-def !unsorted-set|ref? !hash-set|ref?) + + (-def !unsorted-set? (or !unsorted-set|ref? + #?@(:clj [!unsorted-set|byte? !unsorted-set|short? !unsorted-set|char? + !unsorted-set|int? !unsorted-set|long? + !unsorted-set|float? !unsorted-set|double?]))) + +#?(:clj (-def !!unsorted-set? !!hash-set?)) + (-def unsorted-set? hash-set?) + +;; ----- Sorted Sets ----- ;; + + (-def +sorted-set? (isa? #?(:clj clojure.lang.PersistentTreeSet + :cljs cljs.core/PersistentTreeSet))) + (-def !+sorted-set? none?) + (-def ?!+sorted-set? (or +sorted-set? !+sorted-set?)) + +#?(:clj (-def !sorted-set|byte? (isa? it.unimi.dsi.fastutil.bytes.ByteSortedSet))) +#?(:clj (-def !sorted-set|short? (isa? it.unimi.dsi.fastutil.shorts.ShortSortedSet))) +#?(:clj (-def !sorted-set|char? (isa? it.unimi.dsi.fastutil.chars.CharSortedSet))) +#?(:clj (-def !sorted-set|int? (isa? it.unimi.dsi.fastutil.ints.IntSortedSet))) +#?(:clj (-def !sorted-set|long? (isa? it.unimi.dsi.fastutil.longs.LongSortedSet))) +#?(:clj (-def !sorted-set|float? (isa? it.unimi.dsi.fastutil.floats.FloatSortedSet))) +#?(:clj (-def !sorted-set|double? (isa? it.unimi.dsi.fastutil.doubles.DoubleSortedSet))) + ;; CLJS technically can have via goog.structs.AVLTree with same KVs but this hasn't been implemented yet + (-def !sorted-set|ref? #?(:clj (isa? java.util.TreeSet) :cljs none?)) + + (-def !sorted-set? (or !sorted-set|ref? + #?@(:clj [!sorted-set|byte? !sorted-set|short? !sorted-set|char? + !sorted-set|int? !sorted-set|long? + !sorted-set|float? !sorted-set|double?]))) + + ;; CLJ technically can have via ConcurrentSkipListMap with same KVs but this hasn't been implemented yet +#?(:clj (-def !!sorted-set? none?)) + (-def sorted-set? (or ?!+sorted-set? !sorted-set? #?@(:clj [!!sorted-set? (isa? java.util.SortedSet)]))) + +;; ----- Other Sets ----- ;; + + (-def +insertion-ordered-set? (or (isa? linked.set.LinkedSet) + ;; This is true, but we have replaced OrderedSet with LinkedSet + #_(:clj (isa? flatland.ordered.set.OrderedSet)))) + (-def !+insertion-ordered-set? none? + ;; This is true, but we have replaced OrderedSet with LinkedSet + #_(isa? flatland.ordered.set.TransientOrderedSet)) + (-def ?!+insertion-ordered-set? (or +insertion-ordered-set? !+insertion-ordered-set?)) + + (-def !insertion-ordered-set? #?(:clj (isa? java.util.LinkedHashSet) :cljs none?)) + + ;; CLJ technically can have via ConcurrentLinkedHashMap with same KVs but this hasn't been implemented yet +#?(:clj (-def !!insertion-ordered-set? none?)) + + (-def insertion-ordered-set? (or ?!+insertion-ordered-set? !insertion-ordered-set? #?(:clj !!insertion-ordered-set?))) + +;; ----- General Sets ----- ;; + + (-def !+set? (isa? #?(:clj clojure.lang.ITransientSet + :cljs cljs.core/ITransientSet))) + + (-def +set|built-in? (or (isa? #?(:clj clojure.lang.PersistentHashSet :cljs cljs.core/PersistentHashSet)) + (isa? #?(:clj clojure.lang.PersistentTreeSet :cljs cljs.core/PersistentTreeSet)))) + + (-def +set? (isa? #?(:clj clojure.lang.IPersistentSet + :cljs cljs.core/ISet))) + (-def ?!+set? (or !+set? +set?)) + + (-def !set|byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.ByteSet) :cljs none?)) + (-def !set|short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.ShortSet) :cljs none?)) + (-def !set|char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.CharSet) :cljs none?)) + (-def !set|int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.IntSet) :cljs none?)) + (-def !set|long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.LongSet) :cljs none?)) + (-def !set|float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.FloatSet) :cljs none?)) + (-def !set|double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.DoubleSet) :cljs none?)) + (-def !set|ref? (or !unsorted-set|ref? !sorted-set|ref?)) + + (-def !set? (or !set|ref? + #?@(:clj [!set|byte? !set|short? !set|char? + !set|int? !set|long? + !set|float? !set|double?]))) + + (-def !set? (or !unsorted-set? !sorted-set?)) +#?(:clj (-def !!set? (or !!unsorted-set? !!sorted-set?))) + (-def set? (or ?!+set? !set? #?@(:clj [!!set? (isa? java.util.Set)]))) ;; ===== Functions ===== ;; @@ -1460,126 +2160,155 @@ (-def multimethod? (isa? #?(:clj clojure.lang.MultiFn :cljs cljs.core/IMultiFn))) - ;; I.e., can you call/invoke it by being in functor position (first element of an unquoted list)? + ;; I.e., can you call/invoke it by being in functor position (first element of an unquoted list) + ;; within a typed context? ;; TODO should we allow java.lang.Runnable, java.util.concurrent.Callable to be `callable?`? (-def callable? (or ifn? fnt?)) +;; ===== References ===== ;; + + (-def atom? (isa? #?(:clj clojure.lang.IAtom :cljs cljs.core/IAtom))) + + (-def volatile? (isa? #?(:clj clojure.lang.Volatile :cljs cljs.core/Volatile))) + +#?(:clj (-def atomic? (or atom? volatile? + java.util.concurrent.atomic.AtomicReference + ;; From the java.util.concurrent package: + ;; "Additionally, classes are provided only for those + ;; types that are commonly useful in intended applications. + ;; For example, there is no atomic class for representing + ;; byte. In those infrequent cases where you would like + ;; to do so, you can use an AtomicInteger to hold byte + ;; values, and cast appropriately. You can also hold floats + ;; using Float.floatToIntBits and Float.intBitstoFloat + ;; conversions, and doubles using Double.doubleToLongBits + ;; and Double.longBitsToDouble conversions." + java.util.concurrent.atomic.AtomicBoolean + #_java.util.concurrent.atomic.AtomicByte + #_java.util.concurrent.atomic.AtomicShort + java.util.concurrent.atomic.AtomicInteger + java.util.concurrent.atomic.AtomicLong + #_java.util.concurrent.atomic.AtomicFloat + #_java.util.concurrent.atomic.AtomicDouble + com.google.common.util.concurrent.AtomicDouble))) + ;; ===== Miscellaneous ===== ;; +#?(:clj (-def thread? (isa? java.lang.Thread))) + + ;; Able to be used with `throw` + (-def throwable? #?(:clj (isa? java.lang.Throwable) :cljs any?)) + (-def regex? (isa? #?(:clj java.util.regex.Pattern :cljs js/RegExp))) - (-def atom? (isa? #?(:clj clojure.lang.IAtom :cljs cljs.core/IAtom))) - - (-def volatile? (isa? #?(:clj clojure.lang.Volatile :cljs cljs.core/Volatile))) - -#?(:clj (-def atomic? (or atom? volatile? - java.util.concurrent.atomic.AtomicReference - ;; From the java.util.concurrent package: - ;; "Additionally, classes are provided only for those - ;; types that are commonly useful in intended applications. - ;; For example, there is no atomic class for representing - ;; byte. In those infrequent cases where you would like - ;; to do so, you can use an AtomicInteger to hold byte - ;; values, and cast appropriately. You can also hold floats - ;; using Float.floatToIntBits and Float.intBitstoFloat - ;; conversions, and doubles using Double.doubleToLongBits - ;; and Double.longBitsToDouble conversions. - java.util.concurrent.atomic.AtomicBoolean - #_java.util.concurrent.atomic.AtomicByte - #_java.util.concurrent.atomic.AtomicShort - java.util.concurrent.atomic.AtomicInteger - java.util.concurrent.atomic.AtomicLong - #_java.util.concurrent.atomic.AtomicFloat - #_java.util.concurrent.atomic.AtomicDouble - com.google.common.util.concurrent.AtomicDouble))) - -;; TODO finish this below - -(-def m2m-chan? '{:clj #{clojure.core.async.impl.channels.ManyToManyChannel} - :cljs #{cljs.core.async.impl.channels/ManyToManyChannel}}) - -(-def chan? '{:clj #{clojure.core.async.impl.protocols.Channel} - :cljs #{cljs.core.async.impl.channels/ManyToManyChannel - #_"TODO more?"}}) - -(-def keyword? '{:clj #{clojure.lang.Keyword} - :cljs #{cljs.core/Keyword}}) - -(-def symbol? '{:clj #{clojure.lang.Symbol} - :cljs #{cljs.core/Symbol}}) - -(-def file? '{:clj #{java.io.File} - :cljs #{#_js/File}}) ; isn't always available! Use an abstraction - -(-def any? {:clj (uset/union (:clj (preds>types 'prim?)) #{'java.lang.Object}) - :cljs '#{(quote default)}}) - -(-def comparable? {:clj (uset/union '#{byte char short int long float double} '#{Comparable}) - :cljs (:cljs (preds>types 'number?))}) - -(-def record? '{:clj #{clojure.lang.IRecord} - #_:cljs #_#{cljs.core/IRecord}}) ; because can't protocol-dispatch on protocols in CLJS - -(-def transformer? '{:clj #{#_clojure.core.protocols.CollReduce ; no, in order to find most specific type - quantum.untyped.core.reducers.Transformer} - :cljs #{#_cljs.core/IReduce ; CLJS problems with dispatching on protocol - quantum.untyped.core.reducers.Transformer}}) - -#_(-def reducible? (preds>types - 'array? - 'string? - 'record? - 'reducer? - 'chan? - {:cljs (:cljs (preds>types '+map?))} - {:cljs (:cljs (preds>types '+set?))} - 'integer? - {:clj '#{clojure.lang.IReduce - clojure.lang.IReduceInit - clojure.lang.IKVReduce - #_clojure.core.protocols.CollReduce} ; no, in order to find most specific type - #_:cljs #_'#{cljs.core/IReduce}} ; because can't protocol-dispatch on protocols in CLJS - {:clj '#{fast_zip.core.ZipperLocation} - :cljs '#{fast-zip.core/ZipperLocation}})) - -; ----- COLLECTIONS ----- ; - - ;; TODO clojure.lang.Indexed / cljs.core/IIndexed? - (-def indexed? (preds>types string? vector? (isa? clojure.lang.IndexedSeq) array?)) - ;; TODO this might be ambiguous - ;; TODO clojure.lang.Associative / cljs.core/IAssociative? - (-def associative? (preds>types 'map? 'set? 'indexed?)) - ;; TODO this might be ambiguous - ;; TODO clojure.lang.Sequential / cljs.core/ISequential? - (-def sequential? (preds>types 'seq? 'list? 'indexed?)) - ;; TODO this might be ambiguous - ;; TODO clojure.lang.ICollection / cljs.core/ICollection? - (-def counted? (preds>types 'array? 'string? - {:clj (uset/union (:clj (preds>types '!vector? '!!vector? - '!map? '!!map? - '!set? '!!set?)) - '#{clojure.lang.Counted}) - :cljs (:clj (preds>types 'vector? 'map? 'set?))})) - - (-def coll? (preds>types 'sequential? 'associative?)) - - (-def sequential? #?(:clj (or (isa? clojure.lang.Sequential) - (isa? java.util.List)) - )) - - (-def seqable? #?(:clj (or (isa? clojure.lang.ISeq) - (isa? clojure.lang.Seqable) - java-iterable? - char-seq? - map? - array?))) - - ;; Able to be iterated over in some fashion, whether by `first`/`next` seq recursion, reduction, etc. - (-def iterable? (or seqable? reducible?)) - - - (-def true? (value true)) - (-def false? (value false)) -#_(t/def ::form (t/or ::literal t/list? t/vector? ...)) + (-def chan? (isa? #?(:clj clojure.core.async.impl.protocols/Channel + :cljs cljs.core.async.impl.protocols/Channel))) + + (-def keyword? (isa? #?(:clj clojure.lang.Keyword :cljs cljs.core/Keyword))) + (-def symbol? (isa? #?(:clj clojure.lang.Symbol :cljs cljs.core/Symbol))) + + ;; `js/File` isn't always available! Use an abstraction +#?(:clj (-def file? (isa? java.io.File))) + + (-def comparable? #?(:clj (isa? java.lang.Comparable) + ;; TODO other things are comparable; really it depends on the two objects in question + :cljs (or nil? (isa? cljs.core/IComparable)))) + + (-def record? (isa? #?(:clj clojure.lang.IRecord :cljs cljs.core/IRecord))) + + (-def transformer? (isa? quantum.untyped.core.reducers.Transformer)) + +;; ----- Collections ----- ;; + + (-def sorted? #?(:clj (or (isa? #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) + #?@(:clj [(isa? java.util.SortedMap) + (isa? java.util.SortedSet)] + :cljs [(isa? goog.structs.AvlTree)]) + ;; TODO implement — monotonically <, <=, =, >=, > + #_(>expr monotonic?)))) + + (-def transient? (isa? #?(:clj clojure.lang.ITransientCollection + :cljs cljs.core/ITransientCollection))) + + (-def editable? (isa? #?(:clj clojure.lang.IEditableCollection + :cljs cljs.core/IEditableCollection))) + + ;; Indicates efficient lookup by (integer) index (via `get`) + (-def indexed? (or (isa? #?(:clj clojure.lang.Indexed :cljs cljs.core/IIndexed)) + ;; Doesn't guarantee `java.util.List` is implemented, except by + ;; convention + #?(:clj (isa? java.util.RandomAccess)) + #?(:clj char-seq? :cljs string?) + array?)) + + ;; Indicates whether `assoc?!` is supported + (-def associative? (or (isa? #?(:clj clojure.lang.Associative :cljs cljs.core/IAssociative)) + (isa? #?(:clj clojure.lang.ITransientAssociative :cljs cljs.core/ITransientAssociative)) + (or map? indexed?))) + + (-def sequential? (or (isa? #?(:clj clojure.lang.Sequential :cljs cljs.core/ISequential)) + list? indexed?)) + + (-def counted? (or (isa? #?(:clj clojure.lang.Counted :cljs cljs.core/ICounted)) + #?(:clj char-seq? :cljs string?) vector? map? set? array?)) + +#?(:clj (-def java-coll? (isa? java.util.Collection))) + + ;; A group of objects/elements + (-def coll? (or #?(:clj java-coll?) + #?@(:clj [(isa? clojure.lang.IPersistentCollection) + (isa? clojure.lang.ITransientCollection)] + :cljs (isa? cljs.core/ICollection)) + sequential? associative?)) + + (-def iterable? (isa? #?(:clj java.lang.Iterable :cljs cljs.core/IIterable))) + + ;; Whatever is `seqable?` is reducible via a call to `seq`. + ;; Reduction is nearly always preferable to seq-iteration if for no other reason than that + ;; it can take advantage of transducers and reducers. This predicate just answers whether + ;; it is more efficient to reduce than to seq-iterate (note that it should be at least as + ;; efficient as seq-iteration). + (-def prefer-reduce? (or #?(:clj (isa? clojure.lang.IReduceInit :cljs cljs.core/IReduce)) + (isa? #?(:clj clojure.lang.IKVReduce :cljs cljs.core/IKVReduce)) + #?(:clj (isa? clojure.core.protocols/IKVReduce)) + #?(:clj char-seq? :cljs string?) + array? + record? + (isa? #?(:clj fast_zip.core.ZipperLocation :cljs fast-zip.core/ZipperLocation)) + chan?)) + + ;; Whatever is `reducible?` is seqable via a call to `sequence`. + (-def seqable? (or #?@(:clj [(isa? clojure.lang.Seqable) + iterable? + char-seq? + map? + array?] + :cljs [(isa? cljs.core/ISeqable) + array? + string?]))) + + ;; Able to be traversed over in some fashion, whether by `first`/`next` seq-iteration, + ;; reduction, etc. + (-def traversable? (or (isa? #?(:clj clojure.lang.IReduceInit :cljs cljs.core/IReduce)) + (isa? #?(:clj clojure.lang.IKVReduce :cljs cljs.core/IKVReduce)) + #?(:clj (isa? clojure.core.protocols/IKVReduce)) + (isa? #?(:clj clojure.lang.Seqable :cljs cljs.core/ISeqable)) + iterable? + #?(:clj char-seq? :cljs string?) + array? + (isa? #?(:clj fast_zip.core.ZipperLocation :cljs fast-zip.core/ZipperLocation)) + chan?)) + +#_(t/def ::form (t/or ::literal t/list? t/vector? ...)) + +#?(:clj (-def tagged-literal? (isa? clojure.lang.TaggedLiteral))) + + (-def literal? (or nil? boolean? symbol? keyword? string? #?(:clj long?) double? #?(:clj tagged-literal?))) + + +;; ===== Generic ===== ;; + + ;; Standard "uncuttable" types + (-def integral? (or primitive? number?)) ) diff --git a/src-untyped/quantum/untyped/core/type/core.cljc b/src-untyped/quantum/untyped/core/type/core.cljc index d360e5ab..22d1ff79 100644 --- a/src-untyped/quantum/untyped/core/type/core.cljc +++ b/src-untyped/quantum/untyped/core/type/core.cljc @@ -17,9 +17,9 @@ :refer [>ex-info]] [quantum.untyped.core.fn :refer [<- fn->>]] - [quantum.untyped.core.type.defs :as utdef] [quantum.untyped.core.vars - :refer [defalias]])) + :refer [defalias]] + [quantum.untyped.core.type.defs :as utdef])) (def class #?(:clj clojure.core/class :cljs type)) @@ -55,7 +55,7 @@ Byte/TYPE Byte Character/TYPE Character Double/TYPE Double - Void/TYPE Void })) + Void/TYPE Void})) #?(:clj (def unboxed->convertible @@ -90,15 +90,25 @@ (def unboxed-type-map (zipmap (vals boxed-type-map) (keys boxed-type-map)))) -(def prim-types (-> utdef/types (get 'prim?))) -(def prim-types|unevaled (-> utdef/types|unevaled :clj (get 'prim?))) -(def primitive-types (-> utdef/types (get 'primitive?))) -(def primitive-types|unevaled (-> utdef/types|unevaled :clj (get 'primitive?))) -(def primitive-boxed-types (-> utdef/types (get 'primitive-boxed?))) -(def primitive-boxed-types|unevaled (-> utdef/types|unevaled :clj (get 'primitive-boxed?))) +(def prim-types #?(:clj #{Boolean/TYPE Byte/TYPE Character/TYPE + Short/TYPE Integer/TYPE Long/TYPE + Float/TYPE Double/TYPE} + :cljs #{js/Boolean js/Number})) +(def prim-types|unevaled '#{boolean byte char short int long float double}) + +(def primitive-boxed-types #?(:clj #{Boolean Byte Character Short Integer Long Float Double} + :cljs #{js/Boolean js/Number})) +(def primitive-boxed-types|unevaled #?(:clj '#{java.lang.Boolean java.lang.Byte java.lang.Character + java.lang.Short java.lang.Integer java.lang.Long + java.lang.Float java.lang.Double} + :cljs '#{js/Boolean js/Number})) + +(def primitive-types (set/union prim-types primitive-boxed-types)) +(def primitive-types|unevaled (set/union prim-types|unevaled primitive-boxed-types|unevaled)) (def prim|unevaled? #(contains? prim-types|unevaled %)) (def primitive|unevaled? #(contains? primitive-types|unevaled %)) + #?(:clj (def auto-unboxable|unevaled? #(contains? primitive-boxed-types|unevaled %)) :cljs (defn auto-unboxable|unevaled? [x] (throw (>ex-info :unsupported "`auto-unboxable?` not supported by CLJS")))) @@ -114,7 +124,16 @@ :cljs #{ubytes ubytes-clamped ushorts uints bytes shorts ints floats doubles}}) (def cljs-typed-array-convertible-classes - (let [cljs-typed-array-types (-> utdef/array-1d-types :cljs (dissoc :object)) + (let [cljs-typed-array-types '{:byte js/Int8Array + :ubyte js/Uint8Array + :ubyte-clamped js/Uint8ClampedArray + :char js/Uint16Array ; kind of + :ushort js/Uint16Array + :short js/Int16Array + :int js/Int32Array + :uint js/Uint32Array + :float js/Float32Array + :double js/Float64Array} generalize-type (fn->> name str/lower-case (remove #{\u}))] (->> cljs-typed-array-types (reduce @@ -129,6 +148,17 @@ (def java-array-type-regex #"(\[+)(?:(Z|S|B|C|I|J|F|D)|(?:L(.+);))") ; TODO create this regex dynamically +#?(:clj +(defn array-depth-equal? + "Efficiency prioritized because this fn is used a lot in `untyped.core.type/compare|class|class`" + [^Class class0 ^Class class1] + (let [s0 (.getName class0) s1 (.getName class1)] + (loop [i 0] + (let [c0 (.charAt s0 i) c1 (.charAt s1 i) + c0? (identical? c0 \[) c1? (identical? c1 \[)] + (or (and (not c0?) (not c1?)) + (and c0? c1? (recur (unchecked-inc i))))))))) + #?(:clj (defn nth-elem-type|clj "`x` must be Java array type (for now) @@ -151,7 +181,7 @@ (symbol ?object-type) (str (apply str (drop n brackets)) "L" ?object-type ";")))))) -(def default-types (-> utdef/types|unevaled (get ucore/lang) :any)) +(def default-types '#{#?(:clj java.lang.Object :cljs (quote default))}) (defn ->boxed|sym [t] #?(:clj (if-let [boxed (get boxed-type-map t)] boxed t) @@ -197,12 +227,8 @@ double java.lang.Double/TYPE})}) #?(:clj -(defn class>prim-subclasses - {:examples '{(class>prim-subclasses Number) - #{utdef/long utdef/int utdef/short utdef/byte utdef/float utdef/double}}} - [^Class c] - (let [boxed-types (get-in utdef/types [:clj 'primitive-boxed?])] - (->> boxed-types - (r/filter #(isa? % c)) - (r/map boxed->unboxed) - (into #{}))))) +(defn class>prim-subclasses [^Class c] + (->> primitive-boxed-types + (r/filter #(isa? % c)) + (r/map boxed->unboxed) + (into #{})))) diff --git a/src-untyped/quantum/untyped/core/type/defs.cljc b/src-untyped/quantum/untyped/core/type/defs.cljc index 75901ac1..8552b2c6 100644 --- a/src-untyped/quantum/untyped/core/type/defs.cljc +++ b/src-untyped/quantum/untyped/core/type/defs.cljc @@ -35,8 +35,6 @@ goog.structs.AvlTree goog.structs.Queue]))) -;; TODO transition all predicates in file to `t/`s once the old `defnt` is done away with - #?(:clj (def boolean Boolean/TYPE)) #?(:clj (def byte Byte/TYPE)) #?(:clj (def char Character/TYPE)) @@ -46,7 +44,81 @@ #?(:clj (def float Float/TYPE)) #?(:clj (def double Double/TYPE)) -(def primitive-type-meta quantum.untyped.core.type/unboxed-symbol->type-meta) +(def ^{:doc "Could do /MAX_VALUE for the maxes in Java but JS doesn't like it of course + In JavaScript, all numbers are 64-bit floating point numbers. + This means you can't represent in JavaScript all the Java longs + Max 'safe' int: (dec (Math/pow 2 53))"} + unboxed-symbol->type-meta + {'boolean {:bits 1 + :min 0 + :max 1 + #?@(:clj [:array-ident "Z" + :outer-type "[Z" + :boxed java.lang.Boolean + :unboxed Boolean/TYPE])} + 'byte {:bits 8 + :min -128 + :max 127 + #?@(:clj [:array-ident "B" + :outer-type "[B" + :boxed java.lang.Byte + :unboxed Byte/TYPE])} + 'short {:bits 16 + :min -32768 + :max 32767 + #?@(:clj [:array-ident "S" + :outer-type "[S" + :boxed java.lang.Short + :unboxed Short/TYPE])} + 'char {:bits 16 + :min 0 + :max 65535 + #?@(:clj [:array-ident "C" + :outer-type "[C" + :boxed java.lang.Character + :unboxed Character/TYPE])} + 'int {:bits 32 + :min -2147483648 + :max 2147483647 + #?@(:clj [:array-ident "I" + :outer-type "[I" + :boxed java.lang.Integer + :unboxed Integer/TYPE])} + 'long {:bits 64 + :min -9223372036854775808 + :max 9223372036854775807 + #?@(:clj [:array-ident "J" + :outer-type "[J" + :boxed java.lang.Long + :unboxed Long/TYPE])} + ; Technically with floating-point nums, "min" isn't the most negative; + ; it's the smallest absolute + 'float {:bits 32 + :min-absolute 1.4E-45 + :min -3.4028235E38 + :max 3.4028235E38 + :min-int -16777216 ; -2^24 + :max-int 16777216 ; 2^24 + #?@(:clj [:array-ident "F" + :outer-type "[F" + :boxed java.lang.Float + :unboxed Float/TYPE])} + 'double {:bits 64 + ; Because: + ; Double/MIN_VALUE = 4.9E-324 + ; (.-MIN_VALUE js/Number) = 5e-324 + :min-absolute #?(:clj Double/MIN_VALUE + :cljs (.-MIN_VALUE js/Number)) + :min -1.7976931348623157E308 + :max 1.7976931348623157E308 ; Max number in JS + :min-int -9007199254740992 ; -2^53 + :max-int 9007199254740992 ; 2^53 + #?@(:clj [:array-ident "D" + :outer-type "[D" + :boxed java.lang.Double + :unboxed Double/TYPE])}}) + +(def primitive-type-meta unboxed-symbol->type-meta) (def array-ident->primitive-sym (->> unboxed-symbol->type-meta (map (juxt (rcomp val :array-ident) key)) (into {}))) @@ -95,440 +167,3 @@ #?(:clj (def class->str (fn-> str (.substring 6)))) -(defn >array-nd-types [n] - {:boolean (symbol (str (apply str (repeat n \[)) "Z")) - :byte (symbol (str (apply str (repeat n \[)) "B")) - :char (symbol (str (apply str (repeat n \[)) "C")) - :short (symbol (str (apply str (repeat n \[)) "S")) - :int (symbol (str (apply str (repeat n \[)) "I")) - :long (symbol (str (apply str (repeat n \[)) "J")) - :float (symbol (str (apply str (repeat n \[)) "F")) - :double (symbol (str (apply str (repeat n \[)) "D")) - :object (symbol (str (apply str (repeat n \[)) "Ljava.lang.Object;"))}) - -#_(t/def ::lang->type (t/map-of t/keyword? (t/set-of symbol?))) - -;; Mainly for CLJ use within macros for doing type-related things with CLJS -(defonce *types|unevaled (atom {})) - -;; Empty in CLJS, but may be used later so not excising -(defonce *types (atom {})) - -(defn reg-pred! [pred-sym #_t/symbol? data|unevaled #_::lang->type] - (swap! *types|unevaled - (fn [types|unevaled] - (reduce (fn [ret [lang types-for-lang]] (cond-> ret (seq types-for-lang) (assoc-in [lang pred-sym] types-for-lang))) - types|unevaled - data|unevaled))) -#?(:clj (swap! *types assoc-in [:clj pred-sym] (-> data|unevaled :clj eval))) - true) - -(defn reg-preds! [pred->lang->type] - (doseq [[pred lang->type] pred->lang->type] - (reg-pred! pred lang->type))) - -(defn- retrieve [lang #_t/keyword? preds] - (->> preds (map #(get-in @*types|unevaled [lang %])) (remove empty?) (apply uset/union))) - -(defn- preds>types [& preds] - {:clj (retrieve :clj preds) - :cljs (retrieve :cljs preds)}) - -(defn- types-union [& lang->types] - {:clj (->> lang->types (map :clj) (apply uset/union)) - :cljs (->> lang->types (map :cljs) (apply uset/union))}) - -; ===== MAPS ===== ; Associative - -; ----- Generators ----- ; - -(defn- >fastutil-package [x] - (if (= x 'ref) "objects" (str (name x) "s"))) - -(defn- >fastutil-long-form [x] - (if (= x 'ref) "Reference" (-> x name str/capitalize))) - -(defn- >lang->type|!map [k-type #_t/symbol? v-type #_t/symbol? suffixes #_(t/seqable-of t/string?)] #_> #_::lang->type - (let [fastutil-class-name-base - (str "it.unimi.dsi.fastutil." (>fastutil-package k-type) - "." (>fastutil-long-form k-type) "2" (>fastutil-long-form v-type))] - {:clj (->> suffixes - (map #(symbol (str fastutil-class-name-base %))) - set)})) - -(defn- >pred->lang->type|!map|base - [prefix #_(? t/string?) - >lang->type #_(t/spec t/fn? "Generates the `lang->type` corresponding to key and value map types") - ref->ref #_::lang->type] - (let [?prefix (when prefix (str prefix "-")) - base-types (conj (keys unboxed-symbol->type-meta) 'ref) - type-combos (->> base-types - (<- (combo/selections 2)) - ;; No `boolean->*` maps exist in fastutil, for obvious reasons - (remove (fn-> first (= 'boolean)))) - ;; To generate a map predicate symbol when `k-type` and `v-type` are the same - >same-pred-sym (fn [t] (symbol (str "!" ?prefix "map|" t "?"))) - >map-pred-sym (fn [[k-type v-type]] (symbol (str "!" ?prefix "map|" k-type "->" v-type "?"))) - pred->lang->type|combos - (->> type-combos - (map (fn [[k-type v-type]] - (let [pred-sym (>map-pred-sym [k-type v-type]) - lang->type (>lang->type k-type v-type)] - (cond-> (om pred-sym lang->type) - (= k-type v-type) (assoc (>same-pred-sym k-type) lang->type))))) - (reduce into (om))) - pred->lang->type|any - (->> base-types - (map (fn [t] - (let [any-key-sym (symbol (str "!" ?prefix "map|" "any" "->" t "?")) - any-val-sym (symbol (str "!" ?prefix "map|" t "->" "any" "?")) - preds>types|any - (fn [getf] (->> type-combos - (filter (fn-> getf (= t))) - (map >map-pred-sym) - (map (fn [pred-sym] (get pred->lang->type|combos pred-sym))) - (apply types-union)))] - (om any-key-sym (preds>types|any second) - any-val-sym (preds>types|any first))))) - (reduce into (om))) - pred->lang->type|ref - (om (>map-pred-sym ['ref 'ref]) ref->ref - (>same-pred-sym 'ref) ref->ref) - pred->lang->type|non-general - (reduce into (om) [pred->lang->type|combos pred->lang->type|any pred->lang->type|ref]) - pred->lang->type|general - (om (symbol (str "!" ?prefix "map?")) (apply types-union (vals pred->lang->type|non-general)))] - (reduce into (om) [pred->lang->type|non-general pred->lang->type|general]))) - -(defn- >pred->lang->type|!hash-map [lang->type|ref->ref] - (>pred->lang->type|!map|base "hash" - (fn [k-type #_t/symbol? v-type #_t/symbol?] (>lang->type|!map k-type v-type #{"OpenHashMap" "OpenCustomHashMap"})) - lang->type|ref->ref)) - -;; TODO this is dependent on state of `*types|unevaled` -(defn- >pred->lang->type|!unsorted-map [] - (>pred->lang->type|!map|base "unsorted" - (fn [k-type #_t/symbol? v-type #_t/symbol?] (preds>types (symbol (str "!hash-map|" k-type "->" v-type "?")))) - (preds>types '!hash-map|ref?))) - -(defn- >pred->lang->type|!sorted-map [lang->type|ref->ref] - (>pred->lang->type|!map|base "sorted" (fn [k-type v-type] {}) lang->type|ref->ref)) - -;; TODO this is dependent on state of `*types|unevaled` -(defn- >pred->lang->type|!map [] - ;; technically also `object` for CLJS - (>pred->lang->type|!map|base nil (fn [k-type #_t/symbol? v-type #_t/symbol?] (>lang->type|!map k-type v-type #{"Map"})) - (preds>types '!unsorted-map|ref? '!sorted-map|ref?))) - -(defn- >lang->type|!set [t suffixes] #_> #_::lang->type - (let [fastutil-class-name-base - (str "it.unimi.dsi.fastutil." (>fastutil-package t) "." (>fastutil-long-form t))] - {:clj (->> suffixes - (map #(symbol (str fastutil-class-name-base %))) - set)})) - -(defn- >pred->lang->type|!set|base - [prefix #_(? t/string?) - >lang->type #_(t/spec t/fn? "Generates the `lang->type` corresponding to Set type") - lang->type|ref #_::lang->type] - (let [?prefix (when prefix (str prefix "-")) - pred->lang->type|base - (->> (conj (keys unboxed-symbol->type-meta) 'ref) - ;; No `boolean` sets exist in fastutil, for obvious reasons - (remove (fn= 'boolean)) - (map (fn [t] - (let [pred-sym (symbol (str "!" ?prefix "set|" t "?")) - lang->type (>lang->type t)] - [pred-sym lang->type]))) - (into (om)))] - (assoc pred->lang->type|base - (symbol (str "!" ?prefix "set|ref?")) lang->type|ref - (symbol (str "!" ?prefix "set?")) (apply types-union (vals pred->lang->type|base))))) - -(defn- >pred->lang->type|!hash-set [lang->type|ref] - (>pred->lang->type|!set|base "hash" - (fn [t] (>lang->type|!set t #{"OpenHashSet" #_"OpenCustomHashSet"})) - lang->type|ref)) - -;; TODO this is dependent on state of `*types|unevaled` -(defn- >pred->lang->type|!unsorted-set [] - (>pred->lang->type|!set|base "unsorted" - (fn [t] (preds>types (symbol (str "!hash-set|" t "?")))) - (preds>types '!hash-set|ref?))) - -(defn- >pred->lang->type|!sorted-set [lang->type|ref] - (>pred->lang->type|!set|base "sorted" (fn [t] {}) lang->type|ref)) - -;; TODO this is dependent on state of `*types|unevaled` -(defn- >pred->lang->type|!set [] - (>pred->lang->type|!set|base nil (fn [t] (>lang->type|!set t #{"Set"})) - (preds>types '!unsorted-set|ref? '!sorted-set|ref?))) - -; ----- ; - -(reg-pred! '+array-map? '{:clj #{clojure.lang.PersistentArrayMap} - :cljs #{cljs.core/PersistentArrayMap}}) -(reg-pred! '!+array-map? '{:clj #{clojure.lang.PersistentArrayMap$TransientArrayMap} - :cljs #{cljs.core/TransientArrayMap}}) -(reg-pred! '?!+array-map? (preds>types '!+array-map? '+array-map?)) -(reg-pred! '!array-map? {}) -(reg-pred! '!!array-map? {}) -(reg-pred! 'array-map? (preds>types '?!+array-map? '!array-map? '!!array-map?)) - -(reg-pred! '+hash-map? '{:clj #{clojure.lang.PersistentHashMap} - :cljs #{cljs.core/PersistentHashMap}}) -(reg-pred! '!+hash-map? '{:clj #{clojure.lang.PersistentHashMap$TransientHashMap} - :cljs #{cljs.core/TransientHashMap}}) -(reg-pred! '?!+hash-map? (preds>types '!+hash-map? '+hash-map?)) - -(reg-preds! - (>pred->lang->type|!hash-map - '{:clj #{java.util.HashMap - java.util.IdentityHashMap - it.unimi.dsi.fastutil.objects.Reference2ReferenceOpenHashMap - it.unimi.dsi.fastutil.objects.Reference2ReferenceOpenCustomHashMap} - :cljs #{goog.structs.Map}})) - -(reg-pred! '!!hash-map? '{:clj #{java.util.concurrent.ConcurrentHashMap}}) -(reg-pred! 'hash-map? (preds>types '?!+hash-map? '!hash-map? '!!hash-map?)) - -(reg-pred! '+unsorted-map? (preds>types '+hash-map? '+array-map?)) -(reg-pred! '!+unsorted-map? (preds>types '!+hash-map? '!+array-map?)) -(reg-pred! '?!+unsorted-map? (preds>types '?!+hash-map? '?!+array-map?)) - -(reg-preds! (>pred->lang->type|!unsorted-map)) - -(reg-pred! '!!unsorted-map? (preds>types '!!hash-map?)) -(reg-pred! 'unsorted-map? (preds>types '?!+unsorted-map? '!unsorted-map? '!!unsorted-map?)) - -(reg-pred! '+sorted-map? '{:clj #{clojure.lang.PersistentTreeMap} - :cljs #{cljs.core/PersistentTreeMap}}) -(reg-pred! '!+sorted-map? {}) -(reg-pred! '?!+sorted-map? (preds>types '+sorted-map? '!+sorted-map?)) - -(reg-preds! - (>pred->lang->type|!sorted-map - '{:clj #{java.util.TreeMap} - :cljs #{goog.structs.AvlTree}})) - -(reg-pred! '!!sorted-map? {}) -(reg-pred! 'sorted-map? {:clj (uset/union (:clj (preds>types '?!+sorted-map?)) - '#{java.util.SortedMap}) - :cljs (:cljs (preds>types '+sorted-map? '!sorted-map?))}) - -(reg-pred! '!insertion-ordered-map? {:clj '#{java.util.LinkedHashMap}}) -(reg-pred! '+insertion-ordered-map? {:clj '#{flatland.ordered.map.OrderedMap}}) -(reg-pred! 'insertion-ordered-map? (preds>types '!insertion-ordered-map? - '+insertion-ordered-map?)) - -(reg-pred! '!+map? {:clj '#{clojure.lang.ITransientMap} - :cljs (:cljs (preds>types '!+unsorted-map?))}) -(reg-pred! '+map? {:clj '#{clojure.lang.IPersistentMap} - :cljs (:cljs (preds>types '+unsorted-map? '+sorted-map?))}) -(reg-pred! '?!+map? (preds>types '!+map? '+map?)) - -(reg-preds! (>pred->lang->type|!map)) - -(reg-pred! '!!map? (preds>types '!!unsorted-map? '!!sorted-map?)) -(reg-pred! 'map? {:clj (uset/union (:clj (preds>types '!+map?)) - '#{;;' TODO IPersistentMap as well, yes, but all persistent Clojure maps implement java.util.Map - ;; TODO add typed maps into this definition once lazy compilation is in place - java.util.Map}) - :cljs (:cljs (preds>types '?!+map? '!map? '!!map?))}) - -; ===== SETS ===== ; Associative; A special type of Map whose keys and vals are identical - -(reg-pred! '+hash-set? '{:clj #{clojure.lang.PersistentHashSet} - :cljs #{cljs.core/PersistentHashSet}}) -(reg-pred! '!+hash-set? '{:clj #{clojure.lang.PersistentHashSet$TransientHashSet} - :cljs #{cljs.core/TransientHashSet}}) -(reg-pred! '?!+hash-set? (preds>types '!+hash-set? '+hash-set?)) - -(reg-preds! - (>pred->lang->type|!hash-set - '{:clj #{java.util.HashSet - #_java.util.IdentityHashSet} - :cljs #{goog.structs.Set}})) - -(reg-pred! '!!hash-set? {}) ; technically you can make something from ConcurrentHashMap but... -(reg-pred! 'hash-set? (preds>types '?!+hash-set? '!hash-set? '!!hash-set?)) - -(reg-pred! '+unsorted-set? (preds>types '+hash-set?)) -(reg-pred! '!+unsorted-set? (preds>types '!+hash-set?)) -(reg-pred! '?!+unsorted-set? (preds>types '?!+hash-set?)) - -(reg-preds! (>pred->lang->type|!unsorted-set)) - -(reg-pred! '!!unsorted-set? (preds>types '!!hash-set?)) -(reg-pred! 'unsorted-set? (preds>types 'hash-set?)) - -(reg-pred! '+sorted-set? '{:clj #{clojure.lang.PersistentTreeSet} - :cljs #{cljs.core/PersistentTreeSet}}) -(reg-pred! '!+sorted-set? {}) -(reg-pred! '?!+sorted-set? (preds>types '+sorted-set? '!+sorted-set?)) - -(reg-preds! - (>pred->lang->type|!sorted-set - '{:clj #{java.util.TreeSet}})) ; CLJS can have via AVLTree with same KVs - -(reg-pred! '!!sorted-set? {}) -(reg-pred! 'sorted-set? {:clj (uset/union (:clj (preds>types '+sorted-set?)) - '#{java.util.SortedSet}) - :cljs (:cljs (preds>types '+sorted-set? '!sorted-set? '!!sorted-set?))}) - -(reg-pred! '!+set? {:clj '#{clojure.lang.ITransientSet} - :cljs (:cljs (preds>types '!+unsorted-set?))}) -(reg-pred! '+set? {:clj '#{clojure.lang.IPersistentSet} - :cljs (:cljs (preds>types '+unsorted-set? '+sorted-set?))}) -(reg-pred! '?!+set? (preds>types '!+set? '+set?)) - -(reg-preds! (>pred->lang->type|!set)) - -(reg-pred! '!set|int? {:clj '#{it.unimi.dsi.fastutil.ints.IntSet}}) -(reg-pred! '!set|long? {:clj '#{it.unimi.dsi.fastutil.longs.LongSet}}) -(reg-pred! '!set|double? {:clj '#{it.unimi.dsi.fastutil.doubles.DoubleSet}}) -(reg-pred! '!set|ref? (preds>types '!unsorted-set|ref? '!sorted-set|ref?)) -(reg-pred! '!set? (preds>types '!unsorted-set? '!sorted-set?)) -(reg-pred! '!!set? (preds>types '!!unsorted-set? '!!sorted-set?)) -(reg-pred! 'set? {:clj (uset/union (:clj (preds>types '!+set?)) - '#{;; TODO IPersistentSet as well, yes, but all persistent Clojure sets implement java.util.Set - java.util.Set}) - :cljs (:clj (preds>types '?!+set? '!set? '!!set?))}) - -; ===== ARRAYS ===== ; -; TODO do e.g. {:clj {0 {:byte ...}}} -(def array-1d-types {:clj {:boolean (symbol "[Z") - :byte (symbol "[B") - :char (symbol "[C") - :short (symbol "[S") - :long (symbol "[J") - :float (symbol "[F") - :int (symbol "[I") - :double (symbol "[D") - :object (symbol "[Ljava.lang.Object;")} - :cljs '{:byte js/Int8Array - :ubyte js/Uint8Array - :ubyte-clamped js/Uint8ClampedArray - :char js/Uint16Array ; kind of - :ushort js/Uint16Array - :short js/Int16Array - :int js/Int32Array - :uint js/Uint32Array - :float js/Float32Array - :double js/Float64Array - :object js/Array}}) - -(reg-pred! 'undistinguished-array-1d? (->> array-1d-types (map (fn [[k v]] [k (-> v vals set)])) (into {}))) - -(def array-2d-types {:clj (>array-nd-types 2 )}) -(def array-3d-types {:clj (>array-nd-types 3 )}) -(def array-4d-types {:clj (>array-nd-types 4 )}) -(def array-5d-types {:clj (>array-nd-types 5 )}) -(def array-6d-types {:clj (>array-nd-types 6 )}) -(def array-7d-types {:clj (>array-nd-types 7 )}) -(def array-8d-types {:clj (>array-nd-types 8 )}) -(def array-9d-types {:clj (>array-nd-types 9 )}) -(def array-10d-types {:clj (>array-nd-types 10)}) -(reg-pred! 'array? (types-union (->> array-1d-types (map (fn [[k v]] [k (-> v vals set)])) (into {})) - (->> array-2d-types (map (fn [[k v]] [k (-> v vals set)])) (into {})) - (->> array-3d-types (map (fn [[k v]] [k (-> v vals set)])) (into {})) - (->> array-4d-types (map (fn [[k v]] [k (-> v vals set)])) (into {})) - (->> array-5d-types (map (fn [[k v]] [k (-> v vals set)])) (into {})) - (->> array-6d-types (map (fn [[k v]] [k (-> v vals set)])) (into {})) - (->> array-7d-types (map (fn [[k v]] [k (-> v vals set)])) (into {})) - (->> array-8d-types (map (fn [[k v]] [k (-> v vals set)])) (into {})) - (->> array-9d-types (map (fn [[k v]] [k (-> v vals set)])) (into {})) - (->> array-10d-types (map (fn [[k v]] [k (-> v vals set)])) (into {})))) - -(reg-pred! 'booleans? {:clj #{(-> array-1d-types :clj :boolean)}}) -(reg-pred! 'boolean-array? (preds>types 'booleans?)) -(reg-pred! 'bytes? {:clj #{(-> array-1d-types :clj :byte )} :cljs #{(-> array-1d-types :cljs :byte )}}) -(reg-pred! 'byte-array? (preds>types 'bytes?)) -(reg-pred! 'ubytes? { :cljs #{(-> array-1d-types :cljs :ubyte )}}) -(reg-pred! 'ubyte-array? (preds>types 'ubytes?)) -(reg-pred! 'ubytes-clamped? { :cljs #{(-> array-1d-types :cljs :ubyte-clamped)}}) -(reg-pred! 'ubyte-array-clamped? (preds>types 'ubytes-clamped?)) -(reg-pred! 'chars? {:clj #{(-> array-1d-types :clj :char )} :cljs #{(-> array-1d-types :cljs :char )}}) -(reg-pred! 'char-array? (preds>types 'chars?)) -(reg-pred! 'shorts? {:clj #{(-> array-1d-types :clj :short )} :cljs #{(-> array-1d-types :cljs :short )}}) -(reg-pred! 'short-array? (preds>types 'shorts?)) -(reg-pred! 'ushorts? { :cljs #{(-> array-1d-types :cljs :ushort )}}) -(reg-pred! 'ushort-array? (preds>types 'ushorts?)) -(reg-pred! 'ints? {:clj #{(-> array-1d-types :clj :int )} :cljs #{(-> array-1d-types :cljs :int )}}) -(reg-pred! 'int-array? (preds>types 'ints?)) -(reg-pred! 'uints? { :cljs #{(-> array-1d-types :cljs :uint )}}) -(reg-pred! 'uint-array? (preds>types 'uints?)) -(reg-pred! 'longs? {:clj #{(-> array-1d-types :clj :long )} :cljs #{(-> array-1d-types :cljs :long )}}) -(reg-pred! 'long-array? (preds>types 'longs?)) -(reg-pred! 'floats? {:clj #{(-> array-1d-types :clj :float )} :cljs #{(-> array-1d-types :cljs :float )}}) -(reg-pred! 'float-array? (preds>types 'floats?)) -(reg-pred! 'doubles? {:clj #{(-> array-1d-types :clj :double )} :cljs #{(-> array-1d-types :cljs :double )}}) -(reg-pred! 'double-array? (preds>types 'doubles?)) -(reg-pred! 'objects? {:clj #{(-> array-1d-types :clj :object )} :cljs #{(-> array-1d-types :cljs :object )}}) -(reg-pred! 'object-array? (preds>types 'objects?)) - -(reg-pred! 'array-1d? {:clj (->> array-1d-types :clj vals set) - :cljs (->> array-1d-types :cljs vals set)}) - - -(reg-pred! 'numeric-1d? (preds>types 'bytes? 'ubytes? 'ubytes-clamped? - 'chars? - 'shorts? 'ints? 'uints? 'longs? - 'floats? 'doubles?)) - -(reg-pred! 'booleans-2d? {:clj #{(-> array-2d-types :clj :boolean)} :cljs #{(-> array-2d-types :cljs :boolean)}}) -(reg-pred! 'bytes-2d? {:clj #{(-> array-2d-types :clj :byte )} :cljs #{(-> array-2d-types :cljs :byte )}}) -(reg-pred! 'chars-2d? {:clj #{(-> array-2d-types :clj :char )} :cljs #{(-> array-2d-types :cljs :char )}}) -(reg-pred! 'shorts-2d? {:clj #{(-> array-2d-types :clj :short )} :cljs #{(-> array-2d-types :cljs :short )}}) -(reg-pred! 'ints-2d? {:clj #{(-> array-2d-types :clj :int )} :cljs #{(-> array-2d-types :cljs :int )}}) -(reg-pred! 'longs-2d? {:clj #{(-> array-2d-types :clj :long )} :cljs #{(-> array-2d-types :cljs :long )}}) -(reg-pred! 'floats-2d? {:clj #{(-> array-2d-types :clj :float )} :cljs #{(-> array-2d-types :cljs :float )}}) -(reg-pred! 'doubles-2d? {:clj #{(-> array-2d-types :clj :double )} :cljs #{(-> array-2d-types :cljs :double )}}) -(reg-pred! 'objects-2d? {:clj #{(-> array-2d-types :clj :object )} :cljs #{(-> array-2d-types :cljs :object )}}) - -(reg-pred! 'array-2d? {:clj (->> array-2d-types :clj vals set) - :cljs (->> array-2d-types :cljs vals set)}) - -(reg-pred! 'numeric-2d? (preds>types 'bytes-2d? - 'chars-2d? - 'shorts-2d? - 'ints-2d? - 'longs-2d? - 'floats-2d? - 'doubles-2d?)) - -(reg-pred! 'array-3d? {:clj (->> array-3d-types :clj vals set) - :cljs (->> array-3d-types :cljs vals set)}) -(reg-pred! 'array-4d? {:clj (->> array-4d-types :clj vals set) - :cljs (->> array-4d-types :cljs vals set)}) -(reg-pred! 'array-5d? {:clj (->> array-5d-types :clj vals set) - :cljs (->> array-5d-types :cljs vals set)}) -(reg-pred! 'array-6d? {:clj (->> array-6d-types :clj vals set) - :cljs (->> array-6d-types :cljs vals set)}) -(reg-pred! 'array-7d? {:clj (->> array-7d-types :clj vals set) - :cljs (->> array-7d-types :cljs vals set)}) -(reg-pred! 'array-8d? {:clj (->> array-8d-types :clj vals set) - :cljs (->> array-8d-types :cljs vals set)}) -(reg-pred! 'array-9d? {:clj (->> array-9d-types :clj vals set) - :cljs (->> array-9d-types :cljs vals set)}) -(reg-pred! 'array-10d? {:clj (->> array-10d-types :clj vals set) - :cljs (->> array-10d-types :cljs vals set)}) - -(reg-pred! 'objects-nd? {:clj #{(-> array-1d-types :clj :object ) - (-> array-2d-types :clj :object ) - (-> array-3d-types :clj :object ) - (-> array-4d-types :clj :object ) - (-> array-5d-types :clj :object ) - (-> array-6d-types :clj :object ) - (-> array-7d-types :clj :object ) - (-> array-8d-types :clj :object ) - (-> array-9d-types :clj :object ) - (-> array-10d-types :clj :object ) } - :cljs (:cljs (preds>types 'objects?))}) - -;; ===== Predicates ===== ;; - -;; TODO this is just a temporary thing and breaks extensibility -(def types @*types) -;; TODO this is just a temporary thing and breaks extensibility -(def types|unevaled @*types|unevaled) From b64bd62d7697550f33b9d7abbfda39e149ccae69 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 17 Apr 2018 22:28:42 -0600 Subject: [PATCH 014/810] typed `!vector?` --- src-dev/quantum/core/defnt.cljc | 11 +- src-dev/quantum/core/defnt_equivalences.cljc | 7 +- src-untyped/quantum/untyped/core/type.cljc | 107 ++++++++++--------- src/quantum/core/test.cljc | 2 - src/quantum/core/type/defs.cljc | 2 +- test/quantum/test/core/untyped/type.cljc | 1 - 6 files changed, 70 insertions(+), 60 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 5fc3322f..923b404f 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -203,6 +203,13 @@ (c/map+ #(class>most-primitive-class % nilable?)) (join #{}))))) +#?(:clj +(defn spec>most-primitive-class [spec #_t/spec?] #_> #_(? class?) + (let [cs (spec>most-primitive-classes spec)] + (if (-> cs count (not= 1)) + (err! "Not exactly 1 class found" (kw-map spec cs)) + (first cs))))) + #?(:clj (defn out-spec>class [spec #_t/spec?] (let [cs (t/spec>classes spec) cs' (disj cs nil)] @@ -755,8 +762,8 @@ {:env env :form form :caller caller|expr - :args args|analyzed - :spec ...})))))) + :args args + :spec spec})))))) (defn analyze-seq [env form] {:post [(prl! %)]} diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index a5b9dc8d..2dfa4c1f 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -6,8 +6,6 @@ [clojure.core :as c] [quantum.core.defnt :refer [analyze defnt fnt|code *fn->spec]] - [quantum.core.macros - :refer [macroexpand-all case-env env-lang quote+]] [quantum.core.spec :as s] [quantum.core.test :as test :refer [deftest testing is is= throws]] @@ -18,6 +16,8 @@ :refer [code=]] [quantum.untyped.core.form :refer [$]] + [quantum.untyped.core.form.evaluate + :refer [case-env env-lang macroexpand-all]] [quantum.untyped.core.form.type-hint :refer [tag]] [quantum.untyped.core.logic @@ -33,9 +33,6 @@ quantum.core.data.Array quantum.core.Primitive)) -(require '[quantum.core.spec :as s] - '[quantum.core.fn :refer [fn->]]) - ;; =====|=====|=====|=====|===== ;; (is (code= diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 0a970757..7f89d774 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -4,13 +4,14 @@ (:refer-clojure :exclude [< <= = not= >= > == compare * - and or not - boolean byte char short int long float double - boolean? byte? char? short? int? long? float? double? + boolean byte char short int long float double + boolean? byte? bytes? char? short? int? long? float? double? isa? nil? any? class? tagged-literal? #?(:cljs object?) number? decimal? bigdec? integer? ratio? true? false? keyword? string? symbol? - associative? coll? indexed? list? map? map-entry? record? seq? seqable? set? sorted? vector? + associative? coll? counted? indexed? list? map? map-entry? record? + seq? seqable? sequential? set? sorted? vector? fn? ifn? meta ref volatile?]) (:require @@ -67,8 +68,6 @@ #_(defmacro range-of) -(do - (defonce *spec-registry (atom {})) (swap! *spec-registry empty) @@ -1312,7 +1311,7 @@ (defn >array-nd-types [n] (->> '[boolean byte char short int long float double object] (map #(>array-nd-type % n)) - (apply or))) + (apply or)))) (-def booleans? #?(:clj (>array-nd-type 'boolean 1) :cljs none?)) (-def bytes? #?(:clj (>array-nd-type 'byte 1) :cljs (isa? js/Int8Array))) @@ -1413,12 +1412,23 @@ :cljs cljs.core/ITransientVector))) (-def ?!+vector? (or +vector? ?!+vector?)) - ;; TODO complete this -#?(:clj (-def !vector|long? (isa? it.unimi.dsi.fastutil.longs.LongArrayList))) - (-def !vector|ref? (isa? #?(:clj java.util.ArrayList - ;; because supports .push etc. - :cljs js/Array))) - (-def !vector? (or !vector|long? !vector|ref?)) + (-def !vector|byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.ByteArrayList) :cljs none?)) + (-def !vector|short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.ShortArrayList) :cljs none?)) + (-def !vector|char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.CharArrayList) :cljs none?)) + (-def !vector|int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.IntArrayList) :cljs none?)) + (-def !vector|long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.LongArrayList) :cljs none?)) + (-def !vector|float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.FloatArrayList) :cljs none?)) + (-def !vector|double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.DoubleArrayList) :cljs none?)) + + (-def !vector|ref? #?(:clj (or (isa? java.util.ArrayList) + (isa? it.unimi.dsi.fastutil.objects.ReferenceArrayList)) + ;; because supports .push etc. + :cljs (isa? js/Array))) + + (-def !vector? (or !vector|ref? + !vector|byte? !vector|short? !vector|char? + !vector|int? !vector|long? + !vector|float? !vector|double?)) ;; java.util.Vector is deprecated, because you can ;; just create a synchronized wrapper over an ArrayList @@ -1437,7 +1447,7 @@ (isa? java.util.concurrent.ConcurrentLinkedQueue)))) (-def !queue? #?(:clj ;; Considered single-threaded mutable unless otherwise noted - (- (isa? java.util.Queue) (or ?!+queue? !!queue?)) + (identity #_- (isa? java.util.Queue) #_(or ?!+queue? !!queue?)) ; TODO re-enable once `-` works :cljs (isa? goog.structs.Queue))) (-def queue? (or ?!+queue? !queue? #?(:clj !!queue?))) @@ -1785,7 +1795,7 @@ +map?)) (-def !+sorted-map? (and (isa? #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) !+map?)) - (-def ?!+sorted-map? (or +sorted-map? !+sorted-map?)) + (-def ?!+sorted-map? none? #_(or +sorted-map? !+sorted-map?)) ; TODO re-enable when `or` implemented properly (-def !sorted-map|boolean->boolean? none?) (-def !sorted-map|boolean->byte? none?) @@ -2046,9 +2056,9 @@ :cljs (isa? goog.structs.Set))) (-def !hash-set? (or !hash-set|ref? - #?@(:clj [!hash-set|byte? !hash-set|short? !hash-set|char? - !hash-set|int? !hash-set|long? - !hash-set|float? !hash-set|double?]))) + !hash-set|byte? !hash-set|short? !hash-set|char? + !hash-set|int? !hash-set|long? + !hash-set|float? !hash-set|double?)) ;; CLJ technically can have via ConcurrentHashMap with same KVs but this hasn't been implemented yet #?(:clj (-def !!hash-set? none?)) @@ -2060,19 +2070,19 @@ (-def !+unsorted-set? !+hash-set?) (-def ?!+unsorted-set? ?!+hash-set?) -#?(:clj (-def !unsorted-set|byte? !hash-set|byte?)) -#?(:clj (-def !unsorted-set|short? !hash-set|char?)) -#?(:clj (-def !unsorted-set|char? !hash-set|short?)) -#?(:clj (-def !unsorted-set|int? !hash-set|int?)) -#?(:clj (-def !unsorted-set|long? !hash-set|long?)) -#?(:clj (-def !unsorted-set|float? !hash-set|float?)) -#?(:clj (-def !unsorted-set|double? !hash-set|double?)) + (-def !unsorted-set|byte? !hash-set|byte?) + (-def !unsorted-set|short? !hash-set|char?) + (-def !unsorted-set|char? !hash-set|short?) + (-def !unsorted-set|int? !hash-set|int?) + (-def !unsorted-set|long? !hash-set|long?) + (-def !unsorted-set|float? !hash-set|float?) + (-def !unsorted-set|double? !hash-set|double?) (-def !unsorted-set|ref? !hash-set|ref?) (-def !unsorted-set? (or !unsorted-set|ref? - #?@(:clj [!unsorted-set|byte? !unsorted-set|short? !unsorted-set|char? - !unsorted-set|int? !unsorted-set|long? - !unsorted-set|float? !unsorted-set|double?]))) + !unsorted-set|byte? !unsorted-set|short? !unsorted-set|char? + !unsorted-set|int? !unsorted-set|long? + !unsorted-set|float? !unsorted-set|double?)) #?(:clj (-def !!unsorted-set? !!hash-set?)) (-def unsorted-set? hash-set?) @@ -2095,9 +2105,9 @@ (-def !sorted-set|ref? #?(:clj (isa? java.util.TreeSet) :cljs none?)) (-def !sorted-set? (or !sorted-set|ref? - #?@(:clj [!sorted-set|byte? !sorted-set|short? !sorted-set|char? - !sorted-set|int? !sorted-set|long? - !sorted-set|float? !sorted-set|double?]))) + !sorted-set|byte? !sorted-set|short? !sorted-set|char? + !sorted-set|int? !sorted-set|long? + !sorted-set|float? !sorted-set|double?)) ;; CLJ technically can have via ConcurrentSkipListMap with same KVs but this hasn't been implemented yet #?(:clj (-def !!sorted-set? none?)) @@ -2142,9 +2152,9 @@ (-def !set|ref? (or !unsorted-set|ref? !sorted-set|ref?)) (-def !set? (or !set|ref? - #?@(:clj [!set|byte? !set|short? !set|char? - !set|int? !set|long? - !set|float? !set|double?]))) + !set|byte? !set|short? !set|char? + !set|int? !set|long? + !set|float? !set|double?)) (-def !set? (or !unsorted-set? !sorted-set?)) #?(:clj (-def !!set? (or !!unsorted-set? !!sorted-set?))) @@ -2220,18 +2230,18 @@ ;; ----- Collections ----- ;; - (-def sorted? #?(:clj (or (isa? #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) - #?@(:clj [(isa? java.util.SortedMap) - (isa? java.util.SortedSet)] - :cljs [(isa? goog.structs.AvlTree)]) - ;; TODO implement — monotonically <, <=, =, >=, > - #_(>expr monotonic?)))) + (-def sorted? #?(:clj (or (isa? #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) + #?@(:clj [(isa? java.util.SortedMap) + (isa? java.util.SortedSet)] + :cljs [(isa? goog.structs.AvlTree)]) + ;; TODO implement — monotonically <, <=, =, >=, > + #_(>expr monotonic?)))) - (-def transient? (isa? #?(:clj clojure.lang.ITransientCollection - :cljs cljs.core/ITransientCollection))) + (-def transient? (isa? #?(:clj clojure.lang.ITransientCollection + :cljs cljs.core/ITransientCollection))) - (-def editable? (isa? #?(:clj clojure.lang.IEditableCollection - :cljs cljs.core/IEditableCollection))) + (-def editable? (isa? #?(:clj clojure.lang.IEditableCollection + :cljs cljs.core/IEditableCollection))) ;; Indicates efficient lookup by (integer) index (via `get`) (-def indexed? (or (isa? #?(:clj clojure.lang.Indexed :cljs cljs.core/IIndexed)) @@ -2268,8 +2278,9 @@ ;; it can take advantage of transducers and reducers. This predicate just answers whether ;; it is more efficient to reduce than to seq-iterate (note that it should be at least as ;; efficient as seq-iteration). - (-def prefer-reduce? (or #?(:clj (isa? clojure.lang.IReduceInit :cljs cljs.core/IReduce)) - (isa? #?(:clj clojure.lang.IKVReduce :cljs cljs.core/IKVReduce)) + ;; TODO re-enable when dispatch enabled + #_(-def prefer-reduce? (or (isa? #?(:clj clojure.lang.IReduceInit :cljs cljs.core/IReduce)) + (isa? #?(:clj clojure.lang.IKVReduce :cljs cljs.core/IKVReduce)) #?(:clj (isa? clojure.core.protocols/IKVReduce)) #?(:clj char-seq? :cljs string?) array? @@ -2289,7 +2300,8 @@ ;; Able to be traversed over in some fashion, whether by `first`/`next` seq-iteration, ;; reduction, etc. - (-def traversable? (or (isa? #?(:clj clojure.lang.IReduceInit :cljs cljs.core/IReduce)) + ;; TODO re-enable when dispatch enabled + #_(-def traversable? (or (isa? #?(:clj clojure.lang.IReduceInit :cljs cljs.core/IReduce)) (isa? #?(:clj clojure.lang.IKVReduce :cljs cljs.core/IKVReduce)) #?(:clj (isa? clojure.core.protocols/IKVReduce)) (isa? #?(:clj clojure.lang.Seqable :cljs cljs.core/ISeqable)) @@ -2305,10 +2317,7 @@ (-def literal? (or nil? boolean? symbol? keyword? string? #?(:clj long?) double? #?(:clj tagged-literal?))) - ;; ===== Generic ===== ;; ;; Standard "uncuttable" types (-def integral? (or primitive? number?)) - -) diff --git a/src/quantum/core/test.cljc b/src/quantum/core/test.cljc index 4a31e97d..ec0ca457 100644 --- a/src/quantum/core/test.cljc +++ b/src/quantum/core/test.cljc @@ -6,8 +6,6 @@ :refer [fn->]] [quantum.core.print :as pr :refer [ppr-meta]] - [quantum.core.type - :refer [val?]] [quantum.core.vars :refer [#?(:clj defmalias) defalias]] [quantum.untyped.core.type.predicates diff --git a/src/quantum/core/type/defs.cljc b/src/quantum/core/type/defs.cljc index 997408e4..42f5cefa 100644 --- a/src/quantum/core/type/defs.cljc +++ b/src/quantum/core/type/defs.cljc @@ -16,5 +16,5 @@ array-ident->primitive-sym elem-types-clj max-values max-type - #?@(:clj [boxed-types unboxed-types boxed->unboxed-types-evaled promoted-types array-1d-types class->str]) + #?@(:clj [boxed-types unboxed-types boxed->unboxed-types-evaled promoted-types class->str]) types|unevaled types) diff --git a/test/quantum/test/core/untyped/type.cljc b/test/quantum/test/core/untyped/type.cljc index 3b1cff57..8f42bd1c 100644 --- a/test/quantum/test/core/untyped/type.cljc +++ b/test/quantum/test/core/untyped/type.cljc @@ -379,7 +379,6 @@ ;; entire first/left (testing "#{= <+} -> #{<+}" (testing "+ #{<+}" - test-comparisons>comparisons ;; comparisons: [-1, -1], [-1, -1] (test-comparison 1 (| a >a+b >a0) (& >a+b >a0)) ;; comparisons: [-1, -1, 3], [-1, -1] From 783ffb786d9526ef46bfaa7cd1a9aff0d76de13f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 18 Apr 2018 07:45:17 -0600 Subject: [PATCH 015/810] Begin to add `quantum.untyped.core.defnt` --- src-dev/quantum/core/defnt.cljc | 165 +--------- src-untyped/quantum/untyped/core/defnt.cljc | 235 ++++++++++++++ src-untyped/quantum/untyped/core/logic.cljc | 57 ++++ src-untyped/quantum/untyped/core/specs.cljc | 340 ++++++++++++++++++++ src/quantum/core/logic.cljc | 59 +--- src/quantum/core/specs.cljc | 326 +------------------ 6 files changed, 640 insertions(+), 542 deletions(-) create mode 100644 src-untyped/quantum/untyped/core/defnt.cljc create mode 100644 src-untyped/quantum/untyped/core/specs.cljc diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 923b404f..70842a5a 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -43,6 +43,8 @@ :refer [kw-map]] [quantum.untyped.core.data.map :as map] [quantum.untyped.core.data.set :as set] + [quantum.untyped.core.defns + :refer [defns]] [quantum.untyped.core.form :as uform] [quantum.untyped.core.form.evaluate :as ufeval] [quantum.untyped.core.form.generate :as ufgen @@ -101,87 +103,6 @@ (do -;; FNT - -(s/def ::spec s/any?) - -(s/def ::fnt|arg-spec ; TODO expand; make typed destructuring available via ::ss/binding-form - (s/alt :infer #{'?} - :any #{'_} - :spec ::spec)) - -(s/def ::fnt|speced-arg - (s/cat :arg-binding (s/and simple-symbol? - (set/not #{'& '| '>}) - (fn-> meta :tag nil?)) - ::fnt|arg-spec ::fnt|arg-spec)) - -(s/def ::fnt|output-spec (s/? (s/cat :sym (fn1 = '>) ::spec ::spec))) - -(s/def ::fnt|arglist - (s/and vector? - (s/spec - (s/cat :args (s/* ::fnt|speced-arg) - :varargs (s/? (s/cat :sym (fn1 = '&) ::fnt|speced-arg ::fnt|speced-arg)) - :pre (s/? (s/cat :sym (fn1 = '|) ::spec ::spec)) - :post ::fnt|output-spec)) - (s/conformer - #(cond-> % (contains? % :varargs) (update :varargs ::fnt|speced-arg) - (contains? % :pre ) (update :pre ::spec) - (contains? % :post ) (update :post ::spec))) - (fn [{:keys [args varargs]}] - ;; so `env` in `fnt` can work properly in the analysis - ;; TODO need to adjust for destructuring - (c/distinct? - (concat (c/lmap :arg-binding args) - [(:arg-binding varargs)]))))) - -(s/def ::fnt|body (s/alt :body (s/* s/any?))) - -(s/def ::fnt|arglist+body - (s/cat ::fnt|arglist ::fnt|arglist :body ::fnt|body)) - -(s/def ::fnt|overloads - (s/alt :overload-1 ::fnt|arglist+body - :overload-n (s/cat :overloads (s/+ (s/spec ::fnt|arglist+body))))) - -(s/def ::fnt|postchecks - (s/conformer - (fn [f] - (-> f (update :overloads - (fnl mapv (fn [overload] (let [overload' (update overload :body :body)] - (l/if-let [output-spec (-> f :output-spec ::spec)] - (do (s/validate (-> overload' ::fnt|arglist :post) nil?) - (c/assoc-in overload' [::fnt|arglist :post] output-spec)) - overload'))))) - (dissoc :output-spec))))) - -(s/def ::fnt - (s/and (s/spec - (s/cat - ::ss/fn|name (s/? ::ss/fn|name) - ::ss/docstring (s/? ::ss/docstring) - ::ss/meta (s/? ::ss/meta) - :output-spec ::fnt|output-spec - :overloads ::fnt|overloads)) - ::ss/fn|postchecks - ::fnt|postchecks)) - -(s/def ::fns|code ::fnt) - -(s/def ::defnt - (s/and (s/spec - (s/cat - ::ss/fn|name ::ss/fn|name - ::ss/docstring (s/? ::ss/docstring) - ::ss/meta (s/? ::ss/meta) - :output-spec ::fnt|output-spec - :overloads ::fnt|overloads)) - ::ss/fn|postchecks - ::fnt|postchecks)) - -(s/def ::defns|code ::defnt) - #?(:clj (defn class>simplest-class "This ensures that special overloads are not created for non-primitive subclasses @@ -219,88 +140,6 @@ (-> (class>most-primitive-class (first cs') (contains? cs nil)) class>simplest-class))))) -(defn fns|code [kind lang args] - (assert (= lang #?(:clj :clj :cljs :cljs)) lang) - (let [{:keys [::ss/fn|name overloads ::ss/meta] :as args'} - (s/validate args (case kind :defn ::defns|code :fn ::fns|code)) - overload-data>overload - (fn [{{:keys [args varargs pre post]} ::fnt|arglist - body :body}] - (let [spec-code>?class - (fn [spec] (some-> spec eval t/>spec spec>most-primitive-class)) - arg-spec>validation - (fn [{[k spec] ::fnt|arg-spec :keys [arg-binding]}] - ;; TODO this validation is purely temporary until destructuring is supported - (s/validate arg-binding simple-symbol?) - (case k - :any nil - :infer (do (log/pr :warn "Spec inference not yet supported in `defns`. Ignoring request to infer" (str "`" arg-binding "`")) - nil) - :spec (if-let [c|sym (do #?(:clj (some-> spec spec-code>?class ufth/class->instance?-safe-tag|sym) - ;; TODO for now CLJS only does `validate` which is more expensive - :cljs spec))] - (list `instance? c|sym arg-binding) - (list `s/validate arg-binding spec)))) - spec-validations - (concat (c/lmap arg-spec>validation args) - (some-> varargs arg-spec>validation)) - ;; TODO if an arg has been primitive-type-hinted in the `fn` arglist, then no need to do an `instance?` check - ?hint-arg - (fn [{[k spec] ::fnt|arg-spec :keys [arg-binding]}] - #?(:clj - (if (not= k :spec) - arg-binding - (-> arg-binding - (ufth/with-type-hint (some-> spec spec-code>?class)) - (ufth/with-fn-arglist-type-hint lang (count args) varargs))) - :cljs arg-binding)) - arglist' - (->> args - (c/map ?hint-arg) - (<- (cond-> varargs (conj '& (?hint-arg varargs))))) - pre-validations - (>vec (concat (some->> spec-validations (c/lfilter some?)) - (when pre (list 'assert pre)))) - validations - (->> {:post (when post [(list post (symbol "%"))]) - :pre (when (seq pre-validations) pre-validations)} - (c/remove-vals' empty?))] - (list* arglist' (concat (when (seq validations) [validations]) body)))) - overloads (mapv overload-data>overload overloads) - code (case kind - :fn (list* 'fn (concat - (if (contains? args' ::ss/fn|name) - [fn|name] - []) - [overloads])) - :defn (list* 'defn fn|name overloads))] - code)) - -(defmacro fns - "Like `fnt`, but relies on runtime spec checks. - Does not perform type inference (at least not yet). - Also does not currently handle spec checks in - destructuring contexts yet." - [& args] - (fns|code :fn (ufeval/env-lang) args)) - -(defmacro defns - "Like `defnt`, but relies on runtime spec checks. - Does not perform type inference (at least not yet). - Also does not currently handle spec checks in - destructuring contexts yet." - [& args] - (fns|code :defn (ufeval/env-lang) args)) - -(defns abcde "" - ([a ? b _ > t/integer?] {:pre 1} 1 2) - ([c t/string?, d StringBuilder & e _ > t/number?] - (.substring c 0 1) - (.append d 1) - 3 4) - ([f t/long?] - (core/+ f 1))) - ; ----- TYPED PART ----- ; ;; NOTE: All this code can be defnt-ized after; this is just for bootstrapping purposes so performance isn't extremely important in most of these functions. diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc new file mode 100644 index 00000000..18fd2210 --- /dev/null +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -0,0 +1,235 @@ +(ns quantum.untyped.core.defnt + (:require + [clojure.spec.alpha :as s] + [quantum.untyped.core.collections :as c] + [quantum.untyped.core.data.set :as set] + [quantum.untyped.core.fn + :refer [<- fn-> fn1 fnl]] + [quantum.untyped.core.form.evaluate :as ufeval] + [quantum.untyped.core.log :as ulog] + [quantum.untyped.core.logic :as l] + [quantum.untyped.core.specs :as ss])) + +(s/def :quantum.core.defnt/local-name + (s/and simple-symbol? (set/not #{'& '| '>}))) + +;; ----- Specs ----- ;; + +(s/def :quantum.core.defnt/spec s/any?) + +(s/def :quantum.core.defnt/arg-spec ; TODO expand; make typed destructuring available via :quantum.core.specs/binding-form + (s/alt :infer #{'?} + :any #{'_} + :spec :quantum.core.defnt/spec)) + +;; ----- General destructuring ----- ;; + +(s/def :quantum.core.defnt/binding-form + (s/alt :sym :quantum.core.defnt/local-name + :seq :quantum.core.defnt/seq-binding-form + :map :quantum.core.defnt/map-binding-form)) + +;; ----- Sequential destructuring ----- ;; + +(s/def :quantum.core.defnt/seq-binding-form + (s/and vector? + (s/cat :elems (s/* :quantum.core.specs/binding-form) + :rest (s/? (s/cat :amp #{'&} :form :quantum.core.defnt/binding-form)) + :as (s/? (s/cat :as #{:as} :sym :quantum.core.defnt/local-name))))) + +;; ----- Map destructuring ----- ;; + +(defn- >keys|syms|strs [spec] + (s/and vector? + (s/spec (s/* (s/cat :arg-binding spec + :quantum.core.defnt/arg-spec :quantum.core.defnt/arg-spec))))) + +(s/def :quantum.core.defnt/keys (>keys|syms|strs ident?)) + +(s/def :quantum.core.defnt/syms (>keys|syms|strs symbol?)) + +(s/def :quantum.core.defnt/strs (>keys|syms|strs simple-symbol?)) + +(s/def :quantum.core.defnt/or :quantum.core.specs/or) +(s/def :quantum.core.defnt/as :quantum.core.defnt/local-name) + +(s/def :quantum.core.defnt/map-special-binding + (s/keys :opt-un [:quantum.core.defnt/as :quantum.core.defnt/or + :quantum.core.defnt/keys :quantum.core.defnt/syms :quantum.core.defnt/strs])) + +; TODO finish this and others in this namespace +(s/def :quantum.core.defnt/map-binding (s/tuple :quantum.core.defnt/binding-form any?)) + +; TODO +(s/def :quantum.core.specs/ns-keys + (s/tuple + (s/and qualified-keyword? #(-> % name #{"keys" "syms"})) + (s/coll-of simple-symbol? :kind vector?))) + +; TODO +(s/def :quantum.core.specs/map-bindings + (s/every (s/or :mb :quantum.core.specs/map-binding + :nsk :quantum.core.specs/ns-keys + :msb (s/tuple #{:as :or :keys :syms :strs} any?)) :into {})) + +; TODO +(s/def :quantum.core.specs/map-binding-form + (s/merge :quantum.core.specs/map-bindings :quantum.core.specs/map-special-binding)) + +;; ----- Args ----- ;; + +(s/def :quantum.core.defnt/fnt|speced-binding + (s/cat :arg-binding :quantum.core.defnt/fnt|speced-binding + :quantum.core.defnt/fnt|arg-spec :quantum.core.defnt/fnt|arg-spec)) + +(s/def :quantum.core.defnt/fnt|output-spec + (s/? (s/cat :sym (fn1 = '>) :quantum.core.defnt/spec :quantum.core.defnt/spec))) + +(s/def :quantum.core.defnt/fnt|arglist + (s/and vector? + (s/spec + (s/cat :args (s/* :quantum.core.defnt/fnt|speced-binding) + :varargs (s/? (s/cat :sym (fn1 = '&) + :quantum.core.defnt/fnt|speced-binding :quantum.core.defnt/fnt|speced-binding)) + :pre (s/? (s/cat :sym (fn1 = '|) + :quantum.core.defnt/spec :quantum.core.defnt/spec)) + :post :quantum.core.defnt/fnt|output-spec)) + (s/conformer + #(cond-> % (contains? % :varargs) (update :varargs :quantum.core.defnt/fnt|speced-binding) + (contains? % :pre ) (update :pre :quantum.core.defnt/spec) + (contains? % :post ) (update :post :quantum.core.defnt/spec))) + (fn [{:keys [args varargs]}] + ;; so `env` in `fnt` can work properly in the analysis + ;; TODO need to adjust for destructuring + (c/distinct? + (concat (c/lmap :arg-binding args) + [(:arg-binding varargs)]))))) + +(s/def :quantum.core.defnt/fnt|body (s/alt :body (s/* s/any?))) + +(s/def :quantum.core.defnt/fnt|arglist+body + (s/cat :quantum.core.defnt/fnt|arglist :quantum.core.defnt/fnt|arglist + :body :quantum.core.defnt/fnt|body)) + +(s/def :quantum.core.defnt/fnt|overloads + (s/alt :overload-1 :quantum.core.defnt/fnt|arglist+body + :overload-n (s/cat :overloads (s/+ (s/spec :quantum.core.defnt/fnt|arglist+body))))) + +(s/def :quantum.core.defnt/fnt|postchecks + (s/conformer + (fn [f] + (-> f (update :overloads + (fnl mapv (fn [overload] + (let [overload' (update overload :body :body)] + (l/if-let [output-spec (-> f :output-spec :quantum.core.defnt/spec)] + (do (s/validate (-> overload' :quantum.core.defnt/fnt|arglist :post) nil?) + (c/assoc-in overload' [:quantum.core.defnt/fnt|arglist :post] output-spec)) + overload'))))) + (dissoc :output-spec))))) + +(s/def :quantum.core.defnt/fnt + (s/and (s/spec + (s/cat + :quantum.core.specs/fn|name (s/? :quantum.core.specs/fn|name) + :quantum.core.specs/docstring (s/? :quantum.core.specs/docstring) + :quantum.core.specs/meta (s/? :quantum.core.specs/meta) + :output-spec :quantum.core.defnt/fnt|output-spec + :overloads :quantum.core.defnt/fnt|overloads)) + :quantum.core.specs/fn|postchecks + :quantum.core.defnt/fnt|postchecks)) + +(s/def :quantum.core.defnt/fns|code :quantum.core.defnt/fnt) + +(s/def :quantum.core.defnt/defnt + (s/and (s/spec + (s/cat + :quantum.core.specs/fn|name :quantum.core.specs/fn|name + :quantum.core.specs/docstring (s/? :quantum.core.specs/docstring) + :quantum.core.specs/meta (s/? :quantum.core.specs/meta) + :output-spec :quantum.core.defnt/fnt|output-spec + :overloads :quantum.core.defnt/fnt|overloads)) + :quantum.core.specs/fn|postchecks + :quantum.core.defnt/fnt|postchecks)) + +(s/def :quantum.core.defnt/defns|code :quantum.core.defnt/defnt) + +(defn fns|code [kind lang args] + (assert (= lang #?(:clj :clj :cljs :cljs)) lang) + (let [{:keys [:quantum.core.specs/fn|name overloads :quantum.core.specs/meta] :as args'} + (s/validate args (case kind :defn :quantum.core.defnt/defns|code :fn :quantum.core.defnt/fns|code)) + overload-data>overload + (fn [{{:keys [args varargs pre post]} :quantum.core.defnt/fnt|arglist + body :body}] + (let [arg-spec>validation + (fn [{[k spec] :quantum.core.defnt/fnt|arg-spec :keys [arg-binding]}] + ;; TODO this validation is purely temporary until destructuring is supported + (s/validate arg-binding simple-symbol?) + (case k + :any nil + :infer (do (ulog/pr :warn "Spec inference not supported in `defns`. Ignoring request to infer" (str "`" arg-binding "`")) + nil) + :spec (list `s/validate arg-binding spec))) + spec-validations + (concat (c/lmap arg-spec>validation args) + (some-> varargs arg-spec>validation)) + ;; TODO if an arg has been primitive-type-hinted in the `fn` arglist, then no need to do an `instance?` check + ?hint-arg + (fn [{[k spec] :quantum.core.defnt/fnt|arg-spec :keys [arg-binding]}] + arg-binding) + arglist' + (->> args + (c/map ?hint-arg) + (<- (cond-> varargs (conj '& (?hint-arg varargs))))) + pre-validations + (c/>vec (concat (some->> spec-validations (c/lfilter some?)) + (when pre (list 'assert pre)))) + validations + (->> {:post (when post [(list post (symbol "%"))]) + :pre (when (seq pre-validations) pre-validations)} + (c/remove-vals' empty?))] + (list* arglist' (concat (when (seq validations) [validations]) body)))) + overloads (mapv overload-data>overload overloads) + code (case kind + :fn (list* 'fn (concat + (if (contains? args' :quantum.core.specs/fn|name) + [fn|name] + []) + [overloads])) + :defn (list* 'defn fn|name overloads))] + code)) + +#?(:clj +(defmacro fns + "Like `fnt`, but relies on runtime spec checks. Does not perform type inference." + [& args] + (fns|code :fn (ufeval/env-lang) args))) + +#?(:clj +(defmacro defns + "Like `defnt`, but relies on runtime spec checks. Does not perform type inference." + [& args] + (fns|code :defn (ufeval/env-lang) args))) + +(defns abcde "Documentation" + ([a #(instance? Long %)] (+ a 1)) + ([b ? c _ > integer?] {:pre 1} 1 2) + ([d string?, e #(instance? StringBuilder %) & f _ > number?] + (.substring ^String d 0 1) + (.append ^StringBuilder e 1) + 3 4)) + +(defns fghij + ([a number? > number?] (inc a)) + ([a number?, b number? + | (> a b) + > (s/and number? #(> % a) #(> % b))] (+ a b)) + ([a string? + b boolean? + {:as c + :keys [d keyword? e string?] + [f integer?] :f} + #(-> % count (= 2)) + [g double? & h seq? :as i] sequential? + & j seq? + | (and (> a b) (contains? c a)) + > number?] 0)) diff --git a/src-untyped/quantum/untyped/core/logic.cljc b/src-untyped/quantum/untyped/core/logic.cljc index a77f4102..ce177a0f 100644 --- a/src-untyped/quantum/untyped/core/logic.cljc +++ b/src-untyped/quantum/untyped/core/logic.cljc @@ -213,6 +213,63 @@ #?(:clj (defmacro whenp->> "`whenf->>` + `ifp->>`" [x pred & texprs] `(let [x# ~x] (if ~pred (->> x# ~@texprs) x#)))) #?(:clj (defmacro whenp1 [x0 x1] `(fn [arg#] (whenp arg# ~x0 ~x1)))) +;; ===== Conditional `let` bindings ===== ;; + +#?(:clj +(defmacro if-let-base + {:attribution "alexandergunnarson"} + ([cond-sym bindings then] + `(if-let-base ~cond-sym ~bindings ~then nil)) + ([cond-sym [bnd expr & more] then else] + `(let [temp# ~expr ~bnd temp#] + (~cond-sym temp# + ~(if (seq more) + `(if-let-base ~cond-sym [~@more] ~then ~else) + then) + ~else))))) + +#?(:clj +(defmacro if-let + "Like `if-let`, but multiple bindings can be used." + [& xs] `(if-let-base if ~@xs))) + +#?(:clj +(defmacro if-not-let + "if : if-let :: if-not : if-not-let. All conditions must be false." + [& xs] `(if-let-base if-not ~@xs))) + +#?(:clj +(defmacro when-let-base + {:attribution "alexandergunnarson"} + [cond-sym [bnd expr & more] & body] + `(let [temp# ~expr ~bnd temp#] + (~cond-sym temp# + ~(if (seq more) + `(when-let-base ~cond-sym [~@more] ~@body) + `(do ~@body)))))) + +#?(:clj +(defmacro when-let + "Like `when-let`, but multiple bindings can be used." + [& xs] `(if-let-base when ~@xs))) + +#?(:clj +(defmacro when-not-let + "when : when-let :: when-not : when-not-let. All conditions must be false." + [& xs] `(when-let-base when-not ~@xs))) + + +#?(:clj +(defmacro cond-let + "Transforms into a series of nested `if-let` statements." + {:attribution "alexandergunnarson"} + ([] nil) ; no else + ([else] else) + ([bindings then & more] + `(if-let ~bindings + ~then + (cond-let ~@more))))) + ;; ===== `coll-(or|and)` ===== ;; #?(:clj diff --git a/src-untyped/quantum/untyped/core/specs.cljc b/src-untyped/quantum/untyped/core/specs.cljc new file mode 100644 index 00000000..31b1090f --- /dev/null +++ b/src-untyped/quantum/untyped/core/specs.cljc @@ -0,0 +1,340 @@ +(ns quantum.untyped.core.specs + "Adapted from clojure.core.specs version 1.9.0-alpha19 + and enabled in CLJS. Other specs added too. + See https://github.com/clojure/core.specs.alpha/blob/5d85f93ab78386855374256934475af0afe7f380/src/main/clojure/clojure/core/specs/alpha.clj" + (:require + [clojure.core :as core] + [clojure.set :as set] + [quantum.untyped.core.fn + :refer [fn1 fnl]] + [quantum.untyped.core.spec :as s] + [quantum.untyped.core.type.predicates + :refer [val?]])) + +;;;; GENERAL + +(s/def :quantum.core.specs/meta map?) + +;;;; destructure + +(s/def :quantum.core.specs/local-name (s/and simple-symbol? #(not= '& %))) + +(s/def :quantum.core.specs/binding-form + (s/or :sym :quantum.core.specs/local-name + :seq :quantum.core.specs/seq-binding-form + :map :quantum.core.specs/map-binding-form)) + +;; sequential destructuring + +(s/def :quantum.core.specs/seq-binding-form + (s/and vector? + (s/cat :elems (s/* :quantum.core.specs/binding-form) + :rest (s/? (s/cat :amp #{'&} :form :quantum.core.specs/binding-form)) + :as (s/? (s/cat :as #{:as} :sym :quantum.core.specs/local-name))))) + +;; map destructuring + +(s/def :quantum.core.specs/keys (s/coll-of ident? :kind vector?)) +(s/def :quantum.core.specs/syms (s/coll-of symbol? :kind vector?)) +(s/def :quantum.core.specs/strs (s/coll-of simple-symbol? :kind vector?)) +(s/def :quantum.core.specs/or (s/map-of simple-symbol? any?)) +(s/def :quantum.core.specs/as :quantum.core.specs/local-name) + +(s/def :quantum.core.specs/map-special-binding + (s/keys :opt-un [:quantum.core.specs/as :quantum.core.specs/or + :quantum.core.specs/keys :quantum.core.specs/syms :quantum.core.specs/strs])) + +(s/def :quantum.core.specs/map-binding (s/tuple :quantum.core.specs/binding-form any?)) + +(s/def :quantum.core.specs/ns-keys + (s/tuple + (s/and qualified-keyword? #(-> % name #{"keys" "syms"})) + (s/coll-of simple-symbol? :kind vector?))) + +(s/def :quantum.core.specs/map-bindings + (s/every (s/or :mb :quantum.core.specs/map-binding + :nsk :quantum.core.specs/ns-keys + :msb (s/tuple #{:as :or :keys :syms :strs} any?)) :into {})) + +(s/def :quantum.core.specs/map-binding-form + (s/merge :quantum.core.specs/map-bindings :quantum.core.specs/map-special-binding)) + +;; bindings + +(s/def :quantum.core.specs/binding (s/cat :binding :quantum.core.specs/binding-form :init-expr any?)) +(s/def :quantum.core.specs/bindings (s/and vector? (s/* :quantum.core.specs/binding))) + +;; let, if-let, when-let + +(s/fdef core/let + :args (s/cat :bindings :quantum.core.specs/bindings + :body (s/* any?))) + +(s/fdef core/if-let + :args (s/cat :bindings (s/and vector? :quantum.core.specs/binding) + :then any? + :else (s/? any?))) + +(s/fdef core/when-let + :args (s/cat :bindings (s/and vector? :quantum.core.specs/binding) + :body (s/* any?))) + +;; defn, defn-, fn + +(s/def :quantum.core.specs/fn|arglist + (s/and + vector? + (s/cat :args (s/* :quantum.core.specs/binding-form) + :varargs (s/? (s/cat :amp #{'&} :form :quantum.core.specs/binding-form))))) + +(s/def :quantum.core.specs/fn|prepost + (s/and (s/keys :req-un [(or :quantum.core.specs/core/pre :quantum.core.specs/core/post)]) ; TODO we actually really only want to accept un-namespaced keys... + (s/conformer #(set/rename-keys % {:quantum.core.specs/core/pre :pre + :quantum.core.specs/core/post :post})))) + +(s/def :quantum.core.specs/fn|body + (s/alt :prepost+body (s/cat :prepost :quantum.core.specs/fn|prepost + :body (s/+ any?)) + :body (s/* any?))) + +(s/def :quantum.core.specs/fn|arglist+body + (s/cat :quantum.core.specs/fn|arglist :quantum.core.specs/fn|arglist + :body :quantum.core.specs/fn|body)) + +(s/def :quantum.core.specs/fn|name simple-symbol?) + +(s/def :quantum.core.specs/docstring string?) + +(s/def :quantum.core.specs/fn|unique-doc + #(->> [(:quantum.core.specs/docstring %) + (-> % :quantum.core.specs/fn|name meta :doc) + (-> % :pre-meta :doc) + (-> % :post-meta :doc)] + (filter val?) + count + ((fn [x] (<= x 1))))) + +(s/def :quantum.core.specs/fn|unique-meta + #(empty? (set/intersection + (-> % :quantum.core.specs/fn|name meta keys set) + (-> % :pre-meta keys set) + (-> % :post-meta keys set)))) + +(s/def :quantum.core.specs/fn|aggregate-meta + (s/conformer + (fn [{:keys [:quantum.core.specs/fn|name :quantum.core.specs/docstring pre-meta post-meta] :as m}] + (-> m + (dissoc :quantum.core.specs/docstring :pre-meta :post-meta) + (cond-> fn|name + (update :quantum.core.specs/fn|name with-meta + (-> (merge (meta fn|name) pre-meta post-meta) ; TODO use `merge-unique` instead of `:quantum.core.specs/defn|unique-meta` + (cond-> docstring (assoc :doc docstring))))))))) + +(s/def :quantum.core.specs/fn|postchecks + (s/and (s/conformer + (fn [v] + (let [[overloads-k overloads-v] (get v :overloads) + overloads + (-> (case overloads-k + :overload-1 {:overloads [overloads-v]} + :overload-n overloads-v) + (update :overloads + (fnl mapv + (fn1 update :body + (fn [[k v]] + (case k + :body {:body v} + :prepost+body v))))))] + (assoc v :post-meta (:post-meta overloads) + :overloads (:overloads overloads))))) + :quantum.core.specs/fn|unique-doc + :quantum.core.specs/fn|unique-meta + ;; TODO validate metadata like return value etc. + :quantum.core.specs/fn|aggregate-meta)) + +(s/def :quantum.core.specs/fn + (s/and (s/spec + (s/cat :quantum.core.specs/fn|name (s/? :quantum.core.specs/fn|name) + :overloads (s/alt :overload-1 :quantum.core.specs/fn|arglist+body + :overload-n (s/cat :overloads (s/+ (s/spec :quantum.core.specs/fn|arglist+body)))))) + :quantum.core.specs/fn|postchecks)) + +(s/def :quantum.core.specs/defn + (s/and + (s/spec + (s/cat :quantum.core.specs/fn|name :quantum.core.specs/fn|name + :quantum.core.specs/docstring (s/? :quantum.core.specs/docstring) + :pre-meta (s/? :quantum.core.specs/meta) + :overloads (s/alt :overload-1 :quantum.core.specs/fn|arglist+body + :overload-n (s/cat :overloads (s/+ (s/spec :quantum.core.specs/fn|arglist+body)) + :post-meta (s/? :quantum.core.specs/meta))))) + :quantum.core.specs/fn|postchecks)) + +(s/fdef core/defn :args :quantum.core.specs/defn :ret any?) +(s/fdef core/defn- :args :quantum.core.specs/defn :ret any?) +(s/fdef core/fn :args :quantum.core.specs/fn :ret any?) + +;;;; ns + +(s/def :quantum.core.specs/exclude (s/coll-of simple-symbol?)) +(s/def :quantum.core.specs/only (s/coll-of simple-symbol?)) +(s/def :quantum.core.specs/rename (s/map-of simple-symbol? simple-symbol?)) + +(s/def :quantum.core.specs/filters + (s/keys* :opt-un [:quantum.core.specs/exclude :quantum.core.specs/only :quantum.core.specs/rename])) + +(s/def :quantum.core.specs/ns-refer-clojure + (s/spec (s/cat :clause #{:refer-clojure} + :filters :quantum.core.specs/filters))) + +(s/def :quantum.core.specs/refer + (s/or :all #{:all} + :syms (s/coll-of simple-symbol?))) + +(s/def :quantum.core.specs/prefix-list + (s/spec + (s/cat :prefix simple-symbol? + :libspecs (s/+ :quantum.core.specs/libspec)))) + +(s/def :quantum.core.specs/libspec + (s/alt :lib simple-symbol? + :lib+opts (s/spec (s/cat :lib simple-symbol? + :options (s/keys* :opt-un [:quantum.core.specs/as :quantum.core.specs/refer]))))) + +(s/def :quantum.core.specs/ns-require + (s/spec (s/cat :clause #{:require} + :body (s/+ (s/alt :libspec :quantum.core.specs/libspec + :prefix-list :quantum.core.specs/prefix-list + :flag #{:reload :reload-all :verbose}))))) + +(s/def :quantum.core.specs/package-list + (s/spec + (s/cat :package simple-symbol? + :classes (s/* simple-symbol?)))) + +(s/def :quantum.core.specs/import-list + (s/* (s/alt :class simple-symbol? + :package-list :quantum.core.specs/package-list))) + +(s/def :quantum.core.specs/ns-import + (s/spec + (s/cat :clause #{:import} + :classes :quantum.core.specs/import-list))) + +(s/def :quantum.core.specs/ns-refer + (s/spec (s/cat :clause #{:refer} + :lib simple-symbol? + :filters :quantum.core.specs/filters))) + +;; same as :quantum.core.specs/prefix-list, but with :quantum.core.specs/use-libspec instead +(s/def :quantum.core.specs/use-prefix-list + (s/spec + (s/cat :prefix simple-symbol? + :libspecs (s/+ :quantum.core.specs/use-libspec)))) + +;; same as :quantum.core.specs/libspec, but also supports the :quantum.core.specs/filters options in the libspec +(s/def :quantum.core.specs/use-libspec + (s/alt :lib simple-symbol? + :lib+opts + (s/spec (s/cat :lib simple-symbol? + :options (s/keys* :opt-un [:quantum.core.specs/as :quantum.core.specs/refer + :quantum.core.specs/exclude :quantum.core.specs/only + :quantum.core.specs/rename]))))) + +(s/def :quantum.core.specs/ns-use + (s/spec (s/cat :clause #{:use} + :libs (s/+ (s/alt :libspecs :quantum.core.specs/use-libspec + :prefix-list :quantum.core.specs/use-prefix-list + :flag #{:reload :reload-all :verbose}))))) + +(s/def :quantum.core.specs/ns-load + (s/spec (s/cat :clause #{:load} + :libs (s/* string?)))) + +(s/def :quantum.core.specs/name simple-symbol?) +(s/def :quantum.core.specs/extends simple-symbol?) +(s/def :quantum.core.specs/implements (s/coll-of simple-symbol? :kind vector?)) +(s/def :quantum.core.specs/init symbol?) +(s/def :quantum.core.specs/class-ident (s/or :class simple-symbol? :class-name string?)) +(s/def :quantum.core.specs/signature (s/coll-of :quantum.core.specs/class-ident :kind vector?)) +(s/def :quantum.core.specs/constructors (s/map-of :quantum.core.specs/signature :quantum.core.specs/signature)) +(s/def :quantum.core.specs/post-init symbol?) + +(s/def :quantum.core.specs/method + (s/and vector? + (s/cat :name simple-symbol? + :param-types :quantum.core.specs/signature + :return-type simple-symbol?))) + +(s/def :quantum.core.specs/methods (s/coll-of :quantum.core.specs/method :kind vector?)) +(s/def :quantum.core.specs/main boolean?) +(s/def :quantum.core.specs/factory simple-symbol?) +(s/def :quantum.core.specs/state simple-symbol?) +(s/def :quantum.core.specs/get simple-symbol?) +(s/def :quantum.core.specs/set simple-symbol?) +(s/def :quantum.core.specs/expose (s/keys :opt-un [:quantum.core.specs/get :quantum.core.specs/set])) +(s/def :quantum.core.specs/exposes (s/map-of simple-symbol? :quantum.core.specs/expose)) +(s/def :quantum.core.specs/prefix string?) +(s/def :quantum.core.specs/impl-ns simple-symbol?) +(s/def :quantum.core.specs/load-impl-ns boolean?) + +(s/def :quantum.core.specs/ns-gen-class + (s/spec (s/cat :clause #{:gen-class} + :options (s/keys* :opt-un [:quantum.core.specs/name :quantum.core.specs/extends :quantum.core.specs/implements + :quantum.core.specs/init :quantum.core.specs/constructors :quantum.core.specs/post-init + :quantum.core.specs/methods :quantum.core.specs/main :quantum.core.specs/factory :quantum.core.specs/state + :quantum.core.specs/exposes :quantum.core.specs/prefix :quantum.core.specs/impl-ns :quantum.core.specs/load-impl-ns])))) + +(s/def :quantum.core.specs/ns-clauses + (s/* (s/alt :refer-clojure :quantum.core.specs/ns-refer-clojure + :require :quantum.core.specs/ns-require + :import :quantum.core.specs/ns-import + :use :quantum.core.specs/ns-use + :refer :quantum.core.specs/ns-refer + :load :quantum.core.specs/ns-load + :gen-class :quantum.core.specs/ns-gen-class))) + +(s/def :quantum.core.specs/ns-form + (s/cat :name simple-symbol? + :docstring (s/? :quantum.core.specs/docstring) + :attr-map (s/? :quantum.core.specs/meta) + :clauses :quantum.core.specs/ns-clauses)) + +(s/fdef core/ns + :args :quantum.core.specs/ns-form) + +#?(:clj +(defmacro ^:private quotable + "Returns a spec that accepts both the spec and a (quote ...) form of the spec" + [spec] + `(s/or :spec ~spec :quoted-spec (s/cat :quote #{'quote} :spec ~spec)))) + +(s/def :quantum.core.specs/quotable-import-list + (s/* (s/alt :class (quotable simple-symbol?) + :package-list (quotable :quantum.core.specs/package-list)))) + +(s/fdef core/import + :args :quantum.core.specs/quotable-import-list) + +(s/fdef core/refer-clojure + :args (s/* (s/alt + :exclude (s/cat :op (quotable #{:exclude}) :arg (quotable :quantum.core.specs/exclude)) + :only (s/cat :op (quotable #{:only}) :arg (quotable :quantum.core.specs/only)) + :rename (s/cat :op (quotable #{:rename}) :arg (quotable :quantum.core.specs/rename))))) + +;; ----- INTERFACE ----- ;; + +(s/def :quantum.core.specs/code any?) ; TODO must be embeddable + +(s/def :interface/name simple-symbol?) + +;; ----- REIFY ----- ;; + +(s/def :reify/method-name simple-symbol?) + +(s/def :reify|arglist/arg-sym simple-symbol?) ; technically, can be tagged with only particular tags +(s/def :reify/arglist (s/and vector? (s/+ :reify|arglist/arg-sym))) + +(s/def :reify|overload/ret-class-sym simple-symbol?) ; technically, one resolvable to a class + +(s/def :reify|overload/body (s/* :quantum.core.specs/code)) diff --git a/src/quantum/core/logic.cljc b/src/quantum/core/logic.cljc index 0a8050a5..5d31cb70 100644 --- a/src/quantum/core/logic.cljc +++ b/src/quantum/core/logic.cljc @@ -134,62 +134,13 @@ whenc whenc-> whenc->> whenc1 whenp whenp-> whenp->> whenp1)) -; ======== CONDITIONAL LET BINDINGS ======== +;; ===== Conditional `let` bindings ===== ;; #?(:clj -(defmacro if-let-base - {:attribution "alexandergunnarson"} - ([cond-sym bindings then] - `(if-let-base ~cond-sym ~bindings ~then nil)) - ([cond-sym [bnd expr & more] then else] - `(let [temp# ~expr ~bnd temp#] - (~cond-sym temp# - ~(if (seq more) - `(if-let-base ~cond-sym [~@more] ~then ~else) - then) - ~else))))) - -#?(:clj -(defmacro if-let - "Like `if-let`, but multiple bindings can be used." - [& xs] `(if-let-base if ~@xs))) - -#?(:clj -(defmacro if-not-let - "if : if-let :: if-not : if-not-let. All conditions must be false." - [& xs] `(if-let-base if-not ~@xs))) - -#?(:clj -(defmacro when-let-base - {:attribution "alexandergunnarson"} - [cond-sym [bnd expr & more] & body] - `(let [temp# ~expr ~bnd temp#] - (~cond-sym temp# - ~(if (seq more) - `(when-let-base ~cond-sym [~@more] ~@body) - `(do ~@body)))))) - -#?(:clj -(defmacro when-let - "Like `when-let`, but multiple bindings can be used." - [& xs] `(if-let-base when ~@xs))) - -#?(:clj -(defmacro when-not-let - "when : when-let :: when-not : when-not-let. All conditions must be false." - [& xs] `(when-let-base when-not ~@xs))) - - -#?(:clj -(defmacro cond-let - "Transforms into a series of nested `if-let` statements." - {:attribution "alexandergunnarson"} - ([] nil) ; no else - ([else] else) - ([bindings then & more] - `(if-let ~bindings - ~then - (cond-let ~@more))))) +(defaliases u + if-let if-not-let + when-let when-not-let + cond-let)) ;; ===== `coll-(or|and)` ===== ;; diff --git a/src/quantum/core/specs.cljc b/src/quantum/core/specs.cljc index 3593e81f..5e6d3a24 100644 --- a/src/quantum/core/specs.cljc +++ b/src/quantum/core/specs.cljc @@ -1,327 +1,3 @@ (ns quantum.core.specs - "Adapted from clojure.core.specs version 1.9.0-alpha19 - and enabled in CLJS. Other specs added too. - See https://github.com/clojure/core.specs.alpha/blob/5d85f93ab78386855374256934475af0afe7f380/src/main/clojure/clojure/core/specs/alpha.clj" (:require - [clojure.core :as core] - [clojure.set :as set] - [quantum.core.fn :as fn - :refer [fn1 fnl]] - [quantum.core.spec :as s] - [quantum.untyped.core.type.predicates - :refer [val?]])) - -;;;; GENERAL - -(s/def ::meta map?) - -;;;; destructure - -(s/def ::local-name (s/and simple-symbol? #(not= '& %))) - -(s/def ::binding-form - (s/or :sym ::local-name - :seq ::seq-binding-form - :map ::map-binding-form)) - -;; sequential destructuring - -(s/def ::seq-binding-form - (s/and vector? - (s/cat :elems (s/* ::binding-form) - :rest (s/? (s/cat :amp #{'&} :form ::binding-form)) - :as (s/? (s/cat :as #{:as} :sym ::local-name))))) - -;; map destructuring - -(s/def ::keys (s/coll-of ident? :kind vector?)) -(s/def ::syms (s/coll-of symbol? :kind vector?)) -(s/def ::strs (s/coll-of simple-symbol? :kind vector?)) -(s/def ::or (s/map-of simple-symbol? any?)) -(s/def ::as ::local-name) - -(s/def ::map-special-binding - (s/keys :opt-un [::as ::or ::keys ::syms ::strs])) - -(s/def ::map-binding (s/tuple ::binding-form any?)) - -(s/def ::ns-keys - (s/tuple - (s/and qualified-keyword? #(-> % name #{"keys" "syms"})) - (s/coll-of simple-symbol? :kind vector?))) - -(s/def ::map-bindings - (s/every (s/or :mb ::map-binding - :nsk ::ns-keys - :msb (s/tuple #{:as :or :keys :syms :strs} any?)) :into {})) - -(s/def ::map-binding-form (s/merge ::map-bindings ::map-special-binding)) - -;; bindings - -(s/def ::binding (s/cat :binding ::binding-form :init-expr any?)) -(s/def ::bindings (s/and vector? (s/* ::binding))) - -;; let, if-let, when-let - -(s/fdef core/let - :args (s/cat :bindings ::bindings - :body (s/* any?))) - -(s/fdef core/if-let - :args (s/cat :bindings (s/and vector? ::binding) - :then any? - :else (s/? any?))) - -(s/fdef core/when-let - :args (s/cat :bindings (s/and vector? ::binding) - :body (s/* any?))) - -;; defn, defn-, fn - -(s/def ::fn|arglist - (s/and - vector? - (s/cat :args (s/* ::binding-form) - :varargs (s/? (s/cat :amp #{'&} :form ::binding-form))))) - -(s/def ::fn|prepost - (s/and (s/keys :req-un [(or ::core/pre ::core/post)]) ; TODO we actually really only want to accept un-namespaced keys... - (s/conformer #(set/rename-keys % {::core/pre :pre ::core/post :post})))) - -(s/def ::fn|body - (s/alt :prepost+body (s/cat :prepost ::fn|prepost - :body (s/+ any?)) - :body (s/* any?))) - -(s/def ::fn|arglist+body - (s/cat ::fn|arglist ::fn|arglist :body ::fn|body)) - -(s/def ::fn|name simple-symbol?) - -(s/def ::docstring string?) - -(s/def ::fn|unique-doc - #(->> [(::docstring %) - (-> % ::fn|name meta :doc) - (-> % :pre-meta :doc) - (-> % :post-meta :doc)] - (filter val?) - count - ((fn [x] (<= x 1))))) - -(s/def ::fn|unique-meta - #(empty? (set/intersection - (-> % ::fn|name meta keys set) - (-> % :pre-meta keys set) - (-> % :post-meta keys set)))) - -(s/def ::fn|aggregate-meta - (s/conformer - (fn [{:keys [::fn|name ::docstring pre-meta post-meta] :as m}] - (-> m - (dissoc ::docstring :pre-meta :post-meta) - (cond-> fn|name - (update ::fn|name with-meta - (-> (merge (meta fn|name) pre-meta post-meta) ; TODO use `merge-unique` instead of `::defn|unique-meta` - (cond-> docstring (assoc :doc docstring))))))))) - -(s/def ::fn|postchecks - (s/and (s/conformer - (fn [v] - (let [[overloads-k overloads-v] (get v :overloads) - overloads - (-> (case overloads-k - :overload-1 {:overloads [overloads-v]} - :overload-n overloads-v) - (update :overloads - (fnl mapv - (fn1 update :body - (fn [[k v]] - (case k - :body {:body v} - :prepost+body v))))))] - (assoc v :post-meta (:post-meta overloads) - :overloads (:overloads overloads))))) - ::fn|unique-doc - ::fn|unique-meta - ;; TODO validate metadata like return value etc. - ::fn|aggregate-meta)) - -(s/def ::fn - (s/and (s/spec - (s/cat ::fn|name (s/? ::fn|name) - :overloads (s/alt :overload-1 ::fn|arglist+body - :overload-n (s/cat :overloads (s/+ (s/spec ::fn|arglist+body)))))) - ::fn|postchecks)) - -(s/def ::defn - (s/and - (s/spec - (s/cat ::fn|name ::fn|name - ::docstring (s/? ::docstring) - :pre-meta (s/? ::meta) - :overloads (s/alt :overload-1 ::fn|arglist+body - :overload-n (s/cat :overloads (s/+ (s/spec ::fn|arglist+body)) - :post-meta (s/? ::meta))))) - ::fn|postchecks)) - -(s/fdef core/defn :args ::defn :ret any?) -(s/fdef core/defn- :args ::defn :ret any?) -(s/fdef core/fn :args ::fn :ret any?) - -;;;; ns - -(s/def ::exclude (s/coll-of simple-symbol?)) -(s/def ::only (s/coll-of simple-symbol?)) -(s/def ::rename (s/map-of simple-symbol? simple-symbol?)) -(s/def ::filters (s/keys* :opt-un [::exclude ::only ::rename])) - -(s/def ::ns-refer-clojure - (s/spec (s/cat :clause #{:refer-clojure} - :filters ::filters))) - -(s/def ::refer (s/or :all #{:all} - :syms (s/coll-of simple-symbol?))) - -(s/def ::prefix-list - (s/spec - (s/cat :prefix simple-symbol? - :libspecs (s/+ ::libspec)))) - -(s/def ::libspec - (s/alt :lib simple-symbol? - :lib+opts (s/spec (s/cat :lib simple-symbol? - :options (s/keys* :opt-un [::as ::refer]))))) - -(s/def ::ns-require - (s/spec (s/cat :clause #{:require} - :body (s/+ (s/alt :libspec ::libspec - :prefix-list ::prefix-list - :flag #{:reload :reload-all :verbose}))))) - -(s/def ::package-list - (s/spec - (s/cat :package simple-symbol? - :classes (s/* simple-symbol?)))) - -(s/def ::import-list - (s/* (s/alt :class simple-symbol? - :package-list ::package-list))) - -(s/def ::ns-import - (s/spec - (s/cat :clause #{:import} - :classes ::import-list))) - -(s/def ::ns-refer - (s/spec (s/cat :clause #{:refer} - :lib simple-symbol? - :filters ::filters))) - -;; same as ::prefix-list, but with ::use-libspec instead -(s/def ::use-prefix-list - (s/spec - (s/cat :prefix simple-symbol? - :libspecs (s/+ ::use-libspec)))) - -;; same as ::libspec, but also supports the ::filters options in the libspec -(s/def ::use-libspec - (s/alt :lib simple-symbol? - :lib+opts (s/spec (s/cat :lib simple-symbol? - :options (s/keys* :opt-un [::as ::refer ::exclude ::only ::rename]))))) - -(s/def ::ns-use - (s/spec (s/cat :clause #{:use} - :libs (s/+ (s/alt :libspec ::use-libspec - :prefix-list ::use-prefix-list - :flag #{:reload :reload-all :verbose}))))) - -(s/def ::ns-load - (s/spec (s/cat :clause #{:load} - :libs (s/* string?)))) - -(s/def ::name simple-symbol?) -(s/def ::extends simple-symbol?) -(s/def ::implements (s/coll-of simple-symbol? :kind vector?)) -(s/def ::init symbol?) -(s/def ::class-ident (s/or :class simple-symbol? :class-name string?)) -(s/def ::signature (s/coll-of ::class-ident :kind vector?)) -(s/def ::constructors (s/map-of ::signature ::signature)) -(s/def ::post-init symbol?) -(s/def ::method (s/and vector? - (s/cat :name simple-symbol? - :param-types ::signature - :return-type simple-symbol?))) -(s/def ::methods (s/coll-of ::method :kind vector?)) -(s/def ::main boolean?) -(s/def ::factory simple-symbol?) -(s/def ::state simple-symbol?) -(s/def ::get simple-symbol?) -(s/def ::set simple-symbol?) -(s/def ::expose (s/keys :opt-un [::get ::set])) -(s/def ::exposes (s/map-of simple-symbol? ::expose)) -(s/def ::prefix string?) -(s/def ::impl-ns simple-symbol?) -(s/def ::load-impl-ns boolean?) - -(s/def ::ns-gen-class - (s/spec (s/cat :clause #{:gen-class} - :options (s/keys* :opt-un [::name ::extends ::implements - ::init ::constructors ::post-init - ::methods ::main ::factory ::state - ::exposes ::prefix ::impl-ns ::load-impl-ns])))) - -(s/def ::ns-clauses - (s/* (s/alt :refer-clojure ::ns-refer-clojure - :require ::ns-require - :import ::ns-import - :use ::ns-use - :refer ::ns-refer - :load ::ns-load - :gen-class ::ns-gen-class))) - -(s/def ::ns-form - (s/cat :name simple-symbol? - :docstring (s/? ::docstring) - :attr-map (s/? ::meta) - :clauses ::ns-clauses)) - -(s/fdef core/ns - :args ::ns-form) - -#?(:clj -(defmacro ^:private quotable - "Returns a spec that accepts both the spec and a (quote ...) form of the spec" - [spec] - `(s/or :spec ~spec :quoted-spec (s/cat :quote #{'quote} :spec ~spec)))) - -(s/def ::quotable-import-list - (s/* (s/alt :class (quotable simple-symbol?) - :package-list (quotable ::package-list)))) - -(s/fdef core/import - :args ::quotable-import-list) - -(s/fdef core/refer-clojure - :args (s/* (s/alt - :exclude (s/cat :op (quotable #{:exclude}) :arg (quotable ::exclude)) - :only (s/cat :op (quotable #{:only}) :arg (quotable ::only)) - :rename (s/cat :op (quotable #{:rename}) :arg (quotable ::rename))))) - -;; ----- INTERFACE ----- ;; - -(s/def ::code any?) ; TODO must be embeddable - -(s/def :interface/name simple-symbol?) - -;; ----- REIFY ----- ;; - -(s/def :reify/method-name simple-symbol?) - -(s/def :reify|arglist/arg-sym simple-symbol?) ; technically, can be tagged with only particular tags -(s/def :reify/arglist (s/and vector? (s/+ :reify|arglist/arg-sym))) - -(s/def :reify|overload/ret-class-sym simple-symbol?) ; technically, one resolvable to a class - -(s/def :reify|overload/body (s/* ::code)) + [quantum.untyped.core.specs])) From df03e9c8f4bb1c0a077489904fa59d37efa0253c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 19 Apr 2018 10:07:29 -0600 Subject: [PATCH 016/810] Get map destructuring right; greatly extend example --- project-base.clj | 2 + src-untyped/quantum/untyped/core/defnt.cljc | 293 ++++++++++++-------- 2 files changed, 182 insertions(+), 113 deletions(-) diff --git a/project-base.clj b/project-base.clj index f0db9120..c12c78ff 100644 --- a/project-base.clj +++ b/project-base.clj @@ -111,6 +111,8 @@ [org.clojure/data.xml "0.0.8" :exclusions [org.clojure/clojure]] + ; ==== SPECS ==== + [expound "0.5.0"] ; ==== COLLECTIONS ==== [diffit "1.0.0"] ; ==== CONVERT ==== diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index 18fd2210..c0fc7946 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -8,19 +8,17 @@ [quantum.untyped.core.form.evaluate :as ufeval] [quantum.untyped.core.log :as ulog] [quantum.untyped.core.logic :as l] + [quantum.untyped.core.spec :as us] [quantum.untyped.core.specs :as ss])) (s/def :quantum.core.defnt/local-name - (s/and simple-symbol? (set/not #{'& '| '>}))) + (s/and simple-symbol? (set/not #{'& '| '> '?}))) ;; ----- Specs ----- ;; -(s/def :quantum.core.defnt/spec s/any?) - -(s/def :quantum.core.defnt/arg-spec ; TODO expand; make typed destructuring available via :quantum.core.specs/binding-form +(s/def :quantum.core.defnt/spec (s/alt :infer #{'?} - :any #{'_} - :spec :quantum.core.defnt/spec)) + :spec any?)) ;; ----- General destructuring ----- ;; @@ -29,25 +27,27 @@ :seq :quantum.core.defnt/seq-binding-form :map :quantum.core.defnt/map-binding-form)) +(s/def :quantum.core.defnt/speced-binding + (s/cat :binding-form :quantum.core.defnt/binding-form + :spec :quantum.core.defnt/spec)) + ;; ----- Sequential destructuring ----- ;; (s/def :quantum.core.defnt/seq-binding-form (s/and vector? - (s/cat :elems (s/* :quantum.core.specs/binding-form) - :rest (s/? (s/cat :amp #{'&} :form :quantum.core.defnt/binding-form)) + (s/cat :elems (s/* :quantum.core.defnt/speced-binding) + :rest (s/? (s/cat :amp #{'&} :form :quantum.core.defnt/speced-binding)) :as (s/? (s/cat :as #{:as} :sym :quantum.core.defnt/local-name))))) ;; ----- Map destructuring ----- ;; (defn- >keys|syms|strs [spec] (s/and vector? - (s/spec (s/* (s/cat :arg-binding spec - :quantum.core.defnt/arg-spec :quantum.core.defnt/arg-spec))))) + (s/spec (s/* (s/cat :binding-form spec + :spec :quantum.core.defnt/spec))))) (s/def :quantum.core.defnt/keys (>keys|syms|strs ident?)) - (s/def :quantum.core.defnt/syms (>keys|syms|strs symbol?)) - (s/def :quantum.core.defnt/strs (>keys|syms|strs simple-symbol?)) (s/def :quantum.core.defnt/or :quantum.core.specs/or) @@ -57,73 +57,65 @@ (s/keys :opt-un [:quantum.core.defnt/as :quantum.core.defnt/or :quantum.core.defnt/keys :quantum.core.defnt/syms :quantum.core.defnt/strs])) -; TODO finish this and others in this namespace -(s/def :quantum.core.defnt/map-binding (s/tuple :quantum.core.defnt/binding-form any?)) +(s/def :quantum.core.defnt/map-binding + (s/spec (s/cat :binding-form :quantum.core.defnt/binding-form + :key+spec (s/spec (s/cat :key any? :spec :quantum.core.defnt/spec))))) -; TODO -(s/def :quantum.core.specs/ns-keys +(s/def :quantum.core.defnt/ns-keys (s/tuple (s/and qualified-keyword? #(-> % name #{"keys" "syms"})) - (s/coll-of simple-symbol? :kind vector?))) + (>keys|syms|strs simple-symbol?))) -; TODO -(s/def :quantum.core.specs/map-bindings - (s/every (s/or :mb :quantum.core.specs/map-binding - :nsk :quantum.core.specs/ns-keys - :msb (s/tuple #{:as :or :keys :syms :strs} any?)) :into {})) - -; TODO -(s/def :quantum.core.specs/map-binding-form - (s/merge :quantum.core.specs/map-bindings :quantum.core.specs/map-special-binding)) +(s/def :quantum.core.defnt/map-binding-form + (s/and :quantum.core.defnt/map-special-binding + (s/coll-of (s/or :map-binding :quantum.core.defnt/map-binding + :ns-keys :quantum.core.defnt/ns-keys + :special (s/tuple #{:as :or :keys :syms :strs} any?)) :into {}))) ;; ----- Args ----- ;; -(s/def :quantum.core.defnt/fnt|speced-binding - (s/cat :arg-binding :quantum.core.defnt/fnt|speced-binding - :quantum.core.defnt/fnt|arg-spec :quantum.core.defnt/fnt|arg-spec)) - -(s/def :quantum.core.defnt/fnt|output-spec - (s/? (s/cat :sym (fn1 = '>) :quantum.core.defnt/spec :quantum.core.defnt/spec))) +(s/def :quantum.core.defnt/output-spec + (s/? (s/cat :sym (fn1 = '>) :spec :quantum.core.defnt/spec))) -(s/def :quantum.core.defnt/fnt|arglist +(s/def :quantum.core.defnt/arglist (s/and vector? (s/spec - (s/cat :args (s/* :quantum.core.defnt/fnt|speced-binding) - :varargs (s/? (s/cat :sym (fn1 = '&) - :quantum.core.defnt/fnt|speced-binding :quantum.core.defnt/fnt|speced-binding)) - :pre (s/? (s/cat :sym (fn1 = '|) - :quantum.core.defnt/spec :quantum.core.defnt/spec)) - :post :quantum.core.defnt/fnt|output-spec)) + (s/cat :args (s/* :quantum.core.defnt/speced-binding) + :varargs (s/? (s/cat :sym (fn1 = '&) + :speced-binding :quantum.core.defnt/speced-binding)) + :pre (s/? (s/cat :sym (fn1 = '|) + :spec any?)) + :post :quantum.core.defnt/output-spec)) (s/conformer - #(cond-> % (contains? % :varargs) (update :varargs :quantum.core.defnt/fnt|speced-binding) - (contains? % :pre ) (update :pre :quantum.core.defnt/spec) - (contains? % :post ) (update :post :quantum.core.defnt/spec))) + #(cond-> % (contains? % :varargs) (update :varargs :speced-binding) + (contains? % :pre ) (update :pre :spec) + (contains? % :post ) (update :post :spec))) (fn [{:keys [args varargs]}] ;; so `env` in `fnt` can work properly in the analysis ;; TODO need to adjust for destructuring (c/distinct? - (concat (c/lmap :arg-binding args) - [(:arg-binding varargs)]))))) + (concat (c/lmap :binding-form args) + [(:binding-form varargs)]))))) -(s/def :quantum.core.defnt/fnt|body (s/alt :body (s/* s/any?))) +(s/def :quantum.core.defnt/body (s/alt :body (s/* any?))) -(s/def :quantum.core.defnt/fnt|arglist+body - (s/cat :quantum.core.defnt/fnt|arglist :quantum.core.defnt/fnt|arglist - :body :quantum.core.defnt/fnt|body)) +(s/def :quantum.core.defnt/arglist+body + (s/cat :arglist :quantum.core.defnt/arglist + :body :quantum.core.defnt/body)) -(s/def :quantum.core.defnt/fnt|overloads - (s/alt :overload-1 :quantum.core.defnt/fnt|arglist+body - :overload-n (s/cat :overloads (s/+ (s/spec :quantum.core.defnt/fnt|arglist+body))))) +(s/def :quantum.core.defnt/overloads + (s/alt :overload-1 :quantum.core.defnt/arglist+body + :overload-n (s/cat :overloads (s/+ (s/spec :quantum.core.defnt/arglist+body))))) -(s/def :quantum.core.defnt/fnt|postchecks +(s/def :quantum.core.defnt/postchecks (s/conformer (fn [f] (-> f (update :overloads (fnl mapv (fn [overload] (let [overload' (update overload :body :body)] - (l/if-let [output-spec (-> f :output-spec :quantum.core.defnt/spec)] - (do (s/validate (-> overload' :quantum.core.defnt/fnt|arglist :post) nil?) - (c/assoc-in overload' [:quantum.core.defnt/fnt|arglist :post] output-spec)) + (l/if-let [output-spec (-> f :output-spec :spec)] + (do (us/validate (-> overload' :arglist :post) nil?) + (c/assoc-in overload' [:arglist :post] output-spec)) overload'))))) (dissoc :output-spec))))) @@ -133,10 +125,10 @@ :quantum.core.specs/fn|name (s/? :quantum.core.specs/fn|name) :quantum.core.specs/docstring (s/? :quantum.core.specs/docstring) :quantum.core.specs/meta (s/? :quantum.core.specs/meta) - :output-spec :quantum.core.defnt/fnt|output-spec - :overloads :quantum.core.defnt/fnt|overloads)) + :output-spec :quantum.core.defnt/output-spec + :overloads :quantum.core.defnt/overloads)) :quantum.core.specs/fn|postchecks - :quantum.core.defnt/fnt|postchecks)) + :quantum.core.defnt/postchecks)) (s/def :quantum.core.defnt/fns|code :quantum.core.defnt/fnt) @@ -146,79 +138,113 @@ :quantum.core.specs/fn|name :quantum.core.specs/fn|name :quantum.core.specs/docstring (s/? :quantum.core.specs/docstring) :quantum.core.specs/meta (s/? :quantum.core.specs/meta) - :output-spec :quantum.core.defnt/fnt|output-spec - :overloads :quantum.core.defnt/fnt|overloads)) + :output-spec :quantum.core.defnt/output-spec + :overloads :quantum.core.defnt/overloads)) :quantum.core.specs/fn|postchecks - :quantum.core.defnt/fnt|postchecks)) + :quantum.core.defnt/postchecks)) (s/def :quantum.core.defnt/defns|code :quantum.core.defnt/defnt) +(s/def :quantum.core.defnt/binding-form + (s/alt :sym :quantum.core.defnt/local-name + :seq :quantum.core.defnt/seq-binding-form + :map :quantum.core.defnt/map-binding-form)) + +(defn speced-binding>binding [{[kind binding-] :binding-form} #_:quantum.core.defnt/speced-binding] + (case kind + :sym binding- + :seq (let [{:keys [as elems] rest- :rest} binding-] + (cond-> (mapv speced-binding>binding elems) + rest- (conj '& (-> rest- :form speced-binding>binding)) + as (conj :as (:sym as)))) + :map (->> binding- + (map (fn [[k v]] + (case k + :as [k (second v)] + :or [k v] + (:keys :syms :strs) [k (->> v second (mapv :binding-form))] + [(speced-binding>binding v) + (get-in v [:key+spec :key])]))) + (into {})))) + (defn fns|code [kind lang args] (assert (= lang #?(:clj :clj :cljs :cljs)) lang) + (when (= kind :fn) (ulog/warn! "`fn` will ignore spec validation")) (let [{:keys [:quantum.core.specs/fn|name overloads :quantum.core.specs/meta] :as args'} - (s/validate args (case kind :defn :quantum.core.defnt/defns|code :fn :quantum.core.defnt/fns|code)) - overload-data>overload - (fn [{{:keys [args varargs pre post]} :quantum.core.defnt/fnt|arglist - body :body}] - (let [arg-spec>validation - (fn [{[k spec] :quantum.core.defnt/fnt|arg-spec :keys [arg-binding]}] - ;; TODO this validation is purely temporary until destructuring is supported - (s/validate arg-binding simple-symbol?) - (case k - :any nil - :infer (do (ulog/pr :warn "Spec inference not supported in `defns`. Ignoring request to infer" (str "`" arg-binding "`")) - nil) - :spec (list `s/validate arg-binding spec))) - spec-validations - (concat (c/lmap arg-spec>validation args) - (some-> varargs arg-spec>validation)) - ;; TODO if an arg has been primitive-type-hinted in the `fn` arglist, then no need to do an `instance?` check - ?hint-arg - (fn [{[k spec] :quantum.core.defnt/fnt|arg-spec :keys [arg-binding]}] - arg-binding) - arglist' - (->> args - (c/map ?hint-arg) - (<- (cond-> varargs (conj '& (?hint-arg varargs))))) - pre-validations - (c/>vec (concat (some->> spec-validations (c/lfilter some?)) - (when pre (list 'assert pre)))) - validations - (->> {:post (when post [(list post (symbol "%"))]) - :pre (when (seq pre-validations) pre-validations)} - (c/remove-vals' empty?))] - (list* arglist' (concat (when (seq validations) [validations]) body)))) - overloads (mapv overload-data>overload overloads) - code (case kind - :fn (list* 'fn (concat - (if (contains? args' :quantum.core.specs/fn|name) - [fn|name] - []) - [overloads])) - :defn (list* 'defn fn|name overloads))] + (us/validate args (case kind :defn :quantum.core.defnt/defns|code :fn :quantum.core.defnt/fns|code)) + _ (prl! args') + arglist>arity-ident (fn [{:keys [args varargs]}] + (keyword (str "arity-" (if varargs "varargs" (count args))))) + forms (reduce + (fn [ret {{:keys [args varargs] :as arglist} :arglist :keys [body]} #_:quantum.core.defnt/arglist+body] + (prl! ret arglist body) + (let [arglist-form|args (mapv speced-binding>binding args) + arglist-form|varargs (some-> varargs speced-binding>binding) + arglist-form (cond-> arglist-form|args + varargs (conj '& arglist-form|varargs)) + kw-arglist-form (->> arglist-form|args + ;; TODO finish this + ;; (map (fn [binding-] [binding- (binding>kw-ident binding-)])) + (into (array-map))) + kw-arglist-form (cond-> kw-arglist-form + varargs (assoc :varargs arglist-form|varargs)) + overload* (list* arglist-form body) + arity-ident (arglist>arity-ident arglist) + ;; ;; TODO finish this + ;; spec `(s/cat ~(keyword )) + ;; ;; TODO finish this + ;; spec (if (contains? arglist :pre) + ;; `(s/and ~spec (fn [{...}] ~pre)) + ;; spec) + ;; TODO finish this + spec-form|args* nil + ;; TODO finish this + spec-form|fn* nil + ] + (-> ret + (update :overloads conj overload*) + (update :spec-form|args conj arity-ident spec-form|args*) + (update :spec-form|fn conj arity-ident spec-form|fn*)))) + {:overloads [] + :spec-form|args [] + :spec-form|fn []} + overloads) + _ (prl! forms) + spec-form (when (= kind :defn) + `(s/fdef ~fn|name {:args (s/or ~@(:spec-form|args forms)) + :fn (fn [{ret# :ret [arity-kind# args#] :args}] + (case arity-kind# + ~@(:spec-form|fn forms)))})) + fn-form (case kind + :fn (list* 'fn (-> (if (contains? args' :quantum.core.specs/fn|name) + [fn|name] + []) + (conj (:overloads forms)))) + :defn (list* 'defn fn|name (:overloads forms))) + code `(do ~spec-form ~fn-form)] code)) #?(:clj (defmacro fns - "Like `fnt`, but relies on runtime spec checks. Does not perform type inference." - [& args] - (fns|code :fn (ufeval/env-lang) args))) + "Like `fnt`, but relies entirely on runtime spec checks. Does not perform type inference." + [& args] (fns|code :fn (ufeval/env-lang) args))) #?(:clj (defmacro defns - "Like `defnt`, but relies on runtime spec checks. Does not perform type inference." - [& args] - (fns|code :defn (ufeval/env-lang) args))) + "Like `defnt`, but relies entirely on runtime spec checks. Does not perform type inference." + [& args] (fns|code :defn (ufeval/env-lang) args))) + +#_(set! s/*explain-out* expound/printer) -(defns abcde "Documentation" +#_(defns abcde "Documentation" {:metadata "abc"} ([a #(instance? Long %)] (+ a 1)) - ([b ? c _ > integer?] {:pre 1} 1 2) + ([b ?, c _ > integer?] {:pre 1} 1 2) ([d string?, e #(instance? StringBuilder %) & f _ > number?] (.substring ^String d 0 1) (.append ^StringBuilder e 1) 3 4)) -(defns fghij +(defns fghij "Documentation" {:metadata "abc"} ([a number? > number?] (inc a)) ([a number?, b number? | (> a b) @@ -227,9 +253,50 @@ b boolean? {:as c :keys [d keyword? e string?] - [f integer?] :f} + f [:f string?]} #(-> % count (= 2)) [g double? & h seq? :as i] sequential? - & j seq? - | (and (> a b) (contains? c a)) + [j symbol?] vector? + & [l string? :as k] seq? + | (and (> a b) (contains? c a) + a b c d e f g h i j k l) > number?] 0)) + +(s/fdef fghijk + :args (s/or :arity-1 (s/cat :a number?) + :arity-2 (s/and (s/cat :a number? :b number?) + (fn [{a :a b :b}] (> a b))) + :arity-3 (s/and (s/cat :a string? + :b boolean? + :c (s/and #(-> % count (= 2)) + (fn [{:keys [d]}] (keyword? d)) + (fn [{:keys [e]}] (string? e)) + (fn [{f :f}] (string? f))) + :i (s/and sequential? + (fn [[g]] (double? g)) + (fn [[g & h]] (seq? h))) + :arg4# (s/and vector? + (fn [[j]] (symbol? j))) + :k (s/and seq? + (fn [[l]] (string? l)))) + (fn [{a :a + b :b + {:as c :keys [d e] f :f} :c + [g & h :as i] :i + [j] :arg4# + [l :as k] :k}] + (and (> a b) (contains? c a) + a b c d e f g h i j k l)))) + :fn (fn [{ret :ret [arity-kind args] :args}] + (case arity-kind + :arity-1 (let [{a :a} args] + (number? ret)) + :arity-2 (let [{a :a b :b} args] + ((s/and number? #(> % a) #(> % b)) ret)) + :arity-3 (let [{a :a + b :b + {:as c :keys [d e] f :f} :c + [g & h :as i] :i + [j] :arg4# + [l :as k] :k} args] + (number? ret))))) From 1b7ddc6aea49ecfe58721d2b2af320be5083cee0 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 20 Apr 2018 08:35:14 -0600 Subject: [PATCH 017/810] Continue to work to support destructuring --- src-untyped/quantum/untyped/core/defnt.cljc | 207 +++++++++++++------- 1 file changed, 137 insertions(+), 70 deletions(-) diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index c0fc7946..4a978a6d 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -2,17 +2,23 @@ (:require [clojure.spec.alpha :as s] [quantum.untyped.core.collections :as c] - [quantum.untyped.core.data.set :as set] + [quantum.untyped.core.convert :as uconv] + [quantum.untyped.core.data.map + :refer [om]] + [quantum.untyped.core.data.set :as uset] [quantum.untyped.core.fn :refer [<- fn-> fn1 fnl]] [quantum.untyped.core.form.evaluate :as ufeval] [quantum.untyped.core.log :as ulog] - [quantum.untyped.core.logic :as l] + [quantum.untyped.core.logic :as ul] + [quantum.untyped.core.loops + :refer [reduce-2]] + [quantum.untyped.core.reducers :as ur] [quantum.untyped.core.spec :as us] [quantum.untyped.core.specs :as ss])) (s/def :quantum.core.defnt/local-name - (s/and simple-symbol? (set/not #{'& '| '> '?}))) + (s/and simple-symbol? (uset/not #{'& '| '> '?}))) ;; ----- Specs ----- ;; @@ -113,7 +119,7 @@ (-> f (update :overloads (fnl mapv (fn [overload] (let [overload' (update overload :body :body)] - (l/if-let [output-spec (-> f :output-spec :spec)] + (ul/if-let [output-spec (-> f :output-spec :spec)] (do (us/validate (-> overload' :arglist :post) nil?) (c/assoc-in overload' [:arglist :post] output-spec)) overload'))))) @@ -167,60 +173,120 @@ (get-in v [:key+spec :key])]))) (into {})))) +(defn speced-binding>arg-ident + [{[kind binding-] :binding-form} #_:quantum.core.defnt/speced-binding & [i|arg] #_(? nneg-integer?)] + (uconv/>keyword + (case kind + :sym binding- + (:seq :map) + (let [ks (if (= kind :seq) [:as :sym] [:as 1])] + (or (get-in binding- ks) + (gensym (if i|arg (str "arg-" i|arg "-") "varargs"))))))) + +(s/fdef fghijk + :args (s/or :arity-varargs + (s/and (s/cat :a string? + :b boolean? + :c (s/and #(-> % count (= 2)) + (fn [{:keys [d]}] (keyword? d)) + (fn [{:keys [e]}] (string? e)) + (fn [{f :f}] (string? f))) + :i (s/and sequential? + (fn [[g]] (double? g)) + (fn [[g & h]] (seq? h))) + :arg-4# (s/and vector? + (fn [[j]] (symbol? j))) + :k (s/and seq? + (fn [[l]] (string? l))))))) + +;; TODO need to do fns args with outwardly growing recursive context {:k (f ...)} +(defn speced-binding>arg-specs + ([speced-binding #_:quantum.core.defnt/speced-binding]) + ([{:as speced-binding [kind binding-] :binding-form [_ spec] :spec} #_:quantum.core.defnt/speced-binding context] + (let [arg-specssss (into [spec] + (case kind + :sym [] + :seq ((fn abcde-seq [] (let [{elems :elems rest- :rest} binding-] + (->> (mapv speced-binding>arg-specs elems) + (<- (cond-> rest- (conj (-> rest- :form speced-binding>arg-specs)))) + (apply concat))))) + :map ((fn abcde-map [] + (->> binding- + (map (fn [[k v]] (prl! k v) + (case k + (:as :or) nil + (:keys :syms :strs) (->> v second (mapv (fn-> :spec second))) + (speced-binding>arg-specs + (-> v (assoc :spec (get-in v [:key+spec :spec]))))))) + (apply concat))))))] + (prl! arg-specssss) + arg-specssss))) + +(defn arglist>spec-form|arglist + [args+varargs kw-args #_:quantum.core.specs/map-binding-form] + `(s/cat ~@(reduce-2 + (fn [ret speced-binding [_ kw-arg]] + (prl! speced-binding kw-arg) + (let [arg-specs (speced-binding>arg-specs speced-binding)] + (conj ret kw-arg (if (-> arg-specs count (= 1)) + (first arg-specs) + `(s/and ~@arg-specs))))) + [] + args+varargs kw-args))) + (defn fns|code [kind lang args] (assert (= lang #?(:clj :clj :cljs :cljs)) lang) (when (= kind :fn) (ulog/warn! "`fn` will ignore spec validation")) (let [{:keys [:quantum.core.specs/fn|name overloads :quantum.core.specs/meta] :as args'} (us/validate args (case kind :defn :quantum.core.defnt/defns|code :fn :quantum.core.defnt/fns|code)) _ (prl! args') - arglist>arity-ident (fn [{:keys [args varargs]}] - (keyword (str "arity-" (if varargs "varargs" (count args))))) - forms (reduce - (fn [ret {{:keys [args varargs] :as arglist} :arglist :keys [body]} #_:quantum.core.defnt/arglist+body] - (prl! ret arglist body) - (let [arglist-form|args (mapv speced-binding>binding args) - arglist-form|varargs (some-> varargs speced-binding>binding) - arglist-form (cond-> arglist-form|args - varargs (conj '& arglist-form|varargs)) - kw-arglist-form (->> arglist-form|args - ;; TODO finish this - ;; (map (fn [binding-] [binding- (binding>kw-ident binding-)])) - (into (array-map))) - kw-arglist-form (cond-> kw-arglist-form - varargs (assoc :varargs arglist-form|varargs)) - overload* (list* arglist-form body) - arity-ident (arglist>arity-ident arglist) - ;; ;; TODO finish this - ;; spec `(s/cat ~(keyword )) - ;; ;; TODO finish this - ;; spec (if (contains? arglist :pre) - ;; `(s/and ~spec (fn [{...}] ~pre)) - ;; spec) - ;; TODO finish this - spec-form|args* nil - ;; TODO finish this - spec-form|fn* nil - ] - (-> ret - (update :overloads conj overload*) - (update :spec-form|args conj arity-ident spec-form|args*) - (update :spec-form|fn conj arity-ident spec-form|fn*)))) - {:overloads [] - :spec-form|args [] - :spec-form|fn []} - overloads) - _ (prl! forms) + ret-sym (gensym "ret") arity-kind-sym (gensym "arity-kind") args-sym (gensym "args") + {:keys [overload-forms spec-form|args spec-form|fn]} + (reduce + (fn [ret {{:keys [args varargs pre] [_ post] :post :as arglist} :arglist :keys [body]} #_:quantum.core.defnt/arglist+body] + (prl! ret arglist body) + (let [{:keys [fn-arglist kw-args]} + (ur/reducei + (fn [ret {:as speced-binding :keys [varargs?]} i|arg] + (let [arg-ident (speced-binding>arg-ident speced-binding i|arg) + binding- (speced-binding>binding speced-binding)] + (-> ret (cond-> varargs? (update :form conj '&)) + (update :fn-arglist conj binding-) + (update :kw-args assoc binding- arg-ident)))) + {:fn-arglist [] :kw-args (om)} + (cond-> args varargs (conj (assoc varargs :varargs? true)))) + _ (prl! fn-arglist kw-args) + overload-form (list* fn-arglist body) + _ (prl! overload-form) + arity-ident (keyword (str "arity-" (if varargs "varargs" (count args)))) + _ (prl! arity-ident) + spec-form|arglist (arglist>spec-form|arglist (cond-> args varargs (conj varargs)) kw-args) + spec-form|pre (when (contains? arglist :pre) `(fn [~kw-args] ~pre)) + spec-form|args* (if spec-form|pre + `(s/and ~spec-form|arglist ~spec-form|pre) + spec-form|arglist) + spec-form|fn* (if (contains? arglist :post) + `(let [~kw-args ~args-sym] (~post ~ret-sym)) + `any?)] + (-> ret + (update :overload-forms conj overload-form) + (update :spec-form|args conj arity-ident spec-form|args*) + (update :spec-form|fn conj arity-ident spec-form|fn*)))) + {:overloads [] + :spec-form|args [] + :spec-form|fn []} + overloads) + _ (prl! overload-forms spec-form|args spec-form|fn) spec-form (when (= kind :defn) - `(s/fdef ~fn|name {:args (s/or ~@(:spec-form|args forms)) - :fn (fn [{ret# :ret [arity-kind# args#] :args}] - (case arity-kind# - ~@(:spec-form|fn forms)))})) + `(s/fdef ~fn|name {:args (s/or ~@spec-form|args) + :fn (fn [{~ret-sym :ret [~arity-kind-sym ~args-sym] :args}] + (case ~arity-kind-sym ~@spec-form|fn))})) fn-form (case kind :fn (list* 'fn (-> (if (contains? args' :quantum.core.specs/fn|name) [fn|name] []) - (conj (:overloads forms)))) - :defn (list* 'defn fn|name (:overloads forms))) + (conj overload-forms))) + :defn (list* 'defn fn|name overload-forms)) code `(do ~spec-form ~fn-form)] code)) @@ -264,29 +330,30 @@ (s/fdef fghijk :args (s/or :arity-1 (s/cat :a number?) - :arity-2 (s/and (s/cat :a number? :b number?) - (fn [{a :a b :b}] (> a b))) - :arity-3 (s/and (s/cat :a string? - :b boolean? - :c (s/and #(-> % count (= 2)) - (fn [{:keys [d]}] (keyword? d)) - (fn [{:keys [e]}] (string? e)) - (fn [{f :f}] (string? f))) - :i (s/and sequential? - (fn [[g]] (double? g)) - (fn [[g & h]] (seq? h))) - :arg4# (s/and vector? - (fn [[j]] (symbol? j))) - :k (s/and seq? - (fn [[l]] (string? l)))) - (fn [{a :a - b :b - {:as c :keys [d e] f :f} :c - [g & h :as i] :i - [j] :arg4# - [l :as k] :k}] - (and (> a b) (contains? c a) - a b c d e f g h i j k l)))) + :arity-2 (s/and (s/cat :a number? :b number?) + (fn [{a :a b :b}] (> a b))) + :arity-varargs + (s/and (s/cat :a string? + :b boolean? + :c (s/and #(-> % count (= 2)) + (fn [{:keys [d]}] (keyword? d)) + (fn [{:keys [e]}] (string? e)) + (fn [{f :f}] (string? f))) + :i (s/and sequential? + (fn [[g]] (double? g)) + (fn [[g & h]] (seq? h))) + :arg-4# (s/and vector? + (fn [[j]] (symbol? j))) + :k (s/and seq? + (fn [[l]] (string? l)))) + (fn [{a :a + b :b + {:as c :keys [d e] f :f} :c + [g & h :as i] :i + [j] :arg-4# + [l :as k] :k}] + (and (> a b) (contains? c a) + a b c d e f g h i j k l)))) :fn (fn [{ret :ret [arity-kind args] :args}] (case arity-kind :arity-1 (let [{a :a} args] From e59f7862b3c2b80ac2ce806ff4858f985a740691 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 1 May 2018 01:37:53 -0600 Subject: [PATCH 018/810] Untyped `defnt` works!! :D Just need to complete tests --- project-base.clj | 1 + src-untyped/quantum/untyped/core/defnt.cljc | 178 +++++++------------- test/quantum/test/untyped/core/defnt.cljc | 101 +++++++++++ 3 files changed, 164 insertions(+), 116 deletions(-) create mode 100644 test/quantum/test/untyped/core/defnt.cljc diff --git a/project-base.clj b/project-base.clj index c12c78ff..3e719198 100644 --- a/project-base.clj +++ b/project-base.clj @@ -113,6 +113,7 @@ ; ==== SPECS ==== [expound "0.5.0"] + [orchestra "2017.11.12-1"] ; ==== COLLECTIONS ==== [diffit "1.0.0"] ; ==== CONVERT ==== diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index 4a978a6d..1529ffba 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -15,7 +15,9 @@ :refer [reduce-2]] [quantum.untyped.core.reducers :as ur] [quantum.untyped.core.spec :as us] - [quantum.untyped.core.specs :as ss])) + [quantum.untyped.core.specs :as ss] + [quantum.untyped.core.vars + :refer [defmacro-]])) (s/def :quantum.core.defnt/local-name (s/and simple-symbol? (uset/not #{'& '| '> '?}))) @@ -183,50 +185,67 @@ (or (get-in binding- ks) (gensym (if i|arg (str "arg-" i|arg "-") "varargs"))))))) -(s/fdef fghijk - :args (s/or :arity-varargs - (s/and (s/cat :a string? - :b boolean? - :c (s/and #(-> % count (= 2)) - (fn [{:keys [d]}] (keyword? d)) - (fn [{:keys [e]}] (string? e)) - (fn [{f :f}] (string? f))) - :i (s/and sequential? - (fn [[g]] (double? g)) - (fn [[g & h]] (seq? h))) - :arg-4# (s/and vector? - (fn [[j]] (symbol? j))) - :k (s/and seq? - (fn [[l]] (string? l))))))) - -;; TODO need to do fns args with outwardly growing recursive context {:k (f ...)} +(defn context>destructuring [arg-ident #_simple-symbol? context #_vector?] + (reduce + (fn [destructuring [context-type #_#{:map :seq} k varargs?]] + (case context-type + :map {destructuring k} + :seq (let [base (vec (repeatedly k #(gensym "_")))] + (if varargs? + (conj base '& destructuring) + (assoc base k destructuring))) + (:keys :syms :strs) {context-type [destructuring]})) + arg-ident + (rseq context))) + +#?(:clj +(defmacro- spec-fn [[destructuring] [spec sym]] + `(let [spec# ~spec] (fn [~destructuring] (spec# ~sym))))) + +(defn keys-syms-strs>arg-specs [binding- binding-kind context] + (->> (get binding- binding-kind) second + (mapv (fn [{:keys [binding-form #_symbol?] [_ spec] :spec}] + (let [destructuring (context>destructuring binding-form (conj context [binding-kind nil]))] + `(spec-fn [~destructuring] (~spec ~binding-form))))))) + +(defn >as-specs [{:as speced-binding [kind binding-] :binding-form [_ spec] :spec} context] + (let [[k base-spec] (case kind :seq [:sym `clojure.core/seqable?] + :map [1 `clojure.core/map?])] + (let [as-ident (or (get-in binding- [:as k]) (gensym "as")) + destructuring (context>destructuring as-ident context)] + [`(spec-fn [~destructuring] (~base-spec ~as-ident)) + `(spec-fn [~destructuring] (~spec ~as-ident))]))) + (defn speced-binding>arg-specs - ([speced-binding #_:quantum.core.defnt/speced-binding]) - ([{:as speced-binding [kind binding-] :binding-form [_ spec] :spec} #_:quantum.core.defnt/speced-binding context] - (let [arg-specssss (into [spec] - (case kind - :sym [] - :seq ((fn abcde-seq [] (let [{elems :elems rest- :rest} binding-] - (->> (mapv speced-binding>arg-specs elems) - (<- (cond-> rest- (conj (-> rest- :form speced-binding>arg-specs)))) - (apply concat))))) - :map ((fn abcde-map [] - (->> binding- - (map (fn [[k v]] (prl! k v) - (case k - (:as :or) nil - (:keys :syms :strs) (->> v second (mapv (fn-> :spec second))) - (speced-binding>arg-specs - (-> v (assoc :spec (get-in v [:key+spec :spec]))))))) - (apply concat))))))] - (prl! arg-specssss) - arg-specssss))) + ([speced-binding] (speced-binding>arg-specs speced-binding [])) + ([{:as speced-binding [kind binding-] :binding-form [_ spec] :spec} #_:quantum.core.defnt/speced-binding context #_vector?] + (case kind + :sym [(let [destructuring (context>destructuring binding- context)] + `(spec-fn [~destructuring] (~spec ~binding-)))] + :seq (let [{elems :elems rest- :rest} binding-] + (apply concat + (>as-specs speced-binding context) + (->> elems + (map-indexed (fn [i speced-binding] + (speced-binding>arg-specs speced-binding (conj context [:seq i])))) + (apply concat)) + (when rest- + [(speced-binding>arg-specs (:form rest-) (conj context [:seq (count elems) true]))]))) + :map (apply concat + (>as-specs speced-binding context) + (keys-syms-strs>arg-specs binding- :keys context) + (keys-syms-strs>arg-specs binding- :syms context) + (keys-syms-strs>arg-specs binding- :strs context) + (->> (dissoc binding- :as :or :keys :syms :strs) + (map (fn [[k {:as v :keys [key+spec]}]] + (speced-binding>arg-specs + (assoc v :spec (:spec key+spec)) + (conj context [:map (:key key+spec)]))))))))) (defn arglist>spec-form|arglist [args+varargs kw-args #_:quantum.core.specs/map-binding-form] `(s/cat ~@(reduce-2 (fn [ret speced-binding [_ kw-arg]] - (prl! speced-binding kw-arg) (let [arg-specs (speced-binding>arg-specs speced-binding)] (conj ret kw-arg (if (-> arg-specs count (= 1)) (first arg-specs) @@ -239,27 +258,22 @@ (when (= kind :fn) (ulog/warn! "`fn` will ignore spec validation")) (let [{:keys [:quantum.core.specs/fn|name overloads :quantum.core.specs/meta] :as args'} (us/validate args (case kind :defn :quantum.core.defnt/defns|code :fn :quantum.core.defnt/fns|code)) - _ (prl! args') ret-sym (gensym "ret") arity-kind-sym (gensym "arity-kind") args-sym (gensym "args") {:keys [overload-forms spec-form|args spec-form|fn]} (reduce (fn [ret {{:keys [args varargs pre] [_ post] :post :as arglist} :arglist :keys [body]} #_:quantum.core.defnt/arglist+body] - (prl! ret arglist body) (let [{:keys [fn-arglist kw-args]} (ur/reducei (fn [ret {:as speced-binding :keys [varargs?]} i|arg] (let [arg-ident (speced-binding>arg-ident speced-binding i|arg) binding- (speced-binding>binding speced-binding)] - (-> ret (cond-> varargs? (update :form conj '&)) + (-> ret (cond-> varargs? (update :fn-arglist conj '&)) (update :fn-arglist conj binding-) (update :kw-args assoc binding- arg-ident)))) {:fn-arglist [] :kw-args (om)} (cond-> args varargs (conj (assoc varargs :varargs? true)))) - _ (prl! fn-arglist kw-args) overload-form (list* fn-arglist body) - _ (prl! overload-form) arity-ident (keyword (str "arity-" (if varargs "varargs" (count args)))) - _ (prl! arity-ident) spec-form|arglist (arglist>spec-form|arglist (cond-> args varargs (conj varargs)) kw-args) spec-form|pre (when (contains? arglist :pre) `(fn [~kw-args] ~pre)) spec-form|args* (if spec-form|pre @@ -276,11 +290,10 @@ :spec-form|args [] :spec-form|fn []} overloads) - _ (prl! overload-forms spec-form|args spec-form|fn) spec-form (when (= kind :defn) - `(s/fdef ~fn|name {:args (s/or ~@spec-form|args) - :fn (fn [{~ret-sym :ret [~arity-kind-sym ~args-sym] :args}] - (case ~arity-kind-sym ~@spec-form|fn))})) + `(s/fdef ~fn|name :args (s/or ~@spec-form|args) + :fn (fn [{~ret-sym :ret [~arity-kind-sym ~args-sym] :args}] + (case ~arity-kind-sym ~@spec-form|fn)))) fn-form (case kind :fn (list* 'fn (-> (if (contains? args' :quantum.core.specs/fn|name) [fn|name] @@ -300,70 +313,3 @@ "Like `defnt`, but relies entirely on runtime spec checks. Does not perform type inference." [& args] (fns|code :defn (ufeval/env-lang) args))) -#_(set! s/*explain-out* expound/printer) - -#_(defns abcde "Documentation" {:metadata "abc"} - ([a #(instance? Long %)] (+ a 1)) - ([b ?, c _ > integer?] {:pre 1} 1 2) - ([d string?, e #(instance? StringBuilder %) & f _ > number?] - (.substring ^String d 0 1) - (.append ^StringBuilder e 1) - 3 4)) - -(defns fghij "Documentation" {:metadata "abc"} - ([a number? > number?] (inc a)) - ([a number?, b number? - | (> a b) - > (s/and number? #(> % a) #(> % b))] (+ a b)) - ([a string? - b boolean? - {:as c - :keys [d keyword? e string?] - f [:f string?]} - #(-> % count (= 2)) - [g double? & h seq? :as i] sequential? - [j symbol?] vector? - & [l string? :as k] seq? - | (and (> a b) (contains? c a) - a b c d e f g h i j k l) - > number?] 0)) - -(s/fdef fghijk - :args (s/or :arity-1 (s/cat :a number?) - :arity-2 (s/and (s/cat :a number? :b number?) - (fn [{a :a b :b}] (> a b))) - :arity-varargs - (s/and (s/cat :a string? - :b boolean? - :c (s/and #(-> % count (= 2)) - (fn [{:keys [d]}] (keyword? d)) - (fn [{:keys [e]}] (string? e)) - (fn [{f :f}] (string? f))) - :i (s/and sequential? - (fn [[g]] (double? g)) - (fn [[g & h]] (seq? h))) - :arg-4# (s/and vector? - (fn [[j]] (symbol? j))) - :k (s/and seq? - (fn [[l]] (string? l)))) - (fn [{a :a - b :b - {:as c :keys [d e] f :f} :c - [g & h :as i] :i - [j] :arg-4# - [l :as k] :k}] - (and (> a b) (contains? c a) - a b c d e f g h i j k l)))) - :fn (fn [{ret :ret [arity-kind args] :args}] - (case arity-kind - :arity-1 (let [{a :a} args] - (number? ret)) - :arity-2 (let [{a :a b :b} args] - ((s/and number? #(> % a) #(> % b)) ret)) - :arity-3 (let [{a :a - b :b - {:as c :keys [d e] f :f} :c - [g & h :as i] :i - [j] :arg4# - [l :as k] :k} args] - (number? ret))))) diff --git a/test/quantum/test/untyped/core/defnt.cljc b/test/quantum/test/untyped/core/defnt.cljc new file mode 100644 index 00000000..6cb18571 --- /dev/null +++ b/test/quantum/test/untyped/core/defnt.cljc @@ -0,0 +1,101 @@ +(ns quantum.test.untyped.core.defnt + (:require + [quantum.untyped.core.defnt :as this])) + +#_(require '[expound.alpha :as expound]) +#_(set! s/*explain-out* expound/printer) + +#_(defns abcde "Documentation" {:metadata "abc"} + ([a #(instance? Long %)] (+ a 1)) + ([b ?, c _ > integer?] {:pre 1} 1 2) + ([d string?, e #(instance? StringBuilder %) & f _ > number?] + (.substring ^String d 0 1) + (.append ^StringBuilder e 1) + 3 4)) + +;; TODO assert that the below 2 things are equivalent + +(defns fghij "Documentation" {:metadata "abc"} + ([a number? > number?] (inc a)) + ([a number?, b number? + | (> a b) + > (s/and number? #(> % a) #(> % b))] (+ a b)) + ([a string? + b boolean? + {:as c + :keys [ca keyword? cb string?] + {:as cc + {:as cca + :keys [ccaa keyword?] + [[ccabaa some? {:as ccabab :keys [ccababa some?]} some?] some? ccabb some? :as ccab] + [:ccab seq?]} + [:cca map?]} + [:cc map?]} + #(-> % count (= 3)) + [da double? & db seq? :as d] sequential? + [ea symbol?] vector? + & [fa string? :as f] seq? + | (and (> a b) (contains? c a) + a b c ca cb cc cca ccaa ccab ccabaa ccabab ccababa ccabb d da db ea f fa) + > number?] 0)) + +(s/fdef fghijk + :args (s/or :arity-1 (s/cat :a (let [spec# number?] (fn [a] (spec# a)))) + :arity-2 (s/and (s/cat :a (let [spec# number?] (fn [a] (spec# a))) + :b (let [spec# number?] (fn [b] (spec# b)))) + (fn [{a :a b :b}] (> a b))) + :arity-varargs + (s/and (s/cat :a (let [spec# string?] (fn [a] (spec# a))) + :b (let [spec# boolean?] (fn [b] (spec# b))) + :c (s/and (let [spec# #(-> % count (= 3))] (fn [c] (spec# c))) + (let [spec# keyword?] (fn [{:keys [ca]}] (spec# ca))) + (let [spec# string?] (fn [{:keys [cb]}] (spec# cb))) + (let [spec# map?] (fn [{cc :cc}] (spec# cc))) + (let [spec# map?] (fn [{{cca :cca} :cc}] (spec# cca))) + (let [spec# keyword?] (fn [{{{:keys [ccaa]} :cca} :cc}] (spec# ccaa))) + (let [spec# seq?] (fn [{{{ccab :ccab} :cca} :cc}] (spec# ccab))) + (let [spec# some?] (fn [{{{[as#] :ccab} :cca} :cc}] (spec# as#))) + (let [spec# some?] (fn [{{{[[ccabaa]] :ccab} :cca} :cc}] (spec# ccabaa))) + (let [spec# some?] (fn [{{{[[_# ccabab]] :ccab} :cca} :cc}] (spec# ccabab))) + (let [spec# some?] (fn [{{{[[_# {:keys [ccababa]}]] :ccab} :cca} :cc}] (spec# ccababa))) + (let [spec# some?] (fn [{{{[_# ccabb] :ccab} :cca} :cc}] (spec# ccabb)))) + :d (s/and (let [spec# sequential?] (fn [d] (spec# d))) + (let [spec# double?] (fn [[da]] (spec# da))) + (let [spec# seq?] (fn [[_# & db]] (spec# db)))) + :arg-4# (s/and (let [spec# vector?] (fn [as#] (spec# as#))) + (let [spec# symbol?] (fn [[ea]] (spec# ea)))) + :f (s/and (let [spec# seq?] (fn [f] (spec# f))) + (let [spec# string?] (fn [[fa]] (spec# fa))))) + (fn [{a :a + b :b + {:as c + :keys [ca cb] + {:as cc + {:as cca + :keys [ccaa] + [[ccabaa {:as ccabab :keys [ccababa]}] ccabb :as ccab] :ccab} :cca} :cc} :c + [da & db :as d] :d + [ea] :arg-4# + [fa :as f] :f}] + (and (> a b) (contains? c a) + a b c ca cb cc cca ccaa ccab ccabaa ccabab ccababa ccabb d da db ea f fa)))) + :fn (fn [{ret :ret [arity-kind args] :args}] + (case arity-kind + :arity-1 (let [{a :a} args] + (number? ret)) + :arity-2 (let [{a :a b :b} args] + ((s/and number? #(> % a) #(> % b)) ret)) + :arity-3 (let [{a :a + b :b + {:as c + :keys [ca cb] + {:as cc + {:as cca + :keys [ccaa] + [[ccabaa {:as ccabab :keys [ccababa]}] ccabb :as ccab] :ccab} :cca} :cc} :c + [da & db :as d] :d + [ea] :arg-4# + [fa :as f] :f} args] + (number? ret))))) + +(fghij "zx" true {:ca :x :cb "y" :cc {:cca {:ccaa :z :ccab (list [1 {:ccababa 2}] 3)}}} [1.0 4] ['a]) From 120cfcc31ffd8b6f32e2bd5e81d20da8db0ad70c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 1 May 2018 23:44:22 -0600 Subject: [PATCH 019/810] Fix `fns` --- src-dev/quantum/core/defnt.cljc | 4 ++-- src-untyped/quantum/untyped/core/defnt.cljc | 10 +++++----- src-untyped/quantum/untyped/core/type.cljc | 2 +- src-untyped/quantum/untyped/core/type/defs.cljc | 9 ++++++--- src/quantum/core/type/defs.cljc | 2 +- test/quantum/test/untyped/core/defnt.cljc | 3 --- 6 files changed, 15 insertions(+), 15 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 70842a5a..f57263ce 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -43,8 +43,8 @@ :refer [kw-map]] [quantum.untyped.core.data.map :as map] [quantum.untyped.core.data.set :as set] - [quantum.untyped.core.defns - :refer [defns]] + [quantum.untyped.core.defnt + :refer [defns fns]] [quantum.untyped.core.form :as uform] [quantum.untyped.core.form.evaluate :as ufeval] [quantum.untyped.core.form.generate :as ufgen diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index 1529ffba..2846e3bd 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -1,4 +1,5 @@ (ns quantum.untyped.core.defnt + "Primarily for `(de)fns`." (:require [clojure.spec.alpha :as s] [quantum.untyped.core.collections :as c] @@ -199,7 +200,7 @@ (rseq context))) #?(:clj -(defmacro- spec-fn [[destructuring] [spec sym]] +(defmacro spec-fn [[destructuring] [spec sym]] `(let [spec# ~spec] (fn [~destructuring] (spec# ~sym))))) (defn keys-syms-strs>arg-specs [binding- binding-kind context] @@ -295,10 +296,9 @@ :fn (fn [{~ret-sym :ret [~arity-kind-sym ~args-sym] :args}] (case ~arity-kind-sym ~@spec-form|fn)))) fn-form (case kind - :fn (list* 'fn (-> (if (contains? args' :quantum.core.specs/fn|name) - [fn|name] - []) - (conj overload-forms))) + :fn (list* 'fn (concat (when (contains? args' :quantum.core.specs/fn|name) + [fn|name]) + overload-forms)) :defn (list* 'defn fn|name overload-forms)) code `(do ~spec-form ~fn-form)] code)) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 7f89d774..d267cc45 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -1063,7 +1063,7 @@ #?(:clj (def primitive-classes (->> unboxed-symbol->type-meta vals (uc/map+ :unboxed) (join #{})))) -(defn- -spec>classes [spec #_t/spec? classes #_set?] #_> set? +(defn- -spec>classes [spec #_t/spec? classes #_set?] #_> #_set? (cond (class-spec? spec) (conj classes (class-spec>class spec)) (value-spec? spec) diff --git a/src-untyped/quantum/untyped/core/type/defs.cljc b/src-untyped/quantum/untyped/core/type/defs.cljc index 8552b2c6..96b91035 100644 --- a/src-untyped/quantum/untyped/core/type/defs.cljc +++ b/src-untyped/quantum/untyped/core/type/defs.cljc @@ -18,6 +18,8 @@ [quantum.untyped.core.data.set :as uset] [quantum.untyped.core.data.tuple #?@(:cljs [:refer [Tuple]])] + [quantum.untyped.core.defnt + :refer [defns]] [quantum.untyped.core.fn :refer [<- fn-> fnl rcomp]] [quantum.untyped.core.form.evaluate @@ -111,8 +113,8 @@ :cljs (.-MIN_VALUE js/Number)) :min -1.7976931348623157E308 :max 1.7976931348623157E308 ; Max number in JS - :min-int -9007199254740992 ; -2^53 - :max-int 9007199254740992 ; 2^53 + :min-int -9007199254740992 ; -2^53 + :max-int 9007199254740992 ; 2^53 #?@(:clj [:array-ident "D" :outer-type "[D" :boxed java.lang.Double @@ -142,7 +144,8 @@ (zipmap (vals boxed-types) (keys boxed-types)))) #?(:clj -(def boxed->unboxed-types-evaled (->> unboxed-symbol->type-meta vals (map (juxt :boxed :unboxed)) (into {}) eval))) +(def boxed->unboxed-types-evaled + (->> unboxed-symbol->type-meta vals (map (juxt :boxed :unboxed)) (into {}) eval))) (def max-values (->> unboxed-symbol->type-meta diff --git a/src/quantum/core/type/defs.cljc b/src/quantum/core/type/defs.cljc index 42f5cefa..d5f919a8 100644 --- a/src/quantum/core/type/defs.cljc +++ b/src/quantum/core/type/defs.cljc @@ -17,4 +17,4 @@ elem-types-clj max-values max-type #?@(:clj [boxed-types unboxed-types boxed->unboxed-types-evaled promoted-types class->str]) - types|unevaled types) + #_types|unevaled #_types) diff --git a/test/quantum/test/untyped/core/defnt.cljc b/test/quantum/test/untyped/core/defnt.cljc index 6cb18571..175b0f9d 100644 --- a/test/quantum/test/untyped/core/defnt.cljc +++ b/test/quantum/test/untyped/core/defnt.cljc @@ -2,9 +2,6 @@ (:require [quantum.untyped.core.defnt :as this])) -#_(require '[expound.alpha :as expound]) -#_(set! s/*explain-out* expound/printer) - #_(defns abcde "Documentation" {:metadata "abc"} ([a #(instance? Long %)] (+ a 1)) ([b ?, c _ > integer?] {:pre 1} 1 2) From 3c6e4e757f7e9e66a01b0d7fa7f132ab016e04f3 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 2 May 2018 10:11:58 -0600 Subject: [PATCH 020/810] Allow underscore specs in `defns` --- src-untyped/quantum/untyped/core/defnt.cljc | 58 +++++++++++++-------- test/quantum/test/untyped/core/defnt.cljc | 6 ++- 2 files changed, 40 insertions(+), 24 deletions(-) diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index 2846e3bd..55313cf5 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -27,7 +27,8 @@ (s/def :quantum.core.defnt/spec (s/alt :infer #{'?} - :spec any?)) + :any #{'_} + :spec any?)) ;; ----- General destructuring ----- ;; @@ -93,7 +94,7 @@ :varargs (s/? (s/cat :sym (fn1 = '&) :speced-binding :quantum.core.defnt/speced-binding)) :pre (s/? (s/cat :sym (fn1 = '|) - :spec any?)) + :spec (s/or :any-spec #{'_} :spec any?))) :post :quantum.core.defnt/output-spec)) (s/conformer #(cond-> % (contains? % :varargs) (update :varargs :speced-binding) @@ -205,24 +206,27 @@ (defn keys-syms-strs>arg-specs [binding- binding-kind context] (->> (get binding- binding-kind) second - (mapv (fn [{:keys [binding-form #_symbol?] [_ spec] :spec}] + (filter (fn [{[spec-kind _] :spec}] (= spec-kind :spec))) + (mapv (fn [{:keys [binding-form #_symbol?] [spec-kind spec] :spec}] (let [destructuring (context>destructuring binding-form (conj context [binding-kind nil]))] `(spec-fn [~destructuring] (~spec ~binding-form))))))) -(defn >as-specs [{:as speced-binding [kind binding-] :binding-form [_ spec] :spec} context] +(defn >as-specs [{:as speced-binding [kind binding-] :binding-form [spec-kind spec] :spec} context] (let [[k base-spec] (case kind :seq [:sym `clojure.core/seqable?] :map [1 `clojure.core/map?])] (let [as-ident (or (get-in binding- [:as k]) (gensym "as")) destructuring (context>destructuring as-ident context)] - [`(spec-fn [~destructuring] (~base-spec ~as-ident)) - `(spec-fn [~destructuring] (~spec ~as-ident))]))) + (cond-> [`(spec-fn [~destructuring] (~base-spec ~as-ident))] + (= spec-kind :spec) (conj `(spec-fn [~destructuring] (~spec ~as-ident))))))) (defn speced-binding>arg-specs ([speced-binding] (speced-binding>arg-specs speced-binding [])) - ([{:as speced-binding [kind binding-] :binding-form [_ spec] :spec} #_:quantum.core.defnt/speced-binding context #_vector?] + ([{:as speced-binding [kind binding-] :binding-form [spec-kind spec] :spec} + #_:quantum.core.defnt/speced-binding context #_vector?] (case kind - :sym [(let [destructuring (context>destructuring binding- context)] - `(spec-fn [~destructuring] (~spec ~binding-)))] + :sym (when (= spec-kind :spec) + [(let [destructuring (context>destructuring binding- context)] + `(spec-fn [~destructuring] (~spec ~binding-)))]) :seq (let [{elems :elems rest- :rest} binding-] (apply concat (>as-specs speced-binding context) @@ -248,9 +252,10 @@ `(s/cat ~@(reduce-2 (fn [ret speced-binding [_ kw-arg]] (let [arg-specs (speced-binding>arg-specs speced-binding)] - (conj ret kw-arg (if (-> arg-specs count (= 1)) - (first arg-specs) - `(s/and ~@arg-specs))))) + (conj ret kw-arg (case (count arg-specs) + 0 `clojure.core/any? + 1 (first arg-specs) + `(s/and ~@arg-specs))))) [] args+varargs kw-args))) @@ -258,11 +263,12 @@ (assert (= lang #?(:clj :clj :cljs :cljs)) lang) (when (= kind :fn) (ulog/warn! "`fn` will ignore spec validation")) (let [{:keys [:quantum.core.specs/fn|name overloads :quantum.core.specs/meta] :as args'} - (us/validate args (case kind :defn :quantum.core.defnt/defns|code :fn :quantum.core.defnt/fns|code)) + (us/validate args (case kind (:defn :defn-) :quantum.core.defnt/defns|code + :fn :quantum.core.defnt/fns|code)) ret-sym (gensym "ret") arity-kind-sym (gensym "arity-kind") args-sym (gensym "args") {:keys [overload-forms spec-form|args spec-form|fn]} (reduce - (fn [ret {{:keys [args varargs pre] [_ post] :post :as arglist} :arglist :keys [body]} #_:quantum.core.defnt/arglist+body] + (fn [ret {{:keys [args varargs] [pre-kind pre] :pre [_ post] :post :as arglist} :arglist :keys [body]} #_:quantum.core.defnt/arglist+body] (let [{:keys [fn-arglist kw-args]} (ur/reducei (fn [ret {:as speced-binding :keys [varargs?]} i|arg] @@ -276,7 +282,8 @@ overload-form (list* fn-arglist body) arity-ident (keyword (str "arity-" (if varargs "varargs" (count args)))) spec-form|arglist (arglist>spec-form|arglist (cond-> args varargs (conj varargs)) kw-args) - spec-form|pre (when (contains? arglist :pre) `(fn [~kw-args] ~pre)) + spec-form|pre (when (and (contains? arglist :pre) (= pre-kind :spec)) + `(fn [~kw-args] ~pre)) spec-form|args* (if spec-form|pre `(s/and ~spec-form|arglist ~spec-form|pre) spec-form|arglist) @@ -291,25 +298,32 @@ :spec-form|args [] :spec-form|fn []} overloads) - spec-form (when (= kind :defn) + spec-form (when (#{:defn :defn-} kind) `(s/fdef ~fn|name :args (s/or ~@spec-form|args) :fn (fn [{~ret-sym :ret [~arity-kind-sym ~args-sym] :args}] (case ~arity-kind-sym ~@spec-form|fn)))) fn-form (case kind - :fn (list* 'fn (concat (when (contains? args' :quantum.core.specs/fn|name) - [fn|name]) - overload-forms)) - :defn (list* 'defn fn|name overload-forms)) + :fn (list* 'fn (concat (when (contains? args' :quantum.core.specs/fn|name) + [fn|name]) + overload-forms)) + :defn (list* 'defn fn|name overload-forms) + :defn- (list* 'defn- fn|name overload-forms)) code `(do ~spec-form ~fn-form)] code)) #?(:clj (defmacro fns - "Like `fnt`, but relies entirely on runtime spec checks. Does not perform type inference." + "Like `fnt`, but relies entirely on runtime spec checks. Ignores type inference requests, but + allows them for compatibility with `defnt`." [& args] (fns|code :fn (ufeval/env-lang) args))) #?(:clj (defmacro defns - "Like `defnt`, but relies entirely on runtime spec checks. Does not perform type inference." + "Like `defnt`, but relies entirely on runtime spec checks. Ignores type inference requests, but + allows them for compatibility with `defnt`." [& args] (fns|code :defn (ufeval/env-lang) args))) +#?(:clj +(defmacro defns- + "defns : defns- :: defn : defn-" + [& args] (fns|code :defn- (ufeval/env-lang) args))) diff --git a/test/quantum/test/untyped/core/defnt.cljc b/test/quantum/test/untyped/core/defnt.cljc index 175b0f9d..f66b587c 100644 --- a/test/quantum/test/untyped/core/defnt.cljc +++ b/test/quantum/test/untyped/core/defnt.cljc @@ -1,5 +1,6 @@ (ns quantum.test.untyped.core.defnt (:require + [clojure.spec.alpha :as s] [quantum.untyped.core.defnt :as this])) #_(defns abcde "Documentation" {:metadata "abc"} @@ -12,7 +13,8 @@ ;; TODO assert that the below 2 things are equivalent -(defns fghij "Documentation" {:metadata "abc"} +(macroexpand +'(this/defns fghij "Documentation" {:metadata "abc"} ([a number? > number?] (inc a)) ([a number?, b number? | (> a b) @@ -34,7 +36,7 @@ & [fa string? :as f] seq? | (and (> a b) (contains? c a) a b c ca cb cc cca ccaa ccab ccabaa ccabab ccababa ccabb d da db ea f fa) - > number?] 0)) + > number?] 0))) (s/fdef fghijk :args (s/or :arity-1 (s/cat :a (let [spec# number?] (fn [a] (spec# a)))) From ebd22c69d50088dc0f12b3a27fbb50143e0bc4df Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 2 May 2018 10:12:08 -0600 Subject: [PATCH 021/810] Begin to `defns`-spec untyped nss --- src-untyped/quantum/untyped/core/type.cljc | 70 ++++++++-------------- 1 file changed, 25 insertions(+), 45 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index d267cc45..08370db2 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -29,6 +29,8 @@ :refer [>symbol]] [quantum.untyped.core.core :as ucore] [quantum.untyped.core.data.bits :as ubit] + [quantum.untyped.core.defnt + :refer [defns defns-]] [quantum.untyped.core.error :as uerr :refer [err! TODO catch-all]] [quantum.untyped.core.fn :as ufn @@ -75,26 +77,23 @@ (defprotocol PSpec) -(udt/deftype ValueSpec [v] +(udt/deftype ValueSpec [v #_any?] {PSpec nil fipp.ednize/IOverride nil fipp.ednize/IEdn {-edn ([this] (list `value v))} ?Fn {invoke ([_ x] (c/= x v))} - ?Object {equals ([this that] + ?Object {equals ([this that #_any?] (c/or (== this that) (c/and (instance? ValueSpec that) - (c/= v (.-v ^ValueSpec that)))))}}) + (c/= v (.-v ^ValueSpec that)))))}} -(defn value +(defns value "Creates a spec whose extension is the singleton set containing only the value `v`." - [v] (ValueSpec. v)) + [v _] (ValueSpec. v)) -(defn value-spec? [x] (instance? ValueSpec x)) +(defns value-spec? [x _] (instance? ValueSpec x)) -(defn value-spec>value [x] - (if (value-spec? x) - (.-v ^ValueSpec x) - (err! "Not a value spec" x))) +(defns value-spec>value [x value-spec?] (.-v ^ValueSpec x)) ;; ----- @@ -109,17 +108,14 @@ ?Fn {invoke ([_ x] (instance? c x))} ?Meta {meta ([this] meta) with-meta ([this meta'] (ClassSpec. meta' c name))} - ?Object {equals ([this that] + ?Object {equals ([this that #_any?] (c/or (== this that) (c/and (instance? ClassSpec that) (c/= c (.-c ^ClassSpec that)))))}}) -(defn class-spec? [x] (instance? ClassSpec x)) +(defns class-spec? [x _] (instance? ClassSpec x)) -(defn class-spec>class [spec] - (if (class-spec? spec) - (.-c ^ClassSpec spec) - (err! "Cannot cast to ClassSpec" {:x spec}))) +(defns class-spec>class [spec class-spec?] (.-c ^ClassSpec spec)) (udt/deftype ProtocolSpec [meta #_(t/? ::meta) @@ -132,16 +128,11 @@ ?Meta {meta ([this] meta) with-meta ([this meta'] (ProtocolSpec. meta' p name))}}) -(defn protocol-spec? [x] (instance? ProtocolSpec x)) +(defns protocol-spec? [x _] (instance? ProtocolSpec x)) -(defn protocol-spec>protocol [spec] - (if (protocol-spec? spec) - (.-p ^ProtocolSpec spec) - (err! "Cannot cast to ProtocolSpec" {:x spec}))) +(defns protocol-spec>protocol [spec protocol-spec?] (.-p ^ProtocolSpec spec)) -(defn- isa?|protocol [p] - (assert (utpred/protocol? p)) - (ProtocolSpec. nil p nil)) +(defns- isa?|protocol [p utpred/protocol?] (ProtocolSpec. nil p nil)) (defn isa? [x] (ifs #?(:clj (utpred/protocol? x) @@ -228,21 +219,15 @@ (-def spec? (isa? PSpec)) -(defn * +(defns * "Denote on a spec that it must be enforced at runtime. For use with `defnt`." - [spec] - (if (spec? spec) - (update-meta spec assoc :runtime? true) - (err! "Input must be spec" spec))) + [spec spec?] (update-meta spec assoc :runtime? true)) -(defn ref +(defns ref "Denote on a spec that it must not be expanded to use primitive values. For use with `defnt`." - [spec] - (if (spec? spec) - (update-meta spec assoc :ref? true) - (err! "Input must be spec" spec))) + [spec spec?] (update-meta spec assoc :ref? true)) (udt/deftype DeducibleSpec [*spec #_(t/atom-of t/spec?)] {PSpec nil @@ -251,12 +236,9 @@ ?Atom {swap! (([this f] (swap! *spec f))) reset! ([this v] (reset! *spec v))}}) -(defn deducible [x] - (if (spec? x) - (DeducibleSpec. (atom x)) - (err! "`x` must be spec to be part of DeducibleSpec" x))) +(defns deducible [x spec?] (DeducibleSpec. (atom x))) -(defn deducible-spec? [x] (instance? DeducibleSpec x)) +(defns deducible-spec? [x _] (instance? DeducibleSpec x)) ;; ===== EXTENSIONALITY COMPARISON IMPLEMENTATIONS ===== ;; @@ -265,7 +247,7 @@ (coll&/incremental-every? (aritoid nil (constantly true) t/in>) [Long Number])) -(defn compare|class|class* +(defns compare|class|class* "Compare extension (generality|specificity) of ->`c0` to ->`c1`. `0` means they are equally general/specific: - ✓ `(t/= c0 c1)` : the extension of ->`c0` is equal to that of ->`c1`. @@ -280,7 +262,7 @@ `3` means their generality/specificity is incomparable: - ✓ `(t/<> c0 c1)` : the extension of ->`c0` is disjoint w.r.t. to that of ->`c1`. Unboxed primitives are considered to be less general (more specific) than boxed primitives." - [^Class c0 ^Class c1] + [^Class c0 class? ^Class c1 class?] #?(:clj (ifs (== c0 c1) 0 (== c0 Object) 1 (== c1 Object) -1 @@ -302,7 +284,7 @@ (declare compare|dispatch) -(defn compare +(defns compare ;; TODO optimize the `recur`s here as they re-take old code paths "Returns the value of the comparison of the extensions of ->`s0` and ->`s1`. `-1` means (ex ->`s0`) ⊂ (ex ->`s1`) @@ -313,9 +295,7 @@ Does not compare cardinalities or other relations of sets, but rather only sub/superset relations." - [s0 s1] - (assert (spec? s0) {:s0 s0}) - (assert (spec? s1) {:s1 s1}) + [s0 spec?, s1 spec?] (let [dispatched (-> compare|dispatch (get (type s0)) (get (type s1)))] (if (c/nil? dispatched) (err! (str "Specs not handled: " {:s0 s0 :s1 s1}) {:s0 s0 :s1 s1}) From 9b484cefd9686e4d4b77e1a5c46c26f899aee64b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 3 May 2018 08:47:14 -0600 Subject: [PATCH 022/810] Specs work great in `defns` :D --- src-dev/quantum/core/defnt.cljc | 38 +++--- src-untyped/quantum/untyped/core/defnt.cljc | 21 ++-- src-untyped/quantum/untyped/core/spec.cljc | 92 +++++++++----- src-untyped/quantum/untyped/core/type.cljc | 126 ++++++++++---------- src/quantum/core/macros/defnt.cljc | 5 +- src/quantum/core/spec.cljc | 2 +- test/quantum/test/untyped/core/defnt.cljc | 124 ++++++++++--------- 7 files changed, 227 insertions(+), 181 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index f57263ce..b476e220 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -19,8 +19,6 @@ [quantum.core.macros :refer [macroexpand]] [quantum.core.print :as pr] - [quantum.core.spec :as s] - [quantum.core.specs :as ss] [quantum.core.type.core :as tcore] [quantum.core.type.defs :as tdef] [quantum.untyped.core.analyze.ast :as ast] @@ -58,6 +56,8 @@ :refer [join reducei educe]] [quantum.untyped.core.refs :as ref :refer [?deref]] + [quantum.untyped.core.spec :as s] + [quantum.untyped.core.specs :as uss] [quantum.untyped.core.type :as t :refer [?]] [quantum.untyped.core.type.predicates :as utpred] @@ -104,35 +104,35 @@ (do #?(:clj -(defn class>simplest-class +(defns class>simplest-class "This ensures that special overloads are not created for non-primitive subclasses of java.lang.Object (e.g. String, etc.)." - [c #_t/class?] + [c class?] (if (t/primitive-class? c) c (or (tcore/boxed->unboxed c) java.lang.Object)))) #?(:clj -(defn class>most-primitive-class - [c #_t/class? nilable?] +(defns class>most-primitive-class + [c class?, nilable? boolean?] (if nilable? c (or (tcore/boxed->unboxed c) c)))) #?(:clj -(defn spec>most-primitive-classes [spec #_t/spec?] #_> #_(set-of (? class?)) +(defns spec>most-primitive-classes [spec t/spec? > (s/set-of (? class?))] (let [cs (t/spec>classes spec) nilable? (contains? cs nil)] (->> cs (c/map+ #(class>most-primitive-class % nilable?)) (join #{}))))) #?(:clj -(defn spec>most-primitive-class [spec #_t/spec?] #_> #_(? class?) +(defns spec>most-primitive-class [spec t/spec? > (? class?)] (let [cs (spec>most-primitive-classes spec)] (if (-> cs count (not= 1)) (err! "Not exactly 1 class found" (kw-map spec cs)) (first cs))))) #?(:clj -(defn out-spec>class [spec #_t/spec?] +(defns out-spec>class [spec t/spec? > (? class?)] (let [cs (t/spec>classes spec) cs' (disj cs nil)] (if (-> cs' count (not= 1)) ;; NOTE: we don't need to vary the output class if there are multiple output possibilities or just nil @@ -158,7 +158,7 @@ fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "M") (into (array-map) this))))) #?(:clj -(defns class->methods [c t/class?] +(defns class->methods [^Class c class? > map?] (->> (.getMethods c) (remove+ (fn [^java.lang.reflect.Method x] (java.lang.reflect.Modifier/isPrivate (.getModifiers x)))) (map+ (fn [^java.lang.reflect.Method x] (Method. (.getName x) (.getReturnType x) (.getParameterTypes x) @@ -178,7 +178,7 @@ fipp.ednize/IOverride fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "F") (into (array-map) this)))) -(defn class->fields [^Class c] +(defns class->fields [^Class c class? > map?] (->> (.getFields c) (remove+ (fn [^java.lang.reflect.Field x] (java.lang.reflect.Modifier/isPrivate (.getModifiers x)))) (map+ (fn [^java.lang.reflect.Field x] @@ -205,6 +205,7 @@ (def special-symbols '#{do let* deftype* fn* def . if quote new throw}) ; TODO make more complete +;; TODO move (deftype WatchableMutable [^:unsynchronized-mutable v ^:unsynchronized-mutable ^clojure.lang.IFn watch] clojure.lang.IDeref (deref [this] v) @@ -222,6 +223,7 @@ fipp.ednize/IOverride fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "!@") v))) +;; TODO move (defn !ref ([v] (->WatchableMutable v nil)) ([v watch] (->WatchableMutable v watch))) @@ -660,9 +662,9 @@ (s/def :fnt|overload/variadic? boolean?) #_"Must evaluate to an `s/fspec`" -(s/def :fnt|overload/spec ::ss/code) +(s/def :fnt|overload/spec :quantum.core.specs/code) -#_(s/def :fnt|overload/body-codelist (t/seq-of ::ss/code)) +#_(s/def :fnt|overload/body-codelist (t/seq-of :quantum.core.specs/code)) (s/def :fnt/overload (s/keys :req-un [:fnt|overload/arg-classes ; (t/vector-of t/class?) :fnt|overload/arg-specs @@ -675,7 +677,7 @@ :fnt|overload/variadic?])) (s/def ::reify|overload - (s/keys :req-un [:ss/interface + (s/keys :req-un [:quantum.core.specs/interface :reify|overload/out-class :reify/method-sym :reify/arglist-code @@ -862,7 +864,7 @@ :out-class out-class}))) #?(:clj -(defn fnt|overload-group>reify [{:keys [overload-group #_:fnt/overload-group, i #_integer?, fn|name #_::ss/fn|name]}] +(defn fnt|overload-group>reify [{:keys [overload-group #_:fnt/overload-group, i #_integer?, fn|name #_:quantum.core.specs/fn|name]}] (let [reify-overloads (->> (concat [(:unprimitivized overload-group)] (:primitivized overload-group)) (c/map fnt|overload>reify-overload))] @@ -973,7 +975,7 @@ (defn fnt|overloads>protocols [{:keys [overloads #_(t/and t/indexed? (t/seq-of :fnt/overload)) - fn|name #_::ss/fn|name]}] + fn|name #_:quantum.core.specs/fn|name]}] (when (->> overloads (seq-or (fn-> :positional-args-ct (> 2)))) (TODO "Doesn't yet handle protocol creation for arglist counts of > 2")) (when (->> overloads (seq-or :variadic?)) @@ -1018,7 +1020,7 @@ (defn fnt|code [kind lang args] (prl! kind lang args) - (let [{:keys [::ss/fn|name overloads ::ss/meta] :as args'} + (let [{:keys [:quantum.core.specs/fn|name overloads :quantum.core.specs/meta] :as args'} (s/validate args (case kind :defn ::defnt :fn ::fnt)) _ (prl! args') inline? @@ -1062,7 +1064,7 @@ _ (prl! overloads) code (case kind :fn (list* 'fn (concat - (if (contains? args' ::ss/fn|name) + (if (contains? args' :quantum.core.specs/fn|name) [fn|name] []) [overloads|code])) diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index 55313cf5..205ef9d2 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -200,24 +200,20 @@ arg-ident (rseq context))) -#?(:clj -(defmacro spec-fn [[destructuring] [spec sym]] - `(let [spec# ~spec] (fn [~destructuring] (spec# ~sym))))) - (defn keys-syms-strs>arg-specs [binding- binding-kind context] (->> (get binding- binding-kind) second (filter (fn [{[spec-kind _] :spec}] (= spec-kind :spec))) (mapv (fn [{:keys [binding-form #_symbol?] [spec-kind spec] :spec}] (let [destructuring (context>destructuring binding-form (conj context [binding-kind nil]))] - `(spec-fn [~destructuring] (~spec ~binding-form))))))) + `(us/with (fn [~destructuring] ~binding-form) ~spec)))))) (defn >as-specs [{:as speced-binding [kind binding-] :binding-form [spec-kind spec] :spec} context] (let [[k base-spec] (case kind :seq [:sym `clojure.core/seqable?] :map [1 `clojure.core/map?])] (let [as-ident (or (get-in binding- [:as k]) (gensym "as")) destructuring (context>destructuring as-ident context)] - (cond-> [`(spec-fn [~destructuring] (~base-spec ~as-ident))] - (= spec-kind :spec) (conj `(spec-fn [~destructuring] (~spec ~as-ident))))))) + (cond-> [`(us/with (fn [~destructuring] ~as-ident) ~base-spec)] + (= spec-kind :spec) (conj `(us/with (fn [~destructuring] ~as-ident) ~spec)))))) (defn speced-binding>arg-specs ([speced-binding] (speced-binding>arg-specs speced-binding [])) @@ -226,7 +222,7 @@ (case kind :sym (when (= spec-kind :spec) [(let [destructuring (context>destructuring binding- context)] - `(spec-fn [~destructuring] (~spec ~binding-)))]) + `(us/with (fn [~destructuring] ~binding-) ~spec))]) :seq (let [{elems :elems rest- :rest} binding-] (apply concat (>as-specs speced-binding context) @@ -288,8 +284,8 @@ `(s/and ~spec-form|arglist ~spec-form|pre) spec-form|arglist) spec-form|fn* (if (contains? arglist :post) - `(let [~kw-args ~args-sym] (~post ~ret-sym)) - `any?)] + `(let [~kw-args ~args-sym] (s/spec ~post)) + `(s/spec any?))] (-> ret (update :overload-forms conj overload-form) (update :spec-form|args conj arity-ident spec-form|args*) @@ -300,8 +296,9 @@ overloads) spec-form (when (#{:defn :defn-} kind) `(s/fdef ~fn|name :args (s/or ~@spec-form|args) - :fn (fn [{~ret-sym :ret [~arity-kind-sym ~args-sym] :args}] - (case ~arity-kind-sym ~@spec-form|fn)))) + :fn (us/with-gen-spec (fn [{~ret-sym :ret}] ~ret-sym) + (fn [{[~arity-kind-sym ~args-sym] :args}] + (case ~arity-kind-sym ~@spec-form|fn))))) fn-form (case kind :fn (list* 'fn (concat (when (contains? args' :quantum.core.specs/fn|name) [fn|name]) diff --git a/src-untyped/quantum/untyped/core/spec.cljc b/src-untyped/quantum/untyped/core/spec.cljc index 9a8ad286..33b9df94 100644 --- a/src-untyped/quantum/untyped/core/spec.cljc +++ b/src-untyped/quantum/untyped/core/spec.cljc @@ -12,7 +12,7 @@ [quantum.untyped.core.convert :as uconv] [quantum.untyped.core.data :as udata] [quantum.untyped.core.error - :refer [catch-all err!]] + :refer [catch-all err! TODO]] [quantum.untyped.core.fn :refer [constantly with-do]] [quantum.untyped.core.form.evaluate :as ufeval @@ -108,30 +108,34 @@ `(do ~@(->> args (partition-all 2) (map (fn [[v spec]] `(validate-one ~spec ~v))))))) -#?(:clj (quantum.untyped.core.vars/defmalias tuple clojure.spec.alpha/tuple cljs.spec.alpha/tuple )) -#?(:clj (quantum.untyped.core.vars/defmalias coll-of clojure.spec.alpha/coll-of cljs.spec.alpha/coll-of )) -#?(:clj (quantum.untyped.core.vars/defmalias map-of clojure.spec.alpha/map-of cljs.spec.alpha/map-of )) +#?(:clj (quantum.untyped.core.vars/defmalias tuple clojure.spec.alpha/tuple cljs.spec.alpha/tuple )) +#?(:clj (quantum.untyped.core.vars/defmalias coll-of clojure.spec.alpha/coll-of cljs.spec.alpha/coll-of )) +#?(:clj (quantum.untyped.core.vars/defmalias map-of clojure.spec.alpha/map-of cljs.spec.alpha/map-of )) -#?(:clj (quantum.untyped.core.vars/defmalias def clojure.spec.alpha/def cljs.spec.alpha/def )) -#?(:clj (quantum.untyped.core.vars/defmalias fdef clojure.spec.alpha/fdef cljs.spec.alpha/fdef )) +#?(:clj (quantum.untyped.core.vars/defmalias def clojure.spec.alpha/def cljs.spec.alpha/def )) +#?(:clj (quantum.untyped.core.vars/defmalias fdef clojure.spec.alpha/fdef cljs.spec.alpha/fdef )) -#?(:clj (quantum.untyped.core.vars/defmalias keys clojure.spec.alpha/keys cljs.spec.alpha/keys )) -#?(:clj (quantum.untyped.core.vars/defmalias keys* clojure.spec.alpha/keys* cljs.spec.alpha/keys* )) -#?(:clj (quantum.untyped.core.vars/defmalias merge clojure.spec.alpha/merge cljs.spec.alpha/merge )) +#?(:clj (quantum.untyped.core.vars/defmalias keys clojure.spec.alpha/keys cljs.spec.alpha/keys )) +#?(:clj (quantum.untyped.core.vars/defmalias keys* clojure.spec.alpha/keys* cljs.spec.alpha/keys* )) +#?(:clj (quantum.untyped.core.vars/defmalias merge clojure.spec.alpha/merge cljs.spec.alpha/merge )) -#?(:clj (quantum.untyped.core.vars/defmalias spec clojure.spec.alpha/spec cljs.spec.alpha/spec )) -#?(:clj (quantum.untyped.core.vars/defmalias + clojure.spec.alpha/+ cljs.spec.alpha/+ )) -#?(:clj (quantum.untyped.core.vars/defmalias * clojure.spec.alpha/* cljs.spec.alpha/* )) -#?(:clj (quantum.untyped.core.vars/defmalias ? clojure.spec.alpha/? cljs.spec.alpha/? )) +#?(:clj (quantum.untyped.core.vars/defmalias spec clojure.spec.alpha/spec cljs.spec.alpha/spec )) +#?(:clj (quantum.untyped.core.vars/defmalias + clojure.spec.alpha/+ cljs.spec.alpha/+ )) +#?(:clj (quantum.untyped.core.vars/defmalias * clojure.spec.alpha/* cljs.spec.alpha/* )) +#?(:clj (quantum.untyped.core.vars/defmalias ? clojure.spec.alpha/? cljs.spec.alpha/? )) ;; Note that `and` results in a spec, and as such creates a new regex context :/ -#?(:clj (quantum.untyped.core.vars/defmalias and clojure.spec.alpha/and cljs.spec.alpha/and )) -#?(:clj (quantum.untyped.core.vars/defmalias or clojure.spec.alpha/or cljs.spec.alpha/or )) -#?(:clj (quantum.untyped.core.vars/defmalias every clojure.spec.alpha/every cljs.spec.alpha/every )) +#?(:clj (quantum.untyped.core.vars/defmalias and clojure.spec.alpha/and cljs.spec.alpha/and )) +#?(:clj (quantum.untyped.core.vars/defmalias or clojure.spec.alpha/or cljs.spec.alpha/or )) +#?(:clj (quantum.untyped.core.vars/defmalias every clojure.spec.alpha/every cljs.spec.alpha/every )) -#?(:clj (quantum.untyped.core.vars/defmalias conformer clojure.spec.alpha/conformer cljs.spec.alpha/conformer)) -(defalias conform s/conform) -(defalias explain s/explain) +#?(:clj (quantum.untyped.core.vars/defmalias conformer clojure.spec.alpha/conformer cljs.spec.alpha/conformer)) +#?(:clj (quantum.untyped.core.vars/defmalias nonconforming clojure.spec.alpha/nonconforming cljs.spec.alpha/nonconforming)) + +(defalias s/conform) +(defalias s/explain) +(defalias s/explain-data) +(defalias s/describe) #?(:clj (quantum.untyped.core.vars/defmalias cat clojure.spec.alpha/cat cljs.spec.alpha/cat)) #?(:clj (defmacro cat* "`or` :`or*` :: `cat` : `cat*`" [& args] `(cat ~@(udata/quote-map-base uconv/>keyword args true)))) @@ -258,17 +262,49 @@ (defmacro constantly-or [& exprs] `(or* ~@(map #(list 'fn [(gensym "_")] %) exprs)))) -#?(:clj -(defmacro set-of [spec] ; TODO fix this up... - `(let [spec# ~spec] - (or*-forms (and core/set? (coll-of ~spec)) - (and core/set? (coll-of spec#)) - (coll-of ~spec :distinct true :into #{}) - (coll-of spec# :distinct true :into #{}))))) - -(defn validate:val? [x] +#?(:clj (defmacro vec-of [spec & opts] `(coll-of ~spec ~@opts :kind core/vector?))) +#?(:clj (defmacro set-of [spec & opts] `(coll-of ~spec ~@opts :kind core/set?))) + +(defn validate|val? [x] (if (nil? x) (throw (ex-info "Value is not allowed to be nil but was" {})) x)) +#?(:clj (defmacro with [extract-f spec] `(nonconforming (and (conformer ~extract-f) ~spec)))) + +(defn with-gen-spec-impl + "Do not call this directly; use 'with-gen-spec'." + [extract-f extract-f|form gen-spec gen-spec|form] + (let [form `(with-gen-spec ~extract-f|form ~gen-spec|form) + gen-spec (fn [x] (let [spec (gen-spec x) + desc (describe spec) + desc (if (= desc ::s/unknown) + (list 'some-generated-spec gen-spec|form) + desc)] + (with extract-f (@#'s/spec-impl desc spec nil nil))))] + (if (clojure.core/fn? gen-spec) + (reify + s/Specize + (s/specize* [this] this) + (s/specize* [this _] this) + s/Spec + (s/conform* [_ x] (s/conform* (gen-spec x) x)) + (s/unform* [_ x] (s/unform* (gen-spec x) x)) + (s/explain* [_ path via in x] (s/explain* (gen-spec x) path via in x)) + (s/gen* [_ _ _ _] (gen/gen-for-pred gen-spec)) + (s/with-gen* [_ gen-fn'] (TODO)) + (s/describe* [_] form)) + (err! "`wrap-spec` may only be called on fns" {:input gen-spec})))) + +#?(:clj +(defmacro with-gen-spec + "`gen-spec` : an fn that returns a spec based on the input. + `extract-f`: extracts the piece of data from the input that the generated spec will validate. + E.g.: + (s/explain + (s/with-gen-spec (fn [{:keys [a]}] a) (fn [{:keys [b]}] #(> % b))) + {:a 1 :b 1})" + [extract-f gen-spec] + `(with-gen-spec-impl ~extract-f '~extract-f ~gen-spec '~gen-spec))) + (def any? (constantly true)) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 08370db2..871d379e 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -29,6 +29,7 @@ :refer [>symbol]] [quantum.untyped.core.core :as ucore] [quantum.untyped.core.data.bits :as ubit] + [quantum.untyped.core.data.tuple] [quantum.untyped.core.defnt :refer [defns defns-]] [quantum.untyped.core.error :as uerr @@ -45,7 +46,7 @@ :refer [educe join]] [quantum.untyped.core.refs :refer [?deref]] - [quantum.untyped.core.data.tuple] + [quantum.untyped.core.spec :as s] [quantum.untyped.core.type.core :as utcore] [quantum.untyped.core.type.defs :as utdef] [quantum.untyped.core.type.predicates :as utpred] @@ -301,39 +302,47 @@ (err! (str "Specs not handled: " {:s0 s0 :s1 s1}) {:s0 s0 :s1 s1}) (dispatched s0 s1)))) -(defn < +(defns < "Computes whether the extension of spec ->`s0` is a strict subset of that of ->`s1`." - [s0 s1] (let [ret (compare s0 s1)] (c/= ret -1))) + ([s1 spec?] #(< % s1)) + ([s0 spec?, s1 spec?] (let [ret (compare s0 s1)] (c/= ret -1)))) -(defn <= +(defns <= "Computes whether the extension of spec ->`s0` is a (lax) subset of that of ->`s1`." - [s0 s1] (let [ret (compare s0 s1)] (c/or (c/= ret -1) (c/= ret 0)))) + ([s1 spec?] #(<= % s1)) + ([s0 spec?, s1 spec?] (let [ret (compare s0 s1)] (c/or (c/= ret -1) (c/= ret 0))))) -(defn = +(defns = "Computes whether the extension of spec ->`s0` is equal to that of ->`s1`." - [s0 s1] (c/= (compare s0 s1) 0)) + ([s1 spec?] #(= % s1)) + ([s0 spec?, s1 spec?] (c/= (compare s0 s1) 0))) -(defn not= +(defns not= "Computes whether the extension of spec ->`s0` is not equal to that of ->`s1`." - [s0 s1] (c/not (= s0 s1))) + ([s1 spec?] #(not= % s1)) + ([s0 spec?, s1 spec?] (c/not (= s0 s1)))) -(defn >= +(defns >= "Computes whether the extension of spec ->`s0` is a (lax) superset of that of ->`s1`." - [s0 s1] (let [ret (compare s0 s1)] (c/or (c/= ret 1) (c/= ret 0)))) + ([s1 spec?] #(>= % s1)) + ([s0 spec?, s1 spec?] (let [ret (compare s0 s1)] (c/or (c/= ret 1) (c/= ret 0))))) -(defn > +(defns > "Computes whether the extension of spec ->`s0` is a strict superset of that of ->`s1`." - [s0 s1] (c/= (compare s0 s1) 1)) + ([s1 spec?] #(> % s1)) + ([s0 spec?, s1 spec?] (c/= (compare s0 s1) 1))) -(defn >< +(defns >< "Computes whether it is the case that the intersect of the extensions of spec ->`s0` and ->`s1` is non-empty, and neither ->`s0` nor ->`s1` share a subset/equality/superset relationship." - [s0 s1] (c/= (compare s0 s1) 2)) + ([s1 spec?] #(>< % s1)) + ([s0 spec?, s1 spec?] (c/= (compare s0 s1) 2))) -(defn <> +(defns <> "Computes whether the respective extensions of specs ->`s0` and ->`s1` are disjoint." - [s0 s1] (c/= (compare s0 s1) 3)) + ([s1 spec?] #(<> % s1)) + ([s0 spec? s1 spec?] (c/= (compare s0 s1) 3))) (defn inverse [comparison] (case comparison @@ -473,12 +482,9 @@ (c/and (instance? AndSpec that) (c/= args (.-args ^AndSpec that)))))}}) -(defn and-spec? [x] (instance? AndSpec x)) +(defns and-spec? [x _] (instance? AndSpec x)) -(defn and-spec>args [x] - (if (instance? AndSpec x) - (.-args ^AndSpec x) - (err! "Cannot cast to AndSpec" x))) +(defns and-spec>args [x and-spec?] (.-args ^AndSpec x)) (defn and "Sequential/ordered `and`. Analogous to `set/intersection`. @@ -506,12 +512,9 @@ (c/and (instance? OrSpec that) (c/= args (.-args ^OrSpec that)))))}}) -(defn or-spec? [x] (instance? OrSpec x)) +(defns or-spec? [x _] (instance? OrSpec x)) -(defn or-spec>args [x] - (if (instance? OrSpec x) - (.-args ^OrSpec x) - (err! "Cannot cast to OrSpec" x))) +(defns or-spec>args [x or-spec?] (.-args ^OrSpec x)) (defn or "Sequential/ordered `or`. Analogous to `set/union`. @@ -535,17 +538,13 @@ (c/and (instance? NotSpec that) (c/= spec (.-spec ^NotSpec that)))))}}) -(defn not-spec? [x] (instance? NotSpec x)) +(defns not-spec? [x _] (instance? NotSpec x)) -(defn not-spec>inner-spec [spec] - (if (instance? NotSpec spec) - (.-spec ^NotSpec spec) - (err! "Cannot cast to NotSpec" {:x spec}))) +(defns not-spec>inner-spec [spec not-spec?] (.-spec ^NotSpec spec)) (declare nil? val?) -(defn not [spec] - (assert (spec? spec)) +(defns not [spec spec?] (ifs (= spec universal-set) empty-set (= spec empty-set) universal-set (= spec val|by-class?) nil? @@ -558,13 +557,13 @@ (uvar/defalias ! not) -(defn - +(defns - "Computes the difference of `s0` from `s1`: (& s0 (! s1)) If `s0` = `s1`, `∅` If `s0` < `s1`, `∅` If `s0` <> `s1`, `s0` If `s0` > | >< `s1`, `s0` with all elements of `s1` removed" - [s0 #_spec? s1 #_spec?] + [s0 spec?, s1 spec?] #_(prl! s0 s1) (let [c (compare s0 s1)] (case c @@ -588,10 +587,9 @@ #_(udt/deftype SequentialSpec) -(defn of - "Creates a spec that. - `pred` must be `t/<=` iterable" - [pred spec]) +(defns of + "Creates a spec that ... TODO" + [pred (<= iterable?), spec spec?] (TODO)) (udt/deftype FnSpec [name #_(t/? t/symbol?) @@ -613,17 +611,19 @@ fipp.ednize/IEdn {-edn ([this] (list `fn name lookup))}}) -(defn fn|args>out-spec +(defns fn-spec? [x _] (instance? FnSpec x)) + +(defns fn|args>out-spec "Returns nil if args do not match any input spec" - [^FnSpec spec args] + [^FnSpec spec fn-spec?, args _] (when-let [spec-or-arity-specs (get (.-lookup spec) (count args))] (if (spec? spec-or-arity-specs) spec-or-arity-specs (->> spec-or-arity-specs (uc/filter+ #((first %) args)) uc/first second)))) -(defn fn-spec - [name- #_(t/? t/symbol?) - lookup #_(t/map-of t/integer? +(defns fn-spec + [name- (? symbol?) + lookup _ #_(t/map-of t/integer? (t/or (spec spec? "output-spec") (t/vec-of (t/tuple (t/vec-of (spec spec? "input-spec")) (spec spec? "output-spec")))))] @@ -676,7 +676,7 @@ fipp.ednize/IEdn {-edn ([this] `?)}}) -(defn infer? [x] (instance? InferSpec x)) +(defns infer? [x _] (instance? InferSpec x)) ;; ===== Comparison ===== ;; @@ -692,7 +692,7 @@ (def- fn>< (ufn/fn' 2)) (def- fn<> (ufn/fn' 3)) -(defn- compare|todo [s0 s1] +(defns- compare|todo [s0 spec?, s1 spec?] (err! "TODO dispatch" {:s0 s0 :s0|type (type s0) :s1 s1 :s1|type (type s1)})) @@ -700,7 +700,7 @@ (def- compare|universal+empty fn>) -(defn- compare|universal+not [s0 s1] +(defns- compare|universal+not [s0 spec?, s1 spec?] (let [s1|inner (not-spec>inner-spec s1)] (ifs (= s1|inner universal-set) 1 (= s1|inner empty-set) 0 @@ -716,7 +716,7 @@ ;; ----- EmptySet ----- ;; -(defn- compare|empty+not [s0 s1] +(defns- compare|empty+not [s0 spec?, s1 spec?] (let [s1|inner (not-spec>inner-spec s1)] (if (= s1|inner universal-set) 0 @@ -732,7 +732,7 @@ ;; ----- NotSpec ----- ;; -(defn- compare|not+not [s0 s1] +(defns- compare|not+not [s0 spec?, s1 spec?] (let [c (compare (not-spec>inner-spec s0) (not-spec>inner-spec s1))] (case c 0 0 @@ -741,17 +741,17 @@ 2 2 3 2))) -(defn- compare|not+or [s0 s1] +(defns- compare|not+or [s0 spec?, s1 spec?] (compare (not-spec>inner-spec s0) (>logical-complement s1))) -(defn- compare|not+and [s0 s1] +(defns- compare|not+and [s0 spec?, s1 spec?] (compare (not-spec>inner-spec s0) (>logical-complement s1))) -(defn- compare|not+protocol [s0 s1] +(defns- compare|not+protocol [s0 spec?, s1 spec?] (let [s0|inner (not-spec>inner-spec s0)] (if (= s0|inner empty-set) 1 3))) -(defn- compare|not+class [s0 s1] +(defns- compare|not+class [s0 spec?, s1 spec?] (let [s0|inner (not-spec>inner-spec s0)] (if (= s0|inner empty-set) 1 @@ -760,7 +760,7 @@ (-1 2) 2 3 1)))) -(defn- compare|not+value [s0 s1] +(defns- compare|not+value [s0 spec?, s1 spec?] (let [s0|inner (not-spec>inner-spec s0)] (if (= s0|inner empty-set) 1 @@ -772,7 +772,7 @@ ;; ----- OrSpec ----- ;; ;; TODO performance can be improved here by doing fewer comparisons -(defn- compare|or+or [^OrSpec s0 ^OrSpec s1] +(defns- compare|or+or [^OrSpec s0 or-spec?, ^OrSpec s1 or-spec?] (let [l (->> s0 .-args (seq-and (fn1 < s1))) r (->> s1 .-args (seq-and (fn1 < s0)))] (if l @@ -783,7 +783,7 @@ 3 2))))) -(defn- compare|or+and [^OrSpec s0 ^AndSpec s1] +(defns- compare|or+and [^OrSpec s0 or-spec?, ^OrSpec s1 or-spec?] (let [r (->> s1 .-args (seq-and (fn1 < s0)))] (if r 1 3))) @@ -1043,7 +1043,7 @@ #?(:clj (def primitive-classes (->> unboxed-symbol->type-meta vals (uc/map+ :unboxed) (join #{})))) -(defn- -spec>classes [spec #_t/spec? classes #_set?] #_> #_set? +(defns- -spec>classes [spec spec?, classes set? > set?] (cond (class-spec? spec) (conj classes (class-spec>class spec)) (value-spec? spec) @@ -1062,10 +1062,10 @@ :else (err! "Not sure how to handle spec" spec))) -(defn spec>classes #_> #_set? +(defns spec>classes "Outputs the set of all the classes ->`spec` can embody according to its various conditional branches, if any. Ignores nils, treating in Clojure simply as a `java.lang.Object`." - [spec] (-spec>classes spec #{})) + [spec spec? > set?] (-spec>classes spec #{})) #?(:clj (defn- -spec>?class-value [spec spec-nilable?] @@ -1091,9 +1091,9 @@ (def basic-type-syms '[boolean byte char short int long float double ref]) -#?(:clj (defn- >v-sym [prefix #_symbol? kind #_symbol?] (symbol (str prefix "|" kind "?")))) +#?(:clj (defns- >v-sym [prefix symbol?, kind symbol?] (symbol (str prefix "|" kind "?")))) -#?(:clj (defn- >kv-sym [prefix #_symbol? from-type #_symbol? to-type #_symbol?] +#?(:clj (defns- >kv-sym [prefix symbol?, from-type symbol?, to-type symbol?] (symbol (str prefix "|" from-type "->" to-type "?")))) #?(:clj (defmacro- def-preds|map|same-types [prefix #_symbol?] @@ -1273,7 +1273,7 @@ ;; dense integer values), not extensible #?(:clj -(defn >array-nd-type [kind n] +(defns >array-nd-type [kind symbol?, n (s/and integer? pos?) > class-spec?] (let [prefix (apply str (repeat n \[)) letter (case kind boolean "Z" diff --git a/src/quantum/core/macros/defnt.cljc b/src/quantum/core/macros/defnt.cljc index a8519fc5..0d496db4 100644 --- a/src/quantum/core/macros/defnt.cljc +++ b/src/quantum/core/macros/defnt.cljc @@ -87,7 +87,8 @@ (err! "Invalid `defnt` special keyword" {:k x})))) (def qualified-class-name-map - (->> (set/union tcore/primitive-types|unevaled #?(:clj tcore/primitive-array-types)) + (->> (set/union #_tcore/primitive-types|unevaled ; NOTE: commented this out knowing that this will break this old `defnt` + #?(:clj tcore/primitive-array-types)) (repeat 2) (apply zipmap))) @@ -111,7 +112,7 @@ (throw-unless ((fn-or symbol? keyword? string?) pred) (>ex-info "Type predicate must be a symbol, keyword, or string." {:pred pred})) (cond (and (symbol? pred) (anap/possible-type-predicate? pred)) - (->> tdef/types|unevaled + (->> #_tdef/types|unevaled ; NOTE: commented this out knowing that this will break this old `defnt` (<- (get lang)) (<- (get pred)) (<- (validate contains?)) diff --git a/src/quantum/core/spec.cljc b/src/quantum/core/spec.cljc index 9ec3a6c4..17c4fdc2 100644 --- a/src/quantum/core/spec.cljc +++ b/src/quantum/core/spec.cljc @@ -23,4 +23,4 @@ valid? invalid? #?@(:clj [or* or*-forms constantly-or set-of]) - validate:val? any?) + validate|val? any?) diff --git a/test/quantum/test/untyped/core/defnt.cljc b/test/quantum/test/untyped/core/defnt.cljc index f66b587c..7e4734f0 100644 --- a/test/quantum/test/untyped/core/defnt.cljc +++ b/test/quantum/test/untyped/core/defnt.cljc @@ -39,62 +39,72 @@ > number?] 0))) (s/fdef fghijk - :args (s/or :arity-1 (s/cat :a (let [spec# number?] (fn [a] (spec# a)))) - :arity-2 (s/and (s/cat :a (let [spec# number?] (fn [a] (spec# a))) - :b (let [spec# number?] (fn [b] (spec# b)))) - (fn [{a :a b :b}] (> a b))) - :arity-varargs - (s/and (s/cat :a (let [spec# string?] (fn [a] (spec# a))) - :b (let [spec# boolean?] (fn [b] (spec# b))) - :c (s/and (let [spec# #(-> % count (= 3))] (fn [c] (spec# c))) - (let [spec# keyword?] (fn [{:keys [ca]}] (spec# ca))) - (let [spec# string?] (fn [{:keys [cb]}] (spec# cb))) - (let [spec# map?] (fn [{cc :cc}] (spec# cc))) - (let [spec# map?] (fn [{{cca :cca} :cc}] (spec# cca))) - (let [spec# keyword?] (fn [{{{:keys [ccaa]} :cca} :cc}] (spec# ccaa))) - (let [spec# seq?] (fn [{{{ccab :ccab} :cca} :cc}] (spec# ccab))) - (let [spec# some?] (fn [{{{[as#] :ccab} :cca} :cc}] (spec# as#))) - (let [spec# some?] (fn [{{{[[ccabaa]] :ccab} :cca} :cc}] (spec# ccabaa))) - (let [spec# some?] (fn [{{{[[_# ccabab]] :ccab} :cca} :cc}] (spec# ccabab))) - (let [spec# some?] (fn [{{{[[_# {:keys [ccababa]}]] :ccab} :cca} :cc}] (spec# ccababa))) - (let [spec# some?] (fn [{{{[_# ccabb] :ccab} :cca} :cc}] (spec# ccabb)))) - :d (s/and (let [spec# sequential?] (fn [d] (spec# d))) - (let [spec# double?] (fn [[da]] (spec# da))) - (let [spec# seq?] (fn [[_# & db]] (spec# db)))) - :arg-4# (s/and (let [spec# vector?] (fn [as#] (spec# as#))) - (let [spec# symbol?] (fn [[ea]] (spec# ea)))) - :f (s/and (let [spec# seq?] (fn [f] (spec# f))) - (let [spec# string?] (fn [[fa]] (spec# fa))))) - (fn [{a :a - b :b - {:as c - :keys [ca cb] - {:as cc - {:as cca - :keys [ccaa] - [[ccabaa {:as ccabab :keys [ccababa]}] ccabb :as ccab] :ccab} :cca} :cc} :c - [da & db :as d] :d - [ea] :arg-4# - [fa :as f] :f}] - (and (> a b) (contains? c a) - a b c ca cb cc cca ccaa ccab ccabaa ccabab ccababa ccabb d da db ea f fa)))) - :fn (fn [{ret :ret [arity-kind args] :args}] - (case arity-kind - :arity-1 (let [{a :a} args] - (number? ret)) - :arity-2 (let [{a :a b :b} args] - ((s/and number? #(> % a) #(> % b)) ret)) - :arity-3 (let [{a :a - b :b - {:as c - :keys [ca cb] - {:as cc - {:as cca - :keys [ccaa] - [[ccabaa {:as ccabab :keys [ccababa]}] ccabb :as ccab] :ccab} :cca} :cc} :c - [da & db :as d] :d - [ea] :arg-4# - [fa :as f] :f} args] - (number? ret))))) + :args + (s/or + :arity-1 (s/cat :a (s/with (fn [a] a) number?)) + :arity-2 (s/and (s/cat :a (s/with (fn [a] a) number?) + :b (s/with (fn [b] b) number?)) + (fn [{a :a b :b}] (> a b))) + :arity-varargs + (s/and + (s/cat + :a (s/with (fn [a] a) string?) + :b (s/with (fn [b] b) boolean?) + :c (s/and + (s/with (fn [c] c) #(-> % count (= 3))) + (s/with (fn [{:keys [ca]}] ca) keyword?) + (s/with (fn [{:keys [cb]}] cb) string?) + (s/with (fn [{cc :cc}] cc) map?) + (s/with (fn [{{cca :cca} :cc}] cca) map?) + (s/with (fn [{{{:keys [ccaa]} :cca} :cc}] ccaa) keyword?) + (s/with (fn [{{{ccab :ccab} :cca} :cc}] ccab) seq?) + (s/with (fn [{{{[as#] :ccab} :cca} :cc}] as#) some?) + (s/with (fn [{{{[[ccabaa]] :ccab} :cca} :cc}] ccabaa) some?) + (s/with (fn [{{{[[_# ccabab]] :ccab} :cca} :cc}] ccabab) some?) + (s/with (fn [{{{[[_# {:keys [ccababa]}]] :ccab} :cca} :cc}] ccababa)) some? + (s/with (fn [{{{[_# ccabb] :ccab} :cca} :cc}] ccabb) some?)) + :d (s/and + (s/with (fn [d] d) sequential?) + (s/with (fn [[da]] da) double?) + (s/with (fn [[_# & db]] db)) seq?) + :arg-4# (s/and + (s/with (fn [as#] as#) vector?) + (s/with (fn [[ea]] ea)) symbol?) + :f (s/and + (s/with (fn [f] f) seq?) + (s/with (fn [[fa]] fa) string?))) + (fn [{a :a + b :b + {:as c + :keys [ca cb] + {:as cc + {:as cca + :keys [ccaa] + [[ccabaa {:as ccabab :keys [ccababa]}] ccabb :as ccab] :ccab} :cca} :cc} :c + [da & db :as d] :d + [ea] :arg-4# + [fa :as f] :f}] + (and (> a b) (contains? c a) + a b c ca cb cc cca ccaa ccab ccabaa ccabab ccababa ccabb d da db ea f fa)))) + :fn + (s/with-gen-spec (fn [{:keys [ret]}] ret) + (fn [{[arity-kind# args#] :args}] + (case arity-kind# + :arity-1 + (let [{a :a} args#] (s/spec number?)) + :arity-2 + (let [{a :a b :b} args#] (s/spec (s/and number? #(> % a) #(> % b)))) + :arity-3 + (let [{a :a + b :b + {:as c + :keys [ca cb] + {:as cc + {:as cca + :keys [ccaa] + [[ccabaa {:as ccabab :keys [ccababa]}] ccabb :as ccab] :ccab} :cca} :cc} :c + [da & db :as d] :d + [ea] :arg-4# + [fa :as f] :f} args#] (s/spec number?)))))) (fghij "zx" true {:ca :x :cb "y" :cc {:cca {:ccaa :z :ccab (list [1 {:ccababa 2}] 3)}}} [1.0 4] ['a]) From 996038a07865cfa1480b2b984095dd4c7697de3c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 4 May 2018 15:30:36 -0600 Subject: [PATCH 023/810] `s/seq-of` --- src-dev/quantum/core/defnt.cljc | 6 ++++-- src-untyped/quantum/untyped/core/spec.cljc | 2 ++ 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index b476e220..230cdb2d 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -157,6 +157,8 @@ fipp.ednize/IOverride fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "M") (into (array-map) this))))) +#?(:clj (defns method? [x _] (instance? Method x))) + #?(:clj (defns class->methods [^Class c class? > map?] (->> (.getMethods c) @@ -312,9 +314,9 @@ (log/ppr :warn "Not sure how to handle non-local symbol; resolved it for now" (kw-map sym resolved)) resolved)))) -(defn methods->spec +(defns methods->spec "Creates a spec given ->`methods`." - [methods #_(t/seq method?)] + [methods (s/seq-of method?) > t/spec?] ;; TODO room for plenty of optimization here (let [methods|by-ct (->> methods (c/group-by (fn-> :argtypes count)) diff --git a/src-untyped/quantum/untyped/core/spec.cljc b/src-untyped/quantum/untyped/core/spec.cljc index 33b9df94..4089926b 100644 --- a/src-untyped/quantum/untyped/core/spec.cljc +++ b/src-untyped/quantum/untyped/core/spec.cljc @@ -264,6 +264,8 @@ #?(:clj (defmacro vec-of [spec & opts] `(coll-of ~spec ~@opts :kind core/vector?))) #?(:clj (defmacro set-of [spec & opts] `(coll-of ~spec ~@opts :kind core/set?))) +;; Really, `seqable-of` +#?(:clj (defmacro seq-of [spec & opts] `(coll-of ~spec ~@opts))) (defn validate|val? [x] (if (nil? x) From 073f4824a6d29b525c4410048e4bc859214331c8 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 4 May 2018 21:34:48 -0600 Subject: [PATCH 024/810] Parity with `defnt` repo --- src-untyped/quantum/untyped/core/defnt.cljc | 42 +++++++++------------ 1 file changed, 18 insertions(+), 24 deletions(-) diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index 205ef9d2..ce74de0d 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -1,27 +1,21 @@ (ns quantum.untyped.core.defnt "Primarily for `(de)fns`." + (:refer-clojure :exclude [any? ident? qualified-keyword? simple-symbol?]) (:require [clojure.spec.alpha :as s] - [quantum.untyped.core.collections :as c] [quantum.untyped.core.convert :as uconv] [quantum.untyped.core.data.map :refer [om]] - [quantum.untyped.core.data.set :as uset] - [quantum.untyped.core.fn - :refer [<- fn-> fn1 fnl]] [quantum.untyped.core.form.evaluate :as ufeval] - [quantum.untyped.core.log :as ulog] - [quantum.untyped.core.logic :as ul] [quantum.untyped.core.loops :refer [reduce-2]] [quantum.untyped.core.reducers :as ur] [quantum.untyped.core.spec :as us] - [quantum.untyped.core.specs :as ss] - [quantum.untyped.core.vars - :refer [defmacro-]])) + [quantum.untyped.core.type.predicates + :refer [any? ident? qualified-keyword? simple-symbol?]])) (s/def :quantum.core.defnt/local-name - (s/and simple-symbol? (uset/not #{'& '| '> '?}))) + (s/and simple-symbol? (complement #{'& '| '> '?}))) ;; ----- Specs ----- ;; @@ -60,7 +54,7 @@ (s/def :quantum.core.defnt/syms (>keys|syms|strs symbol?)) (s/def :quantum.core.defnt/strs (>keys|syms|strs simple-symbol?)) -(s/def :quantum.core.defnt/or :quantum.core.specs/or) +(s/def :quantum.core.defnt/or (s/map-of simple-symbol? any?)) (s/def :quantum.core.defnt/as :quantum.core.defnt/local-name) (s/def :quantum.core.defnt/map-special-binding @@ -85,15 +79,15 @@ ;; ----- Args ----- ;; (s/def :quantum.core.defnt/output-spec - (s/? (s/cat :sym (fn1 = '>) :spec :quantum.core.defnt/spec))) + (s/? (s/cat :sym #(= % '>) :spec :quantum.core.defnt/spec))) (s/def :quantum.core.defnt/arglist (s/and vector? (s/spec (s/cat :args (s/* :quantum.core.defnt/speced-binding) - :varargs (s/? (s/cat :sym (fn1 = '&) + :varargs (s/? (s/cat :sym #(= % '&) :speced-binding :quantum.core.defnt/speced-binding)) - :pre (s/? (s/cat :sym (fn1 = '|) + :pre (s/? (s/cat :sym #(= % '|) :spec (s/or :any-spec #{'_} :spec any?))) :post :quantum.core.defnt/output-spec)) (s/conformer @@ -103,8 +97,8 @@ (fn [{:keys [args varargs]}] ;; so `env` in `fnt` can work properly in the analysis ;; TODO need to adjust for destructuring - (c/distinct? - (concat (c/lmap :binding-form args) + (distinct? + (concat (map :binding-form args) [(:binding-form varargs)]))))) (s/def :quantum.core.defnt/body (s/alt :body (s/* any?))) @@ -121,12 +115,12 @@ (s/conformer (fn [f] (-> f (update :overloads - (fnl mapv (fn [overload] + #(mapv (fn [overload] (let [overload' (update overload :body :body)] - (ul/if-let [output-spec (-> f :output-spec :spec)] - (do (us/validate (-> overload' :arglist :post) nil?) - (c/assoc-in overload' [:arglist :post] output-spec)) - overload'))))) + (if-let [output-spec (-> f :output-spec :spec)] + (do (us/validate nil? (-> overload' :arglist :post)) + (assoc-in overload' [:arglist :post] output-spec)) + overload'))) %)) (dissoc :output-spec))))) (s/def :quantum.core.defnt/fnt @@ -257,10 +251,10 @@ (defn fns|code [kind lang args] (assert (= lang #?(:clj :clj :cljs :cljs)) lang) - (when (= kind :fn) (ulog/warn! "`fn` will ignore spec validation")) + (when (= kind :fn) (println "WARNING: `fn` will ignore spec validation")) (let [{:keys [:quantum.core.specs/fn|name overloads :quantum.core.specs/meta] :as args'} - (us/validate args (case kind (:defn :defn-) :quantum.core.defnt/defns|code - :fn :quantum.core.defnt/fns|code)) + (us/validate (case kind (:defn :defn-) :quantum.core.defnt/defns|code + :fn :quantum.core.defnt/fns|code) args) ret-sym (gensym "ret") arity-kind-sym (gensym "arity-kind") args-sym (gensym "args") {:keys [overload-forms spec-form|args spec-form|fn]} (reduce From 8179b476ce101082108d77ee8074a279df7f563e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 10 May 2018 21:53:06 -0600 Subject: [PATCH 025/810] `defns` support --- src-untyped/quantum/untyped/core/core.cljc | 3 +- src-untyped/quantum/untyped/core/defnt.cljc | 202 ++++++++++++------ src-untyped/quantum/untyped/core/spec.cljc | 105 +++++++-- .../quantum/untyped/core/type/predicates.cljc | 47 +++- test/quantum/test/untyped/core/defnt.cljc | 160 +++++++++----- 5 files changed, 372 insertions(+), 145 deletions(-) diff --git a/src-untyped/quantum/untyped/core/core.cljc b/src-untyped/quantum/untyped/core/core.cljc index 409626b2..4957773c 100644 --- a/src-untyped/quantum/untyped/core/core.cljc +++ b/src-untyped/quantum/untyped/core/core.cljc @@ -108,7 +108,8 @@ (defn merge-meta-from [to from] (update-meta to merge (meta from))) (defn replace-meta-from [to from] (with-meta to (meta from))) -#?(:clj (defn defalias* [^clojure.lang.Var orig-var ns-name- var-name] +#?(:clj +(defn defalias* [^clojure.lang.Var orig-var ns-name- var-name] (let [;; to avoid warnings var-name' (with-meta var-name (-> orig-var meta (select-keys [:dynamic]))) ^clojure.lang.Var var- diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index ce74de0d..3570ee8e 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -3,6 +3,7 @@ (:refer-clojure :exclude [any? ident? qualified-keyword? simple-symbol?]) (:require [clojure.spec.alpha :as s] + [clojure.spec.gen.alpha :as gen] [quantum.untyped.core.convert :as uconv] [quantum.untyped.core.data.map :refer [om]] @@ -11,14 +12,15 @@ :refer [reduce-2]] [quantum.untyped.core.reducers :as ur] [quantum.untyped.core.spec :as us] + [quantum.untyped.core.specs] [quantum.untyped.core.type.predicates :refer [any? ident? qualified-keyword? simple-symbol?]])) +;; ===== Specs ===== ;; + (s/def :quantum.core.defnt/local-name (s/and simple-symbol? (complement #{'& '| '> '?}))) -;; ----- Specs ----- ;; - (s/def :quantum.core.defnt/spec (s/alt :infer #{'?} :any #{'_} @@ -54,7 +56,7 @@ (s/def :quantum.core.defnt/syms (>keys|syms|strs symbol?)) (s/def :quantum.core.defnt/strs (>keys|syms|strs simple-symbol?)) -(s/def :quantum.core.defnt/or (s/map-of simple-symbol? any?)) +(s/def :quantum.core.defnt/or :quantum.core.specs/or) (s/def :quantum.core.defnt/as :quantum.core.defnt/local-name) (s/def :quantum.core.defnt/map-special-binding @@ -128,7 +130,7 @@ (s/cat :quantum.core.specs/fn|name (s/? :quantum.core.specs/fn|name) :quantum.core.specs/docstring (s/? :quantum.core.specs/docstring) - :quantum.core.specs/meta (s/? :quantum.core.specs/meta) + :pre-meta (s/? :quantum.core.specs/meta) :output-spec :quantum.core.defnt/output-spec :overloads :quantum.core.defnt/overloads)) :quantum.core.specs/fn|postchecks @@ -141,7 +143,7 @@ (s/cat :quantum.core.specs/fn|name :quantum.core.specs/fn|name :quantum.core.specs/docstring (s/? :quantum.core.specs/docstring) - :quantum.core.specs/meta (s/? :quantum.core.specs/meta) + :pre-meta (s/? :quantum.core.specs/meta) :output-spec :quantum.core.defnt/output-spec :overloads :quantum.core.defnt/overloads)) :quantum.core.specs/fn|postchecks @@ -154,6 +156,88 @@ :seq :quantum.core.defnt/seq-binding-form :map :quantum.core.defnt/map-binding-form)) +;; ===== Implementation ===== ;; + +(defn >seq-destructuring-spec + "Creates a spec that performs seq destructuring, and provides a default generator for such based + on the generators of the destructured args." + [positional-destructurer most-complex-positional-destructurer kv-spec or|conformer seq-spec + {:as opts generate-from-seq-spec? :gen?}] + (let [or|unformer (s/conformer second) + most-complex-positional-destructurer|unformer + (s/conformer (fn [x] (s/unform most-complex-positional-destructurer x)))] + (cond-> + (s/and seq-spec + (s/conformer (fn [xs] {:xs xs :xs|destructured xs})) + (us/kv {:xs|destructured (s/and positional-destructurer + or|unformer + kv-spec)}) + (s/conformer (fn [m] (assoc m :xs|positionally-destructured|ct + (when-not (-> m :xs|destructured (contains? :varargs)) + (-> m :xs|destructured count))))) + (us/kv {:xs|destructured + (s/and or|conformer + (s/conformer (fn [x] (s/unform positional-destructurer x))))}) + (s/conformer (fn [{:keys [xs xs|destructured xs|positionally-destructured|ct]}] + (if xs|positionally-destructured|ct + (concat xs|destructured (drop xs|positionally-destructured|ct xs)) + xs|destructured)))) + (not generate-from-seq-spec?) + (s/with-gen + #(->> (s/gen kv-spec) + (gen/fmap (fn [x] (s/conform most-complex-positional-destructurer|unformer x)))))))) + +#?(:clj +(defmacro seq-destructure + "If `generate-from-seq-spec?` is true, generates from `seq-spec`'s generator instead of the + default generation strategy based on the generators of the destructured args." + [seq-spec #_any? args #_(s/* (s/cat :k keyword? :spec any?)) + & [varargs #_(s/nilable (s/cat :k keyword? :spec any?))]] + (let [opts (meta seq-spec) + args (us/validate (s/* (s/cat :k keyword? :spec any?)) args) + varargs (us/validate (s/nilable (s/cat :k keyword? :spec any?)) varargs) + args-ct>args-kw #(keyword (str "args-" %)) + arity>cat (fn [arg-i] + `(s/cat ~@(->> args (take arg-i) + (map (fn [{:keys [k spec]}] [k `any?])) + (apply concat)))) + most-complex-positional-destructurer-sym (gensym "most-complex-positional-destructurer")] + `(let [~most-complex-positional-destructurer-sym + (s/cat ~@(->> args + (map (fn [{:keys [k]}] [k `any?])) + (apply concat)) + ~@(when varargs [(:k varargs) `(s/& (s/+ any?) (s/conformer seq identity))])) + positional-destructurer# + (s/or :args-0 (s/cat) + ~@(->> (range (count args)) + (map (fn [i] [(args-ct>args-kw (inc i)) (arity>cat (inc i))])) + (apply concat)) + ~@(when varargs [:varargs most-complex-positional-destructurer-sym])) + kv-spec# + (us/kv (om ~@(apply concat + (cond-> (->> args (map (fn [{:keys [k spec]}] [k spec]))) + varargs (concat [[(:k varargs) (:spec varargs)]]))))) + or|conformer# + (s/conformer + (fn or|conformer# [m#] + [(case (count m#) + ~@(->> (range (inc (count args))) + (map (juxt identity args-ct>args-kw)) + (apply concat)) + ~@(when varargs [:varargs])) + m#]))] + (>seq-destructuring-spec positional-destructurer# ~most-complex-positional-destructurer-sym + kv-spec# or|conformer# ~seq-spec ~opts))))) + +#?(:clj +(defmacro map-destructure [map-spec #_any? kv-specs #_(s/map-of any? any?)] + (let [kv-spec-sym (gensym "kv-spec") + {:as opts generate-from-map-spec? :gen?} (meta map-spec)] + `(let [~kv-spec-sym (us/kv ~kv-specs)] + ~(if generate-from-map-spec? + `(s/and ~map-spec ~kv-spec-sym) + `(s/with-gen (s/and ~map-spec ~kv-spec-sym) (fn [] (s/gen ~kv-spec-sym)))))))) + (defn speced-binding>binding [{[kind binding-] :binding-form} #_:quantum.core.defnt/speced-binding] (case kind :sym binding- @@ -181,74 +265,60 @@ (or (get-in binding- ks) (gensym (if i|arg (str "arg-" i|arg "-") "varargs"))))))) -(defn context>destructuring [arg-ident #_simple-symbol? context #_vector?] - (reduce - (fn [destructuring [context-type #_#{:map :seq} k varargs?]] - (case context-type - :map {destructuring k} - :seq (let [base (vec (repeatedly k #(gensym "_")))] - (if varargs? - (conj base '& destructuring) - (assoc base k destructuring))) - (:keys :syms :strs) {context-type [destructuring]})) - arg-ident - (rseq context))) - -(defn keys-syms-strs>arg-specs [binding- binding-kind context] - (->> (get binding- binding-kind) second - (filter (fn [{[spec-kind _] :spec}] (= spec-kind :spec))) - (mapv (fn [{:keys [binding-form #_symbol?] [spec-kind spec] :spec}] - (let [destructuring (context>destructuring binding-form (conj context [binding-kind nil]))] - `(us/with (fn [~destructuring] ~binding-form) ~spec)))))) - -(defn >as-specs [{:as speced-binding [kind binding-] :binding-form [spec-kind spec] :spec} context] - (let [[k base-spec] (case kind :seq [:sym `clojure.core/seqable?] - :map [1 `clojure.core/map?])] - (let [as-ident (or (get-in binding- [:as k]) (gensym "as")) - destructuring (context>destructuring as-ident context)] - (cond-> [`(us/with (fn [~destructuring] ~as-ident) ~base-spec)] - (= spec-kind :spec) (conj `(us/with (fn [~destructuring] ~as-ident) ~spec)))))) - -(defn speced-binding>arg-specs - ([speced-binding] (speced-binding>arg-specs speced-binding [])) - ([{:as speced-binding [kind binding-] :binding-form [spec-kind spec] :spec} - #_:quantum.core.defnt/speced-binding context #_vector?] - (case kind - :sym (when (= spec-kind :spec) - [(let [destructuring (context>destructuring binding- context)] - `(us/with (fn [~destructuring] ~binding-) ~spec))]) - :seq (let [{elems :elems rest- :rest} binding-] - (apply concat - (>as-specs speced-binding context) - (->> elems - (map-indexed (fn [i speced-binding] - (speced-binding>arg-specs speced-binding (conj context [:seq i])))) - (apply concat)) - (when rest- - [(speced-binding>arg-specs (:form rest-) (conj context [:seq (count elems) true]))]))) - :map (apply concat - (>as-specs speced-binding context) - (keys-syms-strs>arg-specs binding- :keys context) - (keys-syms-strs>arg-specs binding- :syms context) - (keys-syms-strs>arg-specs binding- :strs context) - (->> (dissoc binding- :as :or :keys :syms :strs) - (map (fn [[k {:as v :keys [key+spec]}]] - (speced-binding>arg-specs - (assoc v :spec (:spec key+spec)) - (conj context [:map (:key key+spec)]))))))))) +(declare speced-binding>spec) + +(defn- speced-binding|seq>spec + [{:as speced-binding [kind binding-] :binding-form [spec-kind spec] :spec}] + `(seq-destructure ~spec + ~(->> binding- :elems + (map-indexed + (fn [i|arg arg|speced-binding] + [(speced-binding>arg-ident arg|speced-binding i|arg) + (speced-binding>spec arg|speced-binding)])) + (apply concat) + vec) + ~@(when-let [varargs|speced-binding (get-in binding- [:rest :form])] + [[(speced-binding>arg-ident varargs|speced-binding) + (speced-binding>spec varargs|speced-binding)]]))) + +(defn- keys||strs||syms>key-specs [kind #_#{:keys :strs :syms} speced-bindings] + (let [binding-form>key + (case kind :keys uconv/>keyword :strs name :syms identity)] + (->> speced-bindings + (filter (fn [{[spec-kind _] :spec}] (= spec-kind :spec))) + (map (fn [{:keys [binding-form #_symbol?] [_ spec] :spec}] + [(binding-form>key binding-form) spec]))))) + +(defn- speced-binding|map>spec + [{:as speced-binding [kind binding-] :binding-form [spec-kind spec] :spec}] + `(map-destructure ~spec + ~(->> (dissoc binding- :as :or) + (map (fn [[k v]] + (case k + (:keys :strs :syms) + (keys||strs||syms>key-specs k (second v)) + [[(get-in v [:key+spec :key]) + (speced-binding>spec + (assoc v :spec (get-in v [:key+spec :spec])))]]))) + (apply concat) + (into {})))) + +(defn speced-binding>spec + [{:as speced-binding [kind binding-] :binding-form [spec-kind spec] :spec}] + (case kind + :sym (if (= spec-kind :spec) spec `any?) + :seq (speced-binding|seq>spec speced-binding) + :map (speced-binding|map>spec speced-binding))) (defn arglist>spec-form|arglist [args+varargs kw-args #_:quantum.core.specs/map-binding-form] `(s/cat ~@(reduce-2 (fn [ret speced-binding [_ kw-arg]] - (let [arg-specs (speced-binding>arg-specs speced-binding)] - (conj ret kw-arg (case (count arg-specs) - 0 `clojure.core/any? - 1 (first arg-specs) - `(s/and ~@arg-specs))))) + (conj ret kw-arg (speced-binding>spec speced-binding))) [] args+varargs kw-args))) +;; TODO handle duplicate bindings (e.g. `_`) by `s/cat` using unique keys — e.g. :b|arg-2 (defn fns|code [kind lang args] (assert (= lang #?(:clj :clj :cljs :cljs)) lang) (when (= kind :fn) (println "WARNING: `fn` will ignore spec validation")) @@ -284,7 +354,7 @@ (update :overload-forms conj overload-form) (update :spec-form|args conj arity-ident spec-form|args*) (update :spec-form|fn conj arity-ident spec-form|fn*)))) - {:overloads [] + {:overload-forms [] :spec-form|args [] :spec-form|fn []} overloads) diff --git a/src-untyped/quantum/untyped/core/spec.cljc b/src-untyped/quantum/untyped/core/spec.cljc index 4089926b..d0631ac9 100644 --- a/src-untyped/quantum/untyped/core/spec.cljc +++ b/src-untyped/quantum/untyped/core/spec.cljc @@ -1,6 +1,6 @@ (ns quantum.untyped.core.spec (:refer-clojure :exclude - [string? keyword? set? number? fn? any? + [ident? string? keyword? set? number? fn? any? assert keys merge + * cat and or constantly]) (:require [clojure.core :as core] @@ -18,6 +18,8 @@ [quantum.untyped.core.form.evaluate :as ufeval :refer [case-env]] [quantum.untyped.core.qualify :as uqual] + [quantum.untyped.core.type.predicates + :refer [ident?]] [quantum.untyped.core.vars :refer [defalias defmalias]]) #?(:cljs @@ -272,31 +274,100 @@ (throw (ex-info "Value is not allowed to be nil but was" {})) x)) -#?(:clj (defmacro with [extract-f spec] `(nonconforming (and (conformer ~extract-f) ~spec)))) +(defn kv + "Based on `s/map-spec-impl`" + ([k->s #_(s/map-of any? specable?)] (kv k->s nil)) + ([k->s #_(s/map-of any? specable?) gen-fn #_(? fn?)] + (let [id (java.util.UUID/randomUUID) + k->s|desc (->> k->s + (map (fn [[k specable]] + [k (if (ident? specable) specable (s/describe specable))])) + (into {}))] + (reify + s/Specize + (specize* [this] this) + (specize* [this _] this) + s/Spec + (conform* [_ x] + (reduce + (fn [x' [k s]] + (let [v (get x' k) + cv (s/conform s v)] + (if (s/invalid? cv) + ::s/invalid + (if (identical? cv v) + x' + ;; TODO we might want to do `assoc?!`, depending + (assoc x' k cv))))) + x + k->s)) + (unform* [_ x] + (reduce + (fn [x' [k s]] + (let [cv (get x' k) + v (s/unform s cv)] + (if (identical? cv v) + x' + ;; TODO we might want to do `assoc?!`, depending + (assoc x' k v)))) + x + k->s)) + (explain* [_ path via in x] + (if-not ;; TODO we might want a more generalized `map?` predicate like `t/map?`, depending, + ;; which would affect more code below + (map? x) + [{:path path :pred 'map? :val x :via via :in in}] + ;; TODO use reducers? + (->> k->s + (map (fn [[k s]] + (let [v (get x k)] + (when-not (s/valid? s v) + (@#'s/explain-1 (get k->s|desc k) s (conj path k) via (conj in k) v))))) + (filter some?) + (apply concat)))) + (gen* [_ overrides path rmap] + (if gen-fn + (gen-fn) + (let [rmap (assoc rmap id (inc (core/or (get rmap id) 0))) + gen (fn [[k s]] + (when-not (@#'s/recur-limit? rmap id path k) + [k (gen/delay (@#'s/gensub s overrides (conj path k) rmap k))])) + gens (->> k->s (map gen) (remove nil?) (into {}))] + (gen/bind (gen/choose 0 (count gens)) + (fn [n] + (let [args (-> gens seq shuffle)] + (->> args + (take n) + (apply concat) + (apply gen/hash-map)))))))) + (with-gen* [_ gen-fn'] (kv k->s gen-fn')) + (describe* [_] `(kv ~k->s|desc)))))) (defn with-gen-spec-impl "Do not call this directly; use 'with-gen-spec'." [extract-f extract-f|form gen-spec gen-spec|form] - (let [form `(with-gen-spec ~extract-f|form ~gen-spec|form) - gen-spec (fn [x] (let [spec (gen-spec x) - desc (describe spec) - desc (if (= desc ::s/unknown) - (list 'some-generated-spec gen-spec|form) - desc)] - (with extract-f (@#'s/spec-impl desc spec nil nil))))] - (if (clojure.core/fn? gen-spec) + (if (fn? gen-spec) + (let [form `(with-gen-spec ~extract-f|form ~gen-spec|form) + gen-spec' (fn [x] + (let [spec (gen-spec x) + desc (s/describe spec) + desc (if (= desc ::s/unknown) + (list 'some-generated-spec gen-spec|form) + desc)] + (s/nonconforming (s/and (s/conformer extract-f) + (@#'s/spec-impl desc spec nil nil)))))] (reify s/Specize (s/specize* [this] this) (s/specize* [this _] this) s/Spec - (s/conform* [_ x] (s/conform* (gen-spec x) x)) - (s/unform* [_ x] (s/unform* (gen-spec x) x)) - (s/explain* [_ path via in x] (s/explain* (gen-spec x) path via in x)) + (s/conform* [_ x] (s/conform* (gen-spec' x) x)) + (s/unform* [_ x] (s/unform* (gen-spec' x) x)) + (s/explain* [_ path via in x] (s/explain* (gen-spec' x) path via in x)) (s/gen* [_ _ _ _] (gen/gen-for-pred gen-spec)) - (s/with-gen* [_ gen-fn'] (TODO)) - (s/describe* [_] form)) - (err! "`wrap-spec` may only be called on fns" {:input gen-spec})))) + (s/with-gen* [_ _] (throw (ex-info "TODO" {}))) + (s/describe* [_] form))) + (throw (ex-info "`wrap-spec` may only be called on fns" {:input gen-spec})))) #?(:clj (defmacro with-gen-spec @@ -308,5 +379,3 @@ {:a 1 :b 1})" [extract-f gen-spec] `(with-gen-spec-impl ~extract-f '~extract-f ~gen-spec '~gen-spec))) - -(def any? (constantly true)) diff --git a/src-untyped/quantum/untyped/core/type/predicates.cljc b/src-untyped/quantum/untyped/core/type/predicates.cljc index c50d9179..1ff0efe5 100644 --- a/src-untyped/quantum/untyped/core/type/predicates.cljc +++ b/src-untyped/quantum/untyped/core/type/predicates.cljc @@ -2,20 +2,57 @@ "For type predicates that are not yet turned into specs. TODO excise and place in `quantum.untyped.core.type`." (:refer-clojure :exclude - [array? boolean? seqable?]) + [any? array? boolean? double? ident? qualified-keyword? seqable? simple-symbol?]) (:require - [clojure.core :as core] + [clojure.core :as core] +#?(:clj + [clojure.future :as fcore]) #_[quantum.untyped.core.core :as ucore])) #_(ucore/log-this-ns) +;; The reason we use `resolve` and `eval` here is that currently we need to prefer built-in impls +;; where possible in order to leverage their generators + +#?(:clj (eval `(defalias ~(if (resolve `fcore/any?) + `fcore/any? + `core/any?))) + :cljs (defalias core/any?)) + +#?(:clj (eval `(defalias ~(if (resolve `fcore/boolean?) + `fcore/boolean? + `core/boolean?))) + :cljs (defalias core/boolean?)) + +#?(:clj (eval `(defalias ~(if (resolve `fcore/double?) + `fcore/double? + `core/double?))) + :cljs (defalias core/double?)) + +#?(:clj (eval `(defalias ~(if (resolve `fcore/ident?) + `fcore/ident? + `core/ident?))) + :cljs (defalias core/ident?)) + +#?(:clj (eval `(defalias ~(if (resolve `fcore/pos-int?) + `fcore/pos-int? + `core/pos-int?))) + :cljs (defalias core/pos-int?)) + +#?(:clj (eval `(defalias ~(if (resolve `fcore/qualified-keyword?) + `fcore/qualified-keyword? + `core/qualified-keyword?))) + :cljs (defalias core/qualified-keyword?)) + +#?(:clj (eval `(defalias ~(if (resolve `fcore/simple-symbol?) + `fcore/simple-symbol? + `core/simple-symbol?))) + :cljs (defalias core/simple-symbol?)) + #?(:clj (defn namespace? [x] (instance? clojure.lang.Namespace x))) (def val? some?) -(defn boolean? [x] #?(:clj (instance? Boolean x) - :cljs (or (true? x) (false? x)))) - (defn lookup? [x] #?(:clj (instance? clojure.lang.ILookup x) :cljs (satisfies? ILookup x))) diff --git a/test/quantum/test/untyped/core/defnt.cljc b/test/quantum/test/untyped/core/defnt.cljc index 7e4734f0..94188af5 100644 --- a/test/quantum/test/untyped/core/defnt.cljc +++ b/test/quantum/test/untyped/core/defnt.cljc @@ -1,78 +1,114 @@ (ns quantum.test.untyped.core.defnt (:require [clojure.spec.alpha :as s] - [quantum.untyped.core.defnt :as this])) + [clojure.spec.gen.alpha :as gen] + [clojure.spec.test.alpha :as stest] + [clojure.test.check.clojure-test + :refer [defspec]] + [quantum.untyped.core.defnt :as this] + [quantum.untyped.core.spec :as us] + [quantum.untyped.core.test + :refer [defspec-test]])) -#_(defns abcde "Documentation" {:metadata "abc"} - ([a #(instance? Long %)] (+ a 1)) - ([b ?, c _ > integer?] {:pre 1} 1 2) - ([d string?, e #(instance? StringBuilder %) & f _ > number?] - (.substring ^String d 0 1) - (.append ^StringBuilder e 1) - 3 4)) +;; Implicit compilation tests +(this/defns abcde "Documentation" {:metadata "fhgjik"} + ([a number? > number?] (inc a)) + ([a pos-int?, b pos-int? + | (> a b) + > (s/and number? #(> % a) #(> % b))] (+ a b)) + ([a #{"a" "b" "c"} + b boolean? + {:as c + :keys [ca keyword? cb string?] + {:as cc + {:as cca + :keys [ccaa keyword?] + [[ccabaa some? {:as ccabab :keys [ccababa some?]} some?] some? ccabb some? & ccabc some? :as ccab] + [:ccab seq?]} + [:cca map?]} + [:cc map?]} + #(-> % count (= 3)) + [da double? & db seq? :as d] sequential? + [ea symbol?] ^:gen? (s/coll-of symbol? :kind vector?) + & [fa #{"a" "b" "c"} :as f] seq? + | (and (> da 50) (contains? c a) + a b c ca cb cc cca ccaa ccab ccabaa ccabab ccababa ccabb ccabc d da db ea f fa) + > number?] 0)) + +(this/defns basic [a number? > number?] (rand)) + +(defspec-test test|basic `basic) + +(this/defns equality [a number? > #(= % a)] a) + +(defspec-test test|equality `equality) + +(this/defns pre-post [a number? | (> a 3) > #(> % 4)] (inc a)) + +(defspec-test test|pre-post `pre-post) + +(this/defns gen|seq|0 [[a number? b number? :as b] ^:gen? (s/tuple double? double?)]) + +(defspec-test test|gen|seq|0 `gen|seq|0) + +(this/defns gen|seq|1 + [[a number? b number? :as b] ^:gen? (s/nonconforming (s/cat :a double? :b double?))]) + +(defspec-test test|gen|seq|1 `gen|seq|1) ;; TODO assert that the below 2 things are equivalent -(macroexpand -'(this/defns fghij "Documentation" {:metadata "abc"} +#_(this/defns abcde "Documentation" {:metadata "abc"} ([a number? > number?] (inc a)) - ([a number?, b number? + ([a pos-int?, b pos-int? | (> a b) > (s/and number? #(> % a) #(> % b))] (+ a b)) - ([a string? + ([a #{"a" "b" "c"} b boolean? {:as c :keys [ca keyword? cb string?] {:as cc {:as cca :keys [ccaa keyword?] - [[ccabaa some? {:as ccabab :keys [ccababa some?]} some?] some? ccabb some? :as ccab] + [[ccabaa some? {:as ccabab :keys [ccababa some?]} some?] some? ccabb some? & ccabc some? :as ccab] [:ccab seq?]} [:cca map?]} [:cc map?]} #(-> % count (= 3)) [da double? & db seq? :as d] sequential? - [ea symbol?] vector? - & [fa string? :as f] seq? - | (and (> a b) (contains? c a) - a b c ca cb cc cca ccaa ccab ccabaa ccabab ccababa ccabb d da db ea f fa) - > number?] 0))) + [ea symbol?] ^:gen? (s/coll-of symbol? :kind vector?) + & [fa #{"a" "b" "c"} :as f] seq? + | (and (> da 50) (contains? c a) + a b c ca cb cc cca ccaa ccab ccabaa ccabab ccababa ccabb ccabc d da db ea f fa) + > number?] 0)) -(s/fdef fghijk +#_(s/fdef abcde :args (s/or - :arity-1 (s/cat :a (s/with (fn [a] a) number?)) - :arity-2 (s/and (s/cat :a (s/with (fn [a] a) number?) - :b (s/with (fn [b] b) number?)) + :arity-1 (s/cat :a number?) + :arity-2 (s/and (s/cat :a pos-int? + :b pos-int?) (fn [{a :a b :b}] (> a b))) :arity-varargs (s/and (s/cat - :a (s/with (fn [a] a) string?) - :b (s/with (fn [b] b) boolean?) - :c (s/and - (s/with (fn [c] c) #(-> % count (= 3))) - (s/with (fn [{:keys [ca]}] ca) keyword?) - (s/with (fn [{:keys [cb]}] cb) string?) - (s/with (fn [{cc :cc}] cc) map?) - (s/with (fn [{{cca :cca} :cc}] cca) map?) - (s/with (fn [{{{:keys [ccaa]} :cca} :cc}] ccaa) keyword?) - (s/with (fn [{{{ccab :ccab} :cca} :cc}] ccab) seq?) - (s/with (fn [{{{[as#] :ccab} :cca} :cc}] as#) some?) - (s/with (fn [{{{[[ccabaa]] :ccab} :cca} :cc}] ccabaa) some?) - (s/with (fn [{{{[[_# ccabab]] :ccab} :cca} :cc}] ccabab) some?) - (s/with (fn [{{{[[_# {:keys [ccababa]}]] :ccab} :cca} :cc}] ccababa)) some? - (s/with (fn [{{{[_# ccabb] :ccab} :cca} :cc}] ccabb) some?)) - :d (s/and - (s/with (fn [d] d) sequential?) - (s/with (fn [[da]] da) double?) - (s/with (fn [[_# & db]] db)) seq?) - :arg-4# (s/and - (s/with (fn [as#] as#) vector?) - (s/with (fn [[ea]] ea)) symbol?) - :f (s/and - (s/with (fn [f] f) seq?) - (s/with (fn [[fa]] fa) string?))) + :a #{"a" "b" "c"} + :b boolean? + :c (this/map-destructure #(-> % count (= 3)) + {:ca keyword? + :cb string? + :cc (this/map-destructure map? + {:cca (this/map-destructure map? + {:ccaa keyword? + :ccab (this/seq-destructure seq? + [:arg-0 (this/seq-destructure some? + [:ccabaa some? + :ccabab (this/map-destructure some? {:ccababa some?})]) + :ccabb some?] + [:ccabc some?])})})}) + :d (this/seq-destructure sequential? [:da double?] [:db seq?]) + :arg-4# (this/seq-destructure ^{:gen? true} (s/coll-of symbol? :kind vector?) [:ea symbol?] ) + :f (this/seq-destructure seq? [:fa #{"a" "b" "c"}])) (fn [{a :a b :b {:as c @@ -80,21 +116,21 @@ {:as cc {:as cca :keys [ccaa] - [[ccabaa {:as ccabab :keys [ccababa]}] ccabb :as ccab] :ccab} :cca} :cc} :c + [[ccabaa {:as ccabab :keys [ccababa]}] ccabb & ccabc :as ccab] :ccab} :cca} :cc} :c [da & db :as d] :d [ea] :arg-4# - [fa :as f] :f}] - (and (> a b) (contains? c a) - a b c ca cb cc cca ccaa ccab ccabaa ccabab ccababa ccabb d da db ea f fa)))) + [fa :as f] :f :as X}] + (and (> da 50) (= a fa) + a b c ca cb cc cca ccaa ccab ccabaa ccabab ccababa ccabb ccabc d da db ea f fa)))) :fn - (s/with-gen-spec (fn [{:keys [ret]}] ret) + (us/with-gen-spec (fn [{ret# :ret}] ret#) (fn [{[arity-kind# args#] :args}] (case arity-kind# :arity-1 (let [{a :a} args#] (s/spec number?)) :arity-2 (let [{a :a b :b} args#] (s/spec (s/and number? #(> % a) #(> % b)))) - :arity-3 + :arity-varargs (let [{a :a b :b {:as c @@ -102,9 +138,23 @@ {:as cc {:as cca :keys [ccaa] - [[ccabaa {:as ccabab :keys [ccababa]}] ccabb :as ccab] :ccab} :cca} :cc} :c + [[ccabaa {:as ccabab :keys [ccababa]}] ccabb & ccabc :as ccab] :ccab} :cca} :cc} :c [da & db :as d] :d [ea] :arg-4# [fa :as f] :f} args#] (s/spec number?)))))) -(fghij "zx" true {:ca :x :cb "y" :cc {:cca {:ccaa :z :ccab (list [1 {:ccababa 2}] 3)}}} [1.0 4] ['a]) +#_(defn abcde "Documentation" {:metadata "abc"} + ([a] (inc a)) + ([a b] (+ a b)) + ([a b + {:as c, + :keys [ca cb], + {:as cc, + {:as cca, + :keys [ccaa], + [[ccabaa {:as ccabab, :keys [ccababa]}] ccabb & ccabc :as ccab] :ccab} :cca} :cc} + [da & db :as d] + [ea] + & + [fa :as f]] + 0)) From 84f7da436be2cf89ff727c6c9211a6d94339119e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 10 May 2018 21:53:37 -0600 Subject: [PATCH 026/810] `and-let` etc. --- src-untyped/quantum/untyped/core/logic.cljc | 72 +++++++++++++-------- 1 file changed, 45 insertions(+), 27 deletions(-) diff --git a/src-untyped/quantum/untyped/core/logic.cljc b/src-untyped/quantum/untyped/core/logic.cljc index ce177a0f..fb237f70 100644 --- a/src-untyped/quantum/untyped/core/logic.cljc +++ b/src-untyped/quantum/untyped/core/logic.cljc @@ -16,13 +16,21 @@ ;; ===== Logical operators ===== ;; - ;; tests value-equivalence +;; ----- Unary operators ----- ;; + + (defalias not core/not) + +;; ----- Binary operators ----- ;; + + ;; Tests value-equivalence (defalias = core/=) - ;; tests identity-equivalence + ;; Tests identity-equivalence (defalias ref= identical?) - (defalias not core/not) +#?(:clj (defmacro implies? [a b] `(if ~a ~b true))) + +;; ----- Infinitary operators ----- ;; #?(:clj (defalias and core/and)) @@ -44,8 +52,6 @@ ;; TODO `xnor` #?(:clj (declare xnor)) -#?(:clj (defmacro implies? [a b] `(if ~a ~b true))) - ;; ===== Function-logical operators ===== ;; (defn fn= [x] (fn [y] (= x y))) @@ -218,46 +224,43 @@ #?(:clj (defmacro if-let-base {:attribution "alexandergunnarson"} - ([cond-sym bindings then] - `(if-let-base ~cond-sym ~bindings ~then nil)) - ([cond-sym [bnd expr & more] then else] - `(let [temp# ~expr ~bnd temp#] - (~cond-sym temp# - ~(if (seq more) - `(if-let-base ~cond-sym [~@more] ~then ~else) - then) - ~else))))) + [cond-op #_symbol? [bind expr & more] then else] + `(let [temp# ~expr ~bind temp#] + (~cond-op temp# + ~(if (seq more) + `(if-let-base ~cond-op [~@more] ~then ~else) + then) + ~else)))) #?(:clj (defmacro if-let "Like `if-let`, but multiple bindings can be used." - [& xs] `(if-let-base if ~@xs))) + [& args] `(if-let-base if ~@args))) #?(:clj (defmacro if-not-let "if : if-let :: if-not : if-not-let. All conditions must be false." - [& xs] `(if-let-base if-not ~@xs))) + [& args] `(if-let-base if-not ~@args))) #?(:clj (defmacro when-let-base {:attribution "alexandergunnarson"} - [cond-sym [bnd expr & more] & body] - `(let [temp# ~expr ~bnd temp#] - (~cond-sym temp# + [cond-op #_symbol? [bind expr & more] & body] + `(let [temp# ~expr ~bind temp#] + (~cond-op temp# ~(if (seq more) - `(when-let-base ~cond-sym [~@more] ~@body) + `(when-let-base ~cond-op [~@more] ~@body) `(do ~@body)))))) #?(:clj (defmacro when-let "Like `when-let`, but multiple bindings can be used." - [& xs] `(if-let-base when ~@xs))) + [& args] `(if-let-base when ~@args))) #?(:clj (defmacro when-not-let "when : when-let :: when-not : when-not-let. All conditions must be false." - [& xs] `(when-let-base when-not ~@xs))) - + [& args] `(when-let-base when-not ~@args))) #?(:clj (defmacro cond-let @@ -265,10 +268,25 @@ {:attribution "alexandergunnarson"} ([] nil) ; no else ([else] else) - ([bindings then & more] - `(if-let ~bindings - ~then - (cond-let ~@more))))) + ([bindings then & more] `(if-let ~bindings ~then (cond-let ~@more))))) + +#?(:clj +(defmacro logical-let-base + {:attribution "alexandergunnarson"} + ([logical-op #_symbol? [bind expr & more]] + `(let [temp# ~expr ~bind temp#] + (~logical-op temp# + ~(if (seq more) + `(logical-let-base ~logical-op [~@more]) + `(~logical-op))))))) + +#?(:clj (defmacro and-let [bindings] `(logical-let-base and ~bindings))) +#?(:clj (defmacro or-let [bindings] `(logical-let-base or ~bindings))) +;; TODO These will require a different, non-incremental approach +#?(:clj (defmacro nand-let [bindings] (throw (ex-info "TODO" {})) #_`(logical-let-base nand ~bindings))) +#?(:clj (defmacro nor-let [bindings] (throw (ex-info "TODO" {})) #_`(logical-let-base nor ~bindings))) +#?(:clj (defmacro xor-let [bindings] (throw (ex-info "TODO" {})) #_`(logical-let-base xor ~bindings))) +#?(:clj (defmacro xnor-let [bindings] (throw (ex-info "TODO" {})) #_`(logical-let-base xnor ~bindings))) ;; ===== `coll-(or|and)` ===== ;; From b36681d756a4452b8cd6bede2e071e59e315972c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 10 May 2018 21:53:52 -0600 Subject: [PATCH 027/810] `educe` enhancements --- .../quantum/untyped/core/reducers.cljc | 39 ++++++++++--------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/src-untyped/quantum/untyped/core/reducers.cljc b/src-untyped/quantum/untyped/core/reducers.cljc index 5be42a67..d35606b3 100644 --- a/src-untyped/quantum/untyped/core/reducers.cljc +++ b/src-untyped/quantum/untyped/core/reducers.cljc @@ -28,9 +28,11 @@ (defprotocol PEduceInit (-educe-init [this f init])) -;; TODO `xs` will hold on to heads of seqs while stepping through; see also http://dev.clojure.org/jira/browse/CLJ-1793 -;; A cross between a `reducer` and a `folder` -(deftype Transformer [xs prev xf] +(deftype + ^{:doc "A cross between an `r/reducer` and an `r/folder`. + NOTE: `xs` will hold on to heads of seqs while stepping through, pre-Clojure-1.9; see also + http://dev.clojure.org/jira/browse/CLJ-1793"} + Transformer [xs prev xf] #?(:clj clojure.lang.IReduce :cljs cljs.core/IReduce) (#?(:clj reduce :cljs -reduce) [this f ] (core/reduce (xf f) prev)) (#?(:clj reduce :cljs -reduce) [this f init] (core/reduce (xf f) init prev)) @@ -53,15 +55,15 @@ {:todo #{"More arity"}} ([^long n xf tf] (case n - 0 (fn ([] (xf)) - ([xs] (tf xs (xf)))) - 1 (fn ([a0] (xf a0)) - ([a0 xs] (tf xs (xf a0)))) - 2 (fn ([a0 a1] (xf a0 a1)) - ([a0 a1 xs] (tf xs (xf a0 a1)))) - 3 (fn ([a0 a1 a2] (xf a0 a1 a2)) - ([a0 a1 a2 xs] (tf xs (xf a0 a1 a2)))) - (err! "Unhandled arity for transducer")))) + 0 (fn ([] (xf)) + ([xs] (tf xs (xf)))) + 1 (fn ([a0] (xf a0)) + ([a0 xs] (tf xs (xf a0)))) + 2 (fn ([a0 a1] (xf a0 a1)) + ([a0 a1 xs] (tf xs (xf a0 a1)))) + 3 (fn ([a0 a1 a2] (xf a0 a1 a2)) + ([a0 a1 a2 xs] (tf xs (xf a0 a1 a2)))) + (err! "Unhandled arity for transducer")))) (defn transducer->transformer "Converts a transducer into a transformer." @@ -78,17 +80,16 @@ ([ret x] (let [ret (rf ret x)] (if (reduced? ret) - (reduced ret) - ret))))) + (reduced ret) + ret))))) ;; ===== Reduction functions ===== ;; (defn educe - "A marriage of `transduce` and `reduce`. - Like `reduce`, does not have a notion of a transforming function - (unlike `transduce`). Like `transduce`, uses the seed (0-arity) and - completing (1-arity) arities of the reducing function when performing - a reduction (unlike `reduce`)." + "A blending of `transduce` and `reduce`. + Like `reduce`, does not have a notion of a transforming function (unlike `transduce`). Like + `transduce`, uses the seed (0-arity) and completing (1-arity) arities of the reducing function + when performing a reduction (unlike `reduce`)." ([f xs] (educe f (f) xs)) ([f init xs] (if (satisfies? PEduceInit xs) From 01897a7900a78ce4207277b016a944bdf9f8cfb2 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 10 May 2018 21:54:04 -0600 Subject: [PATCH 028/810] `defspec` --- src-untyped/quantum/untyped/core/test.cljc | 34 ++++++++++++++++++++++ 1 file changed, 34 insertions(+) create mode 100644 src-untyped/quantum/untyped/core/test.cljc diff --git a/src-untyped/quantum/untyped/core/test.cljc b/src-untyped/quantum/untyped/core/test.cljc new file mode 100644 index 00000000..da460b95 --- /dev/null +++ b/src-untyped/quantum/untyped/core/test.cljc @@ -0,0 +1,34 @@ +(ns quantum.untyped.core.test + (:require + [clojure.spec.alpha :as s] + [clojure.spec.test.alpha :as stest] + [clojure.string :as str] + [clojure.test :as test])) + +(defn report-results [check-results] + (let [checks-passed? (->> check-results (map :failure) (every? nil?))] + (if checks-passed? + (test/do-report {:type :pass + :message (str "Generative tests pass for " + (str/join ", " (map :sym check-results)))}) + (doseq [failed-check (filter :failure check-results)] + (let [r (stest/abbrev-result failed-check) + failure (:failure r)] + (test/do-report + {:type :fail + :message (with-out-str (s/explain-out failure)) + :expected (->> r :spec rest (apply hash-map) :ret) + :actual (if (instance? #?(:clj Throwable :cljs js/Error) failure) + failure + (::stest/val failure))})))) + checks-passed?)) + +#?(:clj +(defmacro defspec-test + {:based-on "https://gist.github.com/kennyjwilli/8bf30478b8a2762d2d09baabc17e2f10"} + ([name sym-or-syms] `(defspec-test ~name ~sym-or-syms nil)) + ([name sym-or-syms opts] + (when test/*load-tests* + `(defn ~(vary-meta name assoc :test + `(fn [] (report-results (stest/check ~sym-or-syms ~opts)))) + [] (test/test-var (var ~name))))))) From ad048755439605cec8f266e3104f04b3848f1a13 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 10 May 2018 21:54:13 -0600 Subject: [PATCH 029/810] Aliasing --- src/quantum/core/logic.cljc | 6 ++++-- src/quantum/core/test.cljc | 4 +++- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/quantum/core/logic.cljc b/src/quantum/core/logic.cljc index 5d31cb70..f7d7e054 100644 --- a/src/quantum/core/logic.cljc +++ b/src/quantum/core/logic.cljc @@ -21,7 +21,6 @@ [quantum.core.logic :as self :refer [fn-not]]))) -; TODO: ; cond-not, for :pre ; Java `switch` is implemented using an array and then points to the code. ; Java String `switch` is implemented using a map8 @@ -140,7 +139,10 @@ (defaliases u if-let if-not-let when-let when-not-let - cond-let)) + cond-let + and-let nand-let + or-let nor-let + xor-let xnor-let)) ;; ===== `coll-(or|and)` ===== ;; diff --git a/src/quantum/core/test.cljc b/src/quantum/core/test.cljc index ec0ca457..bfeed230 100644 --- a/src/quantum/core/test.cljc +++ b/src/quantum/core/test.cljc @@ -8,6 +8,7 @@ :refer [ppr-meta]] [quantum.core.vars :refer [#?(:clj defmalias) defalias]] + [quantum.untyped.core.test :as utest] [quantum.untyped.core.type.predicates :refer [val?]]) #?(:cljs @@ -31,7 +32,8 @@ #?(:clj (defmalias is clojure.test/is cljs.test/is )) #?(:clj (defmalias deftest clojure.test/deftest cljs.test/deftest)) #?(:clj (defmalias testing clojure.test/testing cljs.test/testing)) -#?(:clj (defalias test-ns test/test-ns)) +#?(:clj (defalias test/test-ns)) +#?(:clj (defalias utest/defspec-test)) #?(:clj (defn test-nss-where [pred] From 527904cdd6dc13f75f80c46c1ebdca59d5a38e60 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 11 May 2018 11:49:30 -0600 Subject: [PATCH 030/810] A few compilation fixes --- project-base.clj | 2 ++ src-untyped/quantum/untyped/core/spec.cljc | 2 +- src-untyped/quantum/untyped/core/type.cljc | 2 +- src-untyped/quantum/untyped/core/type/predicates.cljc | 6 ++++-- src/quantum/core/spec.cljc | 2 +- 5 files changed, 9 insertions(+), 5 deletions(-) diff --git a/project-base.clj b/project-base.clj index 3e719198..40618f75 100644 --- a/project-base.clj +++ b/project-base.clj @@ -112,6 +112,8 @@ :exclusions [org.clojure/clojure]] ; ==== SPECS ==== + [clojure-future-spec "1.9.0-beta4" + :exclusions [org.clojure/clojure]] [expound "0.5.0"] [orchestra "2017.11.12-1"] ; ==== COLLECTIONS ==== diff --git a/src-untyped/quantum/untyped/core/spec.cljc b/src-untyped/quantum/untyped/core/spec.cljc index d0631ac9..368adf30 100644 --- a/src-untyped/quantum/untyped/core/spec.cljc +++ b/src-untyped/quantum/untyped/core/spec.cljc @@ -1,6 +1,6 @@ (ns quantum.untyped.core.spec (:refer-clojure :exclude - [ident? string? keyword? set? number? fn? any? + [ident? string? keyword? set? number? any? assert keys merge + * cat and or constantly]) (:require [clojure.core :as core] diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 871d379e..1b6b0c38 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -86,7 +86,7 @@ ?Object {equals ([this that #_any?] (c/or (== this that) (c/and (instance? ValueSpec that) - (c/= v (.-v ^ValueSpec that)))))}} + (c/= v (.-v ^ValueSpec that)))))}}) (defns value "Creates a spec whose extension is the singleton set containing only the value `v`." diff --git a/src-untyped/quantum/untyped/core/type/predicates.cljc b/src-untyped/quantum/untyped/core/type/predicates.cljc index 1ff0efe5..851547a3 100644 --- a/src-untyped/quantum/untyped/core/type/predicates.cljc +++ b/src-untyped/quantum/untyped/core/type/predicates.cljc @@ -2,12 +2,14 @@ "For type predicates that are not yet turned into specs. TODO excise and place in `quantum.untyped.core.type`." (:refer-clojure :exclude - [any? array? boolean? double? ident? qualified-keyword? seqable? simple-symbol?]) + [any? array? boolean? double? ident? pos-int? qualified-keyword? seqable? simple-symbol?]) (:require [clojure.core :as core] #?(:clj [clojure.future :as fcore]) - #_[quantum.untyped.core.core :as ucore])) + #_[quantum.untyped.core.core :as ucore] + [quantum.untyped.core.vars + :refer [defalias]])) #_(ucore/log-this-ns) diff --git a/src/quantum/core/spec.cljc b/src/quantum/core/spec.cljc index 17c4fdc2..89308e4d 100644 --- a/src/quantum/core/spec.cljc +++ b/src/quantum/core/spec.cljc @@ -23,4 +23,4 @@ valid? invalid? #?@(:clj [or* or*-forms constantly-or set-of]) - validate|val? any?) + validate|val?) From 8a254ae17eafba04617b617ac1025d86423ab6fc Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 11 May 2018 14:48:44 -0600 Subject: [PATCH 031/810] Convert untyped type preds to use `defns` --- src-untyped/quantum/untyped/core/core.cljc | 16 ++- src-untyped/quantum/untyped/core/defnt.cljc | 18 +-- src-untyped/quantum/untyped/core/spec.cljc | 13 +- src-untyped/quantum/untyped/core/type.cljc | 128 +++++++++--------- .../quantum/untyped/core/type/predicates.cljc | 14 +- 5 files changed, 102 insertions(+), 87 deletions(-) diff --git a/src-untyped/quantum/untyped/core/core.cljc b/src-untyped/quantum/untyped/core/core.cljc index 4957773c..32d09b1d 100644 --- a/src-untyped/quantum/untyped/core/core.cljc +++ b/src-untyped/quantum/untyped/core/core.cljc @@ -1,10 +1,8 @@ (ns quantum.untyped.core.core (:require #?@(:clj - [[environ.core :as env]]) - [cuerdas.core :as str+] - [quantum.untyped.core.type.predicates :as utpred - :refer [with-metable? metable?]])) + [[environ.core :as env]]) + [cuerdas.core :as str+])) ;; ===== Environment ===== ;; @@ -34,6 +32,16 @@ (defn >sentinel [] #?(:clj (Object.) :cljs #js {})) (def >object >sentinel) +;; ===== quantum.untyped.core.type.predicates ===== ;; + +(defn metable? [x] + #?(:clj (instance? clojure.lang.IMeta x) + :cljs (satisfies? cljs.core/IMeta x))) + +(defn with-metable? [x] + #?(:clj (instance? clojure.lang.IObj x) + :cljs (satisfies? cljs.core/IWithMeta x))) + ; ===== COLLECTIONS ===== (defn seq= diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index 3570ee8e..5256a5a5 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -1,6 +1,6 @@ (ns quantum.untyped.core.defnt "Primarily for `(de)fns`." - (:refer-clojure :exclude [any? ident? qualified-keyword? simple-symbol?]) + (:refer-clojure :exclude [any? ident? qualified-keyword? seqable? simple-symbol?]) (:require [clojure.spec.alpha :as s] [clojure.spec.gen.alpha :as gen] @@ -14,7 +14,7 @@ [quantum.untyped.core.spec :as us] [quantum.untyped.core.specs] [quantum.untyped.core.type.predicates - :refer [any? ident? qualified-keyword? simple-symbol?]])) + :refer [any? ident? qualified-keyword? seqable? simple-symbol?]])) ;; ===== Specs ===== ;; @@ -120,7 +120,7 @@ #(mapv (fn [overload] (let [overload' (update overload :body :body)] (if-let [output-spec (-> f :output-spec :spec)] - (do (us/validate nil? (-> overload' :arglist :post)) + (do (us/assert-conform nil? (-> overload' :arglist :post)) (assoc-in overload' [:arglist :post] output-spec)) overload'))) %)) (dissoc :output-spec))))) @@ -194,8 +194,8 @@ [seq-spec #_any? args #_(s/* (s/cat :k keyword? :spec any?)) & [varargs #_(s/nilable (s/cat :k keyword? :spec any?))]] (let [opts (meta seq-spec) - args (us/validate (s/* (s/cat :k keyword? :spec any?)) args) - varargs (us/validate (s/nilable (s/cat :k keyword? :spec any?)) varargs) + args (us/assert-conform (s/* (s/cat :k keyword? :spec any?)) args) + varargs (us/assert-conform (s/nilable (s/cat :k keyword? :spec any?)) varargs) args-ct>args-kw #(keyword (str "args-" %)) arity>cat (fn [arg-i] `(s/cat ~@(->> args (take arg-i) @@ -269,7 +269,7 @@ (defn- speced-binding|seq>spec [{:as speced-binding [kind binding-] :binding-form [spec-kind spec] :spec}] - `(seq-destructure ~spec + `(seq-destructure ~(if (= spec-kind :spec) spec `seqable?) ~(->> binding- :elems (map-indexed (fn [i|arg arg|speced-binding] @@ -291,7 +291,7 @@ (defn- speced-binding|map>spec [{:as speced-binding [kind binding-] :binding-form [spec-kind spec] :spec}] - `(map-destructure ~spec + `(map-destructure ~(if (= spec-kind :spec) spec `map?) ~(->> (dissoc binding- :as :or) (map (fn [[k v]] (case k @@ -323,8 +323,8 @@ (assert (= lang #?(:clj :clj :cljs :cljs)) lang) (when (= kind :fn) (println "WARNING: `fn` will ignore spec validation")) (let [{:keys [:quantum.core.specs/fn|name overloads :quantum.core.specs/meta] :as args'} - (us/validate (case kind (:defn :defn-) :quantum.core.defnt/defns|code - :fn :quantum.core.defnt/fns|code) args) + (us/assert-conform (case kind (:defn :defn-) :quantum.core.defnt/defns|code + :fn :quantum.core.defnt/fns|code) args) ret-sym (gensym "ret") arity-kind-sym (gensym "arity-kind") args-sym (gensym "args") {:keys [overload-forms spec-form|args spec-form|fn]} (reduce diff --git a/src-untyped/quantum/untyped/core/spec.cljc b/src-untyped/quantum/untyped/core/spec.cljc index 368adf30..ad90e48a 100644 --- a/src-untyped/quantum/untyped/core/spec.cljc +++ b/src-untyped/quantum/untyped/core/spec.cljc @@ -132,13 +132,16 @@ #?(:clj (quantum.untyped.core.vars/defmalias every clojure.spec.alpha/every cljs.spec.alpha/every )) #?(:clj (quantum.untyped.core.vars/defmalias conformer clojure.spec.alpha/conformer cljs.spec.alpha/conformer)) -#?(:clj (quantum.untyped.core.vars/defmalias nonconforming clojure.spec.alpha/nonconforming cljs.spec.alpha/nonconforming)) (defalias s/conform) +(defalias s/nonconforming) +(defalias • nonconforming) (defalias s/explain) (defalias s/explain-data) (defalias s/describe) +(defalias s/nilable) + #?(:clj (quantum.untyped.core.vars/defmalias cat clojure.spec.alpha/cat cljs.spec.alpha/cat)) #?(:clj (defmacro cat* "`or` :`or*` :: `cat` : `cat*`" [& args] `(cat ~@(udata/quote-map-base uconv/>keyword args true)))) @@ -274,6 +277,14 @@ (throw (ex-info "Value is not allowed to be nil but was" {})) x)) +(defn assert-conform [spec x] + (let [conformed (s/conform spec x)] + (if (s/invalid? conformed) + (let [ed (core/merge (assoc (s/explain-data* spec [] [] [] x) + ::s/failure :assertion-failed))] + (throw (ex-info (str "Spec assertion failed\n" (with-out-str (s/explain-out ed))) ed))) + conformed))) + (defn kv "Based on `s/map-spec-impl`" ([k->s #_(s/map-of any? specable?)] (kv k->s nil)) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 1b6b0c38..77e4580f 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -152,11 +152,10 @@ (declare nil?) -(defn >spec +(defns >spec "Coerces ->`x` to a spec, recording its ->`name-sym` if provided." - ([x] (>spec x nil)) - ([x name-sym] - (assert (c/or (c/nil? name-sym) (c/symbol? name-sym))) + ([x _ > (isa? PSpec)] (>spec x nil)) + ([x _, name-sym (s/nilable c/symbol?) > (isa? PSpec)] #?(:clj (cond (satisfies? PSpec x) x ; TODO should add in its name? @@ -191,8 +190,7 @@ ;; ===== DEFINITION ===== ;; -(defn register-spec! [sym spec] - (assert (satisfies? PSpec spec) spec) +(defns register-spec! [sym c/symbol?, spec (isa? PSpec)] (TODO)) #?(:clj @@ -223,12 +221,12 @@ (defns * "Denote on a spec that it must be enforced at runtime. For use with `defnt`." - [spec spec?] (update-meta spec assoc :runtime? true)) + [spec spec? > spec?] (update-meta spec assoc :runtime? true)) (defns ref "Denote on a spec that it must not be expanded to use primitive values. For use with `defnt`." - [spec spec?] (update-meta spec assoc :ref? true)) + [spec spec? > spec?] (update-meta spec assoc :ref? true)) (udt/deftype DeducibleSpec [*spec #_(t/atom-of t/spec?)] {PSpec nil @@ -237,10 +235,10 @@ ?Atom {swap! (([this f] (swap! *spec f))) reset! ([this v] (reset! *spec v))}}) -(defns deducible [x spec?] (DeducibleSpec. (atom x))) - (defns deducible-spec? [x _] (instance? DeducibleSpec x)) +(defns deducible [x spec? > deducible-spec?] (DeducibleSpec. (atom x))) + ;; ===== EXTENSIONALITY COMPARISON IMPLEMENTATIONS ===== ;; #_(is (coll&/incremental-every? (aritoid nil (constantly true) t/in>) @@ -248,6 +246,8 @@ (coll&/incremental-every? (aritoid nil (constantly true) t/in>) [Long Number])) +(def comparisons #{-1 0 1 2 3}) + (defns compare|class|class* "Compare extension (generality|specificity) of ->`c0` to ->`c1`. `0` means they are equally general/specific: @@ -263,7 +263,7 @@ `3` means their generality/specificity is incomparable: - ✓ `(t/<> c0 c1)` : the extension of ->`c0` is disjoint w.r.t. to that of ->`c1`. Unboxed primitives are considered to be less general (more specific) than boxed primitives." - [^Class c0 class? ^Class c1 class?] + [^Class c0 c/class? ^Class c1 c/class? > comparisons] #?(:clj (ifs (== c0 c1) 0 (== c0 Object) 1 (== c1 Object) -1 @@ -296,7 +296,7 @@ Does not compare cardinalities or other relations of sets, but rather only sub/superset relations." - [s0 spec?, s1 spec?] + [s0 spec?, s1 spec? > comparisons] (let [dispatched (-> compare|dispatch (get (type s0)) (get (type s1)))] (if (c/nil? dispatched) (err! (str "Specs not handled: " {:s0 s0 :s1 s1}) {:s0 s0 :s1 s1}) @@ -305,46 +305,46 @@ (defns < "Computes whether the extension of spec ->`s0` is a strict subset of that of ->`s1`." ([s1 spec?] #(< % s1)) - ([s0 spec?, s1 spec?] (let [ret (compare s0 s1)] (c/= ret -1)))) + ([s0 spec?, s1 spec? > c/boolean?] (let [ret (compare s0 s1)] (c/= ret -1)))) (defns <= "Computes whether the extension of spec ->`s0` is a (lax) subset of that of ->`s1`." ([s1 spec?] #(<= % s1)) - ([s0 spec?, s1 spec?] (let [ret (compare s0 s1)] (c/or (c/= ret -1) (c/= ret 0))))) + ([s0 spec?, s1 spec? > c/boolean?] (let [ret (compare s0 s1)] (c/or (c/= ret -1) (c/= ret 0))))) (defns = "Computes whether the extension of spec ->`s0` is equal to that of ->`s1`." ([s1 spec?] #(= % s1)) - ([s0 spec?, s1 spec?] (c/= (compare s0 s1) 0))) + ([s0 spec?, s1 spec? > c/boolean?] (c/= (compare s0 s1) 0))) (defns not= "Computes whether the extension of spec ->`s0` is not equal to that of ->`s1`." ([s1 spec?] #(not= % s1)) - ([s0 spec?, s1 spec?] (c/not (= s0 s1)))) + ([s0 spec?, s1 spec? > c/boolean?] (c/not (= s0 s1)))) (defns >= "Computes whether the extension of spec ->`s0` is a (lax) superset of that of ->`s1`." ([s1 spec?] #(>= % s1)) - ([s0 spec?, s1 spec?] (let [ret (compare s0 s1)] (c/or (c/= ret 1) (c/= ret 0))))) + ([s0 spec?, s1 spec? > c/boolean?] (let [ret (compare s0 s1)] (c/or (c/= ret 1) (c/= ret 0))))) (defns > "Computes whether the extension of spec ->`s0` is a strict superset of that of ->`s1`." ([s1 spec?] #(> % s1)) - ([s0 spec?, s1 spec?] (c/= (compare s0 s1) 1))) + ([s0 spec?, s1 spec? > c/boolean?] (c/= (compare s0 s1) 1))) (defns >< "Computes whether it is the case that the intersect of the extensions of spec ->`s0` and ->`s1` is non-empty, and neither ->`s0` nor ->`s1` share a subset/equality/superset relationship." ([s1 spec?] #(>< % s1)) - ([s0 spec?, s1 spec?] (c/= (compare s0 s1) 2))) + ([s0 spec?, s1 spec? > c/boolean?] (c/= (compare s0 s1) 2))) (defns <> "Computes whether the respective extensions of specs ->`s0` and ->`s1` are disjoint." ([s1 spec?] #(<> % s1)) - ([s0 spec? s1 spec?] (c/= (compare s0 s1) 3))) + ([s0 spec? s1 spec? > c/boolean?] (c/= (compare s0 s1) 3))) -(defn inverse [comparison] +(defns inverse [comparison comparisons > comparisons] (case comparison -1 1 1 -1 @@ -377,7 +377,7 @@ (declare not not-spec? not-spec>inner-spec - and-spec? and-spec>args val|by-class?) -(defn- create-logical-spec|inner [args' s kind comparison-denotes-supersession?] +(defns- create-logical-spec|inner [args' _, s _, kind _, comparison-denotes-supersession? c/boolean?] #_(prl! "") (let [without-superseded-args (->> args' @@ -436,8 +436,9 @@ args' (whenp-> specs conj-s? (conj s'))))))) -(defn- create-logical-spec - [kind #_#{:or :and} construct-fn spec-pred spec>args args #_(fn-> count (> 1)) comparison-denotes-supersession?] +(defns- create-logical-spec + [kind #{:or :and}, construct-fn _, spec-pred _, spec>args _, args (fn-> count (> 1)) + comparison-denotes-supersession? c/boolean?] (if (-> args count (c/= 1)) (first args) (let [;; simplification via inner expansion ; `(| (| a b) c)` -> `(| a b c)` @@ -482,7 +483,7 @@ (c/and (instance? AndSpec that) (c/= args (.-args ^AndSpec that)))))}}) -(defns and-spec? [x _] (instance? AndSpec x)) +(defns and-spec? [x _ > c/boolean?] (instance? AndSpec x)) (defns and-spec>args [x and-spec?] (.-args ^AndSpec x)) @@ -512,7 +513,7 @@ (c/and (instance? OrSpec that) (c/= args (.-args ^OrSpec that)))))}}) -(defns or-spec? [x _] (instance? OrSpec x)) +(defns or-spec? [x _ > c/boolean?] (instance? OrSpec x)) (defns or-spec>args [x or-spec?] (.-args ^OrSpec x)) @@ -538,13 +539,13 @@ (c/and (instance? NotSpec that) (c/= spec (.-spec ^NotSpec that)))))}}) -(defns not-spec? [x _] (instance? NotSpec x)) +(defns not-spec? [x _ > c/boolean?] (instance? NotSpec x)) (defns not-spec>inner-spec [spec not-spec?] (.-spec ^NotSpec spec)) (declare nil? val?) -(defns not [spec spec?] +(defns not [spec spec? > spec?] (ifs (= spec universal-set) empty-set (= spec empty-set) universal-set (= spec val|by-class?) nil? @@ -563,7 +564,7 @@ If `s0` < `s1`, `∅` If `s0` <> `s1`, `s0` If `s0` > | >< `s1`, `s0` with all elements of `s1` removed" - [s0 spec?, s1 spec?] + [s0 spec?, s1 spec? > spec?] #_(prl! s0 s1) (let [c (compare s0 s1)] (case c @@ -611,7 +612,7 @@ fipp.ednize/IEdn {-edn ([this] (list `fn name lookup))}}) -(defns fn-spec? [x _] (instance? FnSpec x)) +(defns fn-spec? [x _ > c/boolean?] (instance? FnSpec x)) (defns fn|args>out-spec "Returns nil if args do not match any input spec" @@ -656,12 +657,12 @@ A map is not an unkeyed collection." [x] (TODO)) -(defn ? +(defns ? "Denotes type inference should be performed. Arity 1: Computes a spec denoting a nilable value satisfying `spec`. Arity 2: Computes whether `x` is nil or satisfies `spec`." - ([x] (or nil? (>spec x))) - ([spec x] (c/or (c/nil? x) (spec x)))) + ([x _ > spec?] (or nil? (>spec x))) + ([spec spec?, x _ > c/boolean?] (c/or (c/nil? x) (spec x)))) ;; This sadly gets a java.lang.AbstractMethodError when one tries to do as simple as: ;; `(def ? (InferSpec. nil))` @@ -676,7 +677,7 @@ fipp.ednize/IEdn {-edn ([this] `?)}}) -(defns infer? [x _] (instance? InferSpec x)) +(defns infer? [x _ > c/boolean?] (instance? InferSpec x)) ;; ===== Comparison ===== ;; @@ -700,7 +701,7 @@ (def- compare|universal+empty fn>) -(defns- compare|universal+not [s0 spec?, s1 spec?] +(defns- compare|universal+not [s0 spec?, s1 spec? > comparisons] (let [s1|inner (not-spec>inner-spec s1)] (ifs (= s1|inner universal-set) 1 (= s1|inner empty-set) 0 @@ -716,7 +717,7 @@ ;; ----- EmptySet ----- ;; -(defns- compare|empty+not [s0 spec?, s1 spec?] +(defns- compare|empty+not [s0 spec?, s1 spec? > comparisons] (let [s1|inner (not-spec>inner-spec s1)] (if (= s1|inner universal-set) 0 @@ -732,7 +733,7 @@ ;; ----- NotSpec ----- ;; -(defns- compare|not+not [s0 spec?, s1 spec?] +(defns- compare|not+not [s0 spec?, s1 spec? > comparisons] (let [c (compare (not-spec>inner-spec s0) (not-spec>inner-spec s1))] (case c 0 0 @@ -741,17 +742,17 @@ 2 2 3 2))) -(defns- compare|not+or [s0 spec?, s1 spec?] +(defns- compare|not+or [s0 spec?, s1 spec? > comparisons] (compare (not-spec>inner-spec s0) (>logical-complement s1))) -(defns- compare|not+and [s0 spec?, s1 spec?] +(defns- compare|not+and [s0 spec?, s1 spec? > comparisons] (compare (not-spec>inner-spec s0) (>logical-complement s1))) -(defns- compare|not+protocol [s0 spec?, s1 spec?] +(defns- compare|not+protocol [s0 spec?, s1 spec? > comparisons] (let [s0|inner (not-spec>inner-spec s0)] (if (= s0|inner empty-set) 1 3))) -(defns- compare|not+class [s0 spec?, s1 spec?] +(defns- compare|not+class [s0 spec?, s1 spec? > comparisons] (let [s0|inner (not-spec>inner-spec s0)] (if (= s0|inner empty-set) 1 @@ -760,7 +761,7 @@ (-1 2) 2 3 1)))) -(defns- compare|not+value [s0 spec?, s1 spec?] +(defns- compare|not+value [s0 spec?, s1 spec? > comparisons] (let [s0|inner (not-spec>inner-spec s0)] (if (= s0|inner empty-set) 1 @@ -772,7 +773,7 @@ ;; ----- OrSpec ----- ;; ;; TODO performance can be improved here by doing fewer comparisons -(defns- compare|or+or [^OrSpec s0 or-spec?, ^OrSpec s1 or-spec?] +(defns- compare|or+or [^OrSpec s0 or-spec?, ^OrSpec s1 or-spec? > comparisons] (let [l (->> s0 .-args (seq-and (fn1 < s1))) r (->> s1 .-args (seq-and (fn1 < s0)))] (if l @@ -783,12 +784,12 @@ 3 2))))) -(defns- compare|or+and [^OrSpec s0 or-spec?, ^OrSpec s1 or-spec?] +(defns- compare|or+and [^OrSpec s0 or-spec?, ^OrSpec s1 or-spec? > comparisons] (let [r (->> s1 .-args (seq-and (fn1 < s0)))] (if r 1 3))) ;; TODO transition to `compare|or+class` when stable -(defn- compare|class+or [s0 ^OrSpec s1] +(defns- compare|class+or [s0 class-spec?, ^OrSpec s1 or-spec? > comparisons] (let [specs (.-args s1)] (first (reduce @@ -809,7 +810,7 @@ specs)))) ;; TODO transition to `compare|or+value` when stable -(defn- compare|value+or [s0 ^OrSpec s1] +(defns- compare|value+or [s0 class-spec?, ^OrSpec s1 or-spec? > comparisons] (let [specs (.-args s1)] (reduce (fn [ret s] @@ -826,10 +827,10 @@ ;; ----- AndSpec ----- ;; -(defn- compare|and+and [^AndSpec s0 ^AndSpec s1] +(defns- compare|and+and [^AndSpec s0 and-spec?, ^AndSpec s1 and-spec? > comparisons] (TODO)) -(defn- compare|class+and [s0 ^AndSpec s1] +(defns- compare|class+and [s0 class-spec?, ^AndSpec s1 and-spec? > comparisons] (let [specs (.-args s1)] (first (reduce @@ -853,7 +854,7 @@ [3 ubit/empty] specs)))) -(defn- compare|value+and [s0 ^AndSpec s1] +(defns- compare|value+and [s0 value-spec?, ^AndSpec s1 and-spec? > comparisons] (let [specs (.-args s1)] (reduce (fn [ret s] @@ -868,28 +869,28 @@ ;; ----- Expression ----- ;; -(defn- compare|expr+expr [s0 s1] (if (c/= s0 s1) 0 3)) +(defns- compare|expr+expr [s0 _, s1 _ > comparisons] (if (c/= s0 s1) 0 3)) (def- compare|expr+value fn<>) ;; ----- ProtocolSpec ----- ;; ;; TODO transition to `compare|protocol+value` when stable -(defn- compare|value+protocol [s0 s1] +(defns- compare|value+protocol [s0 value-spec?, s1 protocol-spec? > comparisons] (let [v (value-spec>value s0) p (protocol-spec>protocol s1)] (if (satisfies? p v) -1 3))) ;; ----- ClassSpec ----- ;; -(defn- compare|class+value [s0 s1] +(defns- compare|class+value [s0 class-spec?, s1 value-spec? > comparisons] (let [c (class-spec>class s0) v (value-spec>value s1)] (if (instance? c v) 1 3))) ;; ----- ValueSpec ----- ;; -(defn- compare|value+value +(defns- compare|value+value "What we'd really like is to have a different version of .equals or .equiv like .equivBehavior in which it returns whether any behavior is different whatsoever between two objects. For instance, `[52]` behaves differently from @@ -902,7 +903,7 @@ reluctantly accept whatever `=` tells us as well as the fallout that results. Thus, `(t/or (t/value []) (t/value (list)))` will result in `(t/value [])`, which is not ideal but both feasible and better than the alternative." - [s0 s1] + [s0 value-spec?, s1 value-spec? > comparisons] (if (c/= (value-spec>value s0) (value-spec>value s1)) 0 @@ -1043,7 +1044,7 @@ #?(:clj (def primitive-classes (->> unboxed-symbol->type-meta vals (uc/map+ :unboxed) (join #{})))) -(defns- -spec>classes [spec spec?, classes set? > set?] +(defns- -spec>classes [spec spec?, classes c/set? > (s/set-of (s/nilable c/class?))] (cond (class-spec? spec) (conj classes (class-spec>class spec)) (value-spec? spec) @@ -1065,17 +1066,17 @@ (defns spec>classes "Outputs the set of all the classes ->`spec` can embody according to its various conditional branches, if any. Ignores nils, treating in Clojure simply as a `java.lang.Object`." - [spec spec? > set?] (-spec>classes spec #{})) + [spec spec? > (s/set-of (s/nilable c/class?))] (-spec>classes spec #{})) #?(:clj -(defn- -spec>?class-value [spec spec-nilable?] +(defns- -spec>?class-value [spec spec?, spec-nilable? c/boolean?] (if (value-spec? spec) (let [v (value-spec>value spec)] (when (c/class? v) {:class v :nilable? spec-nilable?})) nil))) #?(:clj -(defn spec>?class-value +(defns spec>?class-value "Outputs the single class value embodied by ->`spec`. If a spec is extensionally equal the *value* of a class, outputs that class. @@ -1083,7 +1084,7 @@ an extensional subset of the set of all objects conforming to a class, outputs nil." {:examples `{(spec>?class-value (value String)) {:class String :nilable? false} (spec>?class-value (isa? String)) nil}} - [spec] (-spec>?class-value spec false))) + [spec spec?] (-spec>?class-value spec false))) ;; ---------------------- ;; ;; ===== Predicates ===== ;; @@ -1091,9 +1092,10 @@ (def basic-type-syms '[boolean byte char short int long float double ref]) -#?(:clj (defns- >v-sym [prefix symbol?, kind symbol?] (symbol (str prefix "|" kind "?")))) +#?(:clj (defns- >v-sym [prefix c/symbol?, kind c/symbol? > c/symbol?] + (symbol (str prefix "|" kind "?")))) -#?(:clj (defns- >kv-sym [prefix symbol?, from-type symbol?, to-type symbol?] +#?(:clj (defns- >kv-sym [prefix c/symbol?, from-type c/symbol?, to-type c/symbol? > c/symbol?] (symbol (str prefix "|" from-type "->" to-type "?")))) #?(:clj (defmacro- def-preds|map|same-types [prefix #_symbol?] @@ -1273,7 +1275,7 @@ ;; dense integer values), not extensible #?(:clj -(defns >array-nd-type [kind symbol?, n (s/and integer? pos?) > class-spec?] +(defns >array-nd-type [kind c/symbol?, n utpred/pos-int? > class-spec?] (let [prefix (apply str (repeat n \[)) letter (case kind boolean "Z" @@ -1288,7 +1290,7 @@ (isa? (Class/forName (str prefix letter)))))) #?(:clj -(defn >array-nd-types [n] +(defns >array-nd-types [n utpred/pos-int? > spec?] (->> '[boolean byte char short int long float double object] (map #(>array-nd-type % n)) (apply or)))) diff --git a/src-untyped/quantum/untyped/core/type/predicates.cljc b/src-untyped/quantum/untyped/core/type/predicates.cljc index 851547a3..dde8395e 100644 --- a/src-untyped/quantum/untyped/core/type/predicates.cljc +++ b/src-untyped/quantum/untyped/core/type/predicates.cljc @@ -7,11 +7,11 @@ [clojure.core :as core] #?(:clj [clojure.future :as fcore]) - #_[quantum.untyped.core.core :as ucore] + [quantum.untyped.core.core :as ucore] [quantum.untyped.core.vars - :refer [defalias]])) + :refer [defalias defaliases]])) -#_(ucore/log-this-ns) +(ucore/log-this-ns) ;; The reason we use `resolve` and `eval` here is that currently we need to prefer built-in impls ;; where possible in order to leverage their generators @@ -84,13 +84,7 @@ #?(:clj (defn namespace? [x] (instance? clojure.lang.Namespace x))) -(defn metable? [x] - #?(:clj (instance? clojure.lang.IMeta x) - :cljs (satisfies? cljs.core/IMeta x))) - -(defn with-metable? [x] - #?(:clj (instance? clojure.lang.IObj x) - :cljs (satisfies? cljs.core/IWithMeta x))) +(defaliases ucore metable? with-metable?) (defn derefable? [x] #?(:clj (instance? clojure.lang.IDeref x) From 0f021c146ae7ff7a51d79e5bde57163ae483a907 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 11 May 2018 15:06:47 -0600 Subject: [PATCH 032/810] `defns` across quantum.core.defnt --- src-dev/quantum/core/defnt.cljc | 55 +++++++++++----------- src-untyped/quantum/untyped/core/type.cljc | 6 +-- test/quantum/test/core/untyped/type.cljc | 36 +++++++------- 3 files changed, 50 insertions(+), 47 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 230cdb2d..78d6fd4c 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -42,7 +42,7 @@ [quantum.untyped.core.data.map :as map] [quantum.untyped.core.data.set :as set] [quantum.untyped.core.defnt - :refer [defns fns]] + :refer [defns defns- fns]] [quantum.untyped.core.form :as uform] [quantum.untyped.core.form.evaluate :as ufeval] [quantum.untyped.core.form.generate :as ufgen @@ -101,38 +101,35 @@ ; TODO associative sequence over top of a vector (so it'll display like a seq but behave like a vec) -(do - #?(:clj (defns class>simplest-class "This ensures that special overloads are not created for non-primitive subclasses of java.lang.Object (e.g. String, etc.)." - [c class?] + [c t/class? > t/class?] (if (t/primitive-class? c) c (or (tcore/boxed->unboxed c) java.lang.Object)))) #?(:clj -(defns class>most-primitive-class - [c class?, nilable? boolean?] +(defns class>most-primitive-class [c t/class?, nilable? t/boolean? > t/class?] (if nilable? c (or (tcore/boxed->unboxed c) c)))) #?(:clj -(defns spec>most-primitive-classes [spec t/spec? > (s/set-of (? class?))] +(defns spec>most-primitive-classes [spec t/spec? > (s/set-of (? t/class?))] (let [cs (t/spec>classes spec) nilable? (contains? cs nil)] (->> cs (c/map+ #(class>most-primitive-class % nilable?)) (join #{}))))) #?(:clj -(defns spec>most-primitive-class [spec t/spec? > (? class?)] +(defns spec>most-primitive-class [spec t/spec? > (? t/class?)] (let [cs (spec>most-primitive-classes spec)] (if (-> cs count (not= 1)) (err! "Not exactly 1 class found" (kw-map spec cs)) (first cs))))) #?(:clj -(defns out-spec>class [spec t/spec? > (? class?)] +(defns out-spec>class [spec t/spec? > (? t/class?)] (let [cs (t/spec>classes spec) cs' (disj cs nil)] (if (-> cs' count (not= 1)) ;; NOTE: we don't need to vary the output class if there are multiple output possibilities or just nil @@ -160,7 +157,7 @@ #?(:clj (defns method? [x _] (instance? Method x))) #?(:clj -(defns class->methods [^Class c class? > map?] +(defns class->methods [^Class c t/class? > t/map?] (->> (.getMethods c) (remove+ (fn [^java.lang.reflect.Method x] (java.lang.reflect.Modifier/isPrivate (.getModifiers x)))) (map+ (fn [^java.lang.reflect.Method x] (Method. (.getName x) (.getReturnType x) (.getParameterTypes x) @@ -180,7 +177,7 @@ fipp.ednize/IOverride fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "F") (into (array-map) this)))) -(defns class->fields [^Class c class? > map?] +(defns class->fields [^Class c t/class? > t/map?] (->> (.getFields c) (remove+ (fn [^java.lang.reflect.Field x] (java.lang.reflect.Modifier/isPrivate (.getModifiers x)))) (map+ (fn [^java.lang.reflect.Field x] @@ -442,10 +439,10 @@ :field field-form :spec (-> field :type t/>spec)})) -(defn classes>class +(defns classes>class "Ensure that given a set of classes, that set consists of at most a class C and nil. If so, returns C. Otherwise, throws." - [cs #_(set-of class?)] + [cs (s/set-of t/class?) > t/class?] (let [cs' (disj cs nil)] (if (-> cs' count (= 1)) (first cs') @@ -480,7 +477,7 @@ method-or-field args-forms)))))) ;; TODO move this -(defn truthy-expr? [{:as expr :keys [spec]}] +(defns truthy-expr? [{:as expr :keys [spec _]} _ > t/boolean?] (ifs (or (t/= spec t/nil?) (t/= spec t/false?)) false (or (t/> spec t/nil?) @@ -712,8 +709,8 @@ tdef/double 8})) #?(:clj -(defn arg-specs>arg-classes-seq|primitivized - [arg-specs #_(t/seq-of t/spec?)] #_> #_(t/seq-of (t/vec-of t/class?)) +(defns arg-specs>arg-classes-seq|primitivized + [arg-specs (s/seq-of t/spec?) > (s/seq-of (s/vec-of t/class?))] (->> arg-specs (c/lmap (fn [spec] (if (-> spec meta :ref?) @@ -824,7 +821,7 @@ (def fnt-method-sym 'invoke) -(defn- class>interface-part-name [c] +(defns- class>interface-part-name [c t/class? > t/string?] (if (= c java.lang.Object) "Object" (let [illegal-pattern #"\|\+"] @@ -845,8 +842,10 @@ `(~'definterface ~interface-sym (~hinted-method-sym ~hinted-args)))) #?(:clj -(defn fnt|overload>reify-overload #_> #_(seq-of ::reify|overload) - [{:as overload #_:fnt/overload :keys [arg-classes arglist-code|reify|unhinted body-form out-class]}] +(defns fnt|overload>reify-overload + [{:as overload + :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, out-class _]} :fnt/overload + > (s/seq-of ::reify|overload)] (prl! overload) (let [interface-k {:out out-class :in arg-classes} interface @@ -866,7 +865,8 @@ :out-class out-class}))) #?(:clj -(defn fnt|overload-group>reify [{:keys [overload-group #_:fnt/overload-group, i #_integer?, fn|name #_:quantum.core.specs/fn|name]}] +(defns fnt|overload-group>reify + [{:keys [overload-group :fnt/overload-group, i t/integer?, fn|name :quantum.core.specs/fn|name]} _] (let [reify-overloads (->> (concat [(:unprimitivized overload-group)] (:primitivized overload-group)) (c/map fnt|overload>reify-overload))] @@ -881,9 +881,10 @@ (defn >extend-protocol|code [{:keys [protocol|name]}] `(extend-protocol ~protocol|name)) -(defn >defprotocol|code - [{:keys [name #_:protocol/name - overloads #_(t/seqable-of :protocol/overload)]}] ; TODO ensure that overload names do not shadow each other +(defns >defprotocol|code + ;; TODO ensure that overload names do not shadow each other + [{:keys [name :protocol/name + overloads (s/seq-of :protocol/overload)]} _] `(defprotocol ~name ~@(->> overloads (sort-by (fn-> :arglist count)) @@ -975,9 +976,9 @@ nil overloads))) -(defn fnt|overloads>protocols - [{:keys [overloads #_(t/and t/indexed? (t/seq-of :fnt/overload)) - fn|name #_:quantum.core.specs/fn|name]}] +(defns fnt|overloads>protocols + [{:keys [overloads (s/and t/indexed? (s/seq-of :fnt/overload)) + fn|name :quantum.core.specs/fn|name]} _] (when (->> overloads (seq-or (fn-> :positional-args-ct (> 2)))) (TODO "Doesn't yet handle protocol creation for arglist counts of > 2")) (when (->> overloads (seq-or :variadic?)) @@ -1079,5 +1080,3 @@ (defmacro defnt [& args] (fnt|code :defn (ufeval/env-lang) args)) - -) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 77e4580f..0e5b6cdf 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -377,7 +377,7 @@ (declare not not-spec? not-spec>inner-spec - and-spec? and-spec>args val|by-class?) -(defns- create-logical-spec|inner [args' _, s _, kind _, comparison-denotes-supersession? c/boolean?] +(defns- create-logical-spec|inner [args' _, s _, kind _, comparison-denotes-supersession? c/fn?] #_(prl! "") (let [without-superseded-args (->> args' @@ -437,8 +437,8 @@ (whenp-> specs conj-s? (conj s'))))))) (defns- create-logical-spec - [kind #{:or :and}, construct-fn _, spec-pred _, spec>args _, args (fn-> count (> 1)) - comparison-denotes-supersession? c/boolean?] + [kind #{:or :and}, construct-fn _, spec-pred _, spec>args _, args (fn-> count (c/> 1)) + comparison-denotes-supersession? c/fn?] (if (-> args count (c/= 1)) (first args) (let [;; simplification via inner expansion ; `(| (| a b) c)` -> `(| a b c)` diff --git a/test/quantum/test/core/untyped/type.cljc b/test/quantum/test/core/untyped/type.cljc index 8f42bd1c..7cfd0f65 100644 --- a/test/quantum/test/core/untyped/type.cljc +++ b/test/quantum/test/core/untyped/type.cljc @@ -14,8 +14,11 @@ :refer [ifs]] [quantum.untyped.core.numeric :as unum] [quantum.untyped.core.numeric.combinatorics :as ucombo] + [quantum.untyped.core.spec :as s] [quantum.untyped.core.type :as t - :refer [& | !]])) + :refer [& | !]] + [quantum.untyped.core.defnt + :refer [defns]])) (defmacro test-comparisons>comparisons [[_ _ a b]] `[[~@(for [a* (rest a)] @@ -23,21 +26,22 @@ [~@(for [b* (rest b)] `(t/compare ~b* ~a))]]) -(is= -1 (t/compare (t/value 1) t/numerically-byte?)) +;; TODO come back to this +#_(do (is= -1 (t/compare (t/value 1) t/numerically-byte?)) -(is= (& t/long? (>expr (fn1 = 1))) - (t/value 1)) + (is= (& t/long? (>expr (fn1 = 1))) + (t/value 1)) -(is= (& (t/value 1) (>expr unum/integer-value?)) - (t/value 1)) + (is= (& (t/value 1) (>expr unum/integer-value?)) + (t/value 1)) -(t/compare (t/value 1) (>expr unum/integer-value?)) + (t/compare (t/value 1) (>expr unum/integer-value?)) -(is= 0 (t/compare (t/value 1) (>expr (fn1 =|long 1)))) -(is= 0 (t/compare (t/value 1) (>expr (fn [^long x] (= x 1))))) -(is= 0 (t/compare (t/value 1) (>expr (fn [^long x] (== x 1))))) -(is= 0 (t/compare (t/value 1) (>expr (fn [x] (core/== (long x) 1))))) -(is= 0 (t/compare (t/value 1) (>expr (fn [x] (= (long x) 1))))) + (is= 0 (t/compare (t/value 1) (>expr (fn1 =|long 1)))) + (is= 0 (t/compare (t/value 1) (>expr (fn [^long x] (= x 1))))) + (is= 0 (t/compare (t/value 1) (>expr (fn [^long x] (== x 1))))) + (is= 0 (t/compare (t/value 1) (>expr (fn [x] (core/== (long x) 1))))) + (is= 0 (t/compare (t/value 1) (>expr (fn [x] (= (long x) 1)))))) ;; ----- Example interface hierarchy ----- ;; @@ -132,21 +136,21 @@ ;; TESTS ;; -(defn spec>spec-combos +(defns spec>spec-combos "To generate all commutative possibilities for a given spec." - [spec] + [spec t/spec? > (s/seq-of t/spec?)] (ifs (t/and-spec? spec) (->> spec t/and-spec>args ucombo/permutations (map #(t/->AndSpec (vec %) (atom nil)))) (t/or-spec? spec) (->> spec t/or-spec>args ucombo/permutations (map #(t/->OrSpec (vec %) (atom nil)))) [spec])) -(defn test-comparison +(defns test-comparison "Performs a `t/compare` on `a` and `b`, ensuring that their relationship is symmetric, and that the inputs are internally commutative if applicable (e.g. if `a` is an `AndSpec`, ensures that it is commutative). The basis comparison is the first input." - [c a b] + [c t/comparisons a t/spec?, b t/spec?] (doseq ;; Commutativity [a* (spec>spec-combos a) b* (spec>spec-combos b)] From c62cfa8ca134e80caa7f996e48946a6fea683d72 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 11 May 2018 17:26:58 -0600 Subject: [PATCH 033/810] Consolidate some comparison impls; fix some `!` tests --- src-untyped/quantum/untyped/core/type.cljc | 405 ++++++++++----------- test/quantum/test/core/untyped/type.cljc | 170 ++++++--- 2 files changed, 315 insertions(+), 260 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 0e5b6cdf..2e1763c3 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -377,7 +377,45 @@ (declare not not-spec? not-spec>inner-spec - and-spec? and-spec>args val|by-class?) -(defns- create-logical-spec|inner [args' _, s _, kind _, comparison-denotes-supersession? c/fn?] +(defns- create-logical-spec|inner|and + [{:as accum :keys [conj-s? c/boolean?, prefer-orig-args? c/boolean?, s' spec?, specs _]} _ + s* spec?, c* comparisons] + (if ;; Disjointness: the extension of this arg is disjoint w.r.t. that of + ;; at least one other arg + (c/or (c/= c* 3) + ;; Contradiction/empty-set: (& A (! A)) + (if (not-spec? s') + ;; compare not-spec to all others + (= (not-spec>inner-spec s') s*) + ;; compare spec to all not-specs + (c/and (not-spec? s*) (= s' (not-spec>inner-spec s*))))) + (do #_(println "BRANCH 1") + (reduced (assoc accum :conj-s? false :specs [empty-set]))) + (do #_(println "BRANCH 2") + (let [conj-s?' (if ;; `s` must be `><` w.r.t. to all other args if it is to be `conj`ed + (c/not= c* 2) + false + conj-s?) + ;; TODO might similar logic extend to `:or` as well? + ss* (if (not-spec? s') + (let [diff (- s* (not s'))] + (if (and-spec? diff) + ;; preserve inner expansion + (and-spec>args diff) + [diff])) + [s*])] + (assoc accum :conj-s? conj-s?' :specs (into specs ss*)))))) + +(defns- create-logical-spec|inner|or + [{:as accum :keys [specs _]} _, s* spec?, c* comparisons] + (if-not + ;; `s` must be either `><` or `<>` w.r.t. to all other args + (case c* (2 3) true false) + (reduced (assoc accum :prefer-orig-args? true)) + (assoc accum :specs (conj specs s*)))) + +(defns- create-logical-spec|inner + [args' _, s spec?, kind #{:or :and}, comparison-denotes-supersession? c/fn?] #_(prl! "") (let [without-superseded-args (->> args' @@ -393,39 +431,11 @@ (->> without-superseded-args (educe (fn ([accum] accum) - ([{:as accum :keys [conj-s? prefer-orig-args? s' specs]} [s* c*]] + ([accum [s* c*]] #_(prl! kind conj-s? prefer-orig-args? s' specs s* c*) (case kind - :and (if ;; Disjointness: the extension of this arg is disjoint w.r.t. that of - ;; at least one other arg - (c/or (c/= c* 3) - ;; Contradiction/empty-set: (& A (! A)) - (if (not-spec? s') - ;; compare not-spec to all others - (= (not-spec>inner-spec s') s*) - ;; compare spec to all not-specs - (c/and (not-spec? s*) (= s' (not-spec>inner-spec s*))))) - (do (println "BRANCH 1") - (reduced (assoc accum :conj-s? false :specs [empty-set]))) - (do (println "BRANCH 2") - (let [conj-s?' (if ;; `s` must be `><` w.r.t. to all other args if it is to be `conj`ed - (c/not= c* 2) - false - conj-s?) - ;; TODO might similar logic extend to `:or` as well? - ss* (if (not-spec? s') - (let [diff (- s* (not s'))] - (if (and-spec? diff) - ;; preserve inner expansion - (and-spec>args diff) - [diff])) - [s*])] - (assoc accum :conj-s? conj-s?' :specs (into specs ss*))))) - :or (if-not - ;; `s` must be either `><` or `<>` w.r.t. to all other args - (case c* (2 3) true false) - (reduced (assoc accum :prefer-orig-args? true)) - (assoc accum :specs (conj specs s*)))))) + :and (create-logical-spec|inner|and accum s* c*) + :or (create-logical-spec|inner|or accum s* c*)))) {:conj-s? ;; If `s` is a `NotSpec`, and kind is `:and`, then it will be ;; applied by being `-` from all args, not by being `conj`ed (c/not (c/and (c/= kind :and) (not-spec? s))) @@ -437,7 +447,7 @@ (whenp-> specs conj-s? (conj s'))))))) (defns- create-logical-spec - [kind #{:or :and}, construct-fn _, spec-pred _, spec>args _, args (fn-> count (c/> 1)) + [kind #{:or :and}, construct-fn _, spec-pred _, spec>args _, args (fn-> count (c/>= 1)) comparison-denotes-supersession? c/fn?] (if (-> args count (c/= 1)) (first args) @@ -455,7 +465,7 @@ (->> simp|identity+ (educe (fn ([args'] args') - ([args' s] + ([args' s #_spec?] #_(prl! kind args' s) (if (empty? args') (conj args' s) @@ -588,7 +598,7 @@ #_(udt/deftype SequentialSpec) -(defns of +#_(defns of "Creates a spec that ... TODO" [pred (<= iterable?), spec spec?] (TODO)) @@ -623,7 +633,7 @@ (->> spec-or-arity-specs (uc/filter+ #((first %) args)) uc/first second)))) (defns fn-spec - [name- (? symbol?) + [name- (s/nilable c/symbol?) lookup _ #_(t/map-of t/integer? (t/or (spec spec? "output-spec") (t/vec-of (t/tuple (t/vec-of (spec spec? "input-spec")) @@ -632,7 +642,7 @@ (uc/map+ (fn [spec-or-arity-specs] (if (spec? spec-or-arity-specs) spec-or-arity-specs - (->> spec-or-arity-specs (map ))))))] + (->> spec-or-arity-specs (map (TODO)))))))] (FnSpec. name- lookup spec nil))) (deftype FnConstantlySpec @@ -697,6 +707,52 @@ (err! "TODO dispatch" {:s0 s0 :s0|type (type s0) :s1 s1 :s1|type (type s1)})) +;; ----- Multiple ----- ;; + +(defns- compare|atomic+or [s0 spec?, ^OrSpec s1 or-spec? > comparisons] + (let [specs (.-args s1)] + (first + (reduce + (fn [[ret found] s] + (let [ret' (compare s0 s) + found' (-> found (ubit/conj ret') c/long)] + (ifs (c/or (ubit/contains? found' ident) + (ubit/contains? found' <>ident))) + [2 found'] + + [ret' found']))) + [3 ubit/empty] + specs)))) + +(defns- compare|atomic+and [s0 spec?, ^AndSpec s1 and-spec? > comparisons] + (let [specs (.-args s1)] + (first + (reduce + (fn [[ret found] s] + (let [c (compare s0 s)] + (if (c/= c 0) + (reduced [1 nil]) + (let [found' (-> found (ubit/conj c) c/long) + ret' (ifs (ubit/contains? found' > (ubit/conj >ident))) + 3 + 2) + + (ubit/contains? found' <>ident) + (ifs (ubit/contains? found' ident) 1 + c) + + c)] + [ret' found'])))) + [3 ubit/empty] + specs)))) + ;; ----- UniversalSet ----- ;; (def- compare|universal+empty fn>) @@ -742,11 +798,11 @@ 2 2 3 2))) -(defns- compare|not+or [s0 spec?, s1 spec? > comparisons] - (compare (not-spec>inner-spec s0) (>logical-complement s1))) +(defns- compare|not+or [s0 not-spec?, s1 or-spec? > comparisons] + (compare|atomic+or s0 s1)) -(defns- compare|not+and [s0 spec?, s1 spec? > comparisons] - (compare (not-spec>inner-spec s0) (>logical-complement s1))) +(defns- compare|not+and [s0 not-spec?, s1 and-spec? > comparisons] + (compare|atomic+and s0 s1)) (defns- compare|not+protocol [s0 spec?, s1 spec? > comparisons] (let [s0|inner (not-spec>inner-spec s0)] @@ -784,46 +840,17 @@ 3 2))))) -(defns- compare|or+and [^OrSpec s0 or-spec?, ^OrSpec s1 or-spec? > comparisons] +(defns- compare|or+and [^OrSpec s0 or-spec?, ^AndSpec s1 and-spec? > comparisons] (let [r (->> s1 .-args (seq-and (fn1 < s0)))] (if r 1 3))) ;; TODO transition to `compare|or+class` when stable (defns- compare|class+or [s0 class-spec?, ^OrSpec s1 or-spec? > comparisons] - (let [specs (.-args s1)] - (first - (reduce - (fn [[ret found] s] - (let [ret' (compare s0 s) - found' (-> found (ubit/conj ret') c/long)] - (ifs (c/or (ubit/contains? found' ident) - (ubit/contains? found' <>ident))) - [2 found'] - - [ret' found']))) - [3 ubit/empty] - specs)))) + (compare|atomic+or s0 s1)) ;; TODO transition to `compare|or+value` when stable -(defns- compare|value+or [s0 class-spec?, ^OrSpec s1 or-spec? > comparisons] - (let [specs (.-args s1)] - (reduce - (fn [ret s] - (let [ret' (compare s0 s)] ; `1` will never happen - (when (c/= ret' 2) (TODO)) - (if (c/or (c/= ret' -1) - (c/and (c/= ret' 3) (c/= ret 0)) - (c/and (c/= ret' 0) (c/= ret 3))) - ;; because the extension of `s1` only gets bigger - (reduced -1) - ret))) - 3 - specs))) +(defns- compare|value+or [s0 value-spec?, ^OrSpec s1 or-spec? > comparisons] + (compare|atomic+or s0 s1)) ;; ----- AndSpec ----- ;; @@ -831,39 +858,10 @@ (TODO)) (defns- compare|class+and [s0 class-spec?, ^AndSpec s1 and-spec? > comparisons] - (let [specs (.-args s1)] - (first - (reduce - (fn [[ret found] s] - (let [c (compare s0 s)] - (if (c/= c 0) - (reduced [1 nil]) - (let [found' (-> found (ubit/conj c) c/long) - ret' (ifs (ubit/contains? found' > (ubit/conj >ident))) - 3 - 2) - - (ubit/contains? found' <>ident) - (ifs (ubit/contains? found' ident) 1 - c) - - c)] - [ret' found'])))) - [3 ubit/empty] - specs)))) + (compare|atomic+and s0 s1)) (defns- compare|value+and [s0 value-spec?, ^AndSpec s1 and-spec? > comparisons] - (let [specs (.-args s1)] - (reduce - (fn [ret s] - (let [ret' (compare s0 s)] - (if (c/= ret' 3) - (reduced 3) - ret'))) - 3 - specs))) + (compare|atomic+and s0 s1)) ;; ----- InferSpec ----- ;; @@ -911,123 +909,124 @@ ;; ----- Dispatch ----- ;; +;; TODO take away var indirection once done (def- compare|dispatch (let [inverted (fn [f] (fn [s0 s1] (inverse (f s1 s0))))] {UniversalSetSpec - {UniversalSetSpec fn= - EmptySetSpec compare|universal+empty - NotSpec compare|universal+not - OrSpec compare|universal+or - AndSpec compare|universal+and - InferSpec compare|universal+infer - Expression compare|universal+expr - ProtocolSpec compare|universal+protocol - ClassSpec compare|universal+class - ValueSpec compare|universal+value} + {UniversalSetSpec #'fn= + EmptySetSpec #'compare|universal+empty + NotSpec #'compare|universal+not + OrSpec #'compare|universal+or + AndSpec #'compare|universal+and + InferSpec #'compare|universal+infer + Expression #'compare|universal+expr + ProtocolSpec #'compare|universal+protocol + ClassSpec #'compare|universal+class + ValueSpec #'compare|universal+value} EmptySetSpec - {UniversalSetSpec (inverted compare|universal+empty) - EmptySetSpec fn= - NotSpec compare|empty+not - OrSpec compare|empty+or - AndSpec compare|empty+and - InferSpec compare|empty+infer - Expression compare|empty+expr - ProtocolSpec compare|empty+protocol - ClassSpec compare|empty+class - ValueSpec compare|empty+value} + {UniversalSetSpec (inverted #'compare|universal+empty) + EmptySetSpec #'fn= + NotSpec #'compare|empty+not + OrSpec #'compare|empty+or + AndSpec #'compare|empty+and + InferSpec #'compare|empty+infer + Expression #'compare|empty+expr + ProtocolSpec #'compare|empty+protocol + ClassSpec #'compare|empty+class + ValueSpec #'compare|empty+value} NotSpec - {UniversalSetSpec (inverted compare|universal+not) - EmptySetSpec (inverted compare|empty+not) - NotSpec compare|not+not - OrSpec compare|not+or - AndSpec compare|not+and - InferSpec compare|todo - Expression fn<> - ProtocolSpec compare|not+protocol - ClassSpec compare|not+class - ValueSpec compare|not+value} + {UniversalSetSpec (inverted #'compare|universal+not) + EmptySetSpec (inverted #'compare|empty+not) + NotSpec #'compare|not+not + OrSpec #'compare|not+or + AndSpec #'compare|not+and + InferSpec #'compare|todo + Expression #'fn<> + ProtocolSpec #'compare|not+protocol + ClassSpec #'compare|not+class + ValueSpec #'compare|not+value} OrSpec - {UniversalSetSpec (inverted compare|universal+or) - EmptySetSpec (inverted compare|empty+or) - NotSpec (inverted compare|not+or) - OrSpec compare|or+or - AndSpec compare|or+and - InferSpec compare|todo - Expression fn<> - ProtocolSpec compare|todo - ClassSpec (inverted compare|class+or) - ValueSpec (inverted compare|value+or)} + {UniversalSetSpec (inverted #'compare|universal+or) + EmptySetSpec (inverted #'compare|empty+or) + NotSpec (inverted #'compare|not+or) + OrSpec #'compare|or+or + AndSpec #'compare|or+and + InferSpec #'compare|todo + Expression #'fn<> + ProtocolSpec #'compare|todo + ClassSpec (inverted #'compare|class+or) + ValueSpec (inverted #'compare|value+or)} AndSpec - {UniversalSetSpec (inverted compare|universal+and) - EmptySetSpec (inverted compare|empty+and) - NotSpec compare|todo - OrSpec (inverted compare|or+and) - AndSpec compare|and+and - InferSpec compare|todo - Expression fn<> - ProtocolSpec compare|todo - ClassSpec (inverted compare|class+and) - ValueSpec (inverted compare|value+and)} + {UniversalSetSpec (inverted #'compare|universal+and) + EmptySetSpec (inverted #'compare|empty+and) + NotSpec #'compare|todo + OrSpec (inverted #'compare|or+and) + AndSpec #'compare|and+and + InferSpec #'compare|todo + Expression #'fn<> + ProtocolSpec #'compare|todo + ClassSpec (inverted #'compare|class+and) + ValueSpec (inverted #'compare|value+and)} ;; TODO review this InferSpec - {UniversalSetSpec (inverted compare|universal+infer) - EmptySetSpec (inverted compare|empty+infer) - NotSpec compare|todo #_fn> - OrSpec compare|todo #_fn> - AndSpec compare|todo #_fn> - InferSpec compare|todo #_fn= - Expression compare|todo #_fn> - ProtocolSpec compare|todo #_fn> - ClassSpec compare|todo #_fn> - ValueSpec compare|todo #_fn>} + {UniversalSetSpec (inverted #'compare|universal+infer) + EmptySetSpec (inverted #'compare|empty+infer) + NotSpec #'compare|todo #_fn> + OrSpec #'compare|todo #_fn> + AndSpec #'compare|todo #_fn> + InferSpec #'compare|todo #_fn= + Expression #'compare|todo #_fn> + ProtocolSpec #'compare|todo #_fn> + ClassSpec #'compare|todo #_fn> + ValueSpec #'compare|todo #_fn>} ;; TODO review this Expression - {UniversalSetSpec (inverted compare|universal+expr) - EmptySetSpec (inverted compare|empty+expr) - NotSpec compare|todo - OrSpec compare|todo - AndSpec compare|todo - InferSpec compare|todo - Expression compare|expr+expr - ProtocolSpec compare|todo - ClassSpec fn<> ; TODO not entirely true - ValueSpec compare|expr+value} + {UniversalSetSpec (inverted #'compare|universal+expr) + EmptySetSpec (inverted #'compare|empty+expr) + NotSpec #'compare|todo + OrSpec #'compare|todo + AndSpec #'compare|todo + InferSpec #'compare|todo + Expression #'compare|expr+expr + ProtocolSpec #'compare|todo + ClassSpec #'fn<> ; TODO not entirely true + ValueSpec #'compare|expr+value} ProtocolSpec - {UniversalSetSpec (inverted compare|universal+protocol) - EmptySetSpec (inverted compare|empty+protocol) - NotSpec (inverted compare|not+protocol) - OrSpec compare|todo - AndSpec compare|todo - InferSpec fn< - Expression fn<> + {UniversalSetSpec (inverted #'compare|universal+protocol) + EmptySetSpec (inverted #'compare|empty+protocol) + NotSpec (inverted #'compare|not+protocol) + OrSpec #'compare|todo + AndSpec #'compare|todo + InferSpec #'fn< + Expression #'fn<> ProtocolSpec (fn [s0 s1] (if (identical? (protocol-spec>protocol s0) (protocol-spec>protocol s1)) 0 3)) - ClassSpec compare|todo - ValueSpec (inverted compare|value+protocol)} + ClassSpec #'compare|todo + ValueSpec (inverted #'compare|value+protocol)} ClassSpec - {UniversalSetSpec (inverted compare|universal+class) - EmptySetSpec (inverted compare|empty+class) - NotSpec (inverted compare|not+class) - OrSpec compare|class+or - AndSpec compare|class+and - InferSpec compare|todo - Expression fn<> - ProtocolSpec compare|todo + {UniversalSetSpec (inverted #'compare|universal+class) + EmptySetSpec (inverted #'compare|empty+class) + NotSpec (inverted #'compare|not+class) + OrSpec #'compare|class+or + AndSpec #'compare|class+and + InferSpec #'compare|todo + Expression #'fn<> + ProtocolSpec #'compare|todo ClassSpec (fn [s0 s1] (compare|class|class* (class-spec>class s0) (class-spec>class s1))) - ValueSpec compare|class+value} + ValueSpec #'compare|class+value} ValueSpec - {UniversalSetSpec (inverted compare|universal+value) - EmptySetSpec (inverted compare|empty+value) - NotSpec (inverted compare|not+value) - OrSpec compare|value+or - AndSpec compare|value+and - InferSpec compare|todo - Expression (inverted compare|expr+value) - ProtocolSpec compare|value+protocol - ClassSpec (inverted compare|class+value) - ValueSpec compare|value+value}})) + {UniversalSetSpec (inverted #'compare|universal+value) + EmptySetSpec (inverted #'compare|empty+value) + NotSpec (inverted #'compare|not+value) + OrSpec #'compare|value+or + AndSpec #'compare|value+and + InferSpec #'compare|todo + Expression (inverted #'compare|expr+value) + ProtocolSpec #'compare|value+protocol + ClassSpec (inverted #'compare|class+value) + ValueSpec #'compare|value+value}})) #?(:clj (def boxed-class->unboxed-symbol diff --git a/test/quantum/test/core/untyped/type.cljc b/test/quantum/test/core/untyped/type.cljc index 7cfd0f65..ececde77 100644 --- a/test/quantum/test/core/untyped/type.cljc +++ b/test/quantum/test/core/untyped/type.cljc @@ -20,6 +20,8 @@ [quantum.untyped.core.defnt :refer [defns]])) +;; Here, `NotSpec` labels on `testing` mean such *after* simplification + (defmacro test-comparisons>comparisons [[_ _ a b]] `[[~@(for [a* (rest a)] `(t/compare ~a* ~b))] @@ -145,18 +147,20 @@ (map #(t/->OrSpec (vec %) (atom nil)))) [spec])) -(defns test-comparison +#?(:clj +(defmacro test-comparison "Performs a `t/compare` on `a` and `b`, ensuring that their relationship is symmetric, and that the inputs are internally commutative if applicable (e.g. if `a` is an `AndSpec`, ensures that it is commutative). The basis comparison is the first input." - [c t/comparisons a t/spec?, b t/spec?] - (doseq ;; Commutativity - [a* (spec>spec-combos a) - b* (spec>spec-combos b)] - ;; Symmetry - (is= c (t/compare a* b*)) - (is= (t/inverse c) (t/compare b* a*)))) + [c #_t/comparisons a #_t/spec? b #_t/spec?] + `(let [c# ~c] + (doseq ;; Commutativity + [a*# (spec>spec-combos ~a) + b*# (spec>spec-combos ~b)] + ;; Symmetry + (is= c# (t/compare a*# b*#)) + (is= (t/inverse c#) (t/compare b*# a*#)))))) (def comparison-combinations ["#{<}" @@ -198,8 +202,7 @@ (testing "+ NullSetSpec" (test-comparison 1 t/universal-set t/empty-set)) (testing "+ NotSpec" - (test-comparison -1 (! t/universal-set) t/universal-set) ; inner = - (test-comparison 0 (! t/empty-set) t/universal-set)) ; inner < + (test-comparison 1 t/universal-set (! a))) (testing "+ OrSpec" (test-comparison 1 t/universal-set (| ><0 ><1))) (testing "+ AndSpec") @@ -246,15 +249,64 @@ (test-comparison -1 (! a) (! }" - (test-comparison 2 (! a) (| a b)) ; TODO fix impl - (test-comparison 2 (! b) (| a b)) ; TODO fix impl - (test-comparison 2 (! ><0) (| ><0 ><1)) ; TODO fix impl - (test-comparison 2 (! ><1) (| ><0 ><1))) ; TODO fix impl - (testing "inner #{= ><}" - (test-comparison 2 (! i|a) (| i|a i|b)))) ; TODO fix impl - (testing "+ AndSpec" + (testing "#{<}" + ;; TODO Technically something like this but can't do the below b/c of simplification + #_(test-comparison ? (! a) (| (| (! a) }") ; Impossible for `OrSpec` + #_(testing "#{< = > ><}") ; Impossible for `OrSpec` + #_(testing "#{< = > >< <>}") ; Impossible for `OrSpec` + #_(testing "#{< = > <>}") ; Impossible for `OrSpec` + #_(testing "#{< = ><}") ; Impossible for `OrSpec` + #_(testing "#{< = >< <>}") ; Impossible for `OrSpec` + #_(testing "#{< = <>}") ; Impossible for `OrSpec` + #_(testing "#{< >}") ; Impossible for `OrSpec` + #_(testing "#{< > ><}") ; Impossible for `OrSpec` + #_(testing "#{< > >< <>}") ; Impossible for `OrSpec` + #_(testing "#{< > <>}") ; Impossible for `OrSpec` + (testing "#{< ><}" + #_(test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1)) + #_(test-comparison -1 i|>a0 (| i|>a+b i|>a0))) + (testing "#{< >< <>}" + #_(test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1 t/string?))) + (testing "#{< <>}" + #_(test-comparison -1 a (| >a ><0 ><1))) + #_(testing "#{=}") ; Impossible for `OrSpec` + #_(testing "#{= >}") ; Impossible for `OrSpec` + #_(testing "#{= > ><}") ; Impossible for `OrSpec` + #_(testing "#{= > >< <>}") ; Impossible for `OrSpec` + #_(testing "#{= > <>}") ; Impossible for `OrSpec` + (testing "#{= ><}" + (test-comparison -1 (! a) (| (! a) i|><0 i|><1)) + (test-comparison -1 (! i|a) (| (! i|a) i|><0 i|><1))) + (testing "#{= >< <>}" + #_(test-comparison -1 i|a (| i|a i|><0 i|><1 t/string?))) + (testing "#{= <>}" + (test-comparison -1 (! a) (| (! a) }" + #_(test-comparison 1 a (| ><}" + #_(test-comparison 2 i|a (| i|<0 i|><1))) + (testing "#{> >< <>}" + #_(test-comparison 2 i|a (| i|<0 i|><1 t/string?))) + (testing "#{> <>}" + (test-comparison 2 (! a) (| b a)) + (test-comparison 2 (! b) (| a b)) + (test-comparison 2 (! ><0) (| ><0 ><1)) + (test-comparison 2 (! ><1) (| ><1 ><0))) + (testing "#{><}" + #_(test-comparison 2 i|a (| i|><0 i|><1))) + (testing "#{>< <>}" + #_(test-comparison 2 i|a (| i|><0 i|><1 t/string?))) + (testing "#{<>}" + (test-comparison 3 (! a) (| }" (test-comparison ... (! a) (& a (! b))))) (testing "+ InferSpec") @@ -375,9 +427,9 @@ (test-comparison 2 (| i|a i|><0) (| i|><1 i|><2))) (testing "#{<>}, #{<>}" ;; comparisons: <> <> <> <> - (test-comparison 3 (| a b) (| ><0 ><1)))) + (test-comparison 3 (| a b) (| ><0 ><1))))) ;; TODO fix tests/impl - (testing "+ AndSpec" + #_(testing "+ AndSpec" ;; Comparison annotations achieved by first comparing each element of the first/left ;; to the entire second/right, then comparing each element of the second/right to the ;; entire first/left @@ -484,7 +536,7 @@ (testing "> nilabled: #{> <>}" (test-comparison 2 t/object? (t/? t/long?))) (testing ">< nilabled: #{>< <>}" - (test-comparison 2 t/java-iterable? (t/? t/comparable?))) + (test-comparison 2 t/iterable? (t/? t/comparable?))) (testing "<> nilabled: #{<>}" (test-comparison 3 t/long? (t/? t/string?))))) (testing "+ ValueSpec" @@ -516,11 +568,12 @@ (testing "+ ClassSpec" (testing "#{<}" (testing "Boxed Primitive" - (test-comparison -1 t/byte? (& t/number? t/comparable?))) + (test-comparison -1 t/byte? (& t/number? t/comparable?))) (testing "Final Concrete" - (test-comparison -1 t/string? (& t/char-seq? t/comparable?))) - (testing "Extensible Concrete" - (test-comparison -1 t/array-list? (& t/java-iterable? (t/isa? java.util.RandomAccess)))) + (test-comparison -1 t/string? (& t/char-seq? t/comparable?))) + ;; TODO fix + #_(testing "Extensible Concrete" + (test-comparison -1 t/!array-list? (& t/iterable? (t/isa? java.util.RandomAccess)))) (testing "Abstract" (test-comparison -1 (t/isa? java.util.AbstractMap$SimpleEntry) (& (t/isa? java.util.Map$Entry) (t/isa? java.io.Serializable)))) (testing "Interface" @@ -540,42 +593,45 @@ #_(testing "#{< > >< <>}") ; Impossible for `AndSpec` #_(testing "#{< > <>}") ; Impossible for `AndSpec` (testing "#{< ><}" - (test-comparison 2 i|a (& i|>a+b i|>a0 i|>a1 i|><0 i|><1))) + (test-comparison 2 i|a (& i|>a+b i|>a0 i|>a1 i|><0 i|><1))) (testing "#{< >< <>}" - (test-comparison 2 t/java-set? (& t/java-coll? t/char-seq? (t/isa? java.nio.ByteBuffer)))) + (test-comparison 2 t/java-set? (& t/java-coll? t/char-seq? (t/isa? java.nio.ByteBuffer)))) (testing "#{< <>}" - (test-comparison 3 t/string? (& t/char-seq? t/java-set?)) - (test-comparison 3 ><0 (& (! ><1) (! ><0)))) + (test-comparison 3 t/string? (& t/char-seq? t/java-set?)) + (test-comparison 3 ><0 (& (! ><1) (! ><0))) + (test-comparison 3 a (& (! a) (! b)))) #_(testing "#{=}") ; Impossible for `AndSpec` #_(testing "#{= >}") ; Impossible for `AndSpec` #_(testing "#{= > ><}") ; Impossible for `AndSpec` #_(testing "#{= > >< <>}") ; Impossible for `AndSpec` #_(testing "#{= > <>}") ; Impossible for `AndSpec` (testing "#{= ><}" - (test-comparison 1 i|a (& i|a i|><0 i|><1)) - (test-comparison 1 t/char-seq? (& t/char-seq? t/java-set?)) - (test-comparison 1 t/char-seq? (& t/char-seq? t/java-set? t/array-list?))) + (test-comparison 1 i|a (& i|a i|><0 i|><1)) + (test-comparison 1 t/char-seq? (& t/char-seq? t/java-set?)) + (test-comparison 1 t/char-seq? (& t/char-seq? t/java-set? t/!array-list?))) (testing "#{= >< <>}") ; <- TODO comparison should be 1 - (testing "#{= <>}" - (test-comparison 1 t/array-list? (& t/array-list? t/java-set?))) + ;; TODO fix + #_(testing "#{= <>}" + (test-comparison 1 t/!array-list? (& t/!array-list? t/java-set?))) (testing "#{>}" - (test-comparison 1 i|a (& i| ><}" - (test-comparison 2 i|a (& i|<0 i|><1)) - (test-comparison 2 t/array-list? (& (t/isa? javax.management.AttributeList) t/java-set?)) - (test-comparison 2 t/comparable? (& (t/isa? java.nio.ByteBuffer) t/java-set?))) + (test-comparison 2 i|a (& i|<0 i|><1)) + ;; TODO fix + #_(test-comparison 2 t/!array-list? (& (t/isa? javax.management.AttributeList) t/java-set?)) + (test-comparison 2 t/comparable? (& (t/isa? java.nio.ByteBuffer) t/java-set?))) (testing "#{> >< <>}" - (test-comparison 2 i|a (& i|<0 t/array-list?))) + (test-comparison 2 i|a (& i|<0 t/!array-list?))) (testing "#{> <>}") ; <- TODO comparison should be 1 (testing "#{><}" - (test-comparison 2 i|a (& i|><0 i|><1)) - (test-comparison 2 t/char-seq? (& t/java-set? t/array-list?))) + (test-comparison 2 i|a (& i|><0 i|><1)) + (test-comparison 2 t/char-seq? (& t/java-set? t/!array-list?))) (testing "#{>< <>}") ; <- TODO comparison should be 3 (testing "#{<>}" - (test-comparison 3 t/string? (& t/array-list? t/java-set?)))) + (test-comparison 3 t/string? (& t/!array-list? t/java-set?)))) (testing "+ ValueSpec" (testing "#{<}" - (test-comparison -1 (t/value "a") (& t/char-seq? t/comparable?))) + (test-comparison -1 (t/value "a") (& t/char-seq? t/comparable?))) #_(testing "#{< =}") ; not possible for `AndSpec` #_(testing "#{< = >}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` #_(testing "#{< = > ><}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` @@ -591,7 +647,7 @@ #_(testing "#{< ><}") ; `><` not possible for `ValueSpec` #_(testing "#{< >< <>}") ; `><` not possible for `ValueSpec` (testing "#{< <>}" - (test-comparison 3 (t/value "a") (& t/char-seq? t/array-list?)) + (test-comparison 3 (t/value "a") (& t/char-seq? t/!array-list?)) (test-comparison 3 (t/value "a") (& t/char-seq? t/java-set?))) #_(testing "#{=}") ; not possible for `AndSpec` #_(testing "#{= >}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` @@ -608,7 +664,7 @@ #_(testing "#{><}") ; `><` not possible for `ValueSpec` #_(testing "#{>< <>}") ; `><` not possible for `ValueSpec` (testing "#{<>}" - (test-comparison 3 (t/value "a") (& t/array-list? t/java-set?))))) + (test-comparison 3 (t/value "a") (& t/!array-list? t/java-set?))))) (testing "InferSpec" (testing "+ InferSpec") (testing "+ Expression") @@ -666,7 +722,7 @@ (testing "< , >" (test-comparison -1 t/string? t/object?)) (testing "<>" - (test-comparison 3 t/string? t/array-list?))) + (test-comparison 3 t/string? t/!array-list?))) (testing "Final Concrete + Abstract") (testing "Final Concrete + Interface" (testing "< , >" @@ -676,18 +732,18 @@ (testing "Extensible Concrete + Extensible Concrete" (test-comparison 0 t/object? t/object?) (testing "< , >" - (test-comparison -1 t/array-list? t/object?)) + (test-comparison -1 t/!array-list? t/object?)) (testing "<>" - (test-comparison 3 t/array-list? t/thread?))) + (test-comparison 3 t/!array-list? t/thread?))) (testing "Extensible Concrete + Abstract" (testing "< , >" (test-comparison -1 (t/isa? java.util.AbstractCollection) t/object?) - (test-comparison -1 t/array-list? (t/isa? java.util.AbstractCollection))) + (test-comparison -1 t/!array-list? (t/isa? java.util.AbstractCollection))) (testing "<>" (test-comparison 3 t/thread? (t/isa? java.util.AbstractCollection)) (test-comparison 3 (t/isa? java.util.AbstractCollection) t/thread?))) (testing "Extensible Concrete + Interface" - (test-comparison 2 t/array-list? t/char-seq?)) + (test-comparison 2 t/!array-list? t/char-seq?)) (testing "Abstract + Abstract" (test-comparison 0 (t/isa? java.util.AbstractCollection) (t/isa? java.util.AbstractCollection)) (testing "< , >" @@ -701,7 +757,7 @@ (test-comparison 2 (t/isa? java.util.AbstractCollection) t/comparable?))) (testing "Interface + Interface" (testing "< , >" - (test-comparison -1 t/java-coll? t/java-iterable?)) + (test-comparison -1 t/java-coll? t/iterable?)) (testing "><" (test-comparison 2 t/char-seq? t/comparable?)))) (testing "+ ValueSpec" @@ -793,7 +849,7 @@ (is= (| (| a b) (| ><0 ><1)) (| a b ><0 ><1))) ;; TODO fix impl - (testing "via `not`" + #_(testing "via `not`" (is= (| a (! a)) t/universal-set) (is= (| a b (! a)) @@ -907,18 +963,18 @@ (is= (& a b (! a)) t/empty-set) ;; TODO fix impl - (is= (& (| a b) (! a)) + #_(is= (& (| a b) (! a)) b) ;; TODO fix impl - (is= (& (! a) (| a b)) + #_(is= (& (! a) (| a b)) b) ;; TODO fix impl - (is= (& (| a b) (! b) (| b a)) + #_(is= (& (| a b) (! b) (| b a)) b) (is= (& (| a b) (! b) (| ><0 b)) t/empty-set)) ;; TODO fix impl - (is= (& t/primitive? (! t/boolean?)) + #_(is= (& t/primitive? (! t/boolean?)) (| t/byte? t/char? t/short? t/int? t/long? t/float? t/double?))) (testing "#{<+ =} -> #{=}" (is= (& i|>a+b i|>a0 i|a) @@ -938,7 +994,7 @@ (deftest test|= ;; TODO fix impl - (test-comparison 0 + #_(test-comparison 0 (| t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) (& (| t/boolean? t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) (! t/boolean?))) From 392191290718f4812ee76406c36df6ad54c88f1d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 11 May 2018 17:32:17 -0600 Subject: [PATCH 034/810] Temp --- resources-dev/temp-defnt-fixes.clj | 94 ++++++++++++++++++++++++++++++ 1 file changed, 94 insertions(+) create mode 100644 resources-dev/temp-defnt-fixes.clj diff --git a/resources-dev/temp-defnt-fixes.clj b/resources-dev/temp-defnt-fixes.clj new file mode 100644 index 00000000..7bcb6c0c --- /dev/null +++ b/resources-dev/temp-defnt-fixes.clj @@ -0,0 +1,94 @@ +(def i|>a+b (t/isa? i.>a+b)) +(def i|>a0 (t/isa? i.>a0)) +(def i|>a1 (t/isa? i.>a1)) +(def i|>b0 (t/isa? i.>b0)) +(def i|>b1 (t/isa? i.>b1)) +(def i|a (t/isa? i.a)) +(def i|b (t/isa? i.b)) +(def i|<0 (t/isa? i.><0)) +(def i|><1 (t/isa? i.><1)) +(def i|><2 (t/isa? i.><2)) + +;; ----- Hierarchy within existing non-interfaces ----- ;; + +(def >a+b (t/isa? java.util.AbstractCollection)) +(def >a (t/isa? java.util.AbstractList)) +(def >b (t/isa? java.util.AbstractSet)) +(def a (t/isa? java.util.ArrayList)) +(def b (t/isa? java.util.HashSet)) +(def <0 t/byte?) +(def ><1 t/short?) +(def ><2 t/long?) + + +;; ===== TO FIX ===== + +- (testing "AndSpec + ClassSpec • #{<} • Extensible Concrete" + (test-comparison -1 t/!array-list? (& t/iterable? (t/isa? java.util.RandomAccess)))) +- (testing "AndSpec + ClassSpec • #{= <>}" + (test-comparison 1 t/!array-list? (& t/!array-list? t/java-set?))) +- (testing "AndSpec + ClassSpec • #{> ><}" + (test-comparison 2 t/!array-list? (& (t/isa? javax.management.AttributeList) t/java-set?))) +- AndSpec + ClassSpec • "#{= <>}" : + (test-comparison 2 t/!array-list? (& (t/isa? javax.management.AttributeList) t/java-set?)) +- test|or : + (testing "via `not`" + (is= (| a (! a)) + t/universal-set) + (is= (| a b (! a)) + t/universal-set) + (is= (| a b (| (! a) (! b))) + t/universal-set)) +- test|or : and + not + or + (is= (& (| a b) (! a)) + b) + ;; TODO fix impl + (is= (& (! a) (| a b)) + b) + ;; TODO fix impl + (is= (& (| a b) (! b) (| b a)) + b) +- (test-comparison 0 + (| t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) + (& (| t/boolean? t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) + (! t/boolean?))) + +TO IMPLEMENT +- (test-comparison ... (! a) (& a (! b))) +- (testing "AndSpec + ClassSpec • #{= >< <>}") ; <- TODO comparison should be 1 +- (testing "AndSpec + ClassSpec • #{> <>}") ; <- TODO comparison should be 1 +- (testing "AndSpec + ClassSpec • #{>< <>}") ; <- TODO comparison should be 3 + + +(time (clojure.test/test-ns 'quantum.test.core.untyped.type)) +668ms -> 3835ms after instrumenting (5.74 times less performant! :/) + + +"#{> <>}" +(test-comparison 2 (! a) (| b a)) FAIL +(t/compare (! a) (| b a)) -> 3 FAIL +(t/compare (! a) b) -> 1 +(t/compare (! a) a) -> 3 + +"#{> <>}" +(test-comparison 2 a (| <0 ><1)) PASS +(t/compare a (| <0 ><1)) -> 2 PASS +(@#'t/compare|value-or-not+or a ) +(t/compare a 1 +(t/compare a ><0) -> 3 +(t/compare a ><1) -> 3 + + +(load-file "./test/quantum/test/core/untyped/type.cljc") +(do (require '[orchestra.spec.test :as st]) + (orchestra.spec.test/instrument)) +(clojure.test/test-ns 'quantum.test.core.untyped.type) From e53dfe8fa7b27446079f8b0049e2f08c309798a2 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 14 May 2018 17:47:38 -0600 Subject: [PATCH 035/810] Made a ton of fixes to spec comparison logic --- resources-dev/temp-defnt-fixes.clj | 79 +------ src-dev/quantum/core/defnt.cljc | 168 ++++++++------- src-dev/quantum/core/defnt_equivalences.cljc | 15 +- .../quantum/untyped/core/data/bits.cljc | 3 +- src-untyped/quantum/untyped/core/type.cljc | 202 +++++++++--------- test/quantum/test/core/untyped/type.cljc | 129 ++++++----- 6 files changed, 271 insertions(+), 325 deletions(-) diff --git a/resources-dev/temp-defnt-fixes.clj b/resources-dev/temp-defnt-fixes.clj index 7bcb6c0c..06f7ff3e 100644 --- a/resources-dev/temp-defnt-fixes.clj +++ b/resources-dev/temp-defnt-fixes.clj @@ -1,66 +1,8 @@ -(def i|>a+b (t/isa? i.>a+b)) -(def i|>a0 (t/isa? i.>a0)) -(def i|>a1 (t/isa? i.>a1)) -(def i|>b0 (t/isa? i.>b0)) -(def i|>b1 (t/isa? i.>b1)) -(def i|a (t/isa? i.a)) -(def i|b (t/isa? i.b)) -(def i|<0 (t/isa? i.><0)) -(def i|><1 (t/isa? i.><1)) -(def i|><2 (t/isa? i.><2)) - -;; ----- Hierarchy within existing non-interfaces ----- ;; - -(def >a+b (t/isa? java.util.AbstractCollection)) -(def >a (t/isa? java.util.AbstractList)) -(def >b (t/isa? java.util.AbstractSet)) -(def a (t/isa? java.util.ArrayList)) -(def b (t/isa? java.util.HashSet)) -(def <0 t/byte?) -(def ><1 t/short?) -(def ><2 t/long?) - - ;; ===== TO FIX ===== -- (testing "AndSpec + ClassSpec • #{<} • Extensible Concrete" - (test-comparison -1 t/!array-list? (& t/iterable? (t/isa? java.util.RandomAccess)))) -- (testing "AndSpec + ClassSpec • #{= <>}" - (test-comparison 1 t/!array-list? (& t/!array-list? t/java-set?))) -- (testing "AndSpec + ClassSpec • #{> ><}" - (test-comparison 2 t/!array-list? (& (t/isa? javax.management.AttributeList) t/java-set?))) -- AndSpec + ClassSpec • "#{= <>}" : - (test-comparison 2 t/!array-list? (& (t/isa? javax.management.AttributeList) t/java-set?)) -- test|or : - (testing "via `not`" - (is= (| a (! a)) - t/universal-set) - (is= (| a b (! a)) - t/universal-set) - (is= (| a b (| (! a) (! b))) - t/universal-set)) - test|or : and + not + or - (is= (& (| a b) (! a)) - b) - ;; TODO fix impl (is= (& (! a) (| a b)) b) - ;; TODO fix impl - (is= (& (| a b) (! b) (| b a)) - b) -- (test-comparison 0 - (| t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) - (& (| t/boolean? t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) - (! t/boolean?))) TO IMPLEMENT - (test-comparison ... (! a) (& a (! b))) @@ -71,22 +13,11 @@ TO IMPLEMENT (time (clojure.test/test-ns 'quantum.test.core.untyped.type)) 668ms -> 3835ms after instrumenting (5.74 times less performant! :/) - - -"#{> <>}" -(test-comparison 2 (! a) (| b a)) FAIL -(t/compare (! a) (| b a)) -> 3 FAIL -(t/compare (! a) b) -> 1 -(t/compare (! a) a) -> 3 - -"#{> <>}" -(test-comparison 2 a (| <0 ><1)) PASS -(t/compare a (| <0 ><1)) -> 2 PASS -(@#'t/compare|value-or-not+or a ) -(t/compare a 1 -(t/compare a ><0) -> 3 -(t/compare a ><1) -> 3 - +Also certain things take *much* longer: + - (= (| t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) + (& (| t/boolean? t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) + (! t/boolean?))) + - 170ms vs 5.5ms — 30 times less performant!! (load-file "./test/quantum/test/core/untyped/type.cljc") (do (require '[orchestra.spec.test :as st]) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 78d6fd4c..c62c4832 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -105,13 +105,13 @@ (defns class>simplest-class "This ensures that special overloads are not created for non-primitive subclasses of java.lang.Object (e.g. String, etc.)." - [c t/class? > t/class?] + [c (? t/class?) > (? t/class?)] (if (t/primitive-class? c) c (or (tcore/boxed->unboxed c) java.lang.Object)))) #?(:clj -(defns class>most-primitive-class [c t/class?, nilable? t/boolean? > t/class?] +(defns class>most-primitive-class [c (? t/class?), nilable? t/boolean? > (? t/class?)] (if nilable? c (or (tcore/boxed->unboxed c) c)))) #?(:clj @@ -227,26 +227,28 @@ ([v] (->WatchableMutable v nil)) ([v watch] (->WatchableMutable v watch))) +(s/def ::env (s/map-of t/symbol? t/any?)) + (declare analyze*) -(defn analyze-non-map-seqable +(defns- analyze-non-map-seqable "Analyzes a non-map seqable." {:params-doc '{merge-types-fn "2-arity fn that merges two types (or sets of types). The first argument is the current deduced type of the overall expression; the second is the deduced type of the current subexpression."}} - [env form empty-form rf] + [env ::env, form _, empty-form _, rf _] (prl! env form empty-form) (->> form (reducei (fn [accum form' i] (rf accum (analyze* (:env accum) form') i)) {:env env :form (transient empty-form)}) (persistent!-and-add-file-context form))) -(defn analyze-map +(defns- analyze-map {:todo #{"If the map is bound to a variable, preserve type info for it such that lookups can start out with a guarantee of a certain type."}} - [env form] + [env ::env, form _] (TODO "analyze-map") #_(->> form (reduce-kv (fn [{env' :env forms :form} form'k form'v] @@ -258,7 +260,7 @@ (->expr-info {:env env :form (transient {})})) (persistent!-and-add-file-context form))) -(defn analyze-seq|do [env form body] +(defns- analyze-seq|do [env ::env, form _, body _] (prl! env body) (if (empty? body) (ast/do {:env env @@ -276,7 +278,7 @@ :body (>vec body) :spec (:spec expr)})))) -(defn analyze-seq|let*|bindings [env bindings] +(defns analyze-seq|let*|bindings [env ::env, bindings _] (TODO "`let*|bindings` analysis") #_(->> bindings (partition-all+ 2) @@ -290,7 +292,7 @@ (->expr-info {:env env :form (transient [])})) (persistent!-and-add-file-context bindings))) -(defn analyze-seq|let* [env [bindings & body]] +(defns analyze-seq|let* [env ::env, [bindings _ & body _] _] (TODO "`let*` analysis") #_(let [{env' :env bindings' :form} (analyze-seq|let*|bindings env bindings) @@ -301,7 +303,7 @@ :type-info type-info'}))) (defns ?resolve-with-env - [sym t/symbol?, env _] + [sym t/symbol?, env ::env] (let [local (c/get env sym)] (if (some? local) (if (ast/unbound? local) @@ -381,11 +383,11 @@ t/double? nil)))) -(defn analyze-seq|dot|method-call +(defns- analyze-seq|dot|method-call "A note will be made of what methods match the argument types. If only one method is found, that is noted too. If no matching method is found, an exception is thrown." - [env form target target-class #_class? static? #_boolean? method-form #_unqualified-symbol? args-forms #_(seq-of form?)] + [env ::env, form _, target _, target-class t/class?, static? t/boolean?, method-form simple-symbol?, args-forms _ #_(seq-of form?)] ;; TODO cache spec by method (if-not-let [methods-for-name (-> target-class class->methods|with-cache (c/get (name method-form)))] (if (empty? args-forms) @@ -430,8 +432,8 @@ #_(s/validate (-> with-ret-spec :args first :spec) #(t/>= % (t/numerically ?cast-spec))))] with-ret-spec)))))) -(defns analyze-seq|dot|field-access - [env _, form _, target _, field-form _ #_t/unqualified-symbol?, field Field] +(defns- analyze-seq|dot|field-access + [env ::env, form _, target _, field-form simple-symbol?, field (t/isa? Field)] (ast/field-access {:env env :form form @@ -449,7 +451,7 @@ (err! "Found more than one class" cs)))) ;; TODO spec these arguments; e.g. check that ?method||field, if present, is an unqualified symbol -(defn analyze-seq|dot [env form [target-form ?method-or-field & ?args]] +(defns- analyze-seq|dot [env ::env, form _, [target-form _, ?method-or-field _ & ?args _] _] {:pre [(prl! env form target-form ?method-or-field ?args)] :post [(prl! %)]} (let [target (analyze* #_?resolve-with-env env target-form) @@ -484,10 +486,10 @@ (t/> spec t/false?)) nil ; representing "unknown" true)) -(defn analyze-seq|if +(defns- analyze-seq|if "If `*conditional-branch-pruning?*` is falsey, the dead branch's original form will be retained, but it will not be type-analyzed." - [env form [pred-form true-form false-form :as body]] + [env ::env, form _, [pred-form _, true-form _, false-form _ :as body] _] {:post [(prl! %)]} (if (-> body count (not= 3)) (err! "`if` accepts exactly 3 arguments: one predicate test and two branches; received" {:body body}) @@ -514,11 +516,11 @@ (assoc :form (list 'if pred-form true-form (:form @false-expr)))))) nil @whole-expr)))) -(defn analyze-seq|quote [env form body] +(defns- analyze-seq|quote [env ::env, form _, body _] {:post [(prl! %)]} (ast/quoted env form (tcore/most-primitive-class-of body))) -(defn analyze-seq|new [env form [c|form #_class? & args :as body]] +(defns- analyze-seq|new [env ::env, form _ [c|form _ #_t/class? & args _ :as body] _] {:pre [(prl! env form body)]} (let [c|analyzed (analyze* env c|form)] (if-not (and (-> c|analyzed :spec t/value-spec?) @@ -532,7 +534,7 @@ :args args|analyzed :spec (t/isa? c)}))))) -(defn analyze-seq|throw [env form [arg :as body]] +(defns- analyze-seq|throw [env ::env, form _ [arg _ :as body] _] {:pre [(prl! env form body)]} (if (-> body count (not= 1)) (err! "Must supply exactly one input to `throw`; supplied" {:body body}) @@ -546,10 +548,10 @@ ;; `t/none?` because nothing is actually returned :spec t/none?}))))) -(defn analyze-seq* +(defns- analyze-seq* "Analyze a seq after it has been macro-expanded. The ->`form` is post- incremental macroexpansion." - [env [caller|form & body :as form]] + [env ::env, [caller|form _ & body _ :as form] _] (ifs (special-symbols caller|form) (case caller|form do (analyze-seq|do env form body) @@ -605,7 +607,7 @@ :args args :spec spec})))))) -(defn analyze-seq [env form] +(defns- analyze-seq [env ::env, form _] {:post [(prl! %)]} (prl! form) (let [expanded-form (macroexpand form)] @@ -613,7 +615,7 @@ (analyze-seq* env expanded-form) (ast/macro-call {:env env :form form :expanded (analyze-seq* env expanded-form)})))) -(defn analyze-symbol [env form] +(defns- analyze-symbol [env _, form t/symbol?] {:post [(prl! %)]} (let [resolved (?resolve-with-env form env)] (if-not resolved @@ -631,7 +633,7 @@ t/any? (TODO "Unsure of what to do in this case" (kw-map env form resolved))))))) -(defn analyze* [env form] +(defns- analyze* [env ::env, form _] (prl! env form) (when (> (swap! *analyze-i inc) 100) (throw (ex-info "Stack too deep" {:form form}))) (ifs (symbol? form) @@ -647,33 +649,33 @@ (analyze-seq env form) (throw (ex-info "Unrecognized form" {:form form})))) -(defn analyze - ([body] (analyze {} body)) - ([env body] +(defns analyze + ([body _] (analyze {} body)) + ([env ::env, body _] (reset! *analyze-i 0) (analyze* env body))) ;; ===== (DE)FNT ===== ;; #_(s/def :fnt|overload/arglist-code (t/vec-of arg?)) -#_(s/def :fnt|overload/args-classes (t/vec-of t/class?)) -(s/def :fnt|overload/positional-args-ct integer?) -(s/def :fnt|overload/variadic? boolean?) #_"Must evaluate to an `s/fspec`" (s/def :fnt|overload/spec :quantum.core.specs/code) #_(s/def :fnt|overload/body-codelist (t/seq-of :quantum.core.specs/code)) -(s/def :fnt/overload - (s/keys :req-un [:fnt|overload/arg-classes ; (t/vector-of t/class?) - :fnt|overload/arg-specs - :fnt|overload/arglist-code|fn|hinted - :fnt|overload/arglist-code|reify|unhinted - :fnt|overload/body-form - :fnt|overload/positional-args-ct - :fnt|overload/out-spec - :fnt|overload/out-class - :fnt|overload/variadic?])) + +;; Internal +(s/def ::fnt|overload + (s/kv {:arg-classes (s/vec-of t/class?) + :arg-specs t/any? + :arglist-code|fn|hinted t/any? + :arglist-code|reify|unhinted t/any? + :body-form t/any? + :positional-args-ct (s/and t/integer? #(>= % 0)) + :out-spec t/spec? + :out-class (? t/class?) + ;; When present, varargs are considered to be of class Object + :variadic? t/boolean?})) (s/def ::reify|overload (s/keys :req-un [:quantum.core.specs/interface @@ -710,13 +712,23 @@ #?(:clj (defns arg-specs>arg-classes-seq|primitivized + "'primitivized' meaning given an arglist whose specs are `[t/any?]` this will output: + [[java.lang.Object] + [boolean] + [byte] + [short] + [char] + [int] + [long] + [float] + [double]] + which includes all primitive subclasses of the spec." [arg-specs (s/seq-of t/spec?) > (s/seq-of (s/vec-of t/class?))] (->> arg-specs - (c/lmap (fn [spec] + (c/lmap (fn [spec #_t/spec?] (if (-> spec meta :ref?) (-> spec t/spec>classes (disj nil) seq) (let [cs (spec>most-primitive-classes spec)] - (let [base-classes (->> cs (c/map+ class>simplest-class) >set) base-classes (cond-> base-classes (contains? cs nil) (conj java.lang.Object))] (->> cs (c/map+ tcore/class>prim-subclasses) @@ -726,13 +738,16 @@ (apply combo/cartesian-product) (c/lmap >vec)))) +(s/def ::lang #{:clj :cljs}) + #?(:clj -(defn- >fnt|overload - [{:keys [arg-bindings arg-classes|pre-analyze arg-specs|pre-analyze|base args - body-codelist|pre-analyze lang post-form varargs varargs-binding]}] +(defns- >fnt|overload + [{:keys [arg-bindings _, arg-classes|pre-analyze _, arg-specs|pre-analyze|base _, args _ + body-codelist|pre-analyze _, lang ::lang, post-form _, varargs _, varargs-binding _]} _ + > ::fnt|overload] (let [arg-specs|pre-analyze (c/mergev-with - (fn [_ spec c #_t/class?] + (fn [_ spec #_t/spec? c #_t/class?] (cond-> spec (t/primitive-class? c) (t/and c))) arg-specs|pre-analyze|base arg-classes|pre-analyze) env (->> (zipmap arg-bindings arg-specs|pre-analyze) @@ -754,10 +769,10 @@ out-spec (if post-spec (if post-spec|runtime? (case (t/compare post-spec (:spec analyzed)) - -1 post-spec - 1 (:spec analyzed) - 0 post-spec - nil (err! "Body and output spec are unrelated" {:body analyzed :output-spec post-spec})) + -1 post-spec + 1 (:spec analyzed) + 0 post-spec + (2 3) (err! "Body and output spec comparison not handled" {:body analyzed :output-spec post-spec})) (if (t/<= (:spec analyzed) post-spec) (:spec analyzed) (err! "Body does not match output spec" {:body analyzed :output-spec post-spec}))) @@ -777,7 +792,6 @@ :positional-args-ct (count args) :out-spec out-spec :out-class (out-spec>class out-spec) - ;; when present, varargs are considered to be of class Object :variadic? (boolean varargs)}))) #?(:clj ; really, reserve for metalanguage @@ -791,20 +805,23 @@ we decide instead to evaluate specs in languages in which the metalanguage (compiler language) is the same as the object language (e.g. Clojure), and symbolically analyze specs in the rest (e.g. vanilla ClojureScript), deferring code analyzed as functions to be enforced at runtime." - [{:as in {:keys [args varargs] pre-form :pre post-form :post} ::fnt|arglist body-codelist|pre-analyze :body} - {:as opts :keys [lang symbolic-analysis?]}] + [{:as in {:keys [args varargs] pre-form :pre post-form :post} :arglist body-codelist|pre-analyze :body} + {:as opts :keys [lang #_::lang symbolic-analysis? #_t/boolean?]}] (if symbolic-analysis? (err! "Symbolic analysis not supported yet") (let [_ (when pre-form (TODO "Need to handle pre")) varargs-binding (when varargs - ;; TODO this validation is purely temporary until destructuring is supported - (s/validate (:arg-binding varargs) simple-symbol?)) - arg-bindings (mapv :arg-binding args) - ;; TODO this validation is purely temporary until destructuring is supported - _ (s/validate arg-bindings (fnl fn-and simple-symbol?)) + ;; TODO this assertion is purely temporary until destructuring is supported + (assert (-> varargs :binding-form first (= :sym)))) + arg-bindings + (->> args + (mapv (fn [{[kind binding-] :binding-form}] + ;; TODO this assertion is purely temporary until destructuring is supported + (assert kind :sym) + binding-))) arg-specs|pre-analyze|base (->> args - (mapv (fn [{[kind spec] ::fnt|arg-spec}] + (mapv (fn [{[kind #_#{:any :infer :spec}, spec #_t/form?] :spec}] (case kind :any t/any? :infer t/? :spec (-> spec eval t/>spec))))) @@ -829,11 +846,11 @@ (err! "Class cannot contain pattern" {:class c :pattern illegal-pattern}) (-> c >name (str/replace "." "|")))))) -(defn fnt-overload>interface-sym [args-classes out-class] +(defns fnt-overload>interface-sym [args-classes (s/seq-of t/class?), out-class t/class? > t/symbol?] (>symbol (str (->> args-classes (lmap class>interface-part-name) (str/join "+")) ">" (class>interface-part-name out-class)))) -(defn fnt-overload>interface [args-classes out-class] +(defns fnt-overload>interface [args-classes _, out-class t/class?] (let [interface-sym (fnt-overload>interface-sym args-classes out-class) hinted-method-sym (ufth/with-type-hint fnt-method-sym (ufth/>interface-method-tag out-class)) hinted-args (ufth/hint-arglist-with @@ -844,7 +861,7 @@ #?(:clj (defns fnt|overload>reify-overload [{:as overload - :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, out-class _]} :fnt/overload + :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, out-class t/class?]} :fnt/overload > (s/seq-of ::reify|overload)] (prl! overload) (let [interface-k {:out out-class :in arg-classes} @@ -868,7 +885,7 @@ (defns fnt|overload-group>reify [{:keys [overload-group :fnt/overload-group, i t/integer?, fn|name :quantum.core.specs/fn|name]} _] (let [reify-overloads (->> (concat [(:unprimitivized overload-group)] - (:primitivized overload-group)) + (:primitivized overload-group)) (c/map fnt|overload>reify-overload))] `(~'def ~(>symbol (str fn|name "|__" i)) (reify ~@(->> reify-overloads @@ -878,7 +895,7 @@ ~arglist-code ~body-form)])) lcat)))))) -(defn >extend-protocol|code [{:keys [protocol|name]}] +(defns >extend-protocol|code [{:keys [protocol|name t/symbol?]} _] `(extend-protocol ~protocol|name)) (defns >defprotocol|code @@ -978,7 +995,10 @@ (defns fnt|overloads>protocols [{:keys [overloads (s/and t/indexed? (s/seq-of :fnt/overload)) - fn|name :quantum.core.specs/fn|name]} _] + fn|name :quantum.core.specs/fn|name]} _ + > (s/kv {:defprotocol t/any? + :extend-protocols t/any? + :defn t/any?})] (when (->> overloads (seq-or (fn-> :positional-args-ct (> 2)))) (TODO "Doesn't yet handle protocol creation for arglist counts of > 2")) (when (->> overloads (seq-or :variadic?)) @@ -1004,13 +1024,13 @@ ;; `String` is final, so they're mutually exclusive clojure.lang.Named (name|gen [x] (.invoke name|gen|__1 x)))) -(defn gen-register-spec +(defns gen-register-spec "Registers in the map of qualified symbol to input spec, to output spec Example output: (swap! ... assoc `abcde (fn [args] (case (count args) 1 )))" - [{:keys [fn|name arg-ct->spec variadic-overload]}] + [{:keys [fn|name :quantum.core.specs/fn|name, arg-ct->spec _, variadic-overload _]} _] (unify-gensyms `(swap! *fn->spec assoc '~(qualify fn|name) (xp/>expr @@ -1021,7 +1041,7 @@ (err! "Arg count not enough for variadic overload"))]))))) true)) -(defn fnt|code [kind lang args] +(defns fnt|code [kind #{:fn :defn}, lang ::lang, args _] (prl! kind lang args) (let [{:keys [:quantum.core.specs/fn|name overloads :quantum.core.specs/meta] :as args'} (s/validate args (case kind :defn ::defnt :fn ::fnt)) @@ -1035,7 +1055,8 @@ fn|name) fnt|overload-groups (->> overloads (mapv #(fnt|overload-data>overload-group % {:lang lang}))) ;; only one variadic arg allowed - _ (s/validate fnt|overload-groups (fn->> (c/lmap :unprimitivized) (c/lfilter :variadic?) count (<- (<= 1)))) + _ (s/validate fnt|overload-groups + (fn->> (c/lmap :unprimitivized) (c/lfilter :variadic?) count (<- (<= 1)))) arg-ct->spec (->> fnt|overload-groups (c/map+ :unprimitivized) (remove+ :variadic?) @@ -1075,8 +1096,5 @@ ~@fn-codelist))] code)) -(defmacro fnt [& args] - (fnt|code :fn (ufeval/env-lang) args)) - -(defmacro defnt [& args] - (fnt|code :defn (ufeval/env-lang) args)) +#?(:clj (defmacro fnt [& args] (fnt|code :fn (ufeval/env-lang) args))) +#?(:clj (defmacro defnt [& args] (fnt|code :defn (ufeval/env-lang) args))) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 2dfa4c1f..86c576cd 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -321,7 +321,7 @@ ;; will error if not all return values can be safely converted to the return spec (macroexpand ' (defnt #_:inline >int* > int - ([x (t/and t/primitive? (t/not t/boolean?)) #_?] (Primitive/uncheckedIntCast x)) + ([x (t/- t/primitive? t/boolean?) #_?] (Primitive/uncheckedIntCast x)) ([x Number] (.intValue x))) ) @@ -331,11 +331,11 @@ `(do #_(swap! fn->spec assoc #'>int*|gen (xp/casef c/count 1 (xp/condpf-> t/<= (xp/get 0) - (s/and primitive? (s/not boolean?)) t/int? - Number t/int?))) + (t/- t/primitive? t/boolean?) t/int? + Number t/int?))) ~@(case (env-lang) - :clj ($ [(def ~'>int*|__0 ; `(s/and primitive? (s/not boolean?))` + :clj ($ [(def ~'>int*|__0 ; `(t/- t/primitive? t/boolean?)` (reify byte>int (~(tag "int" 'invoke) [~'_ ~(tag "byte" 'x)] (Primitive/uncheckedIntCast x)) short>int (~(tag "int" 'invoke) [~'_ ~(tag "short" 'x)] (Primitive/uncheckedIntCast x)) char>int (~(tag "int" 'invoke) [~'_ ~(tag "char" 'x)] (Primitive/uncheckedIntCast x)) @@ -369,14 +369,13 @@ (defnt >long* {:source "clojure.lang.RT.uncheckedLongCast"} > t/long? - ([x (t/or t/byte? t/char? t/short? t/int? t/long? t/float? t/double?)] - (Primitive/uncheckedLongCast x)) + ([x (t/- t/primitive? t/boolean?)] (Primitive/uncheckedLongCast x)) ([x (t/ref (t/isa? Number))] (.longValue x)))) ;; ----- expanded code ----- ;; `(do ~@(case (env-lang) - :clj ($ [(def ~'>long*|__0 ; `(t/or t/byte? t/char? t/short? t/int? t/long? t/float? t/double?)` + :clj ($ [(def ~'>long*|__0 ; `(t/- t/primitive? t/boolean?)` (reify byte>long (~(tag "long" 'invoke) [~'_ ~(tag "byte" 'x)] (~'Primitive/uncheckedLongCast ~'x)) short>long (~(tag "long" 'invoke) [~'_ ~(tag "short" 'x)] (~'Primitive/uncheckedLongCast ~'x)) char>long (~(tag "long" 'invoke) [~'_ ~(tag "char" 'x)] (~'Primitive/uncheckedLongCast ~'x)) @@ -421,7 +420,7 @@ ;; TODO handle recursion #_([x t/ratio?] (>long (.bigIntegerValue x))) ;; TODO handle calling of other `defnt`s - #_([x (t/or t/char? t/byte? t/short? t/int? t/long?)] (>long* x)) + #_([x (t/- t/primitive? t/boolean?)] (>long* x)) ([x t/float?] (clojure.lang.RT/longCast x)) ; Because primitive casting in Clojure is not supported ; TODO fix ([x t/double?] (clojure.lang.RT/longCast x)) ; TODO fix ([x t/boolean?] (if x 1 0)) diff --git a/src-untyped/quantum/untyped/core/data/bits.cljc b/src-untyped/quantum/untyped/core/data/bits.cljc index 2c885464..0a777d72 100644 --- a/src-untyped/quantum/untyped/core/data/bits.cljc +++ b/src-untyped/quantum/untyped/core/data/bits.cljc @@ -24,7 +24,8 @@ (defn conj ([] empty) ([v] (conj empty v)) - ([xs v] (bit-set xs v))) + ([xs v] (bit-set xs v)) + ([xs v0 v1] (-> xs (conj v0) (conj v1)))) (defalias contains? bit-test) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 2e1763c3..04c7c11e 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -281,10 +281,22 @@ 3) :cljs (TODO))) -;; ===== EXTENSIONALITY COMPARISON ===== ;; +;; ===== Comparison ===== ;; (declare compare|dispatch) +(def ^:const ident 1) +(def ^:const >ident 3) + +(def- fn< (ufn/fn' -1)) +(def- fn= (ufn/fn' 0)) +(def- fn> (ufn/fn' 1)) +(def- fn>< (ufn/fn' 2)) +(def- fn<> (ufn/fn' 3)) + (defns compare ;; TODO optimize the `recur`s here as they re-take old code paths "Returns the value of the comparison of the extensions of ->`s0` and ->`s1`. @@ -377,65 +389,64 @@ (declare not not-spec? not-spec>inner-spec - and-spec? and-spec>args val|by-class?) +(defns complementary? [s0 spec? s1 spec?] (= s0 (not s1))) + +(defns- create-logical-spec|inner|or + [{:as accum :keys [s' spec?]} _, s* spec?, c* comparisons] + (if ;; `s` must be either `><` or `<>` w.r.t. to all other args + (case c* (2 3) true false) + (if ;; Tautology/universal-set: (| A (! A)) + (c/and (c/= c* <>ident) ; optimization before `complementary?` + (complementary? s' s*)) + (reduced (assoc accum :conj-s? false :specs [universal-set])) + (update accum :specs conj s*)) + (reduced (assoc accum :prefer-orig-args? true)))) + (defns- create-logical-spec|inner|and [{:as accum :keys [conj-s? c/boolean?, prefer-orig-args? c/boolean?, s' spec?, specs _]} _ s* spec?, c* comparisons] - (if ;; Disjointness: the extension of this arg is disjoint w.r.t. that of - ;; at least one other arg - (c/or (c/= c* 3) - ;; Contradiction/empty-set: (& A (! A)) - (if (not-spec? s') - ;; compare not-spec to all others - (= (not-spec>inner-spec s') s*) - ;; compare spec to all not-specs - (c/and (not-spec? s*) (= s' (not-spec>inner-spec s*))))) - (do #_(println "BRANCH 1") - (reduced (assoc accum :conj-s? false :specs [empty-set]))) - (do #_(println "BRANCH 2") - (let [conj-s?' (if ;; `s` must be `><` w.r.t. to all other args if it is to be `conj`ed - (c/not= c* 2) - false - conj-s?) - ;; TODO might similar logic extend to `:or` as well? - ss* (if (not-spec? s') - (let [diff (- s* (not s'))] - (if (and-spec? diff) - ;; preserve inner expansion - (and-spec>args diff) - [diff])) - [s*])] - (assoc accum :conj-s? conj-s?' :specs (into specs ss*)))))) - -(defns- create-logical-spec|inner|or - [{:as accum :keys [specs _]} _, s* spec?, c* comparisons] - (if-not - ;; `s` must be either `><` or `<>` w.r.t. to all other args - (case c* (2 3) true false) - (reduced (assoc accum :prefer-orig-args? true)) - (assoc accum :specs (conj specs s*)))) + (if ;; Contradiction/empty-set: (& A (! A)) + (c/or (c/= c* <>ident) ; optimization before `complementary?` + (complementary? s' s*)) + (do #_(println "BRANCH 1") + (reduced (assoc accum :conj-s? false :specs [empty-set]))) + (do #_(println "BRANCH 2") + (let [conj-s?' (if ;; `s` must be `><` w.r.t. to all other args if it is to be `conj`ed + (c/not= c* >args diff) + [diff])) + [s*])] + (assoc accum :conj-s? conj-s?' :specs (into specs ss*)))))) (defns- create-logical-spec|inner [args' _, s spec?, kind #{:or :and}, comparison-denotes-supersession? c/fn?] - #_(prl! "") - (let [without-superseded-args + (let [args+comparisons|without-superseded (->> args' (uc/map+ (juxt identity #(compare s %))) ;; remove all args whose extensions are superseded by `s` (uc/remove+ (fn-> second comparison-denotes-supersession?)) join) ; TODO elide `join` - ;_ (prl! without-superseded-args) - s-redundant? (->> without-superseded-args (seq-or (fn-> second (c/= 0))))] - (ifs s-redundant? args' - (empty? without-superseded-args) [s] + s-redundant? (->> args+comparisons|without-superseded (seq-or (fn-> second (c/= =ident))))] + (ifs s-redundant? + args' + (empty? args+comparisons|without-superseded) + [s] (let [{:keys [conj-s? prefer-orig-args? s' specs]} - (->> without-superseded-args + (->> args+comparisons|without-superseded (educe (fn ([accum] accum) ([accum [s* c*]] #_(prl! kind conj-s? prefer-orig-args? s' specs s* c*) (case kind - :and (create-logical-spec|inner|and accum s* c*) - :or (create-logical-spec|inner|or accum s* c*)))) + :or (create-logical-spec|inner|or accum s* c*) + :and (create-logical-spec|inner|and accum s* c*)))) {:conj-s? ;; If `s` is a `NotSpec`, and kind is `:and`, then it will be ;; applied by being `-` from all args, not by being `conj`ed (c/not (c/and (c/= kind :and) (not-spec? s))) @@ -446,31 +457,42 @@ args' (whenp-> specs conj-s? (conj s'))))))) +(defn- simplify-logical-spec|inner-expansion+ + "Simplification via inner expansion: `(| (| a b) c)` -> `(| a b c)`" + [spec-pred spec>args spec-args #_(of reducible? spec?)] + (->> spec-args + (uc/map+ (fn [arg] (if (spec-pred arg) + (spec>args arg) + [arg]))) + uc/cat+)) + +(defn- simplify-logical-spec|structural-identity+ + "Simplification via structural identity: `(| a b a)` -> `(| a b)`" + [spec-args #_(of reducible? spec?)] + (->> spec-args (uc/map+ >spec) uc/distinct+)) + +(defn- simplify-logical-spec|comparison + "Simplification via intension comparison" + [kind comparison-denotes-supersession? spec-args #_(of reducible? spec?)] + (educe + (fn ([spec-args'] spec-args') + ([spec-args' s #_spec?] + (if (empty? spec-args') + (conj spec-args' s) + (create-logical-spec|inner spec-args' s kind comparison-denotes-supersession?)))) + [] + spec-args)) + (defns- create-logical-spec - [kind #{:or :and}, construct-fn _, spec-pred _, spec>args _, args (fn-> count (c/>= 1)) - comparison-denotes-supersession? c/fn?] - (if (-> args count (c/= 1)) - (first args) - (let [;; simplification via inner expansion ; `(| (| a b) c)` -> `(| a b c)` - simp|expansion - (->> args - (uc/map+ (fn [arg] (if (spec-pred arg) - (spec>args arg) - [arg]))) - uc/cat+) - ;; simplification via structural identity ; `(| a b a)` -> `(| a b)` - simp|identity+ (->> simp|expansion (uc/map+ >spec) uc/distinct+) - ;; simplification via intension comparison - simplified - (->> simp|identity+ - (educe - (fn ([args'] args') - ([args' s #_spec?] - #_(prl! kind args' s) - (if (empty? args') - (conj args' s) - (create-logical-spec|inner args' s kind comparison-denotes-supersession?)))) - []))] + [kind #{:or :and}, construct-fn _, spec-pred _, spec>args _, spec-args (fn-> count (c/>= 1)) + comparison-denotes-supersession? c/fn? > spec?] + (if (-> spec-args count (c/= 1)) + (first spec-args) + (let [simplified + (->> spec-args + (simplify-logical-spec|inner-expansion+ spec-pred spec>args) + simplify-logical-spec|structural-identity+ + (simplify-logical-spec|comparison kind comparison-denotes-supersession?))] (assert (-> simplified count (c/>= 1))) ; for internal implementation correctness (if (-> simplified count (c/= 1)) (first simplified) @@ -575,7 +597,6 @@ If `s0` <> `s1`, `s0` If `s0` > | >< `s1`, `s0` with all elements of `s1` removed" [s0 spec?, s1 spec? > spec?] - #_(prl! s0 s1) (let [c (compare s0 s1)] (case c (0 -1) empty-set @@ -691,18 +712,6 @@ ;; ===== Comparison ===== ;; -(def ^:const ident 1) -(def ^:const >ident 3) - -(def- fn< (ufn/fn' -1)) -(def- fn= (ufn/fn' 0)) -(def- fn> (ufn/fn' 1)) -(def- fn>< (ufn/fn' 2)) -(def- fn<> (ufn/fn' 3)) - (defns- compare|todo [s0 spec?, s1 spec?] (err! "TODO dispatch" {:s0 s0 :s0|type (type s0) :s1 s1 :s1|type (type s1)})) @@ -714,8 +723,8 @@ (first (reduce (fn [[ret found] s] - (let [ret' (compare s0 s) - found' (-> found (ubit/conj ret') c/long)] + (let [c (compare s0 s) + found' (-> found (ubit/conj c) c/long)] (ifs (c/or (ubit/contains? found' ident))) [2 found'] - [ret' found']))) + [c found']))) [3 ubit/empty] specs)))) @@ -739,7 +748,7 @@ (reduced [1 nil]) (let [found' (-> found (ubit/conj c) c/long) ret' (ifs (ubit/contains? found' > (ubit/conj >ident))) + (if (c/= found' (ubit/conj >ident)) 3 2) @@ -775,17 +784,15 @@ (defns- compare|empty+not [s0 spec?, s1 spec? > comparisons] (let [s1|inner (not-spec>inner-spec s1)] - (if (= s1|inner universal-set) - 0 - -1))) - -(def- compare|empty+or fn<) -(def- compare|empty+and fn<) -(def- compare|empty+infer compare|todo) -(def- compare|empty+expr compare|todo) -(def- compare|empty+protocol fn<) -(def- compare|empty+class fn<) -(def- compare|empty+value fn<) + (if (= s1|inner universal-set) 0 -1))) + +(def- compare|empty+or fn<) +(def- compare|empty+and fn<) +(def- compare|empty+infer compare|todo) +(def- compare|empty+expr compare|todo) +(def- compare|empty+protocol fn<) +(def- compare|empty+class fn<) +(def- compare|empty+value fn<) ;; ----- NotSpec ----- ;; @@ -844,11 +851,9 @@ (let [r (->> s1 .-args (seq-and (fn1 < s0)))] (if r 1 3))) -;; TODO transition to `compare|or+class` when stable (defns- compare|class+or [s0 class-spec?, ^OrSpec s1 or-spec? > comparisons] (compare|atomic+or s0 s1)) -;; TODO transition to `compare|or+value` when stable (defns- compare|value+or [s0 value-spec?, ^OrSpec s1 or-spec? > comparisons] (compare|atomic+or s0 s1)) @@ -2292,11 +2297,10 @@ (isa? #?(:clj fast_zip.core.ZipperLocation :cljs fast-zip.core/ZipperLocation)) chan?)) -#_(t/def ::form (t/or ::literal t/list? t/vector? ...)) - #?(:clj (-def tagged-literal? (isa? clojure.lang.TaggedLiteral))) (-def literal? (or nil? boolean? symbol? keyword? string? #?(:clj long?) double? #?(:clj tagged-literal?))) + #_(-def form? (or literal? +list? +vector? ...)) ;; ===== Generic ===== ;; diff --git a/test/quantum/test/core/untyped/type.cljc b/test/quantum/test/core/untyped/type.cljc index ececde77..8463b886 100644 --- a/test/quantum/test/core/untyped/type.cljc +++ b/test/quantum/test/core/untyped/type.cljc @@ -249,11 +249,11 @@ (test-comparison -1 (! a) (! }") ; Impossible for `OrSpec` #_(testing "#{< = > ><}") ; Impossible for `OrSpec` @@ -314,39 +314,39 @@ (testing "+ ProtocolSpec") (testing "+ ClassSpec" (test-comparison 3 (! a) a) ; inner = - (test-comparison 3 (! i|a) i|a) ; inner = - (test-comparison 3 (! a) - (test-comparison 3 (! i|a) i| - (test-comparison 2 (! a) >a) ; inner < - (test-comparison 2 (! i|a) i|>a0) ; inner >< - (test-comparison 1 (! a ) ><0) ; inner <> - (test-comparison 2 (! i|a) i|><0) ; inner >< - (test-comparison 2 (! a) Uc) ; inner < - (test-comparison 2 (! i|a) Uc) ; inner < - (test-comparison 2 (! a) ; inner < - (test-comparison 2 (! i|a0) ; inner < - (test-comparison 1 (! <0) ; inner <> - (test-comparison 2 (! i|<0) ; inner >< - (test-comparison 2 (! a) a) ; inner > - (test-comparison 3 (! i|>a0) i|a) ; inner > - (test-comparison 3 (! >a) - (test-comparison 3 (! i|>a0) i| - (test-comparison 1 (! >a) ><0) ; inner <> - (test-comparison 2 (! i|>a0) i|><0) ; inner >< - (test-comparison 2 (! >a) Uc) ; inner < - (test-comparison 2 (! i|>a0) Uc) ; inner < - (test-comparison 1 (! ><0) a) ; inner <> - (test-comparison 2 (! i|><0) i|a) ; inner >< - (test-comparison 1 (! ><0) - (test-comparison 2 (! i|><0) i|< - (test-comparison 1 (! ><0) >a) ; inner <> - (test-comparison 2 (! i|><0) i|>a0) ; inner >< - (test-comparison 2 (! ><0) Uc) ; inner < - (test-comparison 2 (! i|><0) Uc) ; inner < + (test-comparison 3 (! i|a) i|a) ; inner = + (test-comparison 3 (! a) + (test-comparison 3 (! i|a) i| + (test-comparison 2 (! a) >a) ; inner < + (test-comparison 2 (! i|a) i|>a0) ; inner >< + (test-comparison 1 (! a ) ><0) ; inner <> + (test-comparison 2 (! i|a) i|><0) ; inner >< + (test-comparison 2 (! a) Uc) ; inner < + (test-comparison 2 (! i|a) Uc) ; inner < + (test-comparison 2 (! a) ; inner < + (test-comparison 2 (! i|a0) ; inner < + (test-comparison 1 (! <0) ; inner <> + (test-comparison 2 (! i|<0) ; inner >< + (test-comparison 2 (! a) a) ; inner > + (test-comparison 3 (! i|>a0) i|a) ; inner > + (test-comparison 3 (! >a) + (test-comparison 3 (! i|>a0) i| + (test-comparison 1 (! >a) ><0) ; inner <> + (test-comparison 2 (! i|>a0) i|><0) ; inner >< + (test-comparison 2 (! >a) Uc) ; inner < + (test-comparison 2 (! i|>a0) Uc) ; inner < + (test-comparison 1 (! ><0) a) ; inner <> + (test-comparison 2 (! i|><0) i|a) ; inner >< + (test-comparison 1 (! ><0) + (test-comparison 2 (! i|><0) i|< + (test-comparison 1 (! ><0) >a) ; inner <> + (test-comparison 2 (! i|><0) i|>a0) ; inner >< + (test-comparison 2 (! ><0) Uc) ; inner < + (test-comparison 2 (! i|><0) Uc) ; inner < (testing "+ ValueSpec" (test-comparison -1 (t/value 1) (! (t/value 2))) (test-comparison 3 (t/value "") (! t/string?)))) @@ -571,9 +571,8 @@ (test-comparison -1 t/byte? (& t/number? t/comparable?))) (testing "Final Concrete" (test-comparison -1 t/string? (& t/char-seq? t/comparable?))) - ;; TODO fix - #_(testing "Extensible Concrete" - (test-comparison -1 t/!array-list? (& t/iterable? (t/isa? java.util.RandomAccess)))) + (testing "Extensible Concrete" + (test-comparison -1 a (& t/iterable? (t/isa? java.util.RandomAccess)))) (testing "Abstract" (test-comparison -1 (t/isa? java.util.AbstractMap$SimpleEntry) (& (t/isa? java.util.Map$Entry) (t/isa? java.io.Serializable)))) (testing "Interface" @@ -608,27 +607,26 @@ (testing "#{= ><}" (test-comparison 1 i|a (& i|a i|><0 i|><1)) (test-comparison 1 t/char-seq? (& t/char-seq? t/java-set?)) - (test-comparison 1 t/char-seq? (& t/char-seq? t/java-set? t/!array-list?))) + (test-comparison 1 t/char-seq? (& t/char-seq? t/java-set? a))) (testing "#{= >< <>}") ; <- TODO comparison should be 1 ;; TODO fix - #_(testing "#{= <>}" - (test-comparison 1 t/!array-list? (& t/!array-list? t/java-set?))) + (testing "#{= <>}" + (test-comparison 1 a (& a t/java-set?))) (testing "#{>}" (test-comparison 1 i|a (& i| ><}" (test-comparison 2 i|a (& i|<0 i|><1)) - ;; TODO fix - #_(test-comparison 2 t/!array-list? (& (t/isa? javax.management.AttributeList) t/java-set?)) + (test-comparison 2 a (& (t/isa? javax.management.AttributeList) t/java-set?)) (test-comparison 2 t/comparable? (& (t/isa? java.nio.ByteBuffer) t/java-set?))) (testing "#{> >< <>}" - (test-comparison 2 i|a (& i|<0 t/!array-list?))) + (test-comparison 2 i|a (& i|<0 a))) (testing "#{> <>}") ; <- TODO comparison should be 1 (testing "#{><}" (test-comparison 2 i|a (& i|><0 i|><1)) - (test-comparison 2 t/char-seq? (& t/java-set? t/!array-list?))) + (test-comparison 2 t/char-seq? (& t/java-set? a))) (testing "#{>< <>}") ; <- TODO comparison should be 3 (testing "#{<>}" - (test-comparison 3 t/string? (& t/!array-list? t/java-set?)))) + (test-comparison 3 t/string? (& a t/java-set?)))) (testing "+ ValueSpec" (testing "#{<}" (test-comparison -1 (t/value "a") (& t/char-seq? t/comparable?))) @@ -647,7 +645,7 @@ #_(testing "#{< ><}") ; `><` not possible for `ValueSpec` #_(testing "#{< >< <>}") ; `><` not possible for `ValueSpec` (testing "#{< <>}" - (test-comparison 3 (t/value "a") (& t/char-seq? t/!array-list?)) + (test-comparison 3 (t/value "a") (& t/char-seq? a)) (test-comparison 3 (t/value "a") (& t/char-seq? t/java-set?))) #_(testing "#{=}") ; not possible for `AndSpec` #_(testing "#{= >}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` @@ -664,7 +662,7 @@ #_(testing "#{><}") ; `><` not possible for `ValueSpec` #_(testing "#{>< <>}") ; `><` not possible for `ValueSpec` (testing "#{<>}" - (test-comparison 3 (t/value "a") (& t/!array-list? t/java-set?))))) + (test-comparison 3 (t/value "a") (& a t/java-set?))))) (testing "InferSpec" (testing "+ InferSpec") (testing "+ Expression") @@ -722,7 +720,7 @@ (testing "< , >" (test-comparison -1 t/string? t/object?)) (testing "<>" - (test-comparison 3 t/string? t/!array-list?))) + (test-comparison 3 t/string? a))) (testing "Final Concrete + Abstract") (testing "Final Concrete + Interface" (testing "< , >" @@ -732,18 +730,18 @@ (testing "Extensible Concrete + Extensible Concrete" (test-comparison 0 t/object? t/object?) (testing "< , >" - (test-comparison -1 t/!array-list? t/object?)) + (test-comparison -1 a t/object?)) (testing "<>" - (test-comparison 3 t/!array-list? t/thread?))) + (test-comparison 3 a t/thread?))) (testing "Extensible Concrete + Abstract" (testing "< , >" (test-comparison -1 (t/isa? java.util.AbstractCollection) t/object?) - (test-comparison -1 t/!array-list? (t/isa? java.util.AbstractCollection))) + (test-comparison -1 a (t/isa? java.util.AbstractCollection))) (testing "<>" (test-comparison 3 t/thread? (t/isa? java.util.AbstractCollection)) (test-comparison 3 (t/isa? java.util.AbstractCollection) t/thread?))) (testing "Extensible Concrete + Interface" - (test-comparison 2 t/!array-list? t/char-seq?)) + (test-comparison 2 a t/char-seq?)) (testing "Abstract + Abstract" (test-comparison 0 (t/isa? java.util.AbstractCollection) (t/isa? java.util.AbstractCollection)) (testing "< , >" @@ -848,8 +846,7 @@ (| a b ><0 ><1)) (is= (| (| a b) (| ><0 ><1)) (| a b ><0 ><1))) - ;; TODO fix impl - #_(testing "via `not`" + (testing "via `not`" (is= (| a (! a)) t/universal-set) (is= (| a b (! a)) @@ -962,19 +959,16 @@ t/empty-set) (is= (& a b (! a)) t/empty-set) - ;; TODO fix impl - #_(is= (& (| a b) (! a)) + (is= (& (| a b) (! a)) b) - ;; TODO fix impl + ;; TODO fix impls #_(is= (& (! a) (| a b)) b) - ;; TODO fix impl - #_(is= (& (| a b) (! b) (| b a)) - b) + (is= (& (| a b) (! b) (| b a)) + a) (is= (& (| a b) (! b) (| ><0 b)) t/empty-set)) - ;; TODO fix impl - #_(is= (& t/primitive? (! t/boolean?)) + (is= (& t/primitive? (! t/boolean?)) (| t/byte? t/char? t/short? t/int? t/long? t/float? t/double?))) (testing "#{<+ =} -> #{=}" (is= (& i|>a+b i|>a0 i|a) @@ -993,11 +987,10 @@ [i|<0 i|><1])))) (deftest test|= - ;; TODO fix impl - #_(test-comparison 0 - (| t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) - (& (| t/boolean? t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) - (! t/boolean?))) + ;; Takes an inordinately long time to do `test-comparison 0 ...` even without instrumentation + (is= (| t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) + (& (| t/boolean? t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) + (! t/boolean?))) (test-comparison 0 t/any? t/universal-set) (testing "universal class(-set) identity" (is (t/= t/val? (& t/any? t/val?))))) From 9e4cd2044c9aa78ed819befbddc0de36960d1233 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 15 May 2018 23:44:07 -0600 Subject: [PATCH 036/810] Why type inference is a bad idea --- doc/cljc/quantum/core/defnt.md | 53 ++++++++++++++++++++++++++++++++++ 1 file changed, 53 insertions(+) diff --git a/doc/cljc/quantum/core/defnt.md b/doc/cljc/quantum/core/defnt.md index 96601267..19b64894 100644 --- a/doc/cljc/quantum/core/defnt.md +++ b/doc/cljc/quantum/core/defnt.md @@ -228,3 +228,56 @@ Output constraints: Unlike most static languages, a `nil` value is not considered as having a type except that of nil. + +## Why type inference is not a great idea + +Take the below code: + +```clojure +(defnt transduce + ([ f ?, xs ?] (transduce identity f xs)) + ([xf ?, f ?, xs ?] (transduce xf f (f) xs)) + ([xf ?, f ?, init ?, xs ?] + (let [f' (xf f)] (f' (reduce f' init xs))))) +``` + +- For the `f` in the 1-arity overload: + - Inferred from `(transduce identity f xs)` + - The `f` in the 3-arity overload is then inferred: + - We know that `xf` can be called on `f`, so `xf` must be at least a 1-arity `t/callable?` on `f` + - We know that `f'` can be called on `(reduce f' init xs)`, so `xf` must be at least a 1-arity `t/callable?` on `f` + - Other than that we don't really have any information about `f` +- For the `f` in the 2-arity overload: + - We know that `f` can be called with no arguments, so it must be at least a 0-arity `t/callable?` + - We know that it can be passed to `(transduce xf f (f) xs)` + - We tried to infer the `f` in the 3-arity but it can't be known + +It is infeasible to do inferences in the general case for the following reasons: +- The code will be complex and greatly increase time it takes to get any value out of `defnt` +- The code will likely have high computational complexity even if some impressive algorithm comes out of it +- Even if the code could do it instantly, it would still be a maintenance issue to try to mentally work out for each inference what that ends up being. Labels help quite a lot. + +I think the best approach is not inference, but rather being able to at least do: +- Input/output specs that rely on the input/output specs of other spec'ed fns +- Conditional specs + +Thus the code turns into: +*(TODO: conditionally optional arities etc.)* + +```clojure +(t/def rf? "Reducing function" + (t/fn [ {:doc "seed arity"}] + [_ {:doc "completing arity"}] + [_ _ {:doc "reducing arity"}])) + +(t/def xf? "Transforming function" + (t/fn [rf? > rf?])) + +(defnt transduce + ([ f rf?, xs t/reducible?] (transduce identity f xs)) + ([xf xf?, f rf?, xs t/reducible?] (transduce xf f (f) xs)) + ([xf xf?, f rf?, init _ xs t/reducible?] + (let [f' (xf f)] (f' (reduce f' init xs))))) +``` + +which is much, much nicer because it's much better documented, much more clear what each input and output does, and just overall much easier to follow and reason about, without introducing a meaningful increase in code size, and certainly without adding unnecessary information. From e81c6d26054e668a21bd574e21f35df29ed291a1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 15 May 2018 23:44:41 -0600 Subject: [PATCH 037/810] Repeal and replace type inference --- src-dev/quantum/core/defnt.cljc | 20 +- src-dev/quantum/core/defnt_equivalences.cljc | 611 +++++++++---------- src-untyped/quantum/untyped/core/defnt.cljc | 11 +- src-untyped/quantum/untyped/core/type.cljc | 87 +-- 4 files changed, 313 insertions(+), 416 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index c62c4832..acd1772a 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -87,7 +87,6 @@ ;; - When a function with type overloads is referenced outside of a typed context, then the ;; overload resolution will be done via protocol dispatch unless the function's overloads only ;; differ by arity. In either case, runtime type checks are required. -;; - At some later date, the analyzer will do its best to infer types. ;; - Even if the `defnt` is redefined, you won't have interface problems. ;; Any `defnt` argument, if it requires a non-nilable primitive-like value, will be marked as a primitive. @@ -418,14 +417,7 @@ (update call' :args conj arg-node))) with-ret-spec (update with-arg-specs :spec - (fn [ret-spec] - (let [arg-specs (->> with-arg-specs :args (mapv :spec))] - (if (seq-or t/infer? arg-specs) - (err! "TODO arg spec" (kw-map arg-specs ret-spec (ret-spec arg-specs))) - #_(if (t/infer? arg-spec) - (swap! arg-spec t/and (get ret-spec i)) - ((get ret-spec i) arg-spec)) - (ret-spec arg-specs))))) + (fn [ret-spec] (->> with-arg-specs :args (mapv :spec) ret-spec))) ?cast-spec (?cast-call->spec target-class method-form) _ (when ?cast-spec (ppr :warn "Not yet able to statically validate whether primitive cast will succeed at runtime" {:form form}) @@ -764,7 +756,9 @@ lang (c/count args) varargs))) - post-spec (when post-form (-> post-form eval t/>spec)) + post-spec (cond (nil? post-form) nil + (= post-form '_) t/any? + :else (eval post-form)) post-spec|runtime? (-> post-spec meta :runtime?) out-spec (if post-spec (if post-spec|runtime? @@ -805,7 +799,7 @@ we decide instead to evaluate specs in languages in which the metalanguage (compiler language) is the same as the object language (e.g. Clojure), and symbolically analyze specs in the rest (e.g. vanilla ClojureScript), deferring code analyzed as functions to be enforced at runtime." - [{:as in {:keys [args varargs] pre-form :pre post-form :post} :arglist body-codelist|pre-analyze :body} + [{:as in {:keys [args varargs] pre-form :pre [post-type post-form] :post} :arglist body-codelist|pre-analyze :body} {:as opts :keys [lang #_::lang symbolic-analysis? #_t/boolean?]}] (if symbolic-analysis? (err! "Symbolic analysis not supported yet") @@ -821,9 +815,8 @@ binding-))) arg-specs|pre-analyze|base (->> args - (mapv (fn [{[kind #_#{:any :infer :spec}, spec #_t/form?] :spec}] + (mapv (fn [{[kind #_#{:any :spec}, spec #_t/form?] :spec}] (case kind :any t/any? - :infer t/? :spec (-> spec eval t/>spec))))) arg-classes-seq|pre-analyze (arg-specs>arg-classes-seq|primitivized arg-specs|pre-analyze|base) ;; `unprimitivized` is first because of class sorting @@ -863,7 +856,6 @@ [{:as overload :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, out-class t/class?]} :fnt/overload > (s/seq-of ::reify|overload)] - (prl! overload) (let [interface-k {:out out-class :in arg-classes} interface (-> *interfaces diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 86c576cd..a71e8a2e 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -1,7 +1,7 @@ ;; See https://jsperf.com/js-property-access-comparison — all property accesses (at least of length 1) seem to be equal (ns quantum.core.test.defnt-equivalences - (:refer-clojure :exclude [name *]) + (:refer-clojure :exclude [name identity *]) (:require [clojure.core :as c] [quantum.core.defnt @@ -24,14 +24,15 @@ :refer [ifs]] [quantum.untyped.core.type :as t :refer [? *]]) - (:import clojure.lang.Named - clojure.lang.Reduced - clojure.lang.ISeq - clojure.lang.ASeq - clojure.lang.LazySeq - clojure.lang.Seqable - quantum.core.data.Array - quantum.core.Primitive)) + (:import + clojure.lang.Named + clojure.lang.Reduced + clojure.lang.ISeq + clojure.lang.ASeq + clojure.lang.LazySeq + clojure.lang.Seqable + quantum.core.data.Array + quantum.core.Primitive)) ;; =====|=====|=====|=====|===== ;; @@ -40,21 +41,20 @@ ;; ----- implementation ----- ;; (macroexpand ' - (defnt pid > (? t/string?) [] - (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) - (.getName)))) + (defnt pid [> (? t/string?)] + (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) + (.getName)))) ;; ----- expanded code ----- ;; -($ (do #_(swap! *fn->spec assoc `pid - (xp/>expr - (fn [args##] - (case (count args##) 0 nil)))) +($ (do (swap! *fn->spec assoc #'pid + (t/fn [~'> (? t/string?)])) + (def ~'pid|__0 (reify >Object (~(tag "java.lang.Object" 'invoke) [~'_] - (~'->> (java.lang.management.ManagementFactory/getRuntimeMXBean) - (.getName))))))) + (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) + (.getName))))))) )) @@ -63,26 +63,25 @@ (is (code= (macroexpand ' -(defnt identity|gen|uninlined ([x _] x)) +(defnt identity|uninlined ([x _] x)) ) ;; ----- implementation ----- ;; (macroexpand ' -(defnt identity|gen|uninlined ([x t/any?] x)) +(defnt identity|uninlined ([x t/any?] x)) ) ;; ----- expanded code ----- ;; -($ (do #_(swap! *fn->spec assoc `identity|gen|uninlined - (xp/>expr - (fn [args##] (case (count args##) 1 nil #_(fn-> first t/->spec))))) +($ (do (swap! *fn->spec assoc #'identity|uninlined + (t/fn [t/any?])) ~@(case (env-lang) ;; Because for `any?` it includes primitives as well :clj ($ [;; Direct dispatch ;; One reify per overload - (def ~'identity|gen|uninlined|__0 ; `[x t/any?]` + (def ~'identity|uninlined|__0 ; `[x t/any?]` (reify Object>Object (~(tag "java.lang.Object" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] ~'x) boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] ~'x) @@ -97,23 +96,23 @@ ;; Dynamic dispatch (invoked only if incomplete type information (incl. in untyped context)) ;; in this case no protocol is necessary because it boxes arguments anyway ;; Var indirection may be avoided by making and using static fields via the Clojure 1.8 flag - #_(defn ~'identity|gen|uninlined [~'x] (.invoke identity|gen|uninlined|__0 ~'x))]) + #_(defn ~'identity|uninlined [~'x] (.invoke identity|uninlined|__0 ~'x))]) :cljs ;; Direct dispatch will be simple functions, not `reify`s; not necessary here ;; Dynamic dispatch will be approached later; not clear yet whether there is a huge savings - ($ [(defn ~'identity|gen|uninlined [~'x] ~'x)]))))) + ($ [(defn ~'identity|uninlined [~'x] ~'x)]))))) ) ;; =====|=====|=====|=====|===== ;; ;; TODO will deal with `inline` later -(defnt ^:inline identity|gen ([x t/any?] x)) +(defnt ^:inline identity ([x t/any?] x)) ;; ----- test ----- ;; -(deftest test|identity|gen - (is= (identity|gen 1 ) 1 ) - (is= (identity|gen "") "")) +(deftest test|identity + (is= (identity 1 ) 1 ) + (is= (identity "") "")) ;; =====|=====|=====|=====|===== ;; @@ -121,30 +120,29 @@ ;; TODO don't ignore `:inline` (macroexpand ' -(defnt #_:inline name|gen - ([x t/string? > t/string? ] x) - #?(:clj ([x Named > (* t/string?)] (.getName x)) - :cljs ([x INamed > (* t/string?)] (-name x)))) +(defnt #_:inline name + ([x t/string? > t/string?] x) + #?(:clj ([x (t/isa? Named) > (* t/string?)] (.getName x)) + :cljs ([x (t/isa? INamed) > (* t/string?)] (-name x)))) ) ;; ----- expanded code ----- ;; -($ (do #_(swap! *fn->spec assoc #'name|gen - (xp/casef count - 1 (xp/condpf-> t/<= (xp/get 0) - t/string? (fn-> t/->spec) - ~(case (env-lang) :clj `Named :cljs `INamed) t/string?))) +($ (do (swap! *fn->spec assoc #'name + (t/fn [t/string? > t/string?] + [(t/isa? Named) > (* t/string?)] + [(t/isa? INamed) > (* t/string?)])) ~@(case (env-lang) :clj ($ [;; Only direct dispatch for primitives or for Object, not for subclasses of Object ;; Return value can be primitive; in this case it's not ;; The macro in a typed context will find the appropriate dispatch at compile time - (def ~'name|gen|__0 + (def ~'name|__0 (reify Object>Object (~(tag "java.lang.Object" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] (let* [~(tag "java.lang.String" 'x) ~'x] ~'x)))) - (def ~'name|gen|__1 + (def ~'name|__1 (reify Object>Object (~(tag "java.lang.Object" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] (let* [~(tag "clojure.lang.Named" 'x) ~'x] @@ -153,19 +151,19 @@ ;; TODO implement this ;; This protocol is so suffixed because of the position of the argument on which ;; it dispatches - #_(defprotocol name|gen__Protocol__0 - (name|gen [~'x])) - #_(extend-protocol name|gen__Protocol__0 - java.lang.String (name|gen [x] (.invoke name|gen|__0 x)) + #_(defprotocol name__Protocol__0 + (name [~'x])) + #_(extend-protocol name__Protocol__0 + java.lang.String (name [x] (.invoke name|__0 x)) ;; this is part of the protocol because even though `Named` is an interface, ;; `String` is final, so they're mutually exclusive - clojure.lang.Named (name|gen [x] (.invoke name|gen|__1 x)))]) + clojure.lang.Named (name [x] (.invoke name|__1 x)))]) :cljs ($ [;; No protocol in ClojureScript; consider adding this if a performance increase is ;; demonstrated when using a protocol - (defn ~'name|gen [~'x] + (defn ~'name [~'x] (ifs (string? x) x (satisfies? INamed x) (-name x) - (err! "Not supported for type" {:fn `name|gen :type (type x)})))])))) + (err! "Not supported for type" {:fn `name :type (type x)})))])))) )) @@ -175,24 +173,23 @@ ;; Perhaps silly in ClojureScript, but avoids boxing in Clojure (macroexpand ' -(defnt #_:inline some?|gen +(defnt #_:inline some? ([x t/nil?] false) + ;; Implicitly, `(- t/any? t/nil?)`, so `t/val?` ([x t/any?] true)) ) ;; ----- expanded code ----- ;; -($ (do #_(swap! fn->spec assoc #'some?|gen - (xp/casef c/count - 1 (xp/condpf-> t/<= (xp/get 0) - t/nil? (t/value false) - t/any? (t/value true )))) +($ (do (swap! fn->spec assoc #'some? + (t/fn [t/nil?] + [t/any?])) ~@(case (env-lang) - :clj ($ [(def ~'some?|gen|__0 ; `[x t/nil?]` + :clj ($ [(def ~'some?|__0 ; `[x t/nil?]` (reify Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] false))) - (def ~'some?|gen|__1 ; `[x t/any?]` + (def ~'some?|__1 ; `[x t/any?]` (reify Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] true) boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] true) @@ -205,10 +202,10 @@ double>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "double" 'x)] true))) ;; TODO implement this ;; Dynamic dispatch - #_(defn ~'some?|gen [~'x] - (ifs (nil? x) (.invoke some?|gen|__0 x) - (.invoke some?|gen|__1 x)))]) - :cljs ($ [(defn ~'some?|gen [~'x] + #_(defn ~'some? [~'x] + (ifs (nil? x) (.invoke some?|__0 x) + (.invoke some?|__1 x)))]) + :cljs ($ [(defn ~'some? [~'x] (ifs (nil? x) false true))])))) @@ -220,26 +217,25 @@ ;; Perhaps silly in ClojureScript, but avoids boxing in Clojure (macroexpand ' -(defnt #_:inline reduced?|gen - ([x Reduced] true) - ([x t/any? ] false)) +(defnt #_:inline reduced? + ([x (t/isa? Reduced)] true) + ;; Implicitly, `(- t/any? (t/isa? Reduced))` + ([x t/any? ] false)) ) ;; ----- expanded code ----- ;; -($ (do #_(swap! fn->spec assoc #'reduced?|gen - (xp/casef c/count - 1 (xp/condpf-> t/<= (xp/get 0) - t/reduced? (t/value true) - t/any? (t/value false)))) +($ (do (swap! fn->spec assoc #'reduced? + (t/fn [(t/isa? Reduced)] + [t/any?])) ~@(case (env-lang) - :clj ($ [(def ~'reduced?|gen|__0 ; `[x Reduced]` + :clj ($ [(def ~'reduced?|__0 ; `[x Reduced]` (reify Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] (let* [~(tag "clojure.lang.Reduced" 'x) ~'x] true)))) - (def ~'reduced?|gen|__1 ; `[x t/any?]` + (def ~'reduced?|__1 ; `[x t/any?]` (reify Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] false) boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] false) @@ -252,10 +248,10 @@ double>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "double" 'x)] false))) ;; TODO implement ;; No protocol because just one class; TODO evaluate whether this is better performance-wise? probably is - #_(defn ~'reduced?|gen [~'x] - (ifs (instance? Reduced x) (.invoke reduced?|gen|__0 ~'x) - (.invoke reduced?|gen|__1 ~'x)))]) - :cljs ($ [(defn ~'reduced?|gen [~'x] + #_(defn ~'reduced? [~'x] + (ifs (instance? Reduced x) (.invoke reduced?|__0 ~'x) + (.invoke reduced?|__1 ~'x)))]) + :cljs ($ [(defn ~'reduced? [~'x] (ifs (instance? Reduced x) true false))])))) )) @@ -267,18 +263,17 @@ (macroexpand ' (defnt #_:inline >boolean ([x t/boolean?] x) - ([x t/nil? ] false) - ([x t/any? ] true)) + ([x t/nil?] false) + ;; Implicitly, `(- t/any? t/nil? t/boolean?)` + ([x t/any?] true)) ) ;; ----- expanded code ----- ;; -($ (do #_(swap! fn->spec assoc #'>boolean|gen - (xp/casef c/count - 1 (xp/condpf-> t/<= (xp/get 0) - t/boolean? (fn-> t/->spec) ; TODO fix this - t/nil? (t/value false) - t/any? (t/value true )))) +($ (do (swap! fn->spec assoc #'>boolean + (t/fn [t/boolean?] + [t/nil?] + [t/any?])) ~@(case (env-lang) :clj ($ [(def ~'>boolean|__0 ; `[x t/boolean?]` @@ -320,19 +315,17 @@ ;; auto-upcasts to long or double (because 64-bit) unless you tell it otherwise ;; will error if not all return values can be safely converted to the return spec (macroexpand ' -(defnt #_:inline >int* > int - ([x (t/- t/primitive? t/boolean?) #_?] (Primitive/uncheckedIntCast x)) - ([x Number] (.intValue x))) +(defnt #_:inline >int* > int? + ([x (t/- t/primitive? t/boolean?)] (Primitive/uncheckedIntCast x)) + ([x (t/ref (t/isa? Number))] (.intValue x))) ) ;; ----- expanded code ----- ;; #?(:clj -`(do #_(swap! fn->spec assoc #'>int*|gen - (xp/casef c/count - 1 (xp/condpf-> t/<= (xp/get 0) - (t/- t/primitive? t/boolean?) t/int? - Number t/int?))) +`(do (swap! fn->spec assoc #'>int* + (t/fn [(t/- t/primitive? t/boolean?)] + [(t/ref (t/isa? Number))])) ~@(case (env-lang) :clj ($ [(def ~'>int*|__0 ; `(t/- t/primitive? t/boolean?)` @@ -348,7 +341,7 @@ (let* [~(tag "java.lang.Number" 'x) ~'x] (.intValue x))))) ;; TODO implement this #_(defprotocol >int*_Protocol - (>int*|gen [~'x])) + (>int* [~'x])) #_(extend-protocol >int*__Protocol java.lang.Byte (>int* [~(tag "java.lang.Byte" x)] (.invoke >int*|__0 x)) java.lang.Short (>int* [~(tag "java.lang.Short" x)] (.invoke >int*|__0 x)) @@ -439,123 +432,68 @@ ;; =====|=====|=====|=====|===== ;; (macroexpand ' -(defnt !str - ([] #?(:clj (StringBuilder.) :cljs (StringBuffer.))) - ;; `?*` means infer with opts - ;; This means that e.g., `x` can be an `int`, and since `:any-in-numeric-range?` is `true`, `x` can be - ;; anything in the numeric range of an `int`. - ;; TODO the `:any-in-numeric-range?` option could simply be reduced to a `(if numeric? in-range? identity)` - ;; sort of predicate — `(s/and integer-value? (s/range-of int))` - ;; By default it enforces reasonably strict type checks (i.e. not allowing strange byte manipulation), - ;; so it does not allow e.g. short strings convertible to an arbitrary `int` representation. - ([x #?(:clj (?* {:any-in-numeric-range? true}) :cljs t/any?)] ; TODO unknown if `t/any?` is really allowed here - #?(:clj (StringBuilder. x) :cljs (StringBuffer. x)))) +(defnt !str > #?(:clj (t/isa? StringBuilder) + :cljs (t/isa? StringBuffer)) + ([] #?(:clj (StringBuilder.) :cljs (StringBuffer.))) + ;; If we had combined this arity, `t/or`ing the `t/string?` means it wouldn't have been + ;; handled any differently than `t/char-seq?` +#?(:clj ([x t/string?] (StringBuilder. x))) + ([x #?(:clj (t/or t/char-seq? t/int?) + :cljs t/val?)] + #?(:clj (StringBuilder. x) :cljs (StringBuffer. x)))) ) ;; ----- expanded code ----- ;; -`(do (swap! fn->spec assoc #'!str|gen - (xp/casef c/count - 0 ~(case-env :clj (t/>spec StringBuilder) - :cljs (t/>spec StringBuffer )) - 1 (xp/condpf-> t/<= (xp/get 0) - (s/and primitive? (s/not boolean?)) t/int? - Number t/int?))) +`(do (swap! fn->spec assoc #'!str + (t/fn > #?(:clj (t/isa? StringBuilder) + :cljs (t/isa? StringBuffer)) + [] + #?(:clj [t/string?]) + [#?(:clj (t/or t/char-seq? t/int?) + :cljs t/val?)])) ~(case-env - :clj `(do (def !str|gen|__0 + :clj `(do (def !str|__0 (reify >Object (^java.lang.Object invoke [_# ] (StringBuilder.)))) ;; `(?* {:any-in-numeric-range? true})` - (def !str|gen|__1__0 ; (StringBuilder. ) + (def !str|__1__0 ; (StringBuilder. ) (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'x] (StringBuilder. ^CharSequence x)))) - (def !str|gen|__1__1 ; (StringBuilder. <(range-of t/int?)>) + (def !str|__1__1 ; (StringBuilder. <(range-of t/int?)>) (reify int>Object (^java.lang.Object invoke [_# ^int ~'x] (StringBuilder. x))) ...) - (def !str|gen|__1__2 ; (StringBuilder. ) + (def !str|__1__2 ; (StringBuilder. ) (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'x] (StringBuilder. ^String x)))) - (defprotocol !str|gen__Protocol - (!str|gen__protocol [~'x])) - (extend-protocol !str|gen__Protocol + (defprotocol !str__Protocol + (!str__protocol [~'x])) + (extend-protocol !str__Protocol ...) - (defn !str|gen ([ ] (.invoke !str|gen|__0)) - ([a0] (!str|gen__protocol a0)))) - :cljs `(do (defn !str|gen ([] (StringBuffer.)) - ([a0] (let [x a0] (StringBuffer. x))))))) + (defn !str ([ ] (.invoke !str|__0)) + ([a0] (!str__protocol a0)))) + :cljs `(do (defn !str ([] (StringBuffer.)) + ([a0] (let [x a0] (StringBuffer. x))))))) ;; =====|=====|=====|=====|===== ;; (macroexpand ' -(defnt #_:inline >|gen - #?(:clj ([a ? b ? ] (quantum.core.Numeric/gt a b)) - :cljs ([a t/double? b t/double?] (cljs.core/> a b)))) +(defnt #_:inline > + ;; This is admittedly a place where inference might be nice, but luckily there are no + ;; "sparse" combinations + #?(:clj ([a t/comparable-primitive? b t/comparable-primitive? > t/boolean?] + (quantum.core.Numeric/gt a b)) + :cljs ([a t/double? b t/double? > (t/assume t/boolean?)] + (cljs.core/> a b)))) ) ;; ----- expanded code ----- ;; -`(do (swap! fn->spec assoc #'>|gen - (xp/casef c/count - 2 (xp/condpf-> t/<= (xp/get 0) - t/byte? (xp/condpf-> t/<= (xp/get 1) - t/byte? t/boolean? - t/char? t/boolean? - t/short? t/boolean? - t/int? t/boolean? - t/long? t/boolean? - t/float? t/boolean? - t/double? t/boolean?) - t/char? (xp/condpf-> t/<= (xp/get 1) - t/byte? t/boolean? - t/char? t/boolean? - t/short? t/boolean? - t/int? t/boolean? - t/long? t/boolean? - t/float? t/boolean? - t/double? t/boolean?) - t/short? (xp/condpf-> t/<= (xp/get 1) - t/byte? t/boolean? - t/char? t/boolean? - t/short? t/boolean? - t/int? t/boolean? - t/long? t/boolean? - t/float? t/boolean? - t/double? t/boolean?) - t/int? (xp/condpf-> t/<= (xp/get 1) - t/byte? t/boolean? - t/char? t/boolean? - t/short? t/boolean? - t/int? t/boolean? - t/long? t/boolean? - t/float? t/boolean? - t/double? t/boolean?) - t/long? (xp/condpf-> t/<= (xp/get 1) - t/byte? t/boolean? - t/char? t/boolean? - t/short? t/boolean? - t/int? t/boolean? - t/long? t/boolean? - t/float? t/boolean? - t/double? t/boolean?) - t/float? (xp/condpf-> t/<= (xp/get 1) - t/byte? t/boolean? - t/char? t/boolean? - t/short? t/boolean? - t/int? t/boolean? - t/long? t/boolean? - t/float? t/boolean? - t/double? t/boolean?) - t/double? (xp/condpf-> t/<= (xp/get 1) - t/byte? t/boolean? - t/char? t/boolean? - t/short? t/boolean? - t/int? t/boolean? - t/long? t/boolean? - t/float? t/boolean? - t/double? t/boolean?)))) - +`(do (swap! fn->spec assoc #'> + (t/fn #?(:clj [t/comparable-primitive? t/comparable-primitive? > t/boolean?] + :cljs [t/double? t/double? > (t/assume t/boolean?)]))) ~(case-env - :clj `(do (def >|gen|__0 + :clj `(do (def >|__0 (reify byte+byte>boolean (^boolean invoke [_# ^byte a ^byte b] (Numeric/gt a b)) byte+char>boolean (^boolean invoke [_# ^byte a ^char b] (Numeric/gt a b)) byte+short>boolean (^boolean invoke [_# ^byte a ^short b] (Numeric/gt a b)) @@ -606,66 +544,68 @@ double+float>boolean (^boolean invoke [_# ^double a ^float b] (Numeric/gt a b)) double+double>boolean (^boolean invoke [_# ^double a ^double b] (Numeric/gt a b)))) - (defprotocol >|gen__Protocol - (>|gen [~'a0 ~'a1])) - (extend-protocol >|gen__Protocol + (defprotocol >__Protocol + (> [~'a0 ~'a1])) + (extend-protocol >__Protocol ...)) - :cljs `(do (defn >|gen + :cljs `(do (defn > ([a0 a1] (ifs (double? a0) (ifs (double? a1) (let [a a0 b a1] (cljs.core/> a b)) - (unsupported! `>|gen [a0 a1])) - (unsupported! `>|gen [a0 a1]))))))) + (unsupported! `> [a0 a1])) + (unsupported! `> [a0 a1]))))))) ;; =====|=====|=====|=====|===== ;; (macroexpand ' -(defnt #_:inline str +(defnt #_:inline str > t/string? ([] "") ([x t/nil?] "") ;; could have inferred but there may be other objects who have overridden .toString - #?(:clj ([x Object] (.toString x)) - ;; Can't infer that it returns a string (without a pre-constructed list of built-in functions) + #?(:clj ([x (t/isa? Object)] (.toString x)) + ;; Can't infer that it returns a string (without a pre-constructed list of built-in fns) ;; As such, must explicitly mark - :cljs ([x t/any? > (t/assume string?)] (.join #js [x] ""))) - ;; TODO only one variadic arity allowed currently; theoretically could dispatch on at least pre-variadic args, if not variadic - ([x ? & xs (s/seq ?) #?@(:clj [> (t/assume string?)])] ; TODO should have automatic currying? - (let [sb (!str (str x))] - (doseq [x' xs] (.append sb (str x'))) ; TODO is `doseq` the right approach? + :cljs ([x t/any? > (t/assume t/string?)] (.join #js [x] ""))) + ;; TODO only one variadic arity allowed currently; theoretically could dispatch on at + ;; least pre-variadic args, if not variadic + ;; TODO should have automatic currying? + ([x (t/fn> str t/any?) & xs (? (t/seq-of t/any?)) #?@(:cljs [> (t/assume t/string?)])] + (let [sb (-> x str !str)] ; determined to be StringBuilder + ;; TODO is `doseq` the right approach, or using reduction? + (doseq [x' xs] (.append sb (str x'))) (.toString sb)))) ) ;; ----- expanded code ----- ;; -`(do (swap! fn->spec assoc #'str|gen - (xp/casef c/count - 0 (t/value "") - 1 (xp/condpf-> t/<= (xp/get 0) - nil? (t/value "") - ~@(case-env :clj `[Object t/string?] - :cljs `[t/any? t/string?])) - (xp/condpf-> t/<= ...))) +`(do (swap! fn->spec assoc #'str + (t/fn > t/string? + [] + [t/nil?] +#?(:clj [(t/isa? Object)]) +#?(:cljs [t/any? > (t/assume t/string?)]) + [(t/fn> str t/any?) & (? (t/seq-of t/any?)) #?@(:cljs [> (t/assume t/string?)])])) ~(case-env - :clj `(do (def str|gen|__0 + :clj `(do (def str|__0 (reify >Object (^java.lang.Object invoke [_# ] ""))) - (def str|gen|__1 ; `nil?` + (def str|__1 ; `nil?` (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'x] ""))) - (def str|gen|__2 ; `Object` + (def str|__2 ; `Object` (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'x] (.toString x)))) ;; No protocol needed because overloads of protocolizable arity (n>=1, not variadic) do not vary by class - (defn str|gen - ([ ] (.invoke !str|gen|__0)) - ([a0] (ifs (nil? x) (.invoke !str|gen|__1) - (.invoke !str|gen|__2 a0))) + (defn str + ([ ] (.invoke !str|__0)) + ([a0] (ifs (nil? x) (.invoke !str|__1) + (.invoke !str|__2 a0))) ([x & xs] (let [sb (!str (str x))] (doseq [x' xs] (.append sb (str x'))) ; TODO is `doseq` the right approach? (.toString sb))))) :cljs `(do ;; No protocol needed because overloads of protocolizable arity (n>=1, not variadic) do not vary by class - (defn str|gen + (defn str ([ ] "") ([a0] (ifs (nil? x) "" (.join #js [x] ""))) @@ -677,134 +617,134 @@ ;; =====|=====|=====|=====|===== ;; (macroexpand ' -(defnt #_:inline count - ([xs #?(:clj ? :cljs array?) #?@(:cljs [> t/int?])] (#?(:clj Array/count :cljs .-length) xs)) - ([xs t/string? #?@(:cljs [> t/int?])] (#?(:clj .length :cljs .-length) xs)) - ([xs !+vector? #?@(:cljs [> t/int?])] (#?(:clj count :cljs (do (TODO) 0)) xs))) +(defnt #_:inline count > t/nneg-integer? + ([xs t/array? > t/nneg-int?] (.-length xs)) + ([xs t/string? > #?(:clj t/nneg-int? :cljs (t/assume t/nneg-int?))] + (#?(:clj .length :cljs .-length) xs)) + ([xs !+vector? > t/nneg-int?] (#?(:clj count :cljs (do (TODO) 0)) xs))) ) ;; ----- expanded code ----- ;; -`(do (swap! fn->spec assoc #'count|gen - (xp/casef c/count - 1 (xp/condpf-> t/<= (xp/get 0) - array? t/int? - string? t/int? - !+vector? t/int?))) +`(do (swap! fn->spec assoc #'count + (t/fn > t/pos-integer? + [t/array? > t/nneg-int?] + [t/string? > #?(:clj t/nneg-int? :cljs (t/assume t/nneg-int?))] + [!+vector? > t/nneg-int?])) ~(case-env :clj `(do ;; `array?` - (def count|gen|__0__1 (reify Object>int (^int invoke [_# ^java.lang.Object ~'xs] (Array/count ^"[B" xs)))) + (def count|__0__1 (reify Object>int (^int invoke [_# ^java.lang.Object ~'xs] (Array/count ^"[B" xs)))) ... - (defprotocol count|gen__Protocol ...)) + (defprotocol count__Protocol ...)) :cljs `(do ...))) ;; =====|=====|=====|=====|===== ;; (macroexpand ' (defnt #_:inline get - ([xs t/array? , k (t/-> integer? ?)] (#?(:clj Array/get :cljs aget) xs k)) - ([xs t/string?, k (t/-> integer? ?)] (.charAt xs k)) + ([xs t/array? , k (t/numerically t/int?)] (#?(:clj Array/get :cljs aget) xs k)) + ([xs t/string?, k (t/numerically t/int?)] (.charAt xs k)) ([xs !+vector?, k t/any?] #?(:clj (.valAt xs k) :cljs (TODO)))) ) ;; ----- expanded code ----- ;; +`(do (swap! fn->spec assoc #'count + (t/fn > t/pos-integer? + [t/array? (t/numerically t/int?)] + [t/string? (t/numerically t/int?)] + [!+vector? t/any?])) + + ...) + ;; =====|=====|=====|=====|===== ;; ; TODO CLJS version will come after #?(:clj (macroexpand ' -(defnt seq|gen +(defnt seq "Taken from `clojure.lang.RT/seq`" - > (t/? ISeq) + > (t/? (t/isa? ISeq)) ([xs t/nil? ] nil) ([xs t/array? ] (ArraySeq/createFromObject xs)) - ([xs ASeq ] xs) - ([xs (t/or LazySeq Seqable)] (.seq xs)) - ([xs Iterable ] (clojure.lang.RT/chunkIteratorSeq (.iterator xs))) - ([xs CharSequence ] (StringSeq/create xs)) - ([xs Map ] (seq|gen (.entrySet xs))))) + ([xs (t/isa? ASeq) ] xs) + ([xs (t/or (t/isa? LazySeq) (t/isa? Seqable))] (.seq xs)) + ([xs t/iterable? ] (clojure.lang.RT/chunkIteratorSeq (.iterator xs))) + ([xs t/char-seq? ] (StringSeq/create xs)) + ([xs t/java-map? ] (seq (.entrySet xs))))) ) ;; ----- expanded code ----- ;; #?(:clj -`(do (swap! fn->spec assoc #'seq|gen - (xp/casef c/count - 1 (xp/condpf-> t/<= (xp/get 0) - nil? (t/value nil) - array? (t/>spec ISeq) - (t/>spec ASeq) t/>spec ; TODO fix - (t/or LazySeq Seqable) (t/>spec ISeq) - (t/>spec Iterable) (t/>spec ISeq) - (t/>spec CharSequence) (t/>spec ISeq) - (t/>spec Map) (t/>spec ISeq)))) +`(do (swap! fn->spec assoc #'seq + (t/fn > (t/? (t/isa? ISeq)) + [t/nil?] + [t/array?] + [(t/isa? ASeq)] + [(t/or (t/isa? LazySeq) (t/isa? Seqable))] + [t/iterable?] + [t/char-seq?] + [t/java-map?])) ~(case-env :clj `(do ;; `nil?` - (def seq|gen|__0 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] nil))) + (def seq|__0 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] nil))) ;; `array?` - (def seq|gen|__1__0 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (ArraySeq/createFromObject xs)))) + (def seq|__1__0 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (ArraySeq/createFromObject xs)))) ... ;; `ASeq` - (def seq|gen|__2 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] xs))) + (def seq|__2 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] xs))) ;; `LazySeq` - (def seq|gen|__3__0 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (.seq ^LazySeq xs)))) + (def seq|__3__0 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (.seq ^LazySeq xs)))) ;; `Seqable` - (def seq|gen|__3__1 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (.seq ^Seqable xs)))) + (def seq|__3__1 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (.seq ^Seqable xs)))) ;; `Iterable` - (def seq|gen|__4 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] + (def seq|__4 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (clojure.lang.RT/chunkIteratorSeq (.iterator ^Iterator xs))))) ;; `CharSequence` - (def seq|gen|__5 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (StringSeq/create ^CharSequence xs)))) + (def seq|__5 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (StringSeq/create ^CharSequence xs)))) ;; `Map` - (def seq|gen|__6 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (seq|gen (.entrySet ^Map xs))))) + (def seq|__6 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (seq (.entrySet ^Map xs))))) - (defprotocol seq|gen__Protocol - (seq|gen [a0])) - (extend-protocol seq|gen__Protocol + (defprotocol seq__Protocol + (seq [a0])) + (extend-protocol seq__Protocol ;; `array?` ... - ASeq (seq|gen [^ASeq a0] (.invoke seq|gen|__2 a0)) - LazySeq (seq|gen [^LazySeq a0] (.invoke seq|gen|__3__0 a0)) - Object (seq|gen [a0] + ASeq (seq [^ASeq a0] (.invoke seq|__2 a0)) + LazySeq (seq [^LazySeq a0] (.invoke seq|__3__0 a0)) + Object (seq [a0] ;; these are sequential dispatch because none of these are concrete or abstract classes ;; (most are interfaces etc.) - (ifs (nil? a0) (.invoke seq|gen|__0 a0) - (instance? ASeq a0) (.invoke seq|gen|__2 a0) - (instance? Seqable a0) (.invoke seq|gen|__3__1 a0) - (instance? Iterable a0) (.invoke seq|gen|__4 a0) - (instance? CharSequence a0) (.invoke seq|gen|__5 a0) - (instance? Map a0) (.invoke seq|gen|__6 a0) - (unsupported! `seq|gen a0))))) + (ifs (nil? a0) (.invoke seq|__0 a0) + (instance? ASeq a0) (.invoke seq|__2 a0) + (instance? Seqable a0) (.invoke seq|__3__1 a0) + (instance? Iterable a0) (.invoke seq|__4 a0) + (instance? CharSequence a0) (.invoke seq|__5 a0) + (instance? Map a0) (.invoke seq|__6 a0) + (unsupported! `seq a0))))) :cljs `(do ...)))) ;; =====|=====|=====|=====|===== ;; #?(:clj (macroexpand ' -(defnt first|gen - ([xs t/nil? ] nil) - ([xs (t/and sequential? indexed?)] (get|gen xs 0)) - ([xs ISeq ] (.first xs)) - ([xs ? ] (first|gen (seq|gen xs))))) +(defnt first + ([xs t/nil? ] nil) + ([xs (t/and t/sequential? t/indexed?)] (get xs 0)) + ([xs (t/isa? ISeq) ] (.first xs)) + ([xs ... ] (-> xs seq first)))) ) #?(:clj -`(do (swap! fn->spec assoc #'seq|gen - (xp/casef c/count - 1 (xp/condpf-> t/<= (xp/get 0) - nil? (t/value nil) - (t/and sequential? indexed?) ... - (t/>spec ISeq) Object - (t/or nil? - array? - ASeq - (t/or LazySeq Seqable) - Iterable - CharSequence - Map ) ...))) +`(do (swap! fn->spec assoc #'seq + (t/fn + [t/nil?] + [(t/and t/sequential? t/indexed?)] + [(t/isa? ISeq)] + [...])) ~(case-env :clj `(do ...) @@ -815,24 +755,39 @@ ;; =====|=====|=====|=====|===== ;; (macroexpand ' -(defnt next|gen > (? ISeq) +(defnt next > (? ISeq) "Taken from `clojure.lang.RT/next`" - ([xs t/nil?] nil) - ([xs ISeq ] (.next xs)) - ([xs ? ] (next|gen (seq|gen xs)))) + ([xs t/nil?] nil) + ([xs (t/isa? ISeq)] (.next xs)) + ([xs ...] (-> xs seq next))) ) ;; ----- expanded code ----- ;; +`(do (swap! fn->spec assoc #'next + (t/fn + [t/nil?] + [(t/isa? ISeq)] + [...])) + + ...) + ;; =====|=====|=====|=====|===== ;; +;; TODO: conditionally optional arities etc. for t/fn + +(t/def rf? "Reducing function" + (t/fn ("seed arity" []) + ("completing arity" [_]) + ("reducing arity" [_ _]))) + (defnt reduce "Much of this content taken from clojure.core.protocols for inlining and type-checking purposes." {:attribution "alexandergunnarson"} - ([f ? xs nil?] (f)) - ([f (fn-of 2), init ? xs nil?] init) - ([f ?, init ?, z fast_zip.core.ZipperLocation] + ([f rf? xs t/nil?] (f)) + ([f rf?, init _ xs t/nil?] init) + ([f rf?, init _, z (t/isa? fast_zip.core.ZipperLocation)] (loop [xs (zip/down z) v init] (if (some? z) (let [ret (f v z)] @@ -840,8 +795,8 @@ @ret (recur (zip/right xs) ret))) v))) - ; TODO look at CLJS `array-reduce` - ([f ?, init ?, xs (t/or array? string? !+vector?)] ; because transient vectors aren't reducible + ;; TODO look at CLJS `array-reduce` + ([f rf?, init _, xs (t/or t/array? t/string? t/!+vector?)] ; because transient vectors aren't reducible (let [ct (count xs)] (loop [i 0 v init] (if (< i ct) @@ -850,7 +805,7 @@ @ret (recur (inc* i) ret))) v)))) -#?(:clj ([f ?, init ?, xs clojure.lang.StringSeq] +#?(:clj ([f rf?, init _, xs (t/isa? clojure.lang.StringSeq)] (let [s (.s xs)] (loop [i (.i xs) v init] (if (< i (count s)) @@ -859,31 +814,31 @@ @ret (recur (inc* i) ret))) v))))) -#?(:clj ([f ? - xs (t/or clojure.lang.PersistentVector ; vector's chunked seq is faster than its iter - clojure.lang.LazySeq ; for range - clojure.lang.ASeq)] ; aseqs are iterable, masking internal-reducers +#?(:clj ([f rf? + xs (t/or (t/isa? clojure.lang.PersistentVector) ; vector's chunked seq is faster than its iter + (t/isa? clojure.lang.LazySeq) ; for range + (t/isa? clojure.lang.ASeq))] ; aseqs are iterable, masking internal-reducers (if-let [s (seq xs)] (clojure.core.protocols/internal-reduce (next s) f (first s)) (f)))) -#?(:clj ([f ?, init ? - xs (t/or clojure.lang.PersistentVector ; vector's chunked seq is faster than its iter - clojure.lang.LazySeq ; for range - clojure.lang.ASeq)] ; aseqs are iterable, masking internal-reducers +#?(:clj ([f rf?, init _ + xs (t/or (isa? clojure.lang.PersistentVector) ; vector's chunked seq is faster than its iter + (isa? clojure.lang.LazySeq) ; for range + (isa? clojure.lang.ASeq))] ; aseqs are iterable, masking internal-reducers (let [s (seq xs)] (clojure.core.protocols/internal-reduce s f init)))) - ([x transformer?, f ?] + ([x transformer?, f rf?] (let [rf ((.-xf x) f)] (rf (reduce rf (rf) (.-prev x))))) - ([x transformer?, f ?, init ?] + ([x transformer?, f rf?, init _] (let [rf ((.-xf x) f)] (rf (reduce rf init (.-prev x))))) - ([f ?, init ?, x chan?] (async/reduce f init x)) ; TODO spec `async/reduce` -#?(:cljs ([f ?, init ?, xs +map?] (#_(:clj clojure.core.protocols/kv-reduce + ([f rf?, init _, x t/chan?] (async/reduce f init x)) ; TODO spec `async/reduce` +#?(:cljs ([f rf?, init _, xs t/+map?] (#_(:clj clojure.core.protocols/kv-reduce :cljs -kv-reduce) ; in order to use transducers... -reduce-seq xs f init))) -#?(:cljs ([f ?, init ?, xs +set?] (-reduce-seq xs f init))) - ([f ?, init ?, n numerically-int?] +#?(:cljs ([f rf?, init _, xs t/+set?] (-reduce-seq xs f init))) + ([f rf?, init _, n (t/numerically t/int?)] (loop [i 0 v init] (if (< i n) (let [ret (f v i)] @@ -892,10 +847,10 @@ (recur (inc* i) ret))) ; TODO should only be unchecked if `n` is within unchecked range v))) ;; `iter-reduce` -#?(:clj ([f ? - xs (t/or clojure.lang.APersistentMap$KeySeq - clojure.lang.APersistentMap$ValSeq - Iterable)] +#?(:clj ([f rf? + xs (t/or (t/isa? clojure.lang.APersistentMap$KeySeq) + (t/isa? clojure.lang.APersistentMap$ValSeq) + t/iterable?)] (let [iter (.iterator xs)] (if (.hasNext iter) (loop [ret (.next iter)] @@ -907,10 +862,10 @@ ret)) (f))))) ;; `iter-reduce` -#?(:clj ([f ?, init ? - xs (t/or clojure.lang.APersistentMap$KeySeq - clojure.lang.APersistentMap$ValSeq - Iterable)] +#?(:clj ([f rf?, init _ + xs (t/or (t/isa? clojure.lang.APersistentMap$KeySeq) + (t/isa? clojure.lang.APersistentMap$ValSeq) + t/iterable?)] (let [iter (.iterator xs)] (loop [ret init] (if (.hasNext iter) @@ -919,13 +874,13 @@ @ret (recur ret))) ret))))) -#?(:clj ([f ?, xs clojure.lang.IReduce ] (.reduce xs f))) -#?(:clj ([f ?, init, xs clojure.lang.IKVReduce ] (.kvreduce xs f init))) -#?(:clj ([f ?, init, xs clojure.lang.IReduceInit] (.reduce xs f init))) - ([f (fn-of 2), xs any?] +#?(:clj ([f rf?, xs (t/isa? clojure.lang.IReduce) ] (.reduce xs f))) +#?(:clj ([f rf?, init _, xs (t/isa? clojure.lang.IKVReduce) ] (.kvreduce xs f init))) +#?(:clj ([f rf?, init _, xs (t/isa? clojure.lang.IReduceInit)] (.reduce xs f init))) + ([f rf?, xs (t/isa? clojure.core.protocols/CollReduce)] (#?(:clj clojure.core.protocols/coll-reduce :cljs -reduce) xs f)) - ([f (fn-of 2), init ?, xs any?] + ([f rf?, init _, xs (t/isa? clojure.core.protocols/CollReduce)] (#?(:clj clojure.core.protocols/coll-reduce :cljs -reduce) xs f init))) @@ -933,14 +888,18 @@ ;; =====|=====|=====|=====|===== ;; -(defnt transduce - ([ f ? xs ?] (transduce identity f xs)) - ([xf ? f ? xs ?] (transduce xf f (f) xs)) - ([xf ? f ? init ? xs ?] - (let [f' (xf f)] (f' (reduce f' init xs))))) +(do (t/def xf? "Transforming function" + (t/fn [rf? > rf?])) + + (defnt transduce + ([ f rf?, xs t/reducible?] (transduce identity f xs)) + ([xf xf?, f rf?, xs t/reducible?] (transduce xf f (f) xs)) + ([xf xf?, f rf?, init _ xs t/reducible?] + (let [f' (xf f)] (f' (reduce f' init xs)))))) ;; ----- expanded code ----- ;; + ; ================================================ ; (do diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index 5256a5a5..8cb78152 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -19,11 +19,10 @@ ;; ===== Specs ===== ;; (s/def :quantum.core.defnt/local-name - (s/and simple-symbol? (complement #{'& '| '> '?}))) + (s/and simple-symbol? (complement #{'& '| '>}))) (s/def :quantum.core.defnt/spec - (s/alt :infer #{'?} - :any #{'_} + (s/alt :any #{'_} :spec any?)) ;; ----- General destructuring ----- ;; @@ -374,14 +373,12 @@ #?(:clj (defmacro fns - "Like `fnt`, but relies entirely on runtime spec checks. Ignores type inference requests, but - allows them for compatibility with `defnt`." + "Like `fnt`, but relies entirely on runtime spec checks." [& args] (fns|code :fn (ufeval/env-lang) args))) #?(:clj (defmacro defns - "Like `defnt`, but relies entirely on runtime spec checks. Ignores type inference requests, but - allows them for compatibility with `defnt`." + "Like `defnt`, but relies entirely on runtime spec checks." [& args] (fns|code :defn (ufeval/env-lang) args))) #?(:clj diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 04c7c11e..38cc8331 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -666,19 +666,6 @@ (->> spec-or-arity-specs (map (TODO)))))))] (FnSpec. name- lookup spec nil))) -(deftype FnConstantlySpec - [name #_(t/? t/symbol?) - f #_t/fn? - inner-object #_t/_] - PSpec - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (c/or name (list `fn' inner-object)))) - -#?(:clj -(defmacro fn' [x] - `(let [x# ~x] (FnConstantlySpec. nil (ufn/fn' x#) x#)))) - (defn unkeyed "Creates an unkeyed collection spec, in which the collection may or may not be sequential or even seqable, but must not have key-value @@ -689,27 +676,11 @@ [x] (TODO)) (defns ? - "Denotes type inference should be performed. - Arity 1: Computes a spec denoting a nilable value satisfying `spec`. + "Arity 1: Computes a spec denoting a nilable value satisfying `spec`. Arity 2: Computes whether `x` is nil or satisfies `spec`." ([x _ > spec?] (or nil? (>spec x))) ([spec spec?, x _ > c/boolean?] (c/or (c/nil? x) (spec x)))) -;; This sadly gets a java.lang.AbstractMethodError when one tries to do as simple as: -;; `(def ? (InferSpec. nil))` -;; `(def abcde (? 1)) -(udt/deftype InferSpec [meta #_(t/? ::meta)] - {PSpec nil - ?Fn {invoke (([this x] (? x)) - ([this spec x] (? spec x)))} - ?Meta {meta ([this] meta) - with-meta ([this meta'] (InferSpec. meta'))} - fipp.ednize/IOverride nil - fipp.ednize/IEdn - {-edn ([this] `?)}}) - -(defns infer? [x _ > c/boolean?] (instance? InferSpec x)) - ;; ===== Comparison ===== ;; (defns- compare|todo [s0 spec?, s1 spec?] @@ -774,7 +745,6 @@ (def- compare|universal+or fn>) (def- compare|universal+and fn>) -(def- compare|universal+infer compare|todo) (def- compare|universal+expr compare|todo) (def- compare|universal+protocol fn>) (def- compare|universal+class fn>) @@ -788,7 +758,6 @@ (def- compare|empty+or fn<) (def- compare|empty+and fn<) -(def- compare|empty+infer compare|todo) (def- compare|empty+expr compare|todo) (def- compare|empty+protocol fn<) (def- compare|empty+class fn<) @@ -868,8 +837,6 @@ (defns- compare|value+and [s0 value-spec?, ^AndSpec s1 and-spec? > comparisons] (compare|atomic+and s0 s1)) -;; ----- InferSpec ----- ;; - ;; ----- Expression ----- ;; (defns- compare|expr+expr [s0 _, s1 _ > comparisons] (if (c/= s0 s1) 0 3)) @@ -923,7 +890,6 @@ NotSpec #'compare|universal+not OrSpec #'compare|universal+or AndSpec #'compare|universal+and - InferSpec #'compare|universal+infer Expression #'compare|universal+expr ProtocolSpec #'compare|universal+protocol ClassSpec #'compare|universal+class @@ -934,7 +900,6 @@ NotSpec #'compare|empty+not OrSpec #'compare|empty+or AndSpec #'compare|empty+and - InferSpec #'compare|empty+infer Expression #'compare|empty+expr ProtocolSpec #'compare|empty+protocol ClassSpec #'compare|empty+class @@ -945,7 +910,6 @@ NotSpec #'compare|not+not OrSpec #'compare|not+or AndSpec #'compare|not+and - InferSpec #'compare|todo Expression #'fn<> ProtocolSpec #'compare|not+protocol ClassSpec #'compare|not+class @@ -956,7 +920,6 @@ NotSpec (inverted #'compare|not+or) OrSpec #'compare|or+or AndSpec #'compare|or+and - InferSpec #'compare|todo Expression #'fn<> ProtocolSpec #'compare|todo ClassSpec (inverted #'compare|class+or) @@ -967,31 +930,17 @@ NotSpec #'compare|todo OrSpec (inverted #'compare|or+and) AndSpec #'compare|and+and - InferSpec #'compare|todo Expression #'fn<> ProtocolSpec #'compare|todo ClassSpec (inverted #'compare|class+and) ValueSpec (inverted #'compare|value+and)} ;; TODO review this - InferSpec - {UniversalSetSpec (inverted #'compare|universal+infer) - EmptySetSpec (inverted #'compare|empty+infer) - NotSpec #'compare|todo #_fn> - OrSpec #'compare|todo #_fn> - AndSpec #'compare|todo #_fn> - InferSpec #'compare|todo #_fn= - Expression #'compare|todo #_fn> - ProtocolSpec #'compare|todo #_fn> - ClassSpec #'compare|todo #_fn> - ValueSpec #'compare|todo #_fn>} - ;; TODO review this Expression {UniversalSetSpec (inverted #'compare|universal+expr) EmptySetSpec (inverted #'compare|empty+expr) NotSpec #'compare|todo OrSpec #'compare|todo AndSpec #'compare|todo - InferSpec #'compare|todo Expression #'compare|expr+expr ProtocolSpec #'compare|todo ClassSpec #'fn<> ; TODO not entirely true @@ -1002,7 +951,6 @@ NotSpec (inverted #'compare|not+protocol) OrSpec #'compare|todo AndSpec #'compare|todo - InferSpec #'fn< Expression #'fn<> ProtocolSpec (fn [s0 s1] (if (identical? (protocol-spec>protocol s0) (protocol-spec>protocol s1)) @@ -1016,7 +964,6 @@ NotSpec (inverted #'compare|not+class) OrSpec #'compare|class+or AndSpec #'compare|class+and - InferSpec #'compare|todo Expression #'fn<> ProtocolSpec #'compare|todo ClassSpec (fn [s0 s1] (compare|class|class* (class-spec>class s0) (class-spec>class s1))) @@ -1027,7 +974,6 @@ NotSpec (inverted #'compare|not+value) OrSpec #'compare|value+or AndSpec #'compare|value+and - InferSpec #'compare|todo Expression (inverted #'compare|expr+value) ProtocolSpec #'compare|value+protocol ClassSpec (inverted #'compare|class+value) @@ -1173,7 +1119,7 @@ (-def primitive? (or boolean? #?@(:clj [byte? char? short? int? long? float?]) double?)) -#_(:clj (-def comparable-primitive? (and primitive? (not boolean?)))) +#?(:clj (-def comparable-primitive? (- primitive? boolean?))) ;; ===== Booleans ===== ;; @@ -2190,29 +2136,32 @@ ;; ===== Miscellaneous ===== ;; -#?(:clj (-def thread? (isa? java.lang.Thread))) + (-def metable? (isa? #?(:clj clojure.lang.IMeta :cljs cljs.core/IMeta))) + (-def with-metable? (isa? #?(:clj clojure.lang.IObj :cljs cljs.core/IWithMeta))) + +#?(:clj (-def thread? (isa? java.lang.Thread))) ;; Able to be used with `throw` - (-def throwable? #?(:clj (isa? java.lang.Throwable) :cljs any?)) + (-def throwable? #?(:clj (isa? java.lang.Throwable) :cljs any?)) - (-def regex? (isa? #?(:clj java.util.regex.Pattern :cljs js/RegExp))) + (-def regex? (isa? #?(:clj java.util.regex.Pattern :cljs js/RegExp))) - (-def chan? (isa? #?(:clj clojure.core.async.impl.protocols/Channel - :cljs cljs.core.async.impl.protocols/Channel))) + (-def chan? (isa? #?(:clj clojure.core.async.impl.protocols/Channel + :cljs cljs.core.async.impl.protocols/Channel))) - (-def keyword? (isa? #?(:clj clojure.lang.Keyword :cljs cljs.core/Keyword))) - (-def symbol? (isa? #?(:clj clojure.lang.Symbol :cljs cljs.core/Symbol))) + (-def keyword? (isa? #?(:clj clojure.lang.Keyword :cljs cljs.core/Keyword))) + (-def symbol? (isa? #?(:clj clojure.lang.Symbol :cljs cljs.core/Symbol))) ;; `js/File` isn't always available! Use an abstraction -#?(:clj (-def file? (isa? java.io.File))) +#?(:clj (-def file? (isa? java.io.File))) - (-def comparable? #?(:clj (isa? java.lang.Comparable) - ;; TODO other things are comparable; really it depends on the two objects in question - :cljs (or nil? (isa? cljs.core/IComparable)))) + (-def comparable? #?(:clj (isa? java.lang.Comparable) + ;; TODO other things are comparable; really it depends on the two objects in question + :cljs (or nil? (isa? cljs.core/IComparable)))) - (-def record? (isa? #?(:clj clojure.lang.IRecord :cljs cljs.core/IRecord))) + (-def record? (isa? #?(:clj clojure.lang.IRecord :cljs cljs.core/IRecord))) - (-def transformer? (isa? quantum.untyped.core.reducers.Transformer)) + (-def transformer? (isa? quantum.untyped.core.reducers.Transformer)) ;; ----- Collections ----- ;; From cde0b6411a98876507e1c2d3528a24041ec1338f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 15 May 2018 23:45:03 -0600 Subject: [PATCH 038/810] Start to try out `defnt` etc. --- src/quantum/core/collections/core.cljc | 80 ++++++------ src/quantum/core/convert/primitive.cljc | 13 +- src/quantum/core/core.cljc | 23 +++- src/quantum/core/data/bits.cljc | 6 +- src/quantum/core/ns.cljc | 11 ++ src/quantum/core/vars.cljc | 163 ++++++++++++------------ 6 files changed, 163 insertions(+), 133 deletions(-) diff --git a/src/quantum/core/collections/core.cljc b/src/quantum/core/collections/core.cljc index 581d50d1..1f2c655f 100644 --- a/src/quantum/core/collections/core.cljc +++ b/src/quantum/core/collections/core.cljc @@ -39,14 +39,13 @@ [quantum.core.collections.logic :refer [seq-or]] [quantum.core.macros :as macros - :refer [defnt #?(:clj defnt') case-env env-lang]] - [quantum.core.macros.defnt :as defnt] + :refer [case-env env-lang]] [quantum.core.macros.optimization :refer [identity*]] - [quantum.core.reducers.reduce :as red - :refer [reduce reducei transformer]] + [quantum.core.reducers.reduce :as r + :refer [reduce reducei]] [quantum.core.type :as t - :refer [val? class regex?]] + :refer [class defnt fnt regex? val?]] [quantum.core.type.defs :as tdef] [quantum.core.type.core :as tcore] [quantum.core.vars :as var @@ -127,46 +126,47 @@ ; Very useful sequence and data structure info. #?(:clj -(defn dropr+ ; This is extremely slow by comparison. About twice as slow - ; TODO for O(1) reversible inputs, you can just do that with `drop+` - ; TODO this is not suitable for `fold` contexts +(defnt dropr+ ; This is extremely slow by comparison. About twice as slow + ;; TODO CLJS + ;; TODO for O(1) reversible inputs, you can just do that with `drop+` + ;; TODO this is not suitable for `fold` contexts {:attribution "Christophe Grand - http://grokbase.com/t/gg/clojure/1388ev2krx/butlast-with-reducers"} - [n xs] - (transformer xs - (fn [rf] - (let [buffer (java.util.ArrayDeque. (int n))] - (fn ([] (rf)) - ([ret x] - (let [ret (if (= (.size buffer) n) ; because Java object - (rf ret (.pop buffer)) - ret)] - (.add buffer x) - ret)))))))) + [n (t/numerically t/int?), xs t/reducible? > t/reducible?] + (let [n' (>int n)] + (r/transformer xs + (fnt [rf r/rf?] + (let [buffer (java.util.ArrayDeque. n')] + (fnt ([] (rf)) + ([ret _, x _] + (let [ret' (if (identical? (.size buffer) n') + (rf ret (.pop buffer)) + ret)] + (.add buffer x) + ret'))))))))) #?(:clj (defn taker+ - ; TODO for O(1) reversible inputs, you can just do that with `take+` - ; TODO this is not suitable for `fold` contexts + ;; TODO for CLJS + ;; TODO for O(1) reversible inputs, you can just do that with `take+` + ;; TODO this is not suitable for `fold` contexts {:attribution "Christophe Grand - http://grokbase.com/t/gg/clojure/1388ev2krx/butlast-with-reducers"} - [n coll] - ; TODO use `reducer` - ; TODO for CLJS - (reify - clojure.core.protocols.CollReduce - ;#+cljs cljs.core/IReduce - (coll-reduce [this f1] - (clojure.core.protocols/coll-reduce this f1 (f1))) - (coll-reduce [_ f1 init] - (clojure.core.protocols/coll-reduce - (clojure.core.protocols/coll-reduce - coll - (fn [^java.util.Deque q x] - (when (= (.size q) n) - (.pop q)) - (.add q x) - q) - (java.util.ArrayDeque. (int n))) - f1 init))))) + [n xs] + (reify + clojure.core.protocols.CollReduce + ;#+cljs cljs.core/IReduce + (coll-reduce [this f1] + (clojure.core.protocols/coll-reduce this f1 (f1))) + (coll-reduce [_ f1 init] + (clojure.core.protocols/coll-reduce + (clojure.core.protocols/coll-reduce + coll + (fn [^java.util.Deque q x] + (when (= (.size q) n) + (.pop q)) + (.add q x) + q) + (java.util.ArrayDeque. (int n))) + f1 init))))) ;___________________________________________________________________________________________________________________________________ ;=================================================={ EQUIVALENCE }===================================================== ;=================================================={ =, identical? }===================================================== diff --git a/src/quantum/core/convert/primitive.cljc b/src/quantum/core/convert/primitive.cljc index 7bc75551..1b592d99 100644 --- a/src/quantum/core/convert/primitive.cljc +++ b/src/quantum/core/convert/primitive.cljc @@ -1,16 +1,15 @@ (ns quantum.core.convert.primitive (:require #?(:cljs [com.gfredericks.goog.math.Integer :as int]) - [clojure.core :as core] - [quantum.core.data.bits :as bits + [clojure.core :as core] + [quantum.core.data.bits :as bits :refer [&&]] - [quantum.core.error :as err + [quantum.core.error :as err :refer [>ex-info]] - [quantum.core.defnt :as macros + [quantum.core.type :as t :refer [defnt]] - [quantum.core.vars :as var - :refer [defalias]] - [quantum.untyped.core.type :as t]) + [quantum.core.vars :as var + :refer [defalias]]) #?(:cljs (:require-macros [quantum.core.convert.primitive])) diff --git a/src/quantum/core/core.cljc b/src/quantum/core/core.cljc index 2f4d7ae0..ff5a6634 100644 --- a/src/quantum/core/core.cljc +++ b/src/quantum/core/core.cljc @@ -4,7 +4,9 @@ [clojure.spec.alpha :as s] #?(:clj [clojure.core.specs.alpha :as ss]) [cuerdas.core :as str+] - #?(:clj [environ.core :as env]) + #?(:clj [environ.core :as env]) + [quantum.core.type :as t + :refer [defnt defmacrot defprotocolt]] [quantum.untyped.core.core :as u] [quantum.untyped.core.vars :refer [defalias defaliases]])) @@ -25,17 +27,25 @@ (defaliases u >sentinel >object) +;; TODO typed +;; TODO excise (def unchecked-inc-long #?(:clj (fn [^long x] (unchecked-inc x)) :cljs inc)) ;; ===== Mutability/Effects ===== ;; -(defprotocol IValue +;; TODO excise when typed +#_(defprotocol IValue (get [this]) (set [this newv])) -#?(:clj +(defprotocolt IValue + (get [this _]) + (set [this _, newv _])) + +;; TODO excise when typed +#_(:clj (defmacro with "Evaluates @expr, then @body, then returns @expr. For (side) effects." @@ -43,3 +53,10 @@ `(let [expr# ~expr] ~@body expr#))) + +#?(:clj +(defmacrot with + "Evaluates @expr, then @body, then returns @expr. + For (side) effects." + [expr t/form? & body (? (t/seq-of t/form?))] + `(let [expr# ~expr] ~@body expr#))) diff --git a/src/quantum/core/data/bits.cljc b/src/quantum/core/data/bits.cljc index 90df4f36..6e3186ab 100644 --- a/src/quantum/core/data/bits.cljc +++ b/src/quantum/core/data/bits.cljc @@ -6,10 +6,10 @@ [unsigned-bit-shift-right bit-shift-left bit-shift-right bit-or bit-and bit-xor bit-not]) (:require - [clojure.core :as core ] - [quantum.core.macros :as macros + [clojure.core :as core ] + [quantum.core.type :as t :refer [defnt]] - [quantum.core.vars :as var + [quantum.core.vars :as var :refer [defalias]]) #?(:clj (:import #_[quantum.core Numeric] java.nio.ByteBuffer))) diff --git a/src/quantum/core/ns.cljc b/src/quantum/core/ns.cljc index a398a131..ffcf3f57 100644 --- a/src/quantum/core/ns.cljc +++ b/src/quantum/core/ns.cljc @@ -37,3 +37,14 @@ import-static load-ns load-nss loaded-libs load-lib! load-package! load-dep! assert-ns-aliased) + +#?(:clj +(defn alias-ns + "Create vars in the current namespace to alias each of the public vars in + the supplied namespace. + Takes a symbol." + {:attribution "flatland.useful.ns"} + [ns-name-] + (require ns-name-) + (doseq [[name var] (ns-publics (the-ns ns-name-))] + (alias-var name var)))) diff --git a/src/quantum/core/vars.cljc b/src/quantum/core/vars.cljc index 8f15e568..04deb8ad 100644 --- a/src/quantum/core/vars.cljc +++ b/src/quantum/core/vars.cljc @@ -4,6 +4,8 @@ [defonce, intern, binding with-local-vars, meta, reset-meta!]) (:require [clojure.core :as c] #?(:clj [quantum.core.ns :as ns]) + [quantum.core.type :as t + :refer [? defnt fnt]] [quantum.untyped.core.form.evaluate :refer [case-env]] [quantum.untyped.core.qualify :as qual] @@ -12,118 +14,119 @@ (:require-macros [quantum.core.vars :as this]))) -; ===== META ===== ; +;; ===== Meta ===== ;; -(def reset-meta! c/reset-meta!) -(def meta c/meta) +(t/def meta? (? t/+map?)) -(def update-meta vary-meta) +(defnt meta + "Returns the metadata of `x`, returns nil if there is no metadata." + [x t/metable? > meta?] (.meta x)) -(defn merge-meta - "See also `cljs.tools.reader/merge-meta`." - [x m] (update-meta x merge m)) +(defnt with-meta + "Returns an object of the same type and value as `x`, with map `meta-` as its metadata." + [x t/with-metable?, meta- meta? > (t/spec-of meta-)] (.withMeta x meta-)) + +(defnt reset-meta! + "Atomically resets the metadata for a namespace/var/ref/agent/atom" + [iref (t/isa? #?(:clj clojure.lang.IReference :cljs (TODO))) meta- meta? > (t/spec-of meta-)] + (.resetMeta iref meta-)) -(def merge-meta-from u/merge-meta-from) -(def replace-meta-from u/replace-meta-from) +(defnt update-meta + "Returns an object of the same type and value as `x`, with `(apply f (meta x) args)` as its + metadata." + ;; TODO `f` should more specifically be able to handle the args arity and specs + [x (t/and t/with-metable? t/metable?) f t/fn? & args] + (with-meta x (apply f (meta x) args))) -; ===== DECLARATION/INTERNING ===== ; +(defnt merge-meta + "See also `cljs.tools.reader/merge-meta`." + [x (t/and t/with-metable? t/metable?) meta- meta? > (t/spec-of x)] + (update-meta x merge meta-)) + +(defnt merge-meta-from [to (t/and t/with-metable? t/metable?), from t/metable?] + (update-meta to merge (meta from))) + +(defnt replace-meta-from [to t/with-metable?, from t/metable?] + (with-meta to (meta from))) + +;; ===== Declaration/Interning ===== ;; + +(defnt intern + "Finds or creates a var named by the symbol name in the namespace `ns`, setting its root binding + to `v` if supplied. The namespace must exist. The var will adopt any metadata from `name`. + Returns the var." + ([ns- (t/or t/symbol? t/namespace?), name- symbol?] + (let [var- (clojure.lang.Var/intern (the-ns ns-) name-)] + (when (meta name-) (.setMeta var- (meta name-))) + var-)) + ([ns- (t/or t/symbol? t/namespace?), name- symbol?, v _] + (let [v (clojure.lang.Var/intern (the-ns ns-) name- v)] + (when (meta name-) (.setMeta var- (meta name-))) + var-))) + +;; TODO typed +#?(:clj (defalias u/def)) +;; TODO typed #?(:clj (u/defalias u/defalias)) -#?(:clj (defalias intern c/intern)) +;; TODO typed #?(:clj (u/defaliases u defaliases defaliases')) +#?(:clj (defnt defined? [x t/var?] (.hasRoot x))) + #?(:clj -(defn alias-var - "Create a var with the supplied name in the current namespace, having the same - metadata and root-binding as the supplied var." - {:attribution "flatland.useful.ns"} - [sym var-0] +(defnt alias-var + "Create a var with the supplied name in the current namespace, having the same metadata and + root-binding as the supplied var." + {:attribution "flatland.useful.ns" + :contributors ["Alex Gunnarson"]} + [sym t/symbol?, var- t/var?] (apply intern *ns* (with-meta sym (merge {:dont-test - (str "Alias of " (-> var-0 meta :name))} + (str "Alias of " (-> var- meta :name))} (meta var-0) (meta sym))) - (when (.hasRoot ^clojure.lang.Var var-0) [@var-0])))) - -(comment - "What to do when aliasing a macro:" - ;(def cljs-doseqi (var loops/doseqi)) ; doesn't work because not a var in CLJS - ;(def cljs-doseqi (mfn loops/doseqi)) ; doesn't work because no |eval| in CLJS - ;(defalias doseqi #?(:clj loops/doseqi :cljs cljs-doseqi)) - ; #?(:clj (alter-meta! (var doseqi) assoc :macro true)) ; Sometimes this works - - #_(:clj (defmacro doseqi [& args] `(loops/doseqi ~@args)))) + (when (defined? var-) [(deref var-)])))) +;; TODO typed #?(:clj (quantum.untyped.core.vars/defmalias defmalias quantum.untyped.core.vars/defmalias)) +;; TODO typed #?(:clj (defaliases u defonce def- defmacro-)) -; ============ MANIPULATION + OTHER ============ + +;; ===== Modification ===== ;; #?(:clj -(defn reset-var! - "Like `reset!` but for vars." +(defnt reset-var! + "Like `reset!` but for vars. Atomically sets the root binding of ->`var-` to ->`v`." {:attribution "alexandergunnarson"} - [var-0 val-f] - ;(.bindRoot #'clojure.core/ns ns+) - ;(alter-meta! #'clojure.core/ns merge (meta #'ns+)) - (alter-var-root var-0 (fn [_] val-f)))) + [var- t/var?, v _ > t/var?] + (.alterRoot var- (fnt [_] v)))) #?(:clj -(defn update-var! - "Non-atomic var update" +(defnt update-var! {:attribution "alexandergunnarson"} - ([var-0 f] - (do (alter-var-root var-0 f) - var-0)) - ([var-0 f & args] - (do (alter-var-root var-0 - (fn [var-n] - (apply f var-n args))) - var-0)))) + ([var- t/var?, f (t/fn [_]) > t/var?] + (do (.alterRoot var- f) + var-)) + ;; TODO we need to be able to conditionalize `f`'s arity based on the count of `args` + ([var- f t/fn? & args (? t/seq?) > t/var?] + (do (.alterRoot var- (fnt [v' _] (apply f v' args))) + var-)))) #?(:clj -(defn clear-vars! - "Sets each var in ~@vars to nil." +(defnt clear-vars! + "Sets each var in ->`vars` to nil." {:attribution "alexandergunnarson"} - [& vars] + [& vars (? (t/seq-of t/var?))] (doseq [v vars] (reset-var! v nil)))) -#?(:clj -(defn alias-ns - "Create vars in the current namespace to alias each of the public vars in - the supplied namespace. - Takes a symbol." - {:attribution "flatland.useful.ns"} - [ns-name-] - (require ns-name-) - (doseq [[name var] (ns-publics (the-ns ns-name-))] - (alias-var name var)))) - -#?(:clj -(defn defs - "Defines a provided list of symbol-value pairs as vars in the - current namespace." - {:attribution "alexandergunnarson" - :usage '(defs 'a 1 'b 2 'c 3)} - [& {:as vars}] - (doseq [[sym v] vars] - (intern *ns* sym v)))) - -#?(:clj -(defn defs- - "Like |defs|, but each var defined is private." - {:attribution "alexandergunnarson" - :usage '(defs- 'a 1 'b 2 'c 3)} - [& {:as vars}] - (doseq [[sym v] vars] - (intern *ns* (-> sym (with-meta {:private true})) v)))) - -; ===== THREAD-LOCAL ===== ; +;; ===== Thread-local ===== ;; +;; TODO typed #?(:clj (defalias binding c/binding)) +;; TODO typed #?(:clj (defalias with-local-vars c/with-local-vars)) - -#?(:clj (defalias u/def)) From a95e3e8ea2d898d144107a24a0c7835d595e79d9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 16 May 2018 12:19:24 -0600 Subject: [PATCH 039/810] Prepare for t/fn --- src-untyped/quantum/untyped/core/type.cljc | 89 +++++++++++----------- 1 file changed, 43 insertions(+), 46 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 38cc8331..5a5ef596 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -164,7 +164,7 @@ reg (if (c/nil? name-sym) @*spec-registry (swap! *spec-registry - (fn [reg] + (c/fn [reg] (if-let [spec (get reg name-sym)] (if (c/= (.-name ^ClassSpec spec) name-sym) reg @@ -188,7 +188,7 @@ (value x)) :cljs nil))) -;; ===== DEFINITION ===== ;; +;; ===== Definition ===== ;; (defns register-spec! [sym c/symbol?, spec (isa? PSpec)] (TODO)) @@ -239,7 +239,7 @@ (defns deducible [x spec? > deducible-spec?] (DeducibleSpec. (atom x))) -;; ===== EXTENSIONALITY COMPARISON IMPLEMENTATIONS ===== ;; +;; ===== Extensionality comparison implementations ===== ;; #_(is (coll&/incremental-every? (aritoid nil (constantly true) t/in>) [String Comparable Object]) @@ -441,12 +441,12 @@ (let [{:keys [conj-s? prefer-orig-args? s' specs]} (->> args+comparisons|without-superseded (educe - (fn ([accum] accum) - ([accum [s* c*]] - #_(prl! kind conj-s? prefer-orig-args? s' specs s* c*) - (case kind - :or (create-logical-spec|inner|or accum s* c*) - :and (create-logical-spec|inner|and accum s* c*)))) + (c/fn ([accum] accum) + ([accum [s* c*]] + #_(prl! kind conj-s? prefer-orig-args? s' specs s* c*) + (case kind + :or (create-logical-spec|inner|or accum s* c*) + :and (create-logical-spec|inner|and accum s* c*)))) {:conj-s? ;; If `s` is a `NotSpec`, and kind is `:and`, then it will be ;; applied by being `-` from all args, not by being `conj`ed (c/not (c/and (c/= kind :and) (not-spec? s))) @@ -461,9 +461,9 @@ "Simplification via inner expansion: `(| (| a b) c)` -> `(| a b c)`" [spec-pred spec>args spec-args #_(of reducible? spec?)] (->> spec-args - (uc/map+ (fn [arg] (if (spec-pred arg) - (spec>args arg) - [arg]))) + (uc/map+ (c/fn [arg] (if (spec-pred arg) + (spec>args arg) + [arg]))) uc/cat+)) (defn- simplify-logical-spec|structural-identity+ @@ -475,11 +475,11 @@ "Simplification via intension comparison" [kind comparison-denotes-supersession? spec-args #_(of reducible? spec?)] (educe - (fn ([spec-args'] spec-args') - ([spec-args' s #_spec?] - (if (empty? spec-args') - (conj spec-args' s) - (create-logical-spec|inner spec-args' s kind comparison-denotes-supersession?)))) + (c/fn ([spec-args'] spec-args') + ([spec-args' s #_spec?] + (if (empty? spec-args') + (conj spec-args' s) + (create-logical-spec|inner spec-args' s kind comparison-denotes-supersession?)))) [] spec-args)) @@ -506,7 +506,7 @@ ([this] (c/or @*logical-complement (reset! *logical-complement (not this))))} fipp.ednize/IOverride nil fipp.ednize/IEdn {-edn ([this] (list* `and args))} - ?Fn {invoke ([_ x] (reduce (fn [_ pred] (c/or (pred x) (reduced false))) + ?Fn {invoke ([_ x] (reduce (c/fn [_ pred] (c/or (pred x) (reduced false))) true ; vacuously args))} ?Object ;; Tests for structural equivalence @@ -536,7 +536,7 @@ ([this] (c/or @*logical-complement (reset! *logical-complement (not this))))} fipp.ednize/IOverride nil fipp.ednize/IEdn {-edn ([this] (list* `or args))} - ?Fn {invoke ([_ x] (reduce (fn [_ pred] (let [p (pred x)] (c/and p (reduced p)))) + ?Fn {invoke ([_ x] (reduce (c/fn [_ pred] (let [p (pred x)] (c/and p (reduced p)))) true ; vacuously args))} ?Object ;; Tests for structural equivalence @@ -623,13 +623,10 @@ "Creates a spec that ... TODO" [pred (<= iterable?), spec spec?] (TODO)) +;; TODO do this (udt/deftype FnSpec [name #_(t/? t/symbol?) - lookup #_(t/map-of t/integer? - (t/or (spec spec? "output-spec") - (t/vec-of (t/tuple (spec spec? "input-spec") - (spec spec? "output-spec"))))) - spec #_spec? + dispatch ... meta] {PSpec nil ;; Outputs whether the args match any input spec @@ -653,14 +650,14 @@ spec-or-arity-specs (->> spec-or-arity-specs (uc/filter+ #((first %) args)) uc/first second)))) -(defns fn-spec +(defns fn [name- (s/nilable c/symbol?) lookup _ #_(t/map-of t/integer? (t/or (spec spec? "output-spec") (t/vec-of (t/tuple (t/vec-of (spec spec? "input-spec")) (spec spec? "output-spec")))))] (let [spec (->> lookup vals - (uc/map+ (fn [spec-or-arity-specs] + (uc/map+ (c/fn [spec-or-arity-specs] (if (spec? spec-or-arity-specs) spec-or-arity-specs (->> spec-or-arity-specs (map (TODO)))))))] @@ -678,7 +675,7 @@ (defns ? "Arity 1: Computes a spec denoting a nilable value satisfying `spec`. Arity 2: Computes whether `x` is nil or satisfies `spec`." - ([x _ > spec?] (or nil? (>spec x))) + ([spec spec? > spec?] (or nil? spec)) ([spec spec?, x _ > c/boolean?] (c/or (c/nil? x) (spec x)))) ;; ===== Comparison ===== ;; @@ -693,7 +690,7 @@ (let [specs (.-args s1)] (first (reduce - (fn [[ret found] s] + (c/fn [[ret found] s] (let [c (compare s0 s) found' (-> found (ubit/conj c) c/long)] (ifs (c/or (ubit/contains? found' - ProtocolSpec (fn [s0 s1] (if (identical? (protocol-spec>protocol s0) - (protocol-spec>protocol s1)) - 0 - 3)) + ProtocolSpec (c/fn [s0 s1] (if (identical? (protocol-spec>protocol s0) + (protocol-spec>protocol s1)) + 0 + 3)) ClassSpec #'compare|todo ValueSpec (inverted #'compare|value+protocol)} ClassSpec @@ -966,7 +963,7 @@ AndSpec #'compare|class+and Expression #'fn<> ProtocolSpec #'compare|todo - ClassSpec (fn [s0 s1] (compare|class|class* (class-spec>class s0) (class-spec>class s1))) + ClassSpec (c/fn [s0 s1] (compare|class|class* (class-spec>class s0) (class-spec>class s1))) ValueSpec #'compare|class+value} ValueSpec {UniversalSetSpec (inverted #'compare|universal+value) @@ -1005,10 +1002,10 @@ (c/= spec empty-set) #{} (and-spec? spec) - (reduce (fn [classes' spec'] (-spec>classes spec' classes')) + (reduce (c/fn [classes' spec'] (-spec>classes spec' classes')) classes (and-spec>args spec)) (or-spec? spec) - (reduce (fn [classes' spec'] (-spec>classes spec' classes')) + (reduce (c/fn [classes' spec'] (-spec>classes spec' classes')) classes (or-spec>args spec)) :else (err! "Not sure how to handle spec" spec))) @@ -1157,18 +1154,18 @@ #_(-def numeric-primitive? (and primitive? (not boolean?))) - #_(-def numerically-byte? (and integer-value? (>expr (fn [x] (c/<= -128 x 127))))) - #_(-def numerically-short? (and integer-value? (>expr (fn [x] (c/<= -32768 x 32767))))) - #_(-def numerically-char? (and integer-value? (>expr (fn [x] (c/<= 0 x 65535))))) + #_(-def numerically-byte? (and integer-value? (>expr (c/fn [x] (c/<= -128 x 127))))) + #_(-def numerically-short? (and integer-value? (>expr (c/fn [x] (c/<= -32768 x 32767))))) + #_(-def numerically-char? (and integer-value? (>expr (c/fn [x] (c/<= 0 x 65535))))) #_(-def numerically-unsigned-short? numerically-char?) - #_(-def numerically-int? (and integer-value? (>expr (fn [x] (c/<= -2147483648 x 2147483647))))) - #_(-def numerically-long? (and integer-value? (>expr (fn [x] (c/<= -9223372036854775808 x 9223372036854775807))))) + #_(-def numerically-int? (and integer-value? (>expr (c/fn [x] (c/<= -2147483648 x 2147483647))))) + #_(-def numerically-long? (and integer-value? (>expr (c/fn [x] (c/<= -9223372036854775808 x 9223372036854775807))))) #_(-def numerically-float? (and number? - (>expr (fn [x] (c/<= -3.4028235E38 x 3.4028235E38))) - (>expr (fn [x] (-> x #?(:clj clojure.lang.RT/floatCast :cljs c/float) (c/== x)))))) + (>expr (c/fn [x] (c/<= -3.4028235E38 x 3.4028235E38))) + (>expr (c/fn [x] (-> x #?(:clj clojure.lang.RT/floatCast :cljs c/float) (c/== x)))))) #_(-def numerically-double? (and number? - (>expr (fn [x] (c/<= -1.7976931348623157E308 x 1.7976931348623157E308))) - (>expr (fn [x] (-> x clojure.lang.RT/doubleCast (c/== x)))))) + (>expr (c/fn [x] (c/<= -1.7976931348623157E308 x 1.7976931348623157E308))) + (>expr (c/fn [x] (-> x clojure.lang.RT/doubleCast (c/== x)))))) #_(-def int-like? (and integer-value? numerically-int?)) From 0ef9629869dd8173c7e19f73ed40dba6c97e6536 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 16 May 2018 14:30:37 -0600 Subject: [PATCH 040/810] Fix up `utpred/protocol?` --- src-untyped/quantum/untyped/core/type/predicates.cljc | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/predicates.cljc b/src-untyped/quantum/untyped/core/type/predicates.cljc index dde8395e..6d8932e2 100644 --- a/src-untyped/quantum/untyped/core/type/predicates.cljc +++ b/src-untyped/quantum/untyped/core/type/predicates.cljc @@ -59,9 +59,10 @@ #?(:clj (instance? clojure.lang.ILookup x) :cljs (satisfies? ILookup x))) -#?(:clj (defn protocol? [x] - (and (lookup? x) (-> x (get :on-interface) class?)))) + #?(:clj (and (lookup? x) (-> x (get :on-interface) class?)) + ;; Unfortunately there's no better check in CLJS, at least as of 03/18/2018 + :cljs (and (fn? x) (= (str x) "function (){}")))) (defn regex? [x] (instance? #?(:clj java.util.regex.Pattern :cljs js/RegExp) x)) From 1b1bb1d4a73dadd17e002265cfe722c0f6dfbe10 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 16 May 2018 14:30:49 -0600 Subject: [PATCH 041/810] Begin to split out untyped.core.type into multiple nss --- .../quantum/untyped/core/type/compare.cljc | 453 ++++++++++++++++++ .../untyped/core/type/reifications.cljc | 165 +++++++ 2 files changed, 618 insertions(+) create mode 100644 src-untyped/quantum/untyped/core/type/compare.cljc create mode 100644 src-untyped/quantum/untyped/core/type/reifications.cljc diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc new file mode 100644 index 00000000..7ee234c8 --- /dev/null +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -0,0 +1,453 @@ +(ns quantum.untyped.core.type.compare + "Set-theoretic comparisons on types (subset, equality, superset, intersection, disjointness)." + (:refer-clojure :exclude + [compare < <= = not= >= >, ==]) + (:require + [clojure.core :as c] + [quantum.untyped.core.collections.logic + :refer [seq-and seq-or]] + ;; TODO remove this dependency + [quantum.untyped.core.classes :as uclass] + [quantum.untyped.core.compare + :refer [==]] + [quantum.untyped.core.data.bits :as ubit] + [quantum.untyped.core.defnt + :refer [defns defns-]] + [quantum.untyped.core.error + :refer [err! TODO]] + [quantum.untyped.core.fn + :refer [fn' fn1]] + [quantum.untyped.core.logic + :refer [ifs]] + ;; TODO remove this dependency + [quantum.untyped.core.type.core :as utcore] + [quantum.untyped.core.type.reifications :as utr + :refer [type? + universal-set empty-set + not-type? or-type? and-type? + protocol-type? class-type? + value-type?]] + [quantum.untyped.core.vars + :refer [def-]]) + #?(:clj (:import + [quantum.untyped.core.analyze.expr Expression] + [quantum.untyped.core.type.reifications + UniversalSetType EmptySetType + NotType OrType AndType + ProtocolType ClassType + ValueType]))) + +(declare compare < <= = not= >= > >< <>) + +;; ===== (Comparison) idents ===== ;; + +(def ^:const ident 1) +(def ^:const >ident 3) + +(def- fn< (fn' (fn' >ident)) +(def- fn>< (fn' > (fn' <>ident)) + +(def comparisons #{ident >ident}) + +(defns inverse [comparison comparisons > comparisons] + (case comparison + -1 >ident + 1 comparisons] + (let [ts (.-args t1)] + (first + (reduce + (fn [[ret found] t] + (let [c (compare t0 t) + found' (-> found (ubit/conj c) long)] + (ifs (or (ubit/contains? found' ident) + (ubit/contains? found' <>ident))) + [>ident ubit/empty] + ts)))) + +(defns- compare|atomic+and [t0 type?, ^AndType t1 and-type? > comparisons] + (let [ts (.-args t1)] + (first + (reduce + (c/fn [[ret found] t] + (let [c (compare t0 t)] + (if (c/= c =ident) + (reduced [>ident nil]) + (let [found' (-> found (ubit/conj c) long) + ret' (ifs (ubit/contains? found' >ident)) + <>ident + >ident) + (ifs (ubit/contains? found' ident + (ubit/contains? found' >ident) >ident + c) + + c)] + [ret' found'])))) + [3 ubit/empty] + ts)))) + +;; ----- UniversalSet ----- ;; + +(def- compare|universal+empty fn>) + +(defns- compare|universal+not [t0 type?, t1 not-type? > comparisons] + (let [t1|inner (utr/not-type>inner-type t1)] + (ifs (= t1|inner universal-set) >ident + (= t1|inner empty-set) =ident + (compare t0 t1|inner)))) + +(def- compare|universal+or fn>) +(def- compare|universal+and fn>) +(def- compare|universal+expr compare|todo) +(def- compare|universal+protocol fn>) +(def- compare|universal+class fn>) +(def- compare|universal+value fn>) + +;; ----- EmptySet ----- ;; + +(defns- compare|empty+not [t0 type?, t1 not-type? > comparisons] + (let [t1|inner (utr/not-type>inner-type t1)] + (if (= t1|inner universal-set) =ident comparisons] + (let [c (compare (utr/not-type>inner-type t0) (utr/not-type>inner-type t1))] + (case c + 0 =ident + -1 >ident + 1 comparisons] + (let [t0|inner (utr/not-type>inner-type t0)] + (if (= t0|inner empty-set) >ident <>ident))) + +(defns- compare|not+class [t0 not-type?, t1 class-type? > comparisons] + (let [t0|inner (utr/not-type>inner-type t0)] + (if (= t0|inner empty-set) + >ident + (case (compare t0|inner t1) + ( 1 0) <>ident + (-1 2) >ident)))) + +(defns- compare|not+value [t0 not-type?, t1 value-type? > comparisons] + (let [t0|inner (utr/not-type>inner-type t0)] + (if (= t0|inner empty-set) + >ident + ;; nothing is ever < ValueType (and therefore never ><) + (case (compare t0|inner t1) + (1 0) <>ident + 3 >ident)))) + +;; ----- OrType ----- ;; + +;; TODO performance can be improved here by doing fewer comparisons +(defns- compare|or+or [^OrType t0 or-type?, ^OrType t1 or-type? > comparisons] + (let [l (->> t0 .-args (seq-and (fn1 < t1))) + r (->> t1 .-args (seq-and (fn1 < t0)))] + (if l + (if r =ident ident + (if (->> t0 .-args (seq-and (fn1 <> t1))) + <>ident + > comparisons] + (let [r (->> t1 .-args (seq-and (fn1 < t0)))] + (if r >ident <>ident))) + +(def- compare|class+or compare|atomic+or) +(def- compare|value+or compare|atomic+or) + +;; ----- AndType ----- ;; + +(defns- compare|and+and [^AndType t0 and-type?, ^AndType t1 and-type? > comparisons] + (TODO)) + +(def- compare|class+and compare|atomic+and) +(def- compare|value+and compare|atomic+and) + +;; ----- Expression ----- ;; + +(defns- compare|expr+expr [t0 _, t1 _ > comparisons] (if (c/= t0 t1) =ident <>ident)) + +(def- compare|expr+value fn<>) + +;; ----- ProtocolType ----- ;; + +(defns- compare|protocol+protocol [t0 protocol-type?, t1 protocol-type? > comparisons] + (if (== (utr/protocol-type>protocol t0) (utr/protocol-type>protocol t1)) + =ident + <>ident)) + +;; TODO transition to `compare|protocol+value` when stable +(defns- compare|value+protocol [t0 value-type?, t1 protocol-type? > comparisons] + (let [v (utr/value-type>value t0) + p (utr/protocol-type>protocol t1)] + (if (satisfies? p v) ident))) + +;; ----- ClassType ----- ;; + +(defns compare|class+class* + "Compare extension (generality|specificity) of ->`c0` to ->`c1`. + `0` means they are equally general/specific: + - ✓ `(t/= c0 c1)` : the extension of ->`c0` is equal to that of ->`c1`. + `-1` means ->`c0` is less general (more specific) than ->`c1`. + - ✓ `(t/< c0 c1)` : the extension of ->`c0` is a strict subset of that of ->`c1`. + `1` means ->`c0` is more general (less specific) than ->`c1`: + - ✓ `(t/> c0 c1)` : the extension of ->`c0` is a strict superset of that of ->`c1`. + `2` means: + - ✓ `(t/>< c0 c1)` : the intersect of the extensions of ->`c0` and ->`c1` is non-empty, + but neither ->`c0` nor ->`c1` share a subset/equality/superset + relationship. + `3` means their generality/specificity is incomparable: + - ✓ `(t/<> c0 c1)` : the extension of ->`c0` is disjoint w.r.t. to that of ->`c1`. + Unboxed primitives are considered to be less general (more specific) than boxed primitives." + [^Class c0 c/class? ^Class c1 c/class? > comparisons] + #?(:clj (ifs (== c0 c1) =ident + (== c0 Object) >ident + (== c1 Object) unboxed c0) c1) >ident + (== c0 (utcore/boxed->unboxed c1)) ident + (.isAssignableFrom c0 c1) >ident + (.isAssignableFrom c1 c0) ident) + :cljs (TODO))) + +(defns- compare|class+class [t0 class-type?, t1 class-type? > comparisons] + (compare|class+class* (utr/class-type>class t0) (utr/class-type>class t1))) + +(defns- compare|class+value [t0 class-type?, t1 value-type? > comparisons] + (let [c (utr/class-type>class t0) + v (utr/value-type>value t1)] + (if (instance? c v) >ident <>ident))) + +;; ----- ValueType ----- ;; + +(defns- compare|value+value + "What we'd really like is to have a different version of .equals or .equiv + like .equivBehavior in which it returns whether any behavior is different + whatsoever between two objects. For instance, `[52]` behaves differently from + `(list 52)` because `(get [52] 0)` -> `52` while `(get (list 52) 0)` -> `nil`. + + The issue with this is that yes, one could implement a `strict=` that tries to + emulate this behavior, but even though it is implementable for 'transparent' + objects such as collections, it is not for 'opaque' objects, which would + potentially have to have custom equality behavior per class. So we will simply + reluctantly accept whatever `=` tells us as well as the fallout that results. + Thus, `(t/or (t/value []) (t/value (list)))` will result in `(t/value [])`, + which is not ideal but both feasible and better than the alternative." + [t0 value-type?, t1 value-type? > comparisons] + (if (c/= (utr/value-type>value t0) + (utr/value-type>value t1)) + =ident + <>ident)) + +;; ===== Dispatch ===== ;; + +;; TODO take away var indirection once done +(def- compare|dispatch + (let [inverted (c/fn [f] (c/fn [t0 t1] (inverse (f t1 t0))))] + {UniversalSetType + {UniversalSetType #'fn= + EmptySetType #'compare|universal+empty + NotType #'compare|universal+not + OrType #'compare|universal+or + AndType #'compare|universal+and + Expression #'compare|universal+expr + ProtocolType #'compare|universal+protocol + ClassType #'compare|universal+class + ValueType #'compare|universal+value} + EmptySetType + {UniversalSetType (inverted #'compare|universal+empty) + EmptySetType #'fn= + NotType #'compare|empty+not + OrType #'compare|empty+or + AndType #'compare|empty+and + Expression #'compare|empty+expr + ProtocolType #'compare|empty+protocol + ClassType #'compare|empty+class + ValueType #'compare|empty+value} + NotType + {UniversalSetType (inverted #'compare|universal+not) + EmptySetType (inverted #'compare|empty+not) + NotType #'compare|not+not + OrType #'compare|not+or + AndType #'compare|not+and + Expression #'fn<> + ProtocolType #'compare|not+protocol + ClassType #'compare|not+class + ValueType #'compare|not+value} + OrType + {UniversalSetType (inverted #'compare|universal+or) + EmptySetType (inverted #'compare|empty+or) + NotType (inverted #'compare|not+or) + OrType #'compare|or+or + AndType #'compare|or+and + Expression #'fn<> + ProtocolType #'compare|todo + ClassType (inverted #'compare|class+or) + ValueType (inverted #'compare|value+or)} + AndType + {UniversalSetType (inverted #'compare|universal+and) + EmptySetType (inverted #'compare|empty+and) + NotType #'compare|todo + OrType (inverted #'compare|or+and) + AndType #'compare|and+and + Expression #'fn<> + ProtocolType #'compare|todo + ClassType (inverted #'compare|class+and) + ValueType (inverted #'compare|value+and)} + ;; TODO review this + Expression + {UniversalSetType (inverted #'compare|universal+expr) + EmptySetType (inverted #'compare|empty+expr) + NotType #'compare|todo + OrType #'compare|todo + AndType #'compare|todo + Expression #'compare|expr+expr + ProtocolType #'compare|todo + ClassType #'fn<> ; TODO not entirely true + ValueType #'compare|expr+value} + ProtocolType + {UniversalSetType (inverted #'compare|universal+protocol) + EmptySetType (inverted #'compare|empty+protocol) + NotType (inverted #'compare|not+protocol) + OrType #'compare|todo + AndType #'compare|todo + Expression #'fn<> + ProtocolType #'compare|protocol+protocol + ClassType #'compare|todo + ValueType (inverted #'compare|value+protocol)} + ClassType + {UniversalSetType (inverted #'compare|universal+class) + EmptySetType (inverted #'compare|empty+class) + NotType (inverted #'compare|not+class) + OrType #'compare|class+or + AndType #'compare|class+and + Expression #'fn<> + ProtocolType #'compare|todo + ClassType #'compare|class+class + ValueType #'compare|class+value} + ValueType + {UniversalSetType (inverted #'compare|universal+value) + EmptySetType (inverted #'compare|empty+value) + NotType (inverted #'compare|not+value) + OrType #'compare|value+or + AndType #'compare|value+and + Expression (inverted #'compare|expr+value) + ProtocolType #'compare|value+protocol + ClassType (inverted #'compare|class+value) + ValueType #'compare|value+value}})) + +;; ===== Operators ===== ;; + +(defns compare + "Returns the value of the comparison of the extensions of ->`t0` and ->`t1`. + `-1` means (ex ->`t0`) ⊂ (ex ->`t1`) + `0` means (ex ->`t0`) = (ex ->`t1`) + `1` means (ex ->`t0`) ⊃ (ex ->`t1`) + `2` means (ex ->`t0`) shares other intersect w.r.t. (∩) (ex ->`t1`) + `3` means (ex ->`t0`) disjoint w.r.t. (∅) (ex ->`t1`) + + Does not compare cardinalities or other relations of sets, but rather only sub/superset + relations." + [t0 type?, t1 type? > comparisons] + (let [dispatched (-> compare|dispatch (get (type t0)) (get (type t1)))] + (if (c/nil? dispatched) + (err! (str "Types not handled: " {:t0 t0 :t1 t1}) {:t0 t0 :t1 t1}) + (dispatched t0 t1)))) + +(defns < + "Computes whether the extension of type ->`t0` is a strict subset of that of ->`t1`." + ([t1 type?] #(< % t1)) + ([t0 type?, t1 type? > c/boolean?] (c/= (compare t0 t1) `t0` is a (lax) subset of that of ->`t1`." + ([t1 type?] #(<= % t1)) + ([t0 type?, t1 type? > c/boolean?] + (let [ret (compare t0 t1)] (c/or (c/= ret `t0` is equal to that of ->`t1`." + ([t1 type?] #(= % t1)) + ([t0 type?, t1 type? > c/boolean?] (c/= (compare t0 t1) =ident))) + +(defns not= + "Computes whether the extension of type ->`t0` is not equal to that of ->`t1`." + ([t1 type?] #(not= % t1)) + ([t0 type?, t1 type? > c/boolean?] (c/not (= t0 t1)))) + +(defns >= + "Computes whether the extension of type ->`t0` is a (lax) superset of that of ->`t1`." + ([t1 type?] #(>= % t1)) + ([t0 type?, t1 type? > c/boolean?] + (let [ret (compare t0 t1)] (c/or (c/= ret >ident) (c/= ret =ident))))) + +(defns > + "Computes whether the extension of type ->`t0` is a strict superset of that of ->`t1`." + ([t1 type?] #(> % t1)) + ([t0 type?, t1 type? > c/boolean?] (c/= (compare t0 t1) >ident))) + +(defns >< + "Computes whether it is the case that the intersect of the extensions of type ->`t0` + and ->`t1` is non-empty, and neither ->`t0` nor ->`t1` share a subset/equality/superset + relationship." + ([t1 type?] #(>< % t1)) + ([t0 type?, t1 type? > c/boolean?] (c/= (compare t0 t1) > + "Computes whether the respective extensions of types ->`t0` and ->`t1` are disjoint." + ([t1 type?] #(<> % t1)) + ([t0 type? t1 type? > c/boolean?] (c/= (compare t0 t1) <>ident))) + diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc new file mode 100644 index 00000000..ffafb40b --- /dev/null +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -0,0 +1,165 @@ +(ns quantum.untyped.core.type.reifications + (:refer-clojure :exclude + [==]) + (:require + [fipp.ednize :as fedn] + [quantum.untyped.core.analyze.expr +#?@(:cljs [:refer [Expression]])] + [quantum.untyped.core.compare + :refer [== not==]] + [quantum.untyped.core.defnt + :refer [defns]] + [quantum.untyped.core.form.generate.deftype :as udt]) + #?(:clj (:import + [quantum.untyped.core.analyze.expr Expression]))) + +(defonce *type-registry (atom {})) +(swap! *type-registry empty) + +(defprotocol PType) + +(defns type? [x _ > boolean?] (satisfies? PType x)) + +;; ----- UniversalSetType (`t/U`) ----- ;; + +(udt/deftype + ^{:doc "Represents the set of all sets that do not include themselves (including the empty set). + Equivalent to `(constantly true)`."} + UniversalSetType [] + {PType nil + fedn/IOverride nil + fedn/IEdn {-edn ([this] 'quantum.untyped.core.type/U)}}) + +(def universal-set (UniversalSetType.)) + +;; ----- EmptySetType (`t/∅`) ----- ;; + +(udt/deftype + ^{:doc "Represents the empty set. + Equivalent to `(constantly false)`."} + EmptySetType [] + {PType nil + fednIOverride nil + fednIEdn {-edn ([this] 'quantum.untyped.core.type/∅)}}) + +(def empty-set (EmptySetType.)) + +;; ----- NotType (`t/not` / `t/!`) ----- ;; + +(udt/deftype NotType [t #_t/type?] + {PType nil + fedn/IOverride nil + fedn/IEdn {-edn ([this] (list 'quantum.untyped.core.type/not t))} + ?Fn {invoke ([_ x] (t x))} + ?Object ;; Tests for structural equivalence + {equals ([this that] + (or (== this that) + (and (instance? NotType that) + (= t (.-t ^NotType that)))))}}) + +(defns not-type? [x _ > boolean?] (instance? NotType x)) + +(defns not-type>inner-type [t not-type?] (.-t ^NotType t)) + +;; ----- OrType (`t/or` / `t/|`) ----- ;; + +(udt/deftype OrType [args #_(t/and t/indexed? (t/seq t/type?)) *logical-complement] + {PType nil + fedn/IOverride nil + fedn/IEdn {-edn ([this] (list* 'quantum.untyped.core.type/or args))} + ?Fn {invoke ([_ x] (reduce + (fn [_ t] + (let [satisfies-type? (t x)] + (and satisfies-type? (reduced satisfies-type?)))) + true ; vacuously + args))} + ?Object ;; Tests for structural equivalence + {equals ([this that] + (or (== this that) + (and (instance? OrType that) + (= args (.-args ^OrType that)))))}}) + +(defns or-type? [x _ > boolean?] (instance? OrType x)) + +(defns or-type>args [x or-type?] (.-args ^OrType x)) + +;; ----- AndType (`t/and` | `t/&`) ----- ;; + +(udt/deftype AndType [args #_(t/and t/indexed? (t/seq t/type?)) *logical-complement] + {PType nil + fedn/IOverride nil + fedn/IEdn {-edn ([this] (list* 'quantum.untyped.core.type/and args))} + ?Fn {invoke ([_ x] (reduce (fn [_ t] (or (t x) (reduced false))) + true ; vacuously + args))} + ?Object ;; Tests for structural equivalence + {equals ([this that] + (or (== this that) + (and (instance? AndType that) + (= args (.-args ^AndType that)))))}}) + +(defns and-type? [x _ > boolean?] (instance? AndType x)) + +(defns and-type>args [x and-type?] (.-args ^AndType x)) + +;; ----- Expression ----- ;; + +#?(:clj (extend-protocol PType Expression)) + +;; ----- ProtocolType ----- ;; + +(udt/deftype ProtocolType + [meta #_(t/? ::meta) + p #_t/protocol? + name #_(t/? t/symbol?)] + {PType nil + fedn/IOverride nil + fedn/IEdn {-edn ([this] (or name (list 'quantum.untyped.core.type/isa?|protocol (:on p))))} + ?Fn {invoke ([_ x] (satisfies? p x))} + ?Meta {meta ([this] meta) + with-meta ([this meta'] (ProtocolType. meta' p name))} + ?Object {equals ([this that #_any?] + (or (== this that) + (and (instance? ProtocolType that) + (= p (.-p ^ProtocolType that)))))}}) + +(defns protocol-type? [x _] (instance? ProtocolType x)) + +(defns protocol-type>protocol [t protocol-type?] (.-p ^ProtocolType t)) + +;; ----- ClassType ----- ;; + +(udt/deftype ClassType + [ meta #_(t/? ::meta) + ^Class c #_t/class? + name #_(t/? t/symbol?)] + {PType nil + fedn/IOverride nil + fedn/IEdn {-edn ([this] (or name (list 'quantum.untyped.core.type/isa? c)))} + ?Fn {invoke ([_ x] (instance? c x))} + ?Meta {meta ([this] meta) + with-meta ([this meta'] (ClassType. meta' c name))} + ?Object {equals ([this that #_any?] + (or (== this that) + (and (instance? ClassType that) + (= c (.-c ^ClassType that)))))}}) + +(defns class-type? [x _] (instance? ClassType x)) + +(defns class-type>class [t class-type?] (.-c ^ClassType t)) + +;; ----- ValueType ----- ;; + +(udt/deftype ValueType [v #_any?] + {PType nil + fedn/IOverride nil + fedn/IEdn {-edn ([this] (list 'quantum.untyped.core.type/value v))} + ?Fn {invoke ([_ x] (= x v))} + ?Object {equals ([this that #_any?] + (or (== this that) + (and (instance? ValueType that) + (= v (.-v ^ValueType that)))))}}) + +(defns value-type? [x _] (instance? ValueType x)) + +(defns value-type>value [v value-type?] (.-v ^ValueType v)) From a46010ff43ddf603db69029613b1aac77528cf20 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 16 May 2018 14:31:55 -0600 Subject: [PATCH 042/810] Remove unnecessary namespacing --- .../quantum/untyped/core/type/compare.cljc | 38 +++++++++---------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index 7ee234c8..2ff311a2 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -93,7 +93,7 @@ (let [ts (.-args t1)] (first (reduce - (c/fn [[ret found] t] + (fn [[ret found] t] (let [c (compare t0 t)] (if (c/= c =ident) (reduced [>ident nil]) @@ -245,21 +245,21 @@ `3` means their generality/specificity is incomparable: - ✓ `(t/<> c0 c1)` : the extension of ->`c0` is disjoint w.r.t. to that of ->`c1`. Unboxed primitives are considered to be less general (more specific) than boxed primitives." - [^Class c0 c/class? ^Class c1 c/class? > comparisons] + [^Class c0 class? ^Class c1 class? > comparisons] #?(:clj (ifs (== c0 c1) =ident (== c0 Object) >ident (== c1 Object) unboxed c0) c1) >ident (== c0 (utcore/boxed->unboxed c1)) ident + (not (utcore/array-depth-equal? c0 c1)) <>ident (.isAssignableFrom c0 c1) >ident (.isAssignableFrom c1 c0) ident) :cljs (TODO))) @@ -296,7 +296,7 @@ ;; TODO take away var indirection once done (def- compare|dispatch - (let [inverted (c/fn [f] (c/fn [t0 t1] (inverse (f t1 t0))))] + (let [inverted (fn [f] (fn [t0 t1] (inverse (f t1 t0))))] {UniversalSetType {UniversalSetType #'fn= EmptySetType #'compare|universal+empty @@ -403,51 +403,51 @@ relations." [t0 type?, t1 type? > comparisons] (let [dispatched (-> compare|dispatch (get (type t0)) (get (type t1)))] - (if (c/nil? dispatched) + (if (nil? dispatched) (err! (str "Types not handled: " {:t0 t0 :t1 t1}) {:t0 t0 :t1 t1}) (dispatched t0 t1)))) (defns < "Computes whether the extension of type ->`t0` is a strict subset of that of ->`t1`." ([t1 type?] #(< % t1)) - ([t0 type?, t1 type? > c/boolean?] (c/= (compare t0 t1) boolean?] (c/= (compare t0 t1) c/boolean?] - (let [ret (compare t0 t1)] (c/or (c/= ret boolean?] + (let [ret (compare t0 t1)] (or (c/= ret c/boolean?] (c/= (compare t0 t1) =ident))) + ([t0 type?, t1 type? > boolean?] (c/= (compare t0 t1) =ident))) (defns not= "Computes whether the extension of type ->`t0` is not equal to that of ->`t1`." ([t1 type?] #(not= % t1)) - ([t0 type?, t1 type? > c/boolean?] (c/not (= t0 t1)))) + ([t0 type?, t1 type? > boolean?] (not (= t0 t1)))) (defns >= "Computes whether the extension of type ->`t0` is a (lax) superset of that of ->`t1`." ([t1 type?] #(>= % t1)) - ([t0 type?, t1 type? > c/boolean?] - (let [ret (compare t0 t1)] (c/or (c/= ret >ident) (c/= ret =ident))))) + ([t0 type?, t1 type? > boolean?] + (let [ret (compare t0 t1)] (or (c/= ret >ident) (c/= ret =ident))))) (defns > "Computes whether the extension of type ->`t0` is a strict superset of that of ->`t1`." ([t1 type?] #(> % t1)) - ([t0 type?, t1 type? > c/boolean?] (c/= (compare t0 t1) >ident))) + ([t0 type?, t1 type? > boolean?] (c/= (compare t0 t1) >ident))) (defns >< "Computes whether it is the case that the intersect of the extensions of type ->`t0` and ->`t1` is non-empty, and neither ->`t0` nor ->`t1` share a subset/equality/superset relationship." ([t1 type?] #(>< % t1)) - ([t0 type?, t1 type? > c/boolean?] (c/= (compare t0 t1) > boolean?] (c/= (compare t0 t1) > "Computes whether the respective extensions of types ->`t0` and ->`t1` are disjoint." ([t1 type?] #(<> % t1)) - ([t0 type? t1 type? > c/boolean?] (c/= (compare t0 t1) <>ident))) + ([t0 type? t1 type? > boolean?] (c/= (compare t0 t1) <>ident))) From f27d3bd4816c1a32eb86492e20ac9ebbf9b2be77 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 16 May 2018 15:22:25 -0600 Subject: [PATCH 043/810] Conceptually transition from specs to types --- src-untyped/quantum/untyped/core/type.cljc | 1191 +++++------------ .../quantum/untyped/core/type/compare.cljc | 44 +- .../untyped/core/type/reifications.cljc | 4 +- test/quantum/test/untyped/core/type.cljc | 2 + 4 files changed, 375 insertions(+), 866 deletions(-) create mode 100644 test/quantum/test/untyped/core/type.cljc diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 5a5ef596..0bc75cb0 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -1,66 +1,76 @@ (ns quantum.untyped.core.type "Essentially, set-theoretic definitions and operations on types." {:todo "Maybe reduce dependencies and distribute predicates to other namespaces"} - (:refer-clojure :exclude - [< <= = not= >= > == compare * - - and or not - boolean byte char short int long float double - boolean? byte? bytes? char? short? int? long? float? double? - isa? - nil? any? class? tagged-literal? #?(:cljs object?) - number? decimal? bigdec? integer? ratio? - true? false? keyword? string? symbol? - associative? coll? counted? indexed? list? map? map-entry? record? - seq? seqable? sequential? set? sorted? vector? - fn? ifn? - meta ref volatile?]) - (:require - [clojure.core :as c] - [clojure.string :as str] - [quantum.untyped.core.analyze.expr :as xp - :refer [>expr #?(:cljs Expression)]] - [quantum.untyped.core.classes :as uclass] - [quantum.untyped.core.collections :as uc] - [quantum.untyped.core.collections.logic - :refer [seq-and seq-or]] - [quantum.untyped.core.compare :as ucomp - :refer [== not==]] - [quantum.untyped.core.convert :as uconv - :refer [>symbol]] - [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.data.bits :as ubit] - [quantum.untyped.core.data.tuple] - [quantum.untyped.core.defnt - :refer [defns defns-]] - [quantum.untyped.core.error :as uerr - :refer [err! TODO catch-all]] - [quantum.untyped.core.fn :as ufn - :refer [fn1 rcomp <- fn->]] - [quantum.untyped.core.form.generate.deftype :as udt] - [quantum.untyped.core.logic - :refer [fn-and ifs whenp->]] - [quantum.untyped.core.numeric :as unum] - [quantum.untyped.core.print :as upr] - [quantum.untyped.core.qualify :as qual] - [quantum.untyped.core.reducers :as ur - :refer [educe join]] - [quantum.untyped.core.refs - :refer [?deref]] - [quantum.untyped.core.spec :as s] - [quantum.untyped.core.type.core :as utcore] - [quantum.untyped.core.type.defs :as utdef] - [quantum.untyped.core.type.predicates :as utpred] - [quantum.untyped.core.vars :as uvar - :refer [def- defmacro- update-meta]]) - #?(:clj (:import quantum.untyped.core.analyze.expr.Expression - quantum.untyped.core.data.tuple.Tuple)) -#?(:cljs - (:require-macros - [quantum.untyped.core.type :as self - :refer [-def]]))) + (:refer-clojure :exclude + [< <= = not= >= > == compare * - + and or not + boolean byte char short int long float double + boolean? byte? bytes? char? short? int? long? float? double? + isa? + nil? any? class? tagged-literal? #?(:cljs object?) + number? decimal? bigdec? integer? ratio? + true? false? keyword? string? symbol? + associative? coll? counted? indexed? list? map? map-entry? record? + seq? seqable? sequential? set? sorted? vector? + fn? ifn? + meta + ref volatile?]) + (:require + [clojure.core :as c] + [clojure.string :as str] + [quantum.untyped.core.analyze.expr + :refer [>expr #?(:cljs Expression)]] + [quantum.untyped.core.collections :as uc] + [quantum.untyped.core.collections.logic + :refer [seq-and seq-or]] + [quantum.untyped.core.compare + :refer [==]] + [quantum.untyped.core.convert + :refer [>symbol]] + [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.data.bits :as ubit] + [quantum.untyped.core.data.tuple] + [quantum.untyped.core.defnt + :refer [defns defns-]] + [quantum.untyped.core.error :as uerr + :refer [err! TODO catch-all]] + [quantum.untyped.core.fn :as ufn + :refer [fn1 rcomp <- fn->]] + [quantum.untyped.core.form.generate.deftype :as udt] + [quantum.untyped.core.logic + :refer [fn-and ifs whenp->]] + [quantum.untyped.core.numeric :as unum] + [quantum.untyped.core.print :as upr] + [quantum.untyped.core.qualify :as qual] + [quantum.untyped.core.reducers :as ur + :refer [educe join]] + [quantum.untyped.core.refs + :refer [?deref]] + [quantum.untyped.core.spec :as s] + [quantum.untyped.core.type.compare :as utc + :refer [ident >ident]] + [quantum.untyped.core.type.core :as utcore] + [quantum.untyped.core.type.defs :as utdef] + [quantum.untyped.core.type.predicates :as utpred] + [quantum.untyped.core.type.reifications :as utr + :refer [->AndType ->OrType PType]] + [quantum.untyped.core.vars :as uvar + :refer [def- defmacro- update-meta]]) +#?(:cljs (:require-macros + [quantum.untyped.core.type :as self + :refer [-def]])) +#?(:clj (:import + [quantum.untyped.core.analyze.expr Expression] + [quantum.untyped.core.type.reifications + UniversalSetType EmptySetType + NotType OrType AndType + ProtocolType ClassType + ValueType]))) (ucore/log-this-ns) +;; ===== TODOS ===== ;; + #_(defmacro -> ("Anything that is coercible to x" [x] @@ -71,164 +81,203 @@ #_(defmacro range-of) -(defonce *spec-registry (atom {})) -(swap! *spec-registry empty) +(declare + - create-logical-type nil? val? + and or val|by-class?) -;; ===== SPECS ===== ;; +(defonce *type-registry (atom {})) +;; TODO remove this +(swap! *type-registry empty) -(defprotocol PSpec) +;; ===== Comparison ===== ;; -(udt/deftype ValueSpec [v #_any?] - {PSpec nil - fipp.ednize/IOverride nil - fipp.ednize/IEdn {-edn ([this] (list `value v))} - ?Fn {invoke ([_ x] (c/= x v))} - ?Object {equals ([this that #_any?] - (c/or (== this that) - (c/and (instance? ValueSpec that) - (c/= v (.-v ^ValueSpec that)))))}}) +(uvar/defaliases utc compare < <= = not= >= > >< <> inverse) -(defns value - "Creates a spec whose extension is the singleton set containing only the value `v`." - [v _] (ValueSpec. v)) +;; ===== Type Reification Constructors ===== ;; -(defns value-spec? [x _] (instance? ValueSpec x)) +;; ----- UniversalSetType (`t/U`) ----- ;; -(defns value-spec>value [x value-spec?] (.-v ^ValueSpec x)) +(uvar/defalias utr/universal-set) -;; ----- +;; ----- EmptySetType (`t/∅`) ----- ;; -(udt/deftype ClassSpec - [ meta #_(t/? ::meta) - ^Class c #_t/class? - name #_(t/? t/symbol?)] - {PSpec nil - fipp.ednize/IOverride nil - fipp.ednize/IEdn - {-edn ([this] (c/or name (list `isa? c)))} - ?Fn {invoke ([_ x] (instance? c x))} - ?Meta {meta ([this] meta) - with-meta ([this meta'] (ClassSpec. meta' c name))} - ?Object {equals ([this that #_any?] - (c/or (== this that) - (c/and (instance? ClassSpec that) - (c/= c (.-c ^ClassSpec that)))))}}) - -(defns class-spec? [x _] (instance? ClassSpec x)) - -(defns class-spec>class [spec class-spec?] (.-c ^ClassSpec spec)) - -(udt/deftype ProtocolSpec - [meta #_(t/? ::meta) - p #_t/protocol? - name #_(t/? t/symbol?)] - {PSpec nil - fipp.ednize/IOverride nil - fipp.ednize/IEdn {-edn ([this] (c/or name (list `isa?|protocol (:on p))))} - ?Fn {invoke ([_ x] (satisfies? p x))} - ?Meta {meta ([this] meta) - with-meta ([this meta'] (ProtocolSpec. meta' p name))}}) +(uvar/defalias utr/empty-set) -(defns protocol-spec? [x _] (instance? ProtocolSpec x)) +;; ----- NotType (`t/not` / `t/!`) ----- ;; -(defns protocol-spec>protocol [spec protocol-spec?] (.-p ^ProtocolSpec spec)) +(defns not [t utr/type? > utr/type?] + (ifs (= t universal-set) empty-set + (= t empty-set) universal-set + (= t val|by-class?) nil? + (utr/not-type? t) (utr/not-type>inner-type t) + ;; DeMorgan's Law + (utr/or-type? t) (->> t utr/or-type>args (uc/lmap not) (apply and)) + ;; DeMorgan's Law + (utr/and-type? t) (->> t utr/and-type>args (uc/lmap not) (apply or )) + (NotType. t))) -(defns- isa?|protocol [p utpred/protocol?] (ProtocolSpec. nil p nil)) +(uvar/defalias ! not) -(defn isa? [x] - (ifs #?(:clj (utpred/protocol? x) - ;; Unfortunately there's no better check in CLJS, at least as of 03/18/2018 - :cljs (c/and (c/fn? x) (c/= (str x) "function (){}"))) - (isa?|protocol x) +;; ----- OrType (`t/or` / `t/|`) ----- ;; + +(defn or + "Sequential/ordered `or`. Analogous to `set/union`. + Applies as much 'compression'/deduplication/simplification as possible to the supplied types. + Effectively computes the union of the extension of the ->`args`." + [arg & args] + (create-logical-type :or ->OrType utr/or-type? utr/or-type>args + (cons arg args) (fn1 c/= >ident))) + +(uvar/defalias | or) + +;; ----- AndType (`t/and` | `t/&`) ----- ;; + +(defn and + "Sequential/ordered `and`. Analogous to `set/intersection`. + Applies as much 'compression'/deduplication/simplification as possible to the supplied types. + Effectively computes the intersection of the extension of the ->`args`." + [arg & args] + (create-logical-type :and ->AndType utr/and-type? utr/and-type>args + (cons arg args) (fn1 c/= `t1`, `t0` + If `t0` > | >< `t1`, `t0` with all elements of `t1` removed" + [t0 utr/type?, t1 utr/type? > utr/type?] + (let [c (compare t0 t1)] + (case c + (0 -1) empty-set + 3 t0 + (1 2) + (let [c0 (c/class t0) c1 (c/class t1)] + ;; TODO add dispatch? + (condp == c0 + NotType (condp == (-> t0 utr/not-type>inner-type c/class) + ClassType (condp == c1 + ClassType (AndType. [t0 (not t1)] (atom nil))) + ValueType (condp == c1 + ValueType (AndType. [t0 (not t1)] (atom nil)))) + OrType (condp == c1 + ClassType (let [args (->> t0 utr/or-type>args (uc/remove (fn1 = t1)))] + (case (count args) + 0 empty-set + 1 (first args) + (OrType. args (atom nil)))))))))) -#?(:clj (extend-protocol PSpec Expression)) +(defn isa? [x] + (ifs (utpred/protocol? x) + (isa?|protocol x) -(declare nil?) + (#?(:clj c/class? :cljs c/fn?) x) + (isa?|class x))) -(defns >spec - "Coerces ->`x` to a spec, recording its ->`name-sym` if provided." - ([x _ > (isa? PSpec)] (>spec x nil)) - ([x _, name-sym (s/nilable c/symbol?) > (isa? PSpec)] +;; TODO clean up +(defns >type + "Coerces ->`x` to a type, recording its ->`name-sym` if provided." + ([x _ > utr/type?] (>type x nil)) + ([x _, name-sym (s/nilable c/symbol?) > utr/type?] #?(:clj - (cond (satisfies? PSpec x) - x ; TODO should add in its name? - (c/class? x) - (let [x (c/or #?(:clj (utcore/unboxed->boxed x)) x) - reg (if (c/nil? name-sym) - @*spec-registry - (swap! *spec-registry - (c/fn [reg] - (if-let [spec (get reg name-sym)] - (if (c/= (.-name ^ClassSpec spec) name-sym) - reg - (err! "Class already registered with spec; must first undef" {:class x :spec-name name-sym})) - (let [spec (ClassSpec. nil x name-sym)] - (uc/assoc-in reg [name-sym] spec - [:by-class x] spec))))))] - (c/or (get-in reg [:by-class x]) - (ClassSpec. nil ^Class x name-sym))) - (c/fn? x) - (let [sym (c/or name-sym (>symbol x)) - _ (when-not name-sym - (let [resolved (?deref (ns-resolve *ns* sym))] - (assert (== resolved x) {:x x :sym sym :resolved resolved})))] - (Expression. sym x)) - (c/nil? x) - nil? - (utpred/protocol? x) - (ProtocolSpec. nil x name-sym) - :else - (value x)) + (ifs + (satisfies? PType x) + x ; TODO should add in its name? + (c/class? x) + (let [x (c/or #?(:clj (utcore/unboxed->boxed x)) x) + reg (if (c/nil? name-sym) + @*type-registry + (swap! *type-registry + (c/fn [reg] + (if-let [t (get reg name-sym)] + (if (c/= (.-name ^ClassType t) name-sym) + reg + (err! "Class already registered with type; must first undef" {:class x :type-name name-sym})) + (let [t (ClassType. nil x name-sym)] + (uc/assoc-in reg [name-sym] t + [:by-class x] t))))))] + (c/or (get-in reg [:by-class x]) + (ClassType. nil ^Class x name-sym))) + (c/fn? x) + (let [sym (c/or name-sym (>symbol x)) + _ (when-not name-sym + (let [resolved (?deref (ns-resolve *ns* sym))] + (assert (== resolved x) {:x x :sym sym :resolved resolved})))] + (Expression. sym x)) + (c/nil? x) + nil? + (utpred/protocol? x) + (ProtocolType. nil x name-sym) + (value x)) :cljs nil))) -;; ===== Definition ===== ;; +;; ===== Definition/Registration ===== ;; -(defns register-spec! [sym c/symbol?, spec (isa? PSpec)] +(defns register-type! [sym c/symbol?, t utr/type?] (TODO)) +;; TODO clean up #?(:clj -(defmacro define [sym spec] - `(~'def ~sym (let [spec# ~spec] - (assert (satisfies? PSpec spec#) spec#) - #_(register-spec! '~(qual/qualify sym) spec#) - spec#)))) +(defmacro define [sym t] + `(~'def ~sym (let [t# ~t] + (assert (utr/type? t#) t#) + #_(register-type! '~(qual/qualify sym) t#) + t#)))) +;; TODO clean up (defn undef [reg sym] - (if-let [spec (get reg sym)] + (if-let [t (get reg sym)] (let [reg' (dissoc reg sym)] - (if (instance? ClassSpec spec) - (uc/dissoc-in reg' [:by-class (.-c ^ClassSpec spec)]) + (if (instance? ClassType t) + (uc/dissoc-in reg' [:by-class (.-c ^ClassType t)]) (TODO))) reg)) -(defn undef! [sym] (swap! *spec-registry undef sym)) +;; TODO clean up +(defn undef! [sym] (swap! *type-registry undef sym)) #_(:clj -(defmacro defalias [sym spec] - `(~'def ~sym (>spec ~spec)))) +(defmacro defalias [sym t] + `(~'def ~sym (>type ~t)))) #?(:clj (uvar/defalias -def define)) -(-def spec? (isa? PSpec)) +(-def type? (isa? PType)) + +;; ===== Miscellaneous ===== ;; (defns * - "Denote on a spec that it must be enforced at runtime. + "Denote on a type that it must be enforced at runtime. For use with `defnt`." - [spec spec? > spec?] (update-meta spec assoc :runtime? true)) + [t utr/type? > utr/type?] (update-meta t assoc :runtime? true)) (defns ref - "Denote on a spec that it must not be expanded to use primitive values. + "Denote on a type that it must not be expanded to use primitive values. For use with `defnt`." - [spec spec? > spec?] (update-meta spec assoc :ref? true)) + [t utr/type? > utr/type?] (update-meta t assoc :ref? true)) -(udt/deftype DeducibleSpec [*spec #_(t/atom-of t/spec?)] +;; TODO figure this out +#_(do (udt/deftype DeducibleSpec [*spec #_(t/atom-of t/spec?)] {PSpec nil fipp.ednize/IOverride nil fipp.ednize/IEdn {-edn ([this] (list `deducible @*spec))} @@ -237,393 +286,141 @@ (defns deducible-spec? [x _] (instance? DeducibleSpec x)) -(defns deducible [x spec? > deducible-spec?] (DeducibleSpec. (atom x))) - -;; ===== Extensionality comparison implementations ===== ;; - -#_(is (coll&/incremental-every? (aritoid nil (constantly true) t/in>) - [String Comparable Object]) - (coll&/incremental-every? (aritoid nil (constantly true) t/in>) - [Long Number])) - -(def comparisons #{-1 0 1 2 3}) - -(defns compare|class|class* - "Compare extension (generality|specificity) of ->`c0` to ->`c1`. - `0` means they are equally general/specific: - - ✓ `(t/= c0 c1)` : the extension of ->`c0` is equal to that of ->`c1`. - `-1` means ->`c0` is less general (more specific) than ->`c1`. - - ✓ `(t/< c0 c1)` : the extension of ->`c0` is a strict subset of that of ->`c1`. - `1` means ->`c0` is more general (less specific) than ->`c1`: - - ✓ `(t/> c0 c1)` : the extension of ->`c0` is a strict superset of that of ->`c1`. - `2` means: - - ✓ `(t/>< c0 c1)` : the intersect of the extensions of ->`c0` and ->`c1` is non-empty, - but neither ->`c0` nor ->`c1` share a subset/equality/superset - relationship. - `3` means their generality/specificity is incomparable: - - ✓ `(t/<> c0 c1)` : the extension of ->`c0` is disjoint w.r.t. to that of ->`c1`. - Unboxed primitives are considered to be less general (more specific) than boxed primitives." - [^Class c0 c/class? ^Class c1 c/class? > comparisons] - #?(:clj (ifs (== c0 c1) 0 - (== c0 Object) 1 - (== c1 Object) -1 - (== (utcore/boxed->unboxed c0) c1) 1 - (== c0 (utcore/boxed->unboxed c1)) -1 - ;; we'll consider the two unrelated - (c/not (utcore/array-depth-equal? c0 c1)) 3 - (.isAssignableFrom c0 c1) 1 - (.isAssignableFrom c1 c0) -1 - ;; multiple inheritance of interfaces - (c/or (c/and (uclass/interface? c0) - (c/not (uclass/final? c1))) - (c/and (uclass/interface? c1) - (c/not (uclass/final? c0)))) 2 - 3) - :cljs (TODO))) - -;; ===== Comparison ===== ;; - -(declare compare|dispatch) - -(def ^:const ident 1) -(def ^:const >ident 3) - -(def- fn< (ufn/fn' -1)) -(def- fn= (ufn/fn' 0)) -(def- fn> (ufn/fn' 1)) -(def- fn>< (ufn/fn' 2)) -(def- fn<> (ufn/fn' 3)) - -(defns compare - ;; TODO optimize the `recur`s here as they re-take old code paths - "Returns the value of the comparison of the extensions of ->`s0` and ->`s1`. - `-1` means (ex ->`s0`) ⊂ (ex ->`s1`) - `0` means (ex ->`s0`) = (ex ->`s1`) - `1` means (ex ->`s0`) ⊃ (ex ->`s1`) - `2` means (ex ->`s0`) shares other intersect w.r.t. (∩) (ex ->`s1`) - `3` means (ex ->`s0`) disjoint w.r.t. (∅) (ex ->`s1`) - - Does not compare cardinalities or other relations of sets, but rather only sub/superset - relations." - [s0 spec?, s1 spec? > comparisons] - (let [dispatched (-> compare|dispatch (get (type s0)) (get (type s1)))] - (if (c/nil? dispatched) - (err! (str "Specs not handled: " {:s0 s0 :s1 s1}) {:s0 s0 :s1 s1}) - (dispatched s0 s1)))) - -(defns < - "Computes whether the extension of spec ->`s0` is a strict subset of that of ->`s1`." - ([s1 spec?] #(< % s1)) - ([s0 spec?, s1 spec? > c/boolean?] (let [ret (compare s0 s1)] (c/= ret -1)))) - -(defns <= - "Computes whether the extension of spec ->`s0` is a (lax) subset of that of ->`s1`." - ([s1 spec?] #(<= % s1)) - ([s0 spec?, s1 spec? > c/boolean?] (let [ret (compare s0 s1)] (c/or (c/= ret -1) (c/= ret 0))))) - -(defns = - "Computes whether the extension of spec ->`s0` is equal to that of ->`s1`." - ([s1 spec?] #(= % s1)) - ([s0 spec?, s1 spec? > c/boolean?] (c/= (compare s0 s1) 0))) - -(defns not= - "Computes whether the extension of spec ->`s0` is not equal to that of ->`s1`." - ([s1 spec?] #(not= % s1)) - ([s0 spec?, s1 spec? > c/boolean?] (c/not (= s0 s1)))) - -(defns >= - "Computes whether the extension of spec ->`s0` is a (lax) superset of that of ->`s1`." - ([s1 spec?] #(>= % s1)) - ([s0 spec?, s1 spec? > c/boolean?] (let [ret (compare s0 s1)] (c/or (c/= ret 1) (c/= ret 0))))) - -(defns > - "Computes whether the extension of spec ->`s0` is a strict superset of that of ->`s1`." - ([s1 spec?] #(> % s1)) - ([s0 spec?, s1 spec? > c/boolean?] (c/= (compare s0 s1) 1))) - -(defns >< - "Computes whether it is the case that the intersect of the extensions of spec ->`s0` - and ->`s1` is non-empty, and neither ->`s0` nor ->`s1` share a subset/equality/superset - relationship." - ([s1 spec?] #(>< % s1)) - ([s0 spec?, s1 spec? > c/boolean?] (c/= (compare s0 s1) 2))) - -(defns <> - "Computes whether the respective extensions of specs ->`s0` and ->`s1` are disjoint." - ([s1 spec?] #(<> % s1)) - ([s0 spec? s1 spec? > c/boolean?] (c/= (compare s0 s1) 3))) - -(defns inverse [comparison comparisons > comparisons] - (case comparison - -1 1 - 1 -1 - (0 2 3) comparison)) - -;; ===== LOGICAL ===== ;; - -(defprotocol PLogicalComplement - (>logical-complement [this] - "Returns the content inside a `t/not` applied to the `args` of an n-ary logical - spec (e.g. `or`, `and`). Stored in such specs to more easily compare them with - `not` specs. - E.g. `(>logical-complement (and a b))` -> `(or (not a) (not b))` - `(>logical-complement (or a b))` -> `(and (not a) (not b))`.")) - -(udt/deftype ^{:doc "Equivalent to `(constantly false)`"} EmptySetSpec [] - {PSpec nil - fipp.ednize/IOverride nil - fipp.ednize/IEdn {-edn ([this] `∅)}}) - -(def empty-set (EmptySetSpec.)) - -(udt/deftype ^{:doc "Equivalent to `(constantly true)`"} UniversalSetSpec [] - {PSpec nil - fipp.ednize/IOverride nil - fipp.ednize/IEdn {-edn ([this] `U)}}) +(defns deducible [x spec? > deducible-spec?] (DeducibleSpec. (atom x)))) -;; The set of all sets that do not include themselves (including the empty set) -(def universal-set (UniversalSetSpec.)) +;; ===== Logical ===== ;; -(declare not not-spec? not-spec>inner-spec - and-spec? and-spec>args val|by-class?) +(defns >logical-complement + "Returns the content inside a `t/not` applied to the `args` of an n-ary logical type (e.g. `or`, + `and`). Stored in such types to more easily compare them with `not` types. + E.g. `(>logical-complement (and a b))` -> `(or (not a) (not b))` + `(>logical-complement (or a b))` -> `(and (not a) (not b))`." + [t utr/type? > utr/type?] + (cond (utr/or-type? t) (c/or @(.-*logical-complement ^OrType t) + (reset! (.-*logical-complement ^OrType t) (not t))) + (utr/and-type? t) (c/or @(.-*logical-complement ^AndType t) + (reset! (.-*logical-complement ^AndType t) (not t))) + :else (err! "`>logical-complement` not supported on type" {:type t}))) -(defns complementary? [s0 spec? s1 spec?] (= s0 (not s1))) +(defns complementary? [t0 utr/type? t1 utr/type?] (= t0 (not t1))) -(defns- create-logical-spec|inner|or - [{:as accum :keys [s' spec?]} _, s* spec?, c* comparisons] +(defns- create-logical-type|inner|or + [{:as accum :keys [t' utr/type?]} _, t* utr/type?, c* utc/comparison?] (if ;; `s` must be either `><` or `<>` w.r.t. to all other args (case c* (2 3) true false) (if ;; Tautology/universal-set: (| A (! A)) (c/and (c/= c* <>ident) ; optimization before `complementary?` - (complementary? s' s*)) - (reduced (assoc accum :conj-s? false :specs [universal-set])) - (update accum :specs conj s*)) + (complementary? t' t*)) + (reduced (assoc accum :conj-t? false :types [universal-set])) + (update accum :types conj t*)) (reduced (assoc accum :prefer-orig-args? true)))) -(defns- create-logical-spec|inner|and - [{:as accum :keys [conj-s? c/boolean?, prefer-orig-args? c/boolean?, s' spec?, specs _]} _ - s* spec?, c* comparisons] +(defns- create-logical-type|inner|and + [{:as accum :keys [conj-t? c/boolean?, prefer-orig-args? c/boolean?, t' utr/type?, types _]} _ + t* utr/type?, c* utc/comparison?] (if ;; Contradiction/empty-set: (& A (! A)) (c/or (c/= c* <>ident) ; optimization before `complementary?` - (complementary? s' s*)) + (complementary? t' t*)) (do #_(println "BRANCH 1") - (reduced (assoc accum :conj-s? false :specs [empty-set]))) + (reduced (assoc accum :conj-t? false :types [empty-set]))) (do #_(println "BRANCH 2") - (let [conj-s?' (if ;; `s` must be `><` w.r.t. to all other args if it is to be `conj`ed + (let [conj-t?' (if ;; `s` must be `><` w.r.t. to all other args if it is to be `conj`ed (c/not= c* >args diff) + (utr/and-type>args diff) [diff])) - [s*])] - (assoc accum :conj-s? conj-s?' :specs (into specs ss*)))))) + [t*])] + (assoc accum :conj-t? conj-t?' :types (into types tt*)))))) -(defns- create-logical-spec|inner - [args' _, s spec?, kind #{:or :and}, comparison-denotes-supersession? c/fn?] +(defns- create-logical-type|inner + [args' _, t utr/type?, kind #{:or :and}, comparison-denotes-supersession? c/fn?] (let [args+comparisons|without-superseded (->> args' - (uc/map+ (juxt identity #(compare s %))) - ;; remove all args whose extensions are superseded by `s` + (uc/map+ (juxt identity #(compare t %))) + ;; remove all args whose extensions are superseded by `t` (uc/remove+ (fn-> second comparison-denotes-supersession?)) join) ; TODO elide `join` - s-redundant? (->> args+comparisons|without-superseded (seq-or (fn-> second (c/= =ident))))] - (ifs s-redundant? + t-redundant? (->> args+comparisons|without-superseded (seq-or (fn-> second (c/= =ident))))] + (ifs t-redundant? args' (empty? args+comparisons|without-superseded) - [s] - (let [{:keys [conj-s? prefer-orig-args? s' specs]} + [t] + (let [{:keys [conj-t? prefer-orig-args? t' types]} (->> args+comparisons|without-superseded (educe (c/fn ([accum] accum) - ([accum [s* c*]] - #_(prl! kind conj-s? prefer-orig-args? s' specs s* c*) + ([accum [t* c*]] + #_(prl! kind conj-s? prefer-orig-args? t' types t* c*) (case kind - :or (create-logical-spec|inner|or accum s* c*) - :and (create-logical-spec|inner|and accum s* c*)))) - {:conj-s? ;; If `s` is a `NotSpec`, and kind is `:and`, then it will be + :or (create-logical-type|inner|or accum t* c*) + :and (create-logical-type|inner|and accum t* c*)))) + {:conj-t? ;; If `t` is a `NotType`, and kind is `:and`, then it will be ;; applied by being `-` from all args, not by being `conj`ed - (c/not (c/and (c/= kind :and) (not-spec? s))) + (c/not (c/and (c/= kind :and) (utr/not-type? t))) :prefer-orig-args? false - :s' s - :specs []}))] + :t' t + :types []}))] (if prefer-orig-args? args' - (whenp-> specs conj-s? (conj s'))))))) + (whenp-> types conj-t? (conj t'))))))) -(defn- simplify-logical-spec|inner-expansion+ +(defn- simplify-logical-type|inner-expansion+ "Simplification via inner expansion: `(| (| a b) c)` -> `(| a b c)`" - [spec-pred spec>args spec-args #_(of reducible? spec?)] - (->> spec-args - (uc/map+ (c/fn [arg] (if (spec-pred arg) - (spec>args arg) + [type-pred type>args type-args #_(of reducible? utr/type?)] + (->> type-args + (uc/map+ (c/fn [arg] (if (type-pred arg) + (type>args arg) [arg]))) uc/cat+)) -(defn- simplify-logical-spec|structural-identity+ +(defn- simplify-logical-type|structural-identity+ "Simplification via structural identity: `(| a b a)` -> `(| a b)`" - [spec-args #_(of reducible? spec?)] - (->> spec-args (uc/map+ >spec) uc/distinct+)) + [type-args #_(of reducible? utr/type?)] + (->> type-args (uc/map+ >type) uc/distinct+)) -(defn- simplify-logical-spec|comparison +(defn- simplify-logical-type|comparison "Simplification via intension comparison" - [kind comparison-denotes-supersession? spec-args #_(of reducible? spec?)] + [kind comparison-denotes-supersession? type-args #_(of reducible? utr/type?)] (educe - (c/fn ([spec-args'] spec-args') - ([spec-args' s #_spec?] - (if (empty? spec-args') - (conj spec-args' s) - (create-logical-spec|inner spec-args' s kind comparison-denotes-supersession?)))) + (c/fn ([type-args'] type-args') + ([type-args' t #_utr/type?] + (if (empty? type-args') + (conj type-args' t) + (create-logical-type|inner type-args' t kind comparison-denotes-supersession?)))) [] - spec-args)) + type-args)) -(defns- create-logical-spec - [kind #{:or :and}, construct-fn _, spec-pred _, spec>args _, spec-args (fn-> count (c/>= 1)) - comparison-denotes-supersession? c/fn? > spec?] - (if (-> spec-args count (c/= 1)) - (first spec-args) +(defns- create-logical-type + [kind #{:or :and}, construct-fn _, type-pred _, type>args _, type-args (fn-> count (c/>= 1)) + comparison-denotes-supersession? c/fn? > utr/type?] + (if (-> type-args count (c/= 1)) + (first type-args) (let [simplified - (->> spec-args - (simplify-logical-spec|inner-expansion+ spec-pred spec>args) - simplify-logical-spec|structural-identity+ - (simplify-logical-spec|comparison kind comparison-denotes-supersession?))] + (->> type-args + (simplify-logical-type|inner-expansion+ type-pred type>args) + simplify-logical-type|structural-identity+ + (simplify-logical-type|comparison kind comparison-denotes-supersession?))] (assert (-> simplified count (c/>= 1))) ; for internal implementation correctness (if (-> simplified count (c/= 1)) (first simplified) (construct-fn simplified (atom nil)))))) -;; ===== AND ===== ;; - -(udt/deftype AndSpec [args #_(t/and t/indexed? (t/seq spec?)) *logical-complement] - {PSpec nil - PLogicalComplement {>logical-complement - ([this] (c/or @*logical-complement (reset! *logical-complement (not this))))} - fipp.ednize/IOverride nil - fipp.ednize/IEdn {-edn ([this] (list* `and args))} - ?Fn {invoke ([_ x] (reduce (c/fn [_ pred] (c/or (pred x) (reduced false))) - true ; vacuously - args))} - ?Object ;; Tests for structural equivalence - {equals ([this that] - (c/or (== this that) - (c/and (instance? AndSpec that) - (c/= args (.-args ^AndSpec that)))))}}) - -(defns and-spec? [x _ > c/boolean?] (instance? AndSpec x)) - -(defns and-spec>args [x and-spec?] (.-args ^AndSpec x)) - -(defn and - "Sequential/ordered `and`. Analogous to `set/intersection`. - Applies as much 'compression'/deduplication/simplification as possible to the supplied specs. - Effectively computes the intersection of the extension of the ->`args`." - [arg & args] - (create-logical-spec :and ->AndSpec and-spec? and-spec>args (cons arg args) (fn1 c/= -1))) - -(uvar/defalias & and) - -;; ===== OR ===== ;; - -(udt/deftype OrSpec [args #_(t/and t/indexed? (t/seq spec?)) *logical-complement] - {PSpec nil - PLogicalComplement {>logical-complement - ([this] (c/or @*logical-complement (reset! *logical-complement (not this))))} - fipp.ednize/IOverride nil - fipp.ednize/IEdn {-edn ([this] (list* `or args))} - ?Fn {invoke ([_ x] (reduce (c/fn [_ pred] (let [p (pred x)] (c/and p (reduced p)))) - true ; vacuously - args))} - ?Object ;; Tests for structural equivalence - {equals ([this that] - (c/or (== this that) - (c/and (instance? OrSpec that) - (c/= args (.-args ^OrSpec that)))))}}) - -(defns or-spec? [x _ > c/boolean?] (instance? OrSpec x)) - -(defns or-spec>args [x or-spec?] (.-args ^OrSpec x)) - -(defn or - "Sequential/ordered `or`. Analogous to `set/union`. - Applies as much 'compression'/deduplication/simplification as possible to the supplied specs. - Effectively computes the union of the extension of the ->`args`." - [arg & args] - (create-logical-spec :or ->OrSpec or-spec? or-spec>args (cons arg args) (fn1 c/= 1))) - -(uvar/defalias | or) - -;; ===== OR ===== ;; - -(udt/deftype NotSpec [spec #_t/spec?] - {PSpec nil - fipp.ednize/IOverride nil - fipp.ednize/IEdn {-edn ([this] (list `not spec))} - ?Fn {invoke ([_ x] (spec x))} - ?Object ;; Tests for structural equivalence - {equals ([this that] - (c/or (== this that) - (c/and (instance? NotSpec that) - (c/= spec (.-spec ^NotSpec that)))))}}) - -(defns not-spec? [x _ > c/boolean?] (instance? NotSpec x)) - -(defns not-spec>inner-spec [spec not-spec?] (.-spec ^NotSpec spec)) - -(declare nil? val?) - -(defns not [spec spec? > spec?] - (ifs (= spec universal-set) empty-set - (= spec empty-set) universal-set - (= spec val|by-class?) nil? - (not-spec? spec) (not-spec>inner-spec spec) - ;; DeMorgan's Law - (or-spec? spec) (->> spec or-spec>args (uc/lmap not) (apply and)) - ;; DeMorgan's Law - (and-spec? spec) (->> spec and-spec>args (uc/lmap not) (apply or )) - (NotSpec. spec))) - -(uvar/defalias ! not) - -(defns - - "Computes the difference of `s0` from `s1`: (& s0 (! s1)) - If `s0` = `s1`, `∅` - If `s0` < `s1`, `∅` - If `s0` <> `s1`, `s0` - If `s0` > | >< `s1`, `s0` with all elements of `s1` removed" - [s0 spec?, s1 spec? > spec?] - (let [c (compare s0 s1)] - (case c - (0 -1) empty-set - 3 s0 - (1 2) - (let [c0 (c/class s0) c1 (c/class s1)] - ;; TODO add dispatch? - (condp == c0 - NotSpec (condp == (-> s0 not-spec>inner-spec c/class) - ClassSpec (condp == c1 - ClassSpec (AndSpec. [s0 (not s1)] (atom nil))) - ValueSpec (condp == c1 - ValueSpec (AndSpec. [s0 (not s1)] (atom nil)))) - OrSpec (condp == c1 - ClassSpec (let [args (->> s0 or-spec>args (uc/remove (fn1 = s1)))] - (case (count args) - 0 empty-set - 1 (first args) - (OrSpec. args (atom nil)))))))))) - -#_(udt/deftype SequentialSpec) +;; TODO do this? +#_(udt/deftype SequentialType) #_(defns of - "Creates a spec that ... TODO" - [pred (<= iterable?), spec spec?] (TODO)) + "Creates a type that ... TODO" + [pred (<= iterable?), t utr/type?] (TODO)) ;; TODO do this +(do + (udt/deftype FnSpec [name #_(t/? t/symbol?) dispatch ... @@ -637,8 +434,7 @@ ?Meta {meta ([this] meta) with-meta ([this meta'] (FnSpec. name lookup spec meta'))} fipp.ednize/IOverride nil - fipp.ednize/IEdn - {-edn ([this] (list `fn name lookup))}}) + fipp.ednize/IEdn {-edn ([this] (list `fn name lookup))}}) (defns fn-spec? [x _ > c/boolean?] (instance? FnSpec x)) @@ -663,8 +459,10 @@ (->> spec-or-arity-specs (map (TODO)))))))] (FnSpec. name- lookup spec nil))) +) + (defn unkeyed - "Creates an unkeyed collection spec, in which the collection may + "Creates an unkeyed collection type, in which the collection may or may not be sequential or even seqable, but must not have key-value pairs like a map. Examples of unkeyed collections include a vector (despite its associativity), @@ -673,308 +471,12 @@ [x] (TODO)) (defns ? - "Arity 1: Computes a spec denoting a nilable value satisfying `spec`. - Arity 2: Computes whether `x` is nil or satisfies `spec`." - ([spec spec? > spec?] (or nil? spec)) - ([spec spec?, x _ > c/boolean?] (c/or (c/nil? x) (spec x)))) - -;; ===== Comparison ===== ;; - -(defns- compare|todo [s0 spec?, s1 spec?] - (err! "TODO dispatch" {:s0 s0 :s0|type (type s0) - :s1 s1 :s1|type (type s1)})) - -;; ----- Multiple ----- ;; - -(defns- compare|atomic+or [s0 spec?, ^OrSpec s1 or-spec? > comparisons] - (let [specs (.-args s1)] - (first - (reduce - (c/fn [[ret found] s] - (let [c (compare s0 s) - found' (-> found (ubit/conj c) c/long)] - (ifs (c/or (ubit/contains? found' ident) - (ubit/contains? found' <>ident))) - [2 found'] - - [c found']))) - [3 ubit/empty] - specs)))) - -(defns- compare|atomic+and [s0 spec?, ^AndSpec s1 and-spec? > comparisons] - (let [specs (.-args s1)] - (first - (reduce - (c/fn [[ret found] s] - (let [c (compare s0 s)] - (if (c/= c 0) - (reduced [1 nil]) - (let [found' (-> found (ubit/conj c) c/long) - ret' (ifs (ubit/contains? found' >ident)) - 3 - 2) - - (ubit/contains? found' <>ident) - (ifs (ubit/contains? found' ident) 1 - c) - - c)] - [ret' found'])))) - [3 ubit/empty] - specs)))) - -;; ----- UniversalSet ----- ;; - -(def- compare|universal+empty fn>) - -(defns- compare|universal+not [s0 spec?, s1 spec? > comparisons] - (let [s1|inner (not-spec>inner-spec s1)] - (ifs (= s1|inner universal-set) 1 - (= s1|inner empty-set) 0 - (compare s0 s1|inner)))) - -(def- compare|universal+or fn>) -(def- compare|universal+and fn>) -(def- compare|universal+expr compare|todo) -(def- compare|universal+protocol fn>) -(def- compare|universal+class fn>) -(def- compare|universal+value fn>) - -;; ----- EmptySet ----- ;; - -(defns- compare|empty+not [s0 spec?, s1 spec? > comparisons] - (let [s1|inner (not-spec>inner-spec s1)] - (if (= s1|inner universal-set) 0 -1))) - -(def- compare|empty+or fn<) -(def- compare|empty+and fn<) -(def- compare|empty+expr compare|todo) -(def- compare|empty+protocol fn<) -(def- compare|empty+class fn<) -(def- compare|empty+value fn<) - -;; ----- NotSpec ----- ;; - -(defns- compare|not+not [s0 spec?, s1 spec? > comparisons] - (let [c (compare (not-spec>inner-spec s0) (not-spec>inner-spec s1))] - (case c - 0 0 - -1 1 - 1 -1 - 2 2 - 3 2))) - -(defns- compare|not+or [s0 not-spec?, s1 or-spec? > comparisons] - (compare|atomic+or s0 s1)) - -(defns- compare|not+and [s0 not-spec?, s1 and-spec? > comparisons] - (compare|atomic+and s0 s1)) - -(defns- compare|not+protocol [s0 spec?, s1 spec? > comparisons] - (let [s0|inner (not-spec>inner-spec s0)] - (if (= s0|inner empty-set) 1 3))) - -(defns- compare|not+class [s0 spec?, s1 spec? > comparisons] - (let [s0|inner (not-spec>inner-spec s0)] - (if (= s0|inner empty-set) - 1 - (case (compare s0|inner s1) - ( 1 0) 3 - (-1 2) 2 - 3 1)))) - -(defns- compare|not+value [s0 spec?, s1 spec? > comparisons] - (let [s0|inner (not-spec>inner-spec s0)] - (if (= s0|inner empty-set) - 1 - ;; nothing is ever < ValueSpec (and therefore never ><) - (case (compare s0|inner s1) - (1 0) 3 - 3 1)))) - -;; ----- OrSpec ----- ;; - -;; TODO performance can be improved here by doing fewer comparisons -(defns- compare|or+or [^OrSpec s0 or-spec?, ^OrSpec s1 or-spec? > comparisons] - (let [l (->> s0 .-args (seq-and (fn1 < s1))) - r (->> s1 .-args (seq-and (fn1 < s0)))] - (if l - (if r 0 -1) - (if r - 1 - (if (->> s0 .-args (seq-and (fn1 <> s1))) - 3 - 2))))) - -(defns- compare|or+and [^OrSpec s0 or-spec?, ^AndSpec s1 and-spec? > comparisons] - (let [r (->> s1 .-args (seq-and (fn1 < s0)))] - (if r 1 3))) - -(defns- compare|class+or [s0 class-spec?, ^OrSpec s1 or-spec? > comparisons] - (compare|atomic+or s0 s1)) - -(defns- compare|value+or [s0 value-spec?, ^OrSpec s1 or-spec? > comparisons] - (compare|atomic+or s0 s1)) - -;; ----- AndSpec ----- ;; - -(defns- compare|and+and [^AndSpec s0 and-spec?, ^AndSpec s1 and-spec? > comparisons] - (TODO)) - -(defns- compare|class+and [s0 class-spec?, ^AndSpec s1 and-spec? > comparisons] - (compare|atomic+and s0 s1)) - -(defns- compare|value+and [s0 value-spec?, ^AndSpec s1 and-spec? > comparisons] - (compare|atomic+and s0 s1)) - -;; ----- Expression ----- ;; + "Arity 1: Computes a type denoting a nilable value satisfying `t`. + Arity 2: Computes whether `x` is nil or satisfies `t`." + ([t utr/type? > utr/type?] (or nil? t)) + ([t utr/type?, x _ > c/boolean?] (c/or (c/nil? x) (t x)))) -(defns- compare|expr+expr [s0 _, s1 _ > comparisons] (if (c/= s0 s1) 0 3)) - -(def- compare|expr+value fn<>) - -;; ----- ProtocolSpec ----- ;; - -;; TODO transition to `compare|protocol+value` when stable -(defns- compare|value+protocol [s0 value-spec?, s1 protocol-spec? > comparisons] - (let [v (value-spec>value s0) - p (protocol-spec>protocol s1)] - (if (satisfies? p v) -1 3))) - -;; ----- ClassSpec ----- ;; - -(defns- compare|class+value [s0 class-spec?, s1 value-spec? > comparisons] - (let [c (class-spec>class s0) - v (value-spec>value s1)] - (if (instance? c v) 1 3))) - -;; ----- ValueSpec ----- ;; - -(defns- compare|value+value - "What we'd really like is to have a different version of .equals or .equiv - like .equivBehavior in which it returns whether any behavior is different - whatsoever between two objects. For instance, `[52]` behaves differently from - `(list 52)` because `(get [52] 0)` -> `52` while `(get (list 52) 0)` -> `nil`. - - The issue with this is that yes, one could implement a `strict=` that tries to - emulate this behavior, but even though it is implementable for 'transparent' - objects such as collections, it is not for 'opaque' objects, which would - potentially have to have custom equality behavior per class. So we will simply - reluctantly accept whatever `=` tells us as well as the fallout that results. - Thus, `(t/or (t/value []) (t/value (list)))` will result in `(t/value [])`, - which is not ideal but both feasible and better than the alternative." - [s0 value-spec?, s1 value-spec? > comparisons] - (if (c/= (value-spec>value s0) - (value-spec>value s1)) - 0 - 3)) - -;; ----- Dispatch ----- ;; - -;; TODO take away var indirection once done -(def- compare|dispatch - (let [inverted (c/fn [f] (c/fn [s0 s1] (inverse (f s1 s0))))] - {UniversalSetSpec - {UniversalSetSpec #'fn= - EmptySetSpec #'compare|universal+empty - NotSpec #'compare|universal+not - OrSpec #'compare|universal+or - AndSpec #'compare|universal+and - Expression #'compare|universal+expr - ProtocolSpec #'compare|universal+protocol - ClassSpec #'compare|universal+class - ValueSpec #'compare|universal+value} - EmptySetSpec - {UniversalSetSpec (inverted #'compare|universal+empty) - EmptySetSpec #'fn= - NotSpec #'compare|empty+not - OrSpec #'compare|empty+or - AndSpec #'compare|empty+and - Expression #'compare|empty+expr - ProtocolSpec #'compare|empty+protocol - ClassSpec #'compare|empty+class - ValueSpec #'compare|empty+value} - NotSpec - {UniversalSetSpec (inverted #'compare|universal+not) - EmptySetSpec (inverted #'compare|empty+not) - NotSpec #'compare|not+not - OrSpec #'compare|not+or - AndSpec #'compare|not+and - Expression #'fn<> - ProtocolSpec #'compare|not+protocol - ClassSpec #'compare|not+class - ValueSpec #'compare|not+value} - OrSpec - {UniversalSetSpec (inverted #'compare|universal+or) - EmptySetSpec (inverted #'compare|empty+or) - NotSpec (inverted #'compare|not+or) - OrSpec #'compare|or+or - AndSpec #'compare|or+and - Expression #'fn<> - ProtocolSpec #'compare|todo - ClassSpec (inverted #'compare|class+or) - ValueSpec (inverted #'compare|value+or)} - AndSpec - {UniversalSetSpec (inverted #'compare|universal+and) - EmptySetSpec (inverted #'compare|empty+and) - NotSpec #'compare|todo - OrSpec (inverted #'compare|or+and) - AndSpec #'compare|and+and - Expression #'fn<> - ProtocolSpec #'compare|todo - ClassSpec (inverted #'compare|class+and) - ValueSpec (inverted #'compare|value+and)} - ;; TODO review this - Expression - {UniversalSetSpec (inverted #'compare|universal+expr) - EmptySetSpec (inverted #'compare|empty+expr) - NotSpec #'compare|todo - OrSpec #'compare|todo - AndSpec #'compare|todo - Expression #'compare|expr+expr - ProtocolSpec #'compare|todo - ClassSpec #'fn<> ; TODO not entirely true - ValueSpec #'compare|expr+value} - ProtocolSpec - {UniversalSetSpec (inverted #'compare|universal+protocol) - EmptySetSpec (inverted #'compare|empty+protocol) - NotSpec (inverted #'compare|not+protocol) - OrSpec #'compare|todo - AndSpec #'compare|todo - Expression #'fn<> - ProtocolSpec (c/fn [s0 s1] (if (identical? (protocol-spec>protocol s0) - (protocol-spec>protocol s1)) - 0 - 3)) - ClassSpec #'compare|todo - ValueSpec (inverted #'compare|value+protocol)} - ClassSpec - {UniversalSetSpec (inverted #'compare|universal+class) - EmptySetSpec (inverted #'compare|empty+class) - NotSpec (inverted #'compare|not+class) - OrSpec #'compare|class+or - AndSpec #'compare|class+and - Expression #'fn<> - ProtocolSpec #'compare|todo - ClassSpec (c/fn [s0 s1] (compare|class|class* (class-spec>class s0) (class-spec>class s1))) - ValueSpec #'compare|class+value} - ValueSpec - {UniversalSetSpec (inverted #'compare|universal+value) - EmptySetSpec (inverted #'compare|empty+value) - NotSpec (inverted #'compare|not+value) - OrSpec #'compare|value+or - AndSpec #'compare|value+and - Expression (inverted #'compare|expr+value) - ProtocolSpec #'compare|value+protocol - ClassSpec (inverted #'compare|class+value) - ValueSpec #'compare|value+value}})) +;; ===== Etc. ===== ;; #?(:clj (def boxed-class->unboxed-symbol @@ -991,47 +493,47 @@ #?(:clj (def primitive-classes (->> unboxed-symbol->type-meta vals (uc/map+ :unboxed) (join #{})))) -(defns- -spec>classes [spec spec?, classes c/set? > (s/set-of (s/nilable c/class?))] - (cond (class-spec? spec) - (conj classes (class-spec>class spec)) - (value-spec? spec) - (conj classes (value-spec>value spec)) - (c/= spec universal-set) +(defns- -type>classes [t utr/type?, classes c/set? > (s/set-of (s/nilable c/class?))] + (cond (utr/class-type? t) + (conj classes (utr/class-type>class t)) + (utr/value-type? t) + (conj classes (utr/value-type>value t)) + (c/= t universal-set) #?(:clj #{nil java.lang.Object} :cljs (TODO "Not sure what to do in the case of universal CLJS set")) - (c/= spec empty-set) + (c/= t empty-set) #{} - (and-spec? spec) - (reduce (c/fn [classes' spec'] (-spec>classes spec' classes')) - classes (and-spec>args spec)) - (or-spec? spec) - (reduce (c/fn [classes' spec'] (-spec>classes spec' classes')) - classes (or-spec>args spec)) + (utr/and-type? t) + (reduce (c/fn [classes' t'] (-type>classes t' classes')) + classes (utr/and-type>args t)) + (utr/or-type? t) + (reduce (c/fn [classes' t'] (-type>classes t' classes')) + classes (utr/or-type>args t)) :else - (err! "Not sure how to handle spec" spec))) + (err! "Not sure how to handle type" t))) -(defns spec>classes - "Outputs the set of all the classes ->`spec` can embody according to its various conditional branches, - if any. Ignores nils, treating in Clojure simply as a `java.lang.Object`." - [spec spec? > (s/set-of (s/nilable c/class?))] (-spec>classes spec #{})) +(defns type>classes + "Outputs the set of all the classes ->`t` can embody according to its various conditional + branches, if any. Ignores nils, treating in Clojure simply as a `java.lang.Object`." + [t utr/type? > (s/set-of (s/nilable c/class?))] (-type>classes t #{})) #?(:clj -(defns- -spec>?class-value [spec spec?, spec-nilable? c/boolean?] - (if (value-spec? spec) - (let [v (value-spec>value spec)] - (when (c/class? v) {:class v :nilable? spec-nilable?})) +(defns- -type>?class-value [t utr/type?, type-nilable? c/boolean?] + (if (utr/value-type? t) + (let [v (utr/value-type>value t)] + (when (c/class? v) {:class v :nilable? type-nilable?})) nil))) #?(:clj -(defns spec>?class-value - "Outputs the single class value embodied by ->`spec`. - If a spec is extensionally equal the *value* of a class, outputs that class. +(defns type>?class-value + "Outputs the single class value embodied by ->`t`. + If a type is extensionally equal the *value* of a class, outputs that class. - However, if a spec does not embody the value of a class but rather merely embodies (as all specs) + However, if a type does not embody the value of a class but rather merely embodies (as all types) an extensional subset of the set of all objects conforming to a class, outputs nil." - {:examples `{(spec>?class-value (value String)) {:class String :nilable? false} - (spec>?class-value (isa? String)) nil}} - [spec spec?] (-spec>?class-value spec false))) + {:examples `{(type>?class-value (value String)) {:class String :nilable? false} + (type>?class-value (isa? String)) nil}} + [t utr/type?] (-type>?class-value t false))) ;; ---------------------- ;; ;; ===== Predicates ===== ;; @@ -1086,6 +588,7 @@ (value Long/TYPE) (value Float/TYPE) (value Double/TYPE)))) + ;; TODO for CLJS #?(:clj (-def protocol? (>expr (ufn/fn-> :on-interface class?)))) ;; ===== Primitives ===== ;; @@ -1170,9 +673,9 @@ #_(-def int-like? (and integer-value? numerically-int?)) #_(defn numerically - [spec] - (assert (instance? ClassSpec spec)) - (let [c (.-c ^ClassSpec spec)] + [t] + (assert (utr/class-type? t)) + (let [c (.-c ^ClassType t)] (case (.getName ^Class c) "java.lang.Byte" numerically-byte? "java.lang.Short" numerically-short? @@ -1182,7 +685,7 @@ "java.lang.Float" numerically-float? ;; TODO fix ;;"java.lang.Double" numerically-double? - (err! "Could not find numerical range spec for class" {:c c})))) + (err! "Could not find numerical range type for class" {:c c})))) ;; ========== Collections ========== ;; @@ -1222,7 +725,7 @@ ;; dense integer values), not extensible #?(:clj -(defns >array-nd-type [kind c/symbol?, n utpred/pos-int? > class-spec?] +(defns >array-nd-type [kind c/symbol?, n utpred/pos-int? > utr/class-type?] (let [prefix (apply str (repeat n \[)) letter (case kind boolean "Z" @@ -1237,7 +740,7 @@ (isa? (Class/forName (str prefix letter)))))) #?(:clj -(defns >array-nd-types [n utpred/pos-int? > spec?] +(defns >array-nd-types [n utpred/pos-int? > utr/type?] (->> '[boolean byte char short int long float double object] (map #(>array-nd-type % n)) (apply or)))) @@ -2095,7 +1598,7 @@ (-def ifn? (isa? #?(:clj clojure.lang.IFn :cljs cljs.core/IFn))) - (-def fnt? (and fn? (>expr (fn-> c/meta :spec)))) + (-def fnt? (and fn? (>expr (fn-> c/meta :type)))) (-def multimethod? (isa? #?(:clj clojure.lang.MultiFn :cljs cljs.core/IMultiFn))) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index 2ff311a2..a2ed80f3 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -10,6 +10,7 @@ [quantum.untyped.core.classes :as uclass] [quantum.untyped.core.compare :refer [==]] + [quantum.untyped.core.core :as ucore] [quantum.untyped.core.data.bits :as ubit] [quantum.untyped.core.defnt :refer [defns defns-]] @@ -37,6 +38,8 @@ ProtocolType ClassType ValueType]))) +(ucore/log-this-ns) + (declare compare < <= = not= >= > >< <>) ;; ===== (Comparison) idents ===== ;; @@ -54,8 +57,9 @@ (def- fn<> (fn' <>ident)) (def comparisons #{ident >ident}) +(def comparison? comparisons) -(defns inverse [comparison comparisons > comparisons] +(defns inverse [comparison comparison? > comparison?] (case comparison -1 >ident 1 comparisons] +(defns- compare|atomic+or [t0 type?, ^OrType t1 or-type? > comparison?] (let [ts (.-args t1)] (first (reduce @@ -89,7 +93,7 @@ [<>ident ubit/empty] ts)))) -(defns- compare|atomic+and [t0 type?, ^AndType t1 and-type? > comparisons] +(defns- compare|atomic+and [t0 type?, ^AndType t1 and-type? > comparison?] (let [ts (.-args t1)] (first (reduce @@ -117,7 +121,7 @@ (def- compare|universal+empty fn>) -(defns- compare|universal+not [t0 type?, t1 not-type? > comparisons] +(defns- compare|universal+not [t0 type?, t1 not-type? > comparison?] (let [t1|inner (utr/not-type>inner-type t1)] (ifs (= t1|inner universal-set) >ident (= t1|inner empty-set) =ident @@ -132,7 +136,7 @@ ;; ----- EmptySet ----- ;; -(defns- compare|empty+not [t0 type?, t1 not-type? > comparisons] +(defns- compare|empty+not [t0 type?, t1 not-type? > comparison?] (let [t1|inner (utr/not-type>inner-type t1)] (if (= t1|inner universal-set) =ident comparisons] +(defns- compare|not+not [t0 not-type?, t1 not-type? > comparison?] (let [c (compare (utr/not-type>inner-type t0) (utr/not-type>inner-type t1))] (case c 0 =ident @@ -158,11 +162,11 @@ (def- compare|not+and compare|atomic+and) -(defns- compare|not+protocol [t0 not-type?, t1 protocol-type? > comparisons] +(defns- compare|not+protocol [t0 not-type?, t1 protocol-type? > comparison?] (let [t0|inner (utr/not-type>inner-type t0)] (if (= t0|inner empty-set) >ident <>ident))) -(defns- compare|not+class [t0 not-type?, t1 class-type? > comparisons] +(defns- compare|not+class [t0 not-type?, t1 class-type? > comparison?] (let [t0|inner (utr/not-type>inner-type t0)] (if (= t0|inner empty-set) >ident @@ -171,7 +175,7 @@ (-1 2) >ident)))) -(defns- compare|not+value [t0 not-type?, t1 value-type? > comparisons] +(defns- compare|not+value [t0 not-type?, t1 value-type? > comparison?] (let [t0|inner (utr/not-type>inner-type t0)] (if (= t0|inner empty-set) >ident @@ -183,7 +187,7 @@ ;; ----- OrType ----- ;; ;; TODO performance can be improved here by doing fewer comparisons -(defns- compare|or+or [^OrType t0 or-type?, ^OrType t1 or-type? > comparisons] +(defns- compare|or+or [^OrType t0 or-type?, ^OrType t1 or-type? > comparison?] (let [l (->> t0 .-args (seq-and (fn1 < t1))) r (->> t1 .-args (seq-and (fn1 < t0)))] (if l @@ -194,7 +198,7 @@ <>ident > comparisons] +(defns- compare|or+and [^OrType t0 or-type?, ^AndType t1 and-type? > comparison?] (let [r (->> t1 .-args (seq-and (fn1 < t0)))] (if r >ident <>ident))) @@ -203,7 +207,7 @@ ;; ----- AndType ----- ;; -(defns- compare|and+and [^AndType t0 and-type?, ^AndType t1 and-type? > comparisons] +(defns- compare|and+and [^AndType t0 and-type?, ^AndType t1 and-type? > comparison?] (TODO)) (def- compare|class+and compare|atomic+and) @@ -211,19 +215,19 @@ ;; ----- Expression ----- ;; -(defns- compare|expr+expr [t0 _, t1 _ > comparisons] (if (c/= t0 t1) =ident <>ident)) +(defns- compare|expr+expr [t0 _, t1 _ > comparison?] (if (c/= t0 t1) =ident <>ident)) (def- compare|expr+value fn<>) ;; ----- ProtocolType ----- ;; -(defns- compare|protocol+protocol [t0 protocol-type?, t1 protocol-type? > comparisons] +(defns- compare|protocol+protocol [t0 protocol-type?, t1 protocol-type? > comparison?] (if (== (utr/protocol-type>protocol t0) (utr/protocol-type>protocol t1)) =ident <>ident)) ;; TODO transition to `compare|protocol+value` when stable -(defns- compare|value+protocol [t0 value-type?, t1 protocol-type? > comparisons] +(defns- compare|value+protocol [t0 value-type?, t1 protocol-type? > comparison?] (let [v (utr/value-type>value t0) p (utr/protocol-type>protocol t1)] (if (satisfies? p v) ident))) @@ -245,7 +249,7 @@ `3` means their generality/specificity is incomparable: - ✓ `(t/<> c0 c1)` : the extension of ->`c0` is disjoint w.r.t. to that of ->`c1`. Unboxed primitives are considered to be less general (more specific) than boxed primitives." - [^Class c0 class? ^Class c1 class? > comparisons] + [^Class c0 class? ^Class c1 class? > comparison?] #?(:clj (ifs (== c0 c1) =ident (== c0 Object) >ident (== c1 Object) ident) :cljs (TODO))) -(defns- compare|class+class [t0 class-type?, t1 class-type? > comparisons] +(defns- compare|class+class [t0 class-type?, t1 class-type? > comparison?] (compare|class+class* (utr/class-type>class t0) (utr/class-type>class t1))) -(defns- compare|class+value [t0 class-type?, t1 value-type? > comparisons] +(defns- compare|class+value [t0 class-type?, t1 value-type? > comparison?] (let [c (utr/class-type>class t0) v (utr/value-type>value t1)] (if (instance? c v) >ident <>ident))) @@ -286,7 +290,7 @@ reluctantly accept whatever `=` tells us as well as the fallout that results. Thus, `(t/or (t/value []) (t/value (list)))` will result in `(t/value [])`, which is not ideal but both feasible and better than the alternative." - [t0 value-type?, t1 value-type? > comparisons] + [t0 value-type?, t1 value-type? > comparison?] (if (c/= (utr/value-type>value t0) (utr/value-type>value t1)) =ident @@ -401,7 +405,7 @@ Does not compare cardinalities or other relations of sets, but rather only sub/superset relations." - [t0 type?, t1 type? > comparisons] + [t0 type?, t1 type? > comparison?] (let [dispatched (-> compare|dispatch (get (type t0)) (get (type t1)))] (if (nil? dispatched) (err! (str "Types not handled: " {:t0 t0 :t1 t1}) {:t0 t0 :t1 t1}) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index ffafb40b..d3be23ab 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -7,14 +7,14 @@ #?@(:cljs [:refer [Expression]])] [quantum.untyped.core.compare :refer [== not==]] + [quantum.untyped.core.core :as ucore] [quantum.untyped.core.defnt :refer [defns]] [quantum.untyped.core.form.generate.deftype :as udt]) #?(:clj (:import [quantum.untyped.core.analyze.expr Expression]))) -(defonce *type-registry (atom {})) -(swap! *type-registry empty) +(ucore/log-this-ns) (defprotocol PType) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc new file mode 100644 index 00000000..e3a98aae --- /dev/null +++ b/test/quantum/test/untyped/core/type.cljc @@ -0,0 +1,2 @@ +(ns quantum.test.untyped.core.type) + From f25d7c7004549328a013bca48004f24b316bb9a1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 16 May 2018 15:22:39 -0600 Subject: [PATCH 044/810] Update documentation --- doc/cljc/quantum/core/defnt.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/cljc/quantum/core/defnt.md b/doc/cljc/quantum/core/defnt.md index 19b64894..e934e19b 100644 --- a/doc/cljc/quantum/core/defnt.md +++ b/doc/cljc/quantum/core/defnt.md @@ -40,7 +40,7 @@ public class NumberLessThan7 { public final Number x; public NumberLessThan7 (Number x_) { - if (lessThan(x_, 7)) {// imagine here a `lessThan` function that worked on any two numbers + if (lessThan(x_, 7)) {// imagine here a `lessThan` function that worked on any two `Number`s x = x_; } else { throw new Exception("Number must be less than 7"); From ada1c5c4d385050d5e31d24e5572b90dbb1d8ed5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 16 May 2018 15:22:51 -0600 Subject: [PATCH 045/810] t/fn should not be macro --- src-dev/quantum/core/defnt_equivalences.cljc | 38 ++++++++++---------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index a71e8a2e..af750017 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -48,7 +48,7 @@ ;; ----- expanded code ----- ;; ($ (do (swap! *fn->spec assoc #'pid - (t/fn [~'> (? t/string?)])) + (t/fn [:> (? t/string?)])) (def ~'pid|__0 (reify >Object @@ -129,9 +129,9 @@ ;; ----- expanded code ----- ;; ($ (do (swap! *fn->spec assoc #'name - (t/fn [t/string? > t/string?] - [(t/isa? Named) > (* t/string?)] - [(t/isa? INamed) > (* t/string?)])) + (t/fn [t/string? :> t/string?] + [(t/isa? Named) :> (* t/string?)] + [(t/isa? INamed) :> (* t/string?)])) ~@(case (env-lang) :clj ($ [;; Only direct dispatch for primitives or for Object, not for subclasses of Object @@ -446,8 +446,8 @@ ;; ----- expanded code ----- ;; `(do (swap! fn->spec assoc #'!str - (t/fn > #?(:clj (t/isa? StringBuilder) - :cljs (t/isa? StringBuffer)) + (t/fn :> #?(:clj (t/isa? StringBuilder) + :cljs (t/isa? StringBuffer)) [] #?(:clj [t/string?]) [#?(:clj (t/or t/char-seq? t/int?) @@ -489,8 +489,8 @@ ;; ----- expanded code ----- ;; `(do (swap! fn->spec assoc #'> - (t/fn #?(:clj [t/comparable-primitive? t/comparable-primitive? > t/boolean?] - :cljs [t/double? t/double? > (t/assume t/boolean?)]))) + (t/fn #?(:clj [t/comparable-primitive? t/comparable-primitive? :> t/boolean?] + :cljs [t/double? t/double? :> (t/assume t/boolean?)]))) ~(case-env :clj `(do (def >|__0 @@ -584,8 +584,8 @@ [] [t/nil?] #?(:clj [(t/isa? Object)]) -#?(:cljs [t/any? > (t/assume t/string?)]) - [(t/fn> str t/any?) & (? (t/seq-of t/any?)) #?@(:cljs [> (t/assume t/string?)])])) +#?(:cljs [t/any? :> (t/assume t/string?)]) + [(t/fn> str t/any?) :& (? (t/seq-of t/any?)) #?@(:cljs [:> (t/assume t/string?)])])) ~(case-env :clj `(do (def str|__0 @@ -627,10 +627,10 @@ ;; ----- expanded code ----- ;; `(do (swap! fn->spec assoc #'count - (t/fn > t/pos-integer? - [t/array? > t/nneg-int?] - [t/string? > #?(:clj t/nneg-int? :cljs (t/assume t/nneg-int?))] - [!+vector? > t/nneg-int?])) + (t/fn :> t/pos-integer? + [t/array? :> t/nneg-int?] + [t/string? :> #?(:clj t/nneg-int? :cljs (t/assume t/nneg-int?))] + [!+vector? :> t/nneg-int?])) ~(case-env :clj `(do ;; `array?` @@ -651,7 +651,7 @@ ;; ----- expanded code ----- ;; `(do (swap! fn->spec assoc #'count - (t/fn > t/pos-integer? + (t/fn :> t/pos-integer? [t/array? (t/numerically t/int?)] [t/string? (t/numerically t/int?)] [!+vector? t/any?])) @@ -777,9 +777,9 @@ ;; TODO: conditionally optional arities etc. for t/fn (t/def rf? "Reducing function" - (t/fn ("seed arity" []) - ("completing arity" [_]) - ("reducing arity" [_ _]))) + (t/fn "seed arity" [] + "completing arity" [_] + "reducing arity" [_ _])) (defnt reduce "Much of this content taken from clojure.core.protocols for inlining and @@ -889,7 +889,7 @@ ;; =====|=====|=====|=====|===== ;; (do (t/def xf? "Transforming function" - (t/fn [rf? > rf?])) + (t/fn [rf? :> rf?])) (defnt transduce ([ f rf?, xs t/reducible?] (transduce identity f xs)) From 393b4b24023b5eae6e6ff5eccd72077bb90f8381 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 16 May 2018 15:23:02 -0600 Subject: [PATCH 046/810] Remove largely useless test code --- test/quantum/test/core/defnt.cljc | 460 ------------------------------ 1 file changed, 460 deletions(-) diff --git a/test/quantum/test/core/defnt.cljc b/test/quantum/test/core/defnt.cljc index f0d3b82b..f3b80724 100644 --- a/test/quantum/test/core/defnt.cljc +++ b/test/quantum/test/core/defnt.cljc @@ -417,319 +417,10 @@ (xp/condpf-> t/<= (xp/get 2) t/long? t/long?))))))) -(deftest test|analyze-seq|do - (is= (analyze '(do)) - (ast/do {:env {} - :form '(do) - :body [] - :spec t/nil?})) - (is= (analyze '(do 1)) - (ast/do {:env {} - :form '(do 1) - :body [1] - :spec (t/value 1)})) - (is= (analyze '(do 1 "a")) - (ast/do {:env {} - :form '(do 1 "a") - :body [1 "a"] - :spec (t/value "a")}))) - -(deftest test|analyze - (testing "symbol" - (testing "unbound" - (is= (analyze {'c (ast/unbound 'c)} 'c) - (ast/unbound 'c)))) - (testing "static call" - (testing "literal arguments" - (is= (analyze '(Numeric/bitAnd 1 2)) - (ast/macro-call - {:form '(Numeric/bitAnd 1 2), - :expanded (ast/method-call - {:env {} - :form '(. Numeric bitAnd 1 2) - :target (ast/symbol 'Numeric t/class?) - :method 'bitAnd - :args [(ast/literal 1 (t/value 1)) - (ast/literal 2 (t/value 2))] - :spec t/long?}) ;; TODO more specific than this? - :spec t/long?})) ;; TODO more specific than this? - (throws (analyze '(Numeric/bitAnd 1.0 2.0)) - (fn-and (fn-> :message (= "No matching clause found")) - (fn-> :data (= {:v (t/value 1.0)})))) - (throws (analyze '(Numeric/bitAnd 1.0 2)) - (fn-and (fn-> :message (= "No matching clause found")) - (fn-> :data (= {:v (t/value 1.0)})))) - (throws (analyze '(Numeric/bitAnd 1 2.0)) - (fn-and (fn-> :message (= "No matching clause found")) - (fn-> :data (= {:v (t/value 2.0)})))) - (throws (analyze '(Numeric/bitAnd "" 2.0)) - (fn-and (fn-> :message (= "No matching clause found")) - (fn-> :data (= {:v (t/value "")})))) - (throws (analyze '(Numeric/bitAnd nil 2.0)) - (fn-and (fn-> :message (= "No matching clause found")) - (fn-> :data (= {:v t/nil?})))) - - (is= (analyze '(byte 1)) - (ast/macro-call - {:form '(byte 1) - :expanded (ast/method-call - {:env {} - :form '(. clojure.lang.RT (uncheckedByteCast 1)) - :target (ast/symbol 'clojure.lang.RT t/class?) - :method 'uncheckedByteCast - :args [(ast/literal 1 t/long?)] - :spec t/byte?}) - :spec t/byte?})) - (throws (analyze '(byte "")) ; TODO fix - (fn-> :message (= "Spec assertion failed")))) - (testing "unbound arguments" - (analyze {'a (ast/unbound 'a)} - '(Numeric/isZero a))))) - -(let* [a 1 b (byte 2)] - a - (Numeric/add c (Numeric/bitAnd a b))) - -(deftest fnt|overload-data>overload-group - (is= (this/fnt|overload-data>overload-group - {::this/fnt|arglist - {:pre nil :post nil - :args [{:arg-binding 'x - ::this/fnt|arg-spec [:spec 't/string?]}] :varargs nil} - :body []} - {:lang :clj}) - {:unprimitivized - {:arglist-code|reify|unhinted '[x] - :arg-classes [java.lang.Object] - :arglist-code|fn|hinted [(tag "java.lang.Object" 'x)], - :body-form ($ (let* [~(tag "java.lang.String" 'x) ~'x] nil)) - :positional-args-ct 1 - :variadic? false - :arg-specs [t/string?] - :out-spec (t/value nil) - :out-class java.lang.Object} - :primitivized nil})) - -;; For any unquoted seq-expression E that has at least one leaf: -;; if E is an expression whose type must be inferred: -;; if E has not reached stability (stability = only one reified, TODO what about abstracts?) -;; E's type must itself be inferred - -#_(let [gen-unbound - #(!ref (->type-info - {:reifieds #{} - :infer? true})) - gen-expected - (fn [env ast] - [env ast] - #_(->expr-info - {:env env - :form form - :type-info - (->type-info type-info)}))] - #_(let [env {'a (gen-unbound) - 'b (gen-unbound)} - form '(and:boolean a b)] - (is= (->typed env form) - (gen-expected form env - {:reifieds #{boolean} - :abstracts #{#_...} - #_:conditionals - #_{boolean {boolean #{boolean}}}}))) - #_(let [env {'a (gen-unbound)} - form '(Numeric/isZero a)] - (is= (-> (->typed env form) - (assoc-in [:type-info :fn-types] nil)) - (gen-expected - {'a (!ref (t/ast 'a ? (t/or t/byte t/char t/short t/int t/long t/float t/double)))} - (t/ast '(. Numeric isZero a) (t/fn' t/boolean))))) - #_(let [env {'a (gen-unbound) - 'b (gen-unbound)} - form '(Numeric/bitAnd a b)] - (is= nil #_(->typed env form) - (gen-expected - {'a (!ref (t/ast 'a ? (t/or t/byte t/char t/short t/int t/long))) - 'b (!ref (t/ast 'b ? (t/or t/byte t/char t/short t/int t/long)))} - (t/ast '(. Numeric bitAnd a b) - ;; TODO make spec fns easily editable - (t/spec [[a0 a1]] ; input is sequence of arg-specs; return value is spec - (condp = a0 - ;; TODO use map lookup? - t/byte (condp = a1 - t/byte t/byte - t/char t/char - t/short t/short - t/int t/int - t/long t/long) - t/char (condp = a1 - t/byte t/char - t/char t/char - t/short t/short - t/int t/int - t/long t/long) - t/short (condp = a1 - t/byte t/short - t/char t/short - t/short t/short - t/int t/int - t/long t/long) - t/int (condp = a1 - t/byte t/int - t/char t/int - t/short t/int - t/int t/int - t/long t/long) - t/long (condp = a1 - t/byte t/long - t/char t/long - t/short t/long - t/int t/long - t/long t/long))))))) - - (let [env {'a (gen-unbound) - 'b (gen-unbound)} - form '(Numeric/negate (Numeric/bitAnd a b))] - (is= #_(->typed env form) - (gen-expected form - {'a (!ref (t/ast 'a ? ...)) - 'b (!ref (t/ast 'b ? ...))} - (t/ast '(. Numeric bitAnd a b)) - {:reifieds #{byte char short int long} - :abstracts #{...}}))) - #_(let [env {'a (gen-unbound) - 'b (gen-unbound)} - form '(negate:int|long (Numeric/bitAnd a b))] - ;; Because the only valid argtypes to `negate:int|long` are S = #{[int] [long]}, - ;; `Numeric/bitAnd` must only accept argtypes that produce a subset of S - ;; The argtypes to `Numeric/bitAnd` that produce a subset of S are: - #_#{[byte int] - [byte long] - [char int] - [char long] - [short int] - [short long] - [int byte] - [int char] - [int short] - [int int] - [int long] - [long byte] - [long char] - [long short] - [long int] - [long long]} - ;; So `a`, then, can be: - #_#{byte char short int long} - ;; and likewise `b` can be: - #_#{byte char short int long} - (is= (->typed env form) - (gen-expected form - {'a (!ref (->type-info - {:reifieds #{byte char short int long} - :fn-types {} - :infer? true})) - 'b (!ref (->type-info - {:reifieds #{byte char short int long} - :fn-types {} - :infer? true}))} - {:reifieds #{int long} - :abstracts #{...}})))) - -(def ff this/fn-type-satisfies-expr?) - -(deftest test|fn-type-satisfies-expr? - (is= (ff ))) - -(defn test|->typed|literal-equivalence [f formf] - (testing "nil" - (is= (f nil) - (->expr-info {:env {} :form (formf nil) - :type-info (->type-info {:reifieds #{:nil}})}))) - (testing "numbers" - (is= (f 1) - (->expr-info {:env {} :form (formf 1) - :type-info (->type-info {:reifieds #{Long/TYPE}})})) - (is= (f 1.0) - (->expr-info {:env {} :form (formf 1.0) - :type-info (->type-info {:reifieds #{Double/TYPE}})})) - (is= (f 1N) - (->expr-info {:env {} :form (formf 1N) - :type-info (->type-info {:reifieds #{clojure.lang.BigInt}})})) - (is= (f 1M) - (->expr-info {:env {} :form (formf 1M) - :type-info (->type-info {:reifieds #{java.math.BigDecimal}})}))) - (testing "string" - (is= (f "abc") - (->expr-info {:env {} :form (formf "abc") - :type-info (->type-info {:reifieds #{String}})}))) - (testing "keyword" - (is= (f :abc) - (->expr-info {:env {} :form (formf :abc) - :type-info (->type-info {:reifieds #{Keyword}})})))) - -(deftest test|->typed|literals - (test|->typed|literal-equivalence ->typed identity)) - -(deftest test|->typed|do - (testing "Base case" - (is= (->typed '(do)) - (->expr-info {:env {} :form nil - :type-info (->type-info {:reifieds #{:nil}})}))) - (testing "Literals" - (test|->typed|literal-equivalence #(->typed (list 'do %)) #(list 'do %)))) - -(deftest test|->typed|let - (testing "Base case" - (is= (->typed '(let [])) - (->expr-info {:env {} :form '(let* [] (do))}))) - (testing "Literals" - (test|->typed|literal-equivalence - #(->typed (list 'let* '[a nil] %)) - #(list 'let* '[a nil] (list 'do %)))) - ) - -(def ->typed:if:test-cases -; pruning?, true-form, false-form, branch - {false {2 {3 {true (fn [pred true-form false-form] - (->expr-info {:env {} - :form (list 'if pred true-form false-form) - :type-info (->type-info {:reifieds #{Long/TYPE}})})) - false (fn [pred true-form false-form] - (->expr-info {:env {} - :form (list 'if pred true-form false-form) - :type-info (->type-info {:reifieds #{Long/TYPE}})}))}}} - true {2 {3 {true (fn [pred true-form false-form] - (->expr-info {:env {} - :form true-form - :type-info (->type-info {:reifieds #{Long/TYPE}})})) - false (fn [pred true-form false-form] - (->expr-info {:env {} - :form false-form - :type-info (->type-info {:reifieds #{Long/TYPE}})}))}}}}) - (def truthy-objects [1 1.0 1N 1M "abc" :abc]) (def falsey-objects [nil]) (def objects {true truthy-objects false falsey-objects}) -(deftest test|->typed|if - (testing "Syntax" - (throws (->typed '(if))) - (throws (->typed '(if 1))) - (throws (->typed '(if 1 2)))) - (testing "Literals" - (doseq [pruning? [true false] - true-form [2] - false-form [3] - branch [true false]] - (testing (istr "conditional branch pruning = ~{pruning?}; form = ~{(list 'if true-form false-form)}; branch = ~{branch}") - (binding [this/*conditional-branch-pruning?* pruning?] - (doseq [pred (get objects branch)] - (is= (->typed (list 'if pred true-form false-form)) - ((get-in ->typed|if|test-cases [pruning? true-form false-form branch]) - pred true-form false-form)))))))) - - - ;; ----- Overload resolution ----- ; TODO use logic programming and variable unification e.g. `?1` `?2` ? @@ -783,11 +474,6 @@ `reduce-count` is 36.824665 ms - twice as fast"} [xs] (reduce count|rf xs)) -(defnt ^:inline name - ([x string?] x) - #?(:clj ([x Named ] (.getName x)) - :cljs ([x INamed ] (-name x)))) - ; the order encountered is the preferred order in case of ambiguity ; Some things tracked include arity of function, arguments to function, etc. ; Lazily compiled; will cause a chain reaction of compilations @@ -844,44 +530,6 @@ #?(:cljs ([x array-1d? , k js-integer? ] (core/aget x k))) #?(:clj ([x ? , k ? ] (Array/get x k)))) -(defnt transformer - "Given a reducible collection, and a transformation function transform, - returns a reducible collection, where any supplied reducing - fn will be transformed by transform. transform is a function of reducing fn to - reducing fn." - ([xs reducible?, xf xfn?] - (if (instance? Transformer xs) - (Transformer. (.-xs ^Transformer xs) xs xf) - (Transformer. xs xs xf)))) - -(defnt transducer->transformer - "Converts a transducer into a transformer." - {:todo #{"More arity"}} - ([n ?, xf xfn?] - (case n - 0 (fn ([] (xf)) - ([xs] (transformer xs (xf)))) - 1 (fn ([a0] (xf a0)) - ([a0 xs] (transformer xs (xf a0)))) - 2 (fn ([a0 a1] (xf a0 a1)) - ([a0 a1 xs] (transformer xs (xf a0 a1)))) - 3 (fn ([a0 a1 a2] (xf a0 a1 a2)) - ([a0 a1 a2 xs] (transformer xs (xf a0 a1 a2)))) - (throw (ex-info "Unhandled arity for transducer" nil))))) - -(defnt map|transducer [f ?] - ; TODO what does this actually entail? should it be that it errors on `f`s that don't implement *all* possible arities? - (fnt [rf ?] - (fn ; TODO auto-generate? ; TODO `fnt` ? - ([] (rf)) - ([ret] (rf ret)) - ([ret x0] (rf ret (f x0))) - ([ret x0 x1] (rf ret (f x0 x1))) - ([ret x0 x1 x2] (rf ret (f x0 x1 x2))) - ([ret x0 x1 x2 & xs] (rf ret (apply f x0 x1 x2 xs)))))) - -(def map+ (transducer->transformer 1 map|transducer)) - (defnt get-in* ([x ? k0 ?] (get x k0)) ([x ? k0 ? k1 ?] (Array/get x k0 k1)) @@ -904,91 +552,6 @@ ... [IPersistentVector long long]] -(defonce *interfaces (atom {})) - -; IF AN EAGER RESULT: - -; +* 0 arity -(definterface long•I (^long invoke [])) - -; `+*` 1 arity -(definterface byte•I•byte (^byte invoke [^byte a0])) -(definterface char•I•char (^char invoke [^char a0])) -(definterface int•I•int (^int invoke [^int a0])) -(definterface long•I•long (^long invoke [^long a0])) -(definterface float•I•float (^float invoke [^float a0])) -(definterface double•I•double (^double invoke [^double a0])) - -; `+*` 2-arity -(definterface byte•I•byte (^byte invoke [^byte a0 ...])) -(definterface char•I•char (^char invoke [^char a0 ...])) -(definterface int•I•int (^int invoke [^int a0 ...])) -(definterface long•I•long (^long invoke [^long a0 ...])) -(definterface float•I•float (^float invoke [^float a0 ...])) -(definterface double•I•double (^double invoke [^double a0 ...])) -(definterface double•I•double (^double invoke [^double a0 ...])) -... - -; `+*` 2-arity variadic -? - -(definterface boolean•I•byte (^boolean invoke [^byte a0])) -(or (get @*interfaces 'boolean•I•byte) (swap! *interfaces assoc 'boolean•I•byte boolean•I•byte)) -(definterface boolean•I•char (^boolean invoke [^char a0])) -(or (get @*interfaces 'boolean•I•char) (swap! *interfaces assoc 'boolean•I•char boolean•I•char)) -(definterface boolean•I•int (^boolean invoke [^int a0])) -(swap! *interfaces assoc 'boolean•I•byte boolean•I•byte) -(definterface boolean•I•long (^boolean invoke [^long a0])) -(swap! *interfaces assoc 'boolean•I•byte boolean•I•byte) -(definterface boolean•I•float (^boolean invoke [^float a0])) -(swap! *interfaces assoc 'boolean•I•byte boolean•I•byte) -(definterface boolean•I•double (^boolean invoke [^double a0])) -(swap! *interfaces assoc 'boolean•I•byte boolean•I•byte) - -(def zero? (reify boolean•I•byte (^boolean invoke [this ^byte n] (Numeric/isZero n)) - boolean•I•char (^boolean invoke [this ^char n] (Numeric/isZero n)) - boolean•I•int (^boolean invoke [this ^int n] (Numeric/isZero n)) - boolean•I•long (^boolean invoke [this ^long n] (Numeric/isZero n)) - boolean•I•float (^boolean invoke [this ^float n] (Numeric/isZero n)) - boolean•I•double (^boolean invoke [this ^double n] (Numeric/isZero n)))) - -(defnt zero? [n ?] (Numeric/isZero n)) - - - - - - - -(defnt zero? ([n long] (Numeric/isZero n))) - -(defn zero?) - -(defnt zero? ([n ?] (Numeric/isZero n))) -(zero? 1) - -(let [^boolean•I•double z zero?] (.invoke z 3.0)) ; it's just a simple reify - -#_(defnt even? - [n ?] (zero? (bit-and n 1))) -#_=> -(def even? (reify )) - -; Normally `zero?` when passed e.g. as a higher-order function might be like - -;; ----- Spec'ed `defnt+`s ----- - -;; One thing that would be nice is to marry `defnt` with `clojure.spec`. -;; We want the specs to be reflected in the parameter declaration, type hints, and so on. -;; -;; We also want it to know about e.g., since a function returns `(< 5 x 100)`, then x must -;; be not just a number, but *specifically* a number between 5 and 100, exclusive. -;; Non-`Collection` datatypes are opaque and do not participate in this benefit (?). -;; -;; core.spec functions like `s/or`, `s/and`, `s/coll-of`, and certain type predicates are -;; able to be leveraged in computing the best overload with the least dynamic dispatch -;; possible. - (defnt example ([a (s/and even? #(< 5 % 100)) b t/any? @@ -1038,26 +601,3 @@ :c ::example|c :d ::example|d) :fn ::example|__ret) - - -;; ----- TYPE INFERENCE ----- ;; - -(expr-info '(let [a (Integer. 2) b (Double. 3)] a)) -; => {:class java.lang.Integer, :prim? false} -(expr-info '(let [a (Integer. 2) b (Double. 3)] (if false a b))) -; => nil -; But I'd like to have it infer the "LCD", namely, `(v/and number? (v/or* (fn= 2) (fn= 3)))`. - -;; I realize that this also is probably prohibitively expensive. - -(expr-info '(let [a (Integer. 2) b (Double. 3)] (if false a (int b)))) -; => nil (inferred `Integer` or `int`) - -(expr-info '(let [a (Integer. 2) b (Double. 3)] (if false a (Integer. b)))) -; => {:class java.lang.Integer, :prim? false} - -;; At very least it would be nice to have "spec inference". I.e. know, via `fdef`, that a -;; function meets a particular set of specs/characteristics and so any call to that function -;; will necessarily comply with the type. - - From 5c2ba4ec9c82304b68fa97aaded3069292fe20dd Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 16 May 2018 15:27:53 -0600 Subject: [PATCH 047/810] Move untyped core test nss into the correct place --- test/quantum/test/core/untyped/type.cljc | 996 ------------------ .../core}/analyze/expr.cljc | 0 .../untyped => untyped/core}/collections.cljc | 0 .../untyped => untyped/core}/convert.cljc | 0 test/quantum/test/untyped/core/type.cljc | 996 +++++++++++++++++- 5 files changed, 995 insertions(+), 997 deletions(-) delete mode 100644 test/quantum/test/core/untyped/type.cljc rename test/quantum/test/{core/untyped => untyped/core}/analyze/expr.cljc (100%) rename test/quantum/test/{core/untyped => untyped/core}/collections.cljc (100%) rename test/quantum/test/{core/untyped => untyped/core}/convert.cljc (100%) diff --git a/test/quantum/test/core/untyped/type.cljc b/test/quantum/test/core/untyped/type.cljc deleted file mode 100644 index 8463b886..00000000 --- a/test/quantum/test/core/untyped/type.cljc +++ /dev/null @@ -1,996 +0,0 @@ -(ns quantum.test.core.untyped.type - (:require - [clojure.core :as core] - [quantum.core.error :as err - :refer [>err]] - [quantum.core.fn :as fn - :refer [fn-> fn1]] - [quantum.core.test :as test - :refer [deftest testing is is= throws]] - [quantum.untyped.core.analyze.ast :as ast] - [quantum.untyped.core.analyze.expr :as xp - :refer [>expr]] - [quantum.untyped.core.logic - :refer [ifs]] - [quantum.untyped.core.numeric :as unum] - [quantum.untyped.core.numeric.combinatorics :as ucombo] - [quantum.untyped.core.spec :as s] - [quantum.untyped.core.type :as t - :refer [& | !]] - [quantum.untyped.core.defnt - :refer [defns]])) - -;; Here, `NotSpec` labels on `testing` mean such *after* simplification - -(defmacro test-comparisons>comparisons [[_ _ a b]] - `[[~@(for [a* (rest a)] - `(t/compare ~a* ~b))] - [~@(for [b* (rest b)] - `(t/compare ~b* ~a))]]) - -;; TODO come back to this -#_(do (is= -1 (t/compare (t/value 1) t/numerically-byte?)) - - (is= (& t/long? (>expr (fn1 = 1))) - (t/value 1)) - - (is= (& (t/value 1) (>expr unum/integer-value?)) - (t/value 1)) - - (t/compare (t/value 1) (>expr unum/integer-value?)) - - (is= 0 (t/compare (t/value 1) (>expr (fn1 =|long 1)))) - (is= 0 (t/compare (t/value 1) (>expr (fn [^long x] (= x 1))))) - (is= 0 (t/compare (t/value 1) (>expr (fn [^long x] (== x 1))))) - (is= 0 (t/compare (t/value 1) (>expr (fn [x] (core/== (long x) 1))))) - (is= 0 (t/compare (t/value 1) (>expr (fn [x] (= (long x) 1)))))) - -;; ----- Example interface hierarchy ----- ;; - -(do - -(gen-interface :name i.>a+b) -(gen-interface :name i.>a0) -(gen-interface :name i.>a1) -(gen-interface :name i.>b0) -(gen-interface :name i.>b1) - -(gen-interface :name i.a :extends [i.>a0 i.>a1 i.>a+b]) -(gen-interface :name i.b :extends [i.>b0 i.>b1 i.>a+b]) - -(gen-interface :name i.<0) -(gen-interface :name i.><1) -(gen-interface :name i.><2) - -(def i|>a+b (t/isa? i.>a+b)) -(def i|>a0 (t/isa? i.>a0)) -(def i|>a1 (t/isa? i.>a1)) -(def i|>b0 (t/isa? i.>b0)) -(def i|>b1 (t/isa? i.>b1)) -(def i|a (t/isa? i.a)) -(def i|b (t/isa? i.b)) -(def i|<0 (t/isa? i.><0)) -(def i|><1 (t/isa? i.><1)) -(def i|><2 (t/isa? i.><2)) - -) - -;; ----- Hierarchy within existing non-interfaces ----- ;; - -(do (def >a+b (t/isa? java.util.AbstractCollection)) - (def >a (t/isa? java.util.AbstractList)) - (def >b (t/isa? java.util.AbstractSet)) - (def a (t/isa? java.util.ArrayList)) - (def b (t/isa? java.util.HashSet)) - (def <0 t/byte?) - (def ><1 t/short?) - (def ><2 t/long?)) - -(def Uc (t/isa? java.lang.Object)) - -;; ----- Example protocols ----- ;; - -(do - -(defprotocol AProtocolAll (a-protocol-all [this])) - -(extend-protocol AProtocolAll - nil (a-protocol-all [this]) - Object (a-protocol-all [this])) - -(defprotocol AProtocolString (a-protocol-string [this])) - -(extend-protocol AProtocolString - java.lang.String (a-protocol-string [this])) - -(defprotocol AProtocolNonNil (a-protocol-non-nil [this])) - -(extend-protocol AProtocolNonNil - Object (a-protocol-non-nil [this])) - -(defprotocol AProtocolOnlyNil (a-protocol-only-nil [this])) - -(extend-protocol AProtocolOnlyNil - nil (a-protocol-only-nil [this])) - -(defprotocol AProtocolNone (a-protocol-none [this])) - -(def protocol-specs - (->> [AProtocolAll AProtocolString AProtocolNonNil AProtocolOnlyNil AProtocolNone] - (map t/>spec) set)) - -) - -;; TESTS ;; - -(defns spec>spec-combos - "To generate all commutative possibilities for a given spec." - [spec t/spec? > (s/seq-of t/spec?)] - (ifs (t/and-spec? spec) (->> spec t/and-spec>args ucombo/permutations - (map #(t/->AndSpec (vec %) (atom nil)))) - (t/or-spec? spec) (->> spec t/or-spec>args ucombo/permutations - (map #(t/->OrSpec (vec %) (atom nil)))) - [spec])) - -#?(:clj -(defmacro test-comparison - "Performs a `t/compare` on `a` and `b`, ensuring that their relationship is symmetric, - and that the inputs are internally commutative if applicable (e.g. if `a` is an `AndSpec`, - ensures that it is commutative). - The basis comparison is the first input." - [c #_t/comparisons a #_t/spec? b #_t/spec?] - `(let [c# ~c] - (doseq ;; Commutativity - [a*# (spec>spec-combos ~a) - b*# (spec>spec-combos ~b)] - ;; Symmetry - (is= c# (t/compare a*# b*#)) - (is= (t/inverse c#) (t/compare b*# a*#)))))) - -(def comparison-combinations - ["#{<}" - "#{< =}" - "#{< = >}" - "#{< = > ><}" - "#{< = > >< <>}" - "#{< = > <>}" - "#{< = ><}" - "#{< = >< <>}" - "#{< = <>}" - "#{< >}" - "#{< > ><}" - "#{< > >< <>}" - "#{< > <>}" - "#{< ><}" - "#{< >< <>}" - "#{< <>}" - "#{=}" - "#{= >}" - "#{= > ><}" - "#{= > >< <>}" - "#{= > <>}" - "#{= ><}" - "#{= >< <>}" - "#{= <>}" - "#{>}" - "#{> ><}" - "#{> >< <>}" - "#{> <>}" - "#{><}" - "#{>< <>}" - "#{<>}"]) - -(deftest test|in|compare - (testing "UniversalSetSpec" - (testing "+ UniversalSetSpec" - (test-comparison 0 t/universal-set t/universal-set)) - (testing "+ NullSetSpec" - (test-comparison 1 t/universal-set t/empty-set)) - (testing "+ NotSpec" - (test-comparison 1 t/universal-set (! a))) - (testing "+ OrSpec" - (test-comparison 1 t/universal-set (| ><0 ><1))) - (testing "+ AndSpec") - (testing "+ InferSpec") - (testing "+ Expression") - (testing "+ ProtocolSpec" - (doseq [spec protocol-specs] - (test-comparison 1 t/universal-set spec))) - (testing "+ ClassSpec") - (testing "+ ValueSpec" - (doseq [spec [(t/value t/universal-set) - (t/value t/empty-set) - (t/value 0) - (t/value nil)]] - (test-comparison 1 t/universal-set spec)))) - ;; The null set is considered to always (vacuously) be a subset of any set - (testing "NullSetSpec" - (testing "+ NullSetSpec" - (test-comparison 0 t/empty-set t/empty-set)) - (testing "+ NotSpec" - (testing "Inner ClassSpec" - (test-comparison -1 t/empty-set (! a))) - (testing "Inner ValueSpec" - (test-comparison -1 t/empty-set (! (t/value 1))))) - (testing "+ OrSpec" - (test-comparison -1 t/empty-set (| ><0 ><1))) - (testing "+ AndSpec") - (testing "+ InferSpec") - (testing "+ Expression") - (testing "+ ProtocolSpec" - (doseq [spec protocol-specs] - (test-comparison -1 t/empty-set spec))) - (testing "+ ClassSpec") - (testing "+ ValueSpec" - (test-comparison -1 t/empty-set (t/value t/empty-set)) - (test-comparison -1 t/empty-set (t/value 0)))) - (testing "NotSpec" - (testing "+ NotSpec" - (test-comparison 0 (! a) (! a)) - (test-comparison 2 (! a) (! b)) - (test-comparison 2 (! i|a) (! i|b)) - (test-comparison 2 (! t/string?) (! t/byte?)) - (test-comparison 1 (! a) (! >a)) - (test-comparison -1 (! a) (! }") ; Impossible for `OrSpec` - #_(testing "#{< = > ><}") ; Impossible for `OrSpec` - #_(testing "#{< = > >< <>}") ; Impossible for `OrSpec` - #_(testing "#{< = > <>}") ; Impossible for `OrSpec` - #_(testing "#{< = ><}") ; Impossible for `OrSpec` - #_(testing "#{< = >< <>}") ; Impossible for `OrSpec` - #_(testing "#{< = <>}") ; Impossible for `OrSpec` - #_(testing "#{< >}") ; Impossible for `OrSpec` - #_(testing "#{< > ><}") ; Impossible for `OrSpec` - #_(testing "#{< > >< <>}") ; Impossible for `OrSpec` - #_(testing "#{< > <>}") ; Impossible for `OrSpec` - (testing "#{< ><}" - #_(test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1)) - #_(test-comparison -1 i|>a0 (| i|>a+b i|>a0))) - (testing "#{< >< <>}" - #_(test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1 t/string?))) - (testing "#{< <>}" - #_(test-comparison -1 a (| >a ><0 ><1))) - #_(testing "#{=}") ; Impossible for `OrSpec` - #_(testing "#{= >}") ; Impossible for `OrSpec` - #_(testing "#{= > ><}") ; Impossible for `OrSpec` - #_(testing "#{= > >< <>}") ; Impossible for `OrSpec` - #_(testing "#{= > <>}") ; Impossible for `OrSpec` - (testing "#{= ><}" - (test-comparison -1 (! a) (| (! a) i|><0 i|><1)) - (test-comparison -1 (! i|a) (| (! i|a) i|><0 i|><1))) - (testing "#{= >< <>}" - #_(test-comparison -1 i|a (| i|a i|><0 i|><1 t/string?))) - (testing "#{= <>}" - (test-comparison -1 (! a) (| (! a) }" - #_(test-comparison 1 a (| ><}" - #_(test-comparison 2 i|a (| i|<0 i|><1))) - (testing "#{> >< <>}" - #_(test-comparison 2 i|a (| i|<0 i|><1 t/string?))) - (testing "#{> <>}" - (test-comparison 2 (! a) (| b a)) - (test-comparison 2 (! b) (| a b)) - (test-comparison 2 (! ><0) (| ><0 ><1)) - (test-comparison 2 (! ><1) (| ><1 ><0))) - (testing "#{><}" - #_(test-comparison 2 i|a (| i|><0 i|><1))) - (testing "#{>< <>}" - #_(test-comparison 2 i|a (| i|><0 i|><1 t/string?))) - (testing "#{<>}" - (test-comparison 3 (! a) (| }" - (test-comparison ... (! a) (& a (! b))))) - (testing "+ InferSpec") - (testing "+ Expression") - (testing "+ ProtocolSpec") - (testing "+ ClassSpec" - (test-comparison 3 (! a) a) ; inner = - (test-comparison 3 (! i|a) i|a) ; inner = - (test-comparison 3 (! a) - (test-comparison 3 (! i|a) i| - (test-comparison 2 (! a) >a) ; inner < - (test-comparison 2 (! i|a) i|>a0) ; inner >< - (test-comparison 1 (! a ) ><0) ; inner <> - (test-comparison 2 (! i|a) i|><0) ; inner >< - (test-comparison 2 (! a) Uc) ; inner < - (test-comparison 2 (! i|a) Uc) ; inner < - (test-comparison 2 (! a) ; inner < - (test-comparison 2 (! i|a0) ; inner < - (test-comparison 1 (! <0) ; inner <> - (test-comparison 2 (! i|<0) ; inner >< - (test-comparison 2 (! a) a) ; inner > - (test-comparison 3 (! i|>a0) i|a) ; inner > - (test-comparison 3 (! >a) - (test-comparison 3 (! i|>a0) i| - (test-comparison 1 (! >a) ><0) ; inner <> - (test-comparison 2 (! i|>a0) i|><0) ; inner >< - (test-comparison 2 (! >a) Uc) ; inner < - (test-comparison 2 (! i|>a0) Uc) ; inner < - (test-comparison 1 (! ><0) a) ; inner <> - (test-comparison 2 (! i|><0) i|a) ; inner >< - (test-comparison 1 (! ><0) - (test-comparison 2 (! i|><0) i|< - (test-comparison 1 (! ><0) >a) ; inner <> - (test-comparison 2 (! i|><0) i|>a0) ; inner >< - (test-comparison 2 (! ><0) Uc) ; inner < - (test-comparison 2 (! i|><0) Uc) ; inner < - (testing "+ ValueSpec" - (test-comparison -1 (t/value 1) (! (t/value 2))) - (test-comparison 3 (t/value "") (! t/string?)))) - (testing "OrSpec" - (testing "+ OrSpec" - ;; Comparison annotations achieved by first comparing each element of the first/left - ;; to the entire second/right, then comparing each element of the second/right to the - ;; entire first/left - ;; TODO add complete comparisons via `comparison-combinations` - (testing "#{<}, #{<}" - ;; comparisons: < < < < - (test-comparison 0 (| a b) (| a b)) - ;; comparisons: < < < < - (test-comparison 0 (| i|>a+b i|>a0) (| i|>a+b i|>a0))) - (testing "#{<}, #{<, ><}" - ;; comparisons: < < < < >< >< - (test-comparison -1 (| i|>a+b i|>a0) (| i|>a+b i|>a0 i|><0 i|><1)) - ;; comparisons: < < < < >< >< >< - (test-comparison -1 (| i|>a+b i|>a0) (| i|>a+b i|>a0 i|>a1 i|><0 i|><1)) - ;; comparisons: < < < < < < >< >< - (test-comparison -1 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|>a0 i|>a1 i|><0 i|><1))) - (testing "#{<, ><}, #{<}" - ;; comparisons: < < >< < < - (test-comparison 1 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|>a0)) - ;; comparisons: >< < < < < - (test-comparison 1 (| i|a i|><0 i|><1) (| i|><0 i|><1))) - (testing "#{<, ><}, #{<, ><}" - ;; comparisons: < >< < >< - (test-comparison 2 (| i|>a+b i|>a0) (| i|>a+b i|><0)) - ;; comparisons: < >< >< < >< >< - (test-comparison 2 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|><0 i|><1)) - ;; comparisons: < < >< < < >< >< - (test-comparison 2 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|>a0 i|><0 i|><1)) - ;; comparisons: < < >< < >< - (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|a i|><0)) - ;; comparisons: < >< >< < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|a i|><0 i|><1)) - ;; comparisons: >< < < >< - (test-comparison 2 (| i|a i|><0) (| i|><0 i|><1)) - ;; comparisons: >< < >< >< < - (test-comparison 2 (| i|a i|><1 i|><2) (| i|><0 i|><1)) - ;; comparisons: >< >< < < >< - (test-comparison 2 (| i|a i|><0 i|><1) (| i|><1 i|><2))) - (testing "#{<, ><}, #{><}" - ;; comparisons: < >< >< >< - (test-comparison 2 (| i|a i|><0) (| i|>a+b i|>a0)) - ;; comparisons: < >< >< >< >< - (test-comparison 2 (| i|a i|><0 i|><1) (| i|>a+b i|>a0)) - ;; comparisons: < >< >< >< >< - (test-comparison 2 (| i|a i|><0) (| i|>a+b i|>a0 i|>a1)) - ;; comparisons: < >< >< >< >< >< - (test-comparison 2 (| i|a i|><0 i|><1) (| i|>a+b i|>a0 i|>a1))) - (testing "#{<, <>}, #{<, <>}" - ;; comparisons: < <> < <> - (test-comparison 2 (| a b) (| a ><1)) - ;; comparisons: <> < < <> - (test-comparison 2 (| a b) (| b ><1))) - (testing "#{<, <>}, #{><, <>}" - ;; comparisons: <, <> >< <> <> - (test-comparison 2 (| a b) (| >a ><0 ><1))) - (testing "#{><}, #{<, ><}" - ;; comparisons: >< >< >< < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|<0 i|><1)) - ;; comparisons: >< >< >< >< < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0 i|>a1) (| i|<0 i|><1)) - ;; comparisons: >< >< >< < < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|<0 i|><1)) - ;; comparisons: >< >< >< >< < < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0 i|>a1) (| i|<0 i|><1)) - ;; comparisons: >< >< >< < < < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|<0 i|><1)) - ;; comparisons: >< >< >< >< < < < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0 i|>a1) (| i|<0 i|><1))) - (testing "#{><}, #{><}" - ;; comparisons: >< >< >< >< - (test-comparison 2 (| i|a i|><2) (| i|><0 i|><1)) - ;; comparisons: >< >< >< >< - (test-comparison 2 (| i|a i|><0) (| i|><1 i|><2))) - (testing "#{<>}, #{<>}" - ;; comparisons: <> <> <> <> - (test-comparison 3 (| a b) (| ><0 ><1))))) - ;; TODO fix tests/impl - #_(testing "+ AndSpec" - ;; Comparison annotations achieved by first comparing each element of the first/left - ;; to the entire second/right, then comparing each element of the second/right to the - ;; entire first/left - (testing "#{= <+} -> #{<+}" - (testing "+ #{<+}" - ;; comparisons: [-1, -1], [-1, -1] - (test-comparison 1 (| a >a+b >a0) (& >a+b >a0)) - ;; comparisons: [-1, -1, 3], [-1, -1] - (test-comparison 1 (| a >a+b >a0 >a1) (& >a+b >a0)) - ;; comparisons: [-1, -1], [-1, -1, 3] - (test-comparison 3 (| a >a+b >a0) (& >a+b >a0 >a1)) - ;; comparisons: [-1, -1, -1], [-1, -1, -1] - (test-comparison 1 (| a >a+b >a0 >a1) (& >a+b >a0 >a1))) - (testing "+ #{∅+}" - ;; comparisons: [3, 3, 3], [3, 3] - (test-comparison 3 (| a >a+b >a0) (& ><0 ><1))) - (testing "+ #{<+ ∅+}" - ;; comparisons: [-1, 3], [-1, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& >a+b ><0 ><1)) - ;; comparisons: [-1, 3, 3], [-1, 3, 3] - (test-comparison 3 (| a >a+b >a0 >a1) (& >a+b ><0 ><1)) - ;; comparisons: [-1, -1], [-1, -1, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& >a+b >a0 ><0 ><1)) - ;; comparisons: [-1, -1, 3], [-1, -1, 3, 3] - (test-comparison 3 (| a >a+b >a0 >a1) (& >a+b >a0 ><0 ><1)) - ;; comparisons: [-1, -1], [-1, -1, 3, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& >a+b >a0 >a1 ><0 ><1)) - ;; comparisons: [-1, -1, -], [-1, -1, -1, 3, 3] - (test-comparison 3 (| a >a+b >a0 >a1) (& >a+b >a0 >a1 ><0 ><1))) - (testing "+ #{= ∅+}" - ;; comparisons: [3, 3], [-1, 3] - (test-comparison 3 (| a >a+b >a0) (& a ><0)) - ;; comparisons: [3, 3], [-1, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& a ><0 ><1))) - (testing "+ #{>+ ∅+}" - ;; comparisons: [3, 3], [-1, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& <0 ><1)) - ;; comparisons: [3, 3, 3], [-1, 3, 3] - (test-comparison 3 (| a >a+b >a0 >a1) (& <0 ><1)) - ;; comparisons: [3, 3], [-1, -1, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& <0 ><1)) - ;; comparisons: [3, 3, 3], [-1, -1, 3, 3] - (test-comparison 3 (| a >a+b >a0 >a1) (& <0 ><1)) - ;; comparisons: [3, 3], [-1, -1, 3, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& <0 ><1)) - ;; comparisons: [3, 3, 3], [-1, -1, -1, 3, 3] - (test-comparison 3 (| a >a+b >a0 >a1) (& <0 ><1))))) - (testing "+ InferSpec") - (testing "+ Expression") - (testing "+ ProtocolSpec") - (testing "+ ClassSpec" - (testing "#{<}" - (test-comparison -1 i|a+b i|>a0 i|>a1))) - #_(testing "#{< =}") ; Impossible for `OrSpec` - #_(testing "#{< = >}") ; Impossible for `OrSpec` - #_(testing "#{< = > ><}") ; Impossible for `OrSpec` - #_(testing "#{< = > >< <>}") ; Impossible for `OrSpec` - #_(testing "#{< = > <>}") ; Impossible for `OrSpec` - #_(testing "#{< = ><}") ; Impossible for `OrSpec` - #_(testing "#{< = >< <>}") ; Impossible for `OrSpec` - #_(testing "#{< = <>}") ; Impossible for `OrSpec` - #_(testing "#{< >}") ; Impossible for `OrSpec` - #_(testing "#{< > ><}") ; Impossible for `OrSpec` - #_(testing "#{< > >< <>}") ; Impossible for `OrSpec` - #_(testing "#{< > <>}") ; Impossible for `OrSpec` - (testing "#{< ><}" - (test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1)) - (test-comparison -1 i|>a0 (| i|>a+b i|>a0))) - (testing "#{< >< <>}" - (test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1 t/string?))) - (testing "#{< <>}" - (test-comparison -1 a (| >a ><0 ><1))) - #_(testing "#{=}") ; Impossible for `OrSpec` - #_(testing "#{= >}") ; Impossible for `OrSpec` - #_(testing "#{= > ><}") ; Impossible for `OrSpec` - #_(testing "#{= > >< <>}") ; Impossible for `OrSpec` - #_(testing "#{= > <>}") ; Impossible for `OrSpec` - (testing "#{= ><}" - (test-comparison -1 i|a (| i|a i|><0 i|><1))) - (testing "#{= >< <>}" - (test-comparison -1 i|a (| i|a i|><0 i|><1 t/string?))) - (testing "#{= <>}" - (test-comparison -1 a (| a ><0 ><1))) - (testing "#{>}" - (test-comparison 1 a (| ><}" - (test-comparison 2 i|a (| i|<0 i|><1))) - (testing "#{> >< <>}" - (test-comparison 2 i|a (| i|<0 i|><1 t/string?))) - (testing "#{> <>}" - (test-comparison 2 a (| <0 ><1))) - (testing "#{><}" - (test-comparison 2 i|a (| i|><0 i|><1))) - (testing "#{>< <>}" - (test-comparison 2 i|a (| i|><0 i|><1 t/string?))) - (testing "#{<>}" - (test-comparison 3 a (| ><0 ><1))) - (testing "Nilable" - (testing "< nilabled: #{< <>}" - (test-comparison -1 t/long? (t/? t/object?))) - (testing "= nilabled: #{= <>}" - (test-comparison -1 t/long? (t/? t/long?))) - (testing "> nilabled: #{> <>}" - (test-comparison 2 t/object? (t/? t/long?))) - (testing ">< nilabled: #{>< <>}" - (test-comparison 2 t/iterable? (t/? t/comparable?))) - (testing "<> nilabled: #{<>}" - (test-comparison 3 t/long? (t/? t/string?))))) - (testing "+ ValueSpec" - (testing "arg <" - (testing "+ arg <") - (testing "+ arg =") - (testing "+ arg >") - (testing "+ arg ><") - (testing "+ arg <>" - (test-comparison -1 (t/value "a") (| t/string? t/byte?)) - (test-comparison -1 (t/value 1) (| (t/value 1) (t/value 2))) - (test-comparison -1 (t/value 1) (| (t/value 2) (t/value 1))) - (testing "+ arg <>" - (test-comparison -1 (t/value 1) (| (t/value 1) (t/value 2) (t/value 3))) - (test-comparison -1 (t/value 1) (| (t/value 2) (t/value 1) (t/value 3))) - (test-comparison -1 (t/value 1) (| (t/value 2) (t/value 3) (t/value 1)))))) - (testing "arg =" - (testing "+ arg <>" - (test-comparison -1 t/nil? (| t/nil? t/string?)))) - (testing "arg <>" - (testing "+ arg <>" - (test-comparison 3 (t/value "a") (| t/byte? t/long?)) - (test-comparison 3 (t/value 3) (| (t/value 1) (t/value 2))))))) - (testing "AndSpec" - (testing "+ AndSpec") - (testing "+ InferSpec") - (testing "+ Expression") - (testing "+ ProtocolSpec") - (testing "+ ClassSpec" - (testing "#{<}" - (testing "Boxed Primitive" - (test-comparison -1 t/byte? (& t/number? t/comparable?))) - (testing "Final Concrete" - (test-comparison -1 t/string? (& t/char-seq? t/comparable?))) - (testing "Extensible Concrete" - (test-comparison -1 a (& t/iterable? (t/isa? java.util.RandomAccess)))) - (testing "Abstract" - (test-comparison -1 (t/isa? java.util.AbstractMap$SimpleEntry) (& (t/isa? java.util.Map$Entry) (t/isa? java.io.Serializable)))) - (testing "Interface" - (test-comparison -1 i|a (& i|>a0 i|>a1)))) - (testing "#{<}" - (test-comparison -1 i|a (& i|>a0 i|>a1))) - #_(testing "#{< =}") ; Impossible for `AndSpec` - #_(testing "#{< = >}") ; Impossible for `AndSpec` - #_(testing "#{< = > ><}") ; Impossible for `AndSpec` - #_(testing "#{< = > >< <>}") ; Impossible for `AndSpec` - #_(testing "#{< = > <>}") ; Impossible for `AndSpec` - #_(testing "#{< = ><}") ; Impossible for `AndSpec` - #_(testing "#{< = >< <>}") ; Impossible for `AndSpec` - #_(testing "#{< = <>}") ; Impossible for `AndSpec` - #_(testing "#{< >}") ; Impossible for `AndSpec` - #_(testing "#{< > ><}") ; Impossible for `AndSpec` - #_(testing "#{< > >< <>}") ; Impossible for `AndSpec` - #_(testing "#{< > <>}") ; Impossible for `AndSpec` - (testing "#{< ><}" - (test-comparison 2 i|a (& i|>a+b i|>a0 i|>a1 i|><0 i|><1))) - (testing "#{< >< <>}" - (test-comparison 2 t/java-set? (& t/java-coll? t/char-seq? (t/isa? java.nio.ByteBuffer)))) - (testing "#{< <>}" - (test-comparison 3 t/string? (& t/char-seq? t/java-set?)) - (test-comparison 3 ><0 (& (! ><1) (! ><0))) - (test-comparison 3 a (& (! a) (! b)))) - #_(testing "#{=}") ; Impossible for `AndSpec` - #_(testing "#{= >}") ; Impossible for `AndSpec` - #_(testing "#{= > ><}") ; Impossible for `AndSpec` - #_(testing "#{= > >< <>}") ; Impossible for `AndSpec` - #_(testing "#{= > <>}") ; Impossible for `AndSpec` - (testing "#{= ><}" - (test-comparison 1 i|a (& i|a i|><0 i|><1)) - (test-comparison 1 t/char-seq? (& t/char-seq? t/java-set?)) - (test-comparison 1 t/char-seq? (& t/char-seq? t/java-set? a))) - (testing "#{= >< <>}") ; <- TODO comparison should be 1 - ;; TODO fix - (testing "#{= <>}" - (test-comparison 1 a (& a t/java-set?))) - (testing "#{>}" - (test-comparison 1 i|a (& i| ><}" - (test-comparison 2 i|a (& i|<0 i|><1)) - (test-comparison 2 a (& (t/isa? javax.management.AttributeList) t/java-set?)) - (test-comparison 2 t/comparable? (& (t/isa? java.nio.ByteBuffer) t/java-set?))) - (testing "#{> >< <>}" - (test-comparison 2 i|a (& i|<0 a))) - (testing "#{> <>}") ; <- TODO comparison should be 1 - (testing "#{><}" - (test-comparison 2 i|a (& i|><0 i|><1)) - (test-comparison 2 t/char-seq? (& t/java-set? a))) - (testing "#{>< <>}") ; <- TODO comparison should be 3 - (testing "#{<>}" - (test-comparison 3 t/string? (& a t/java-set?)))) - (testing "+ ValueSpec" - (testing "#{<}" - (test-comparison -1 (t/value "a") (& t/char-seq? t/comparable?))) - #_(testing "#{< =}") ; not possible for `AndSpec` - #_(testing "#{< = >}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` - #_(testing "#{< = > ><}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` - #_(testing "#{< = > >< <>}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` - #_(testing "#{< = > <>}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` - #_(testing "#{< = ><}") ; not possible for `AndSpec`; `><` not possible for `ValueSpec` - #_(testing "#{< = >< <>}") ; not possible for `AndSpec`; `><` not possible for `ValueSpec` - #_(testing "#{< = <>}") ; not possible for `AndSpec` - #_(testing "#{< >}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` - #_(testing "#{< > ><}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` - #_(testing "#{< > >< <>}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` - #_(testing "#{< > <>}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` - #_(testing "#{< ><}") ; `><` not possible for `ValueSpec` - #_(testing "#{< >< <>}") ; `><` not possible for `ValueSpec` - (testing "#{< <>}" - (test-comparison 3 (t/value "a") (& t/char-seq? a)) - (test-comparison 3 (t/value "a") (& t/char-seq? t/java-set?))) - #_(testing "#{=}") ; not possible for `AndSpec` - #_(testing "#{= >}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` - #_(testing "#{= > ><}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` - #_(testing "#{= > >< <>}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` - #_(testing "#{= > <>}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` - #_(testing "#{= ><}") ; `><` not possible for `ValueSpec` - #_(testing "#{= >< <>}") ; `><` not possible for `ValueSpec` - (testing "#{= <>}") - #_(testing "#{>}") ; `>` not possible for `ValueSpec` - #_(testing "#{> ><}") ; `>` and `><` not possible for `ValueSpec` - #_(testing "#{> >< <>}") ; `>` and `><` not possible for `ValueSpec` - #_(testing "#{> <>}") ; `>` not possible for `ValueSpec` - #_(testing "#{><}") ; `><` not possible for `ValueSpec` - #_(testing "#{>< <>}") ; `><` not possible for `ValueSpec` - (testing "#{<>}" - (test-comparison 3 (t/value "a") (& a t/java-set?))))) - (testing "InferSpec" - (testing "+ InferSpec") - (testing "+ Expression") - (testing "+ ProtocolSpec") - (testing "+ ClassSpec") - (testing "+ ValueSpec")) - (testing "Expression" - (testing "+ Expression") - (testing "+ ProtocolSpec") - (testing "+ ClassSpec") - (testing "+ ValueSpec")) - (testing "ProtocolSpec" - (testing "+ ProtocolSpec" - (test-comparison 0 (t/isa? AProtocolAll) (t/isa? AProtocolAll)) - (test-comparison 3 (t/isa? AProtocolAll) (t/isa? AProtocolNone))) - (testing "+ ClassSpec") - (testing "+ ValueSpec" - (let [values #{t/universal-set t/empty-set nil {} 1 "" AProtocolAll - quantum.test.core.untyped.type.AProtocolAll}] - (doseq [v values] - (test-comparison -1 (t/value v) (t/isa? AProtocolAll))) - (doseq [v [""]] - (test-comparison -1 (t/value v) (t/isa? AProtocolString))) - (doseq [v (disj values "")] - (test-comparison 3 (t/value v) (t/isa? AProtocolString))) - (doseq [v (disj values nil)] - (test-comparison -1 (t/value v) (t/isa? AProtocolNonNil))) - (doseq [v [nil]] - (test-comparison 3 (t/value v) (t/isa? AProtocolNonNil))) - (doseq [v [nil]] - (test-comparison -1 (t/value v) (t/isa? AProtocolOnlyNil))) - (doseq [v (disj values nil)] - (test-comparison 3 (t/value v) (t/isa? AProtocolOnlyNil))) - (doseq [v values] - (test-comparison 3 (t/value v) (t/isa? AProtocolNone)))))) - (testing "ClassSpec" - (testing "+ ClassSpec" - (testing "Boxed Primitive + Boxed Primitive" - (test-comparison 0 t/long? t/long?) - (test-comparison 3 t/long? t/int?)) - (testing "Boxed Primitive + Final Concrete" - (test-comparison 3 t/long? t/string?)) - (testing "Boxed Primitive + Extensible Concrete" - (testing "< , >" - (test-comparison -1 t/long? t/object?)) - (testing "<>" - (test-comparison 3 t/long? t/thread?))) - (testing "Boxed Primitive + Abstract" - (test-comparison 3 t/long? (t/isa? java.util.AbstractCollection))) - (testing "Boxed Primitive + Interface" - (test-comparison 3 t/long? t/char-seq?)) - (testing "Final Concrete + Final Concrete" - (test-comparison 0 t/string? t/string?)) - (testing "Final Concrete + Extensible Concrete" - (testing "< , >" - (test-comparison -1 t/string? t/object?)) - (testing "<>" - (test-comparison 3 t/string? a))) - (testing "Final Concrete + Abstract") - (testing "Final Concrete + Interface" - (testing "< , >" - (test-comparison -1 t/string? t/comparable?)) - (testing "<>" - (test-comparison 3 t/string? t/java-coll?))) - (testing "Extensible Concrete + Extensible Concrete" - (test-comparison 0 t/object? t/object?) - (testing "< , >" - (test-comparison -1 a t/object?)) - (testing "<>" - (test-comparison 3 a t/thread?))) - (testing "Extensible Concrete + Abstract" - (testing "< , >" - (test-comparison -1 (t/isa? java.util.AbstractCollection) t/object?) - (test-comparison -1 a (t/isa? java.util.AbstractCollection))) - (testing "<>" - (test-comparison 3 t/thread? (t/isa? java.util.AbstractCollection)) - (test-comparison 3 (t/isa? java.util.AbstractCollection) t/thread?))) - (testing "Extensible Concrete + Interface" - (test-comparison 2 a t/char-seq?)) - (testing "Abstract + Abstract" - (test-comparison 0 (t/isa? java.util.AbstractCollection) (t/isa? java.util.AbstractCollection)) - (testing "< , >" - (test-comparison -1 (t/isa? java.util.AbstractList) (t/isa? java.util.AbstractCollection))) - (testing "<>" - (test-comparison 3 (t/isa? java.util.AbstractList) (t/isa? java.util.AbstractQueue)))) - (testing "Abstract + Interface" - (testing "< , >" - (test-comparison -1 (t/isa? java.util.AbstractCollection) t/java-coll?)) - (testing "><" - (test-comparison 2 (t/isa? java.util.AbstractCollection) t/comparable?))) - (testing "Interface + Interface" - (testing "< , >" - (test-comparison -1 t/java-coll? t/iterable?)) - (testing "><" - (test-comparison 2 t/char-seq? t/comparable?)))) - (testing "+ ValueSpec" - (testing "<" - (testing "Class equality" - (test-comparison -1 (t/value "a") t/string?)) - (testing "Class inheritance" - (test-comparison -1 (t/value "a") t/char-seq?) - (test-comparison -1 (t/value "a") t/object?))) - (testing "<>" - (test-comparison 3 (t/value "a") t/byte?)))) - (testing "ValueSpec" - (testing "+ ValueSpec" - (testing "=" - (test-comparison 0 (t/value nil) (t/value nil)) - (test-comparison 0 (t/value 1 ) (t/value 1 )) - (test-comparison 0 (t/value "a") (t/value "a"))) - (testing "=, non-strict" - (test-comparison 0 (t/value (vector) ) (t/value (list) )) - (test-comparison 0 (t/value (vector (vector))) (t/value (vector (list)))) - (test-comparison 0 (t/value (hash-map) ) (t/value (sorted-map) ))) - (testing "<>" - (test-comparison 3 (t/value 1 ) (t/value 2 )) - (test-comparison 3 (t/value "a") (t/value "b")) - (test-comparison 3 (t/value 1 ) (t/value "a")) - (test-comparison 3 (t/value nil) (t/value "a")))))) - -(deftest test|not - (testing "simplification" - (testing "universal/null set" - (is= (! t/universal-set) - t/empty-set) - (is= (! t/empty-set) - t/universal-set)) - (testing "universal class-set" - (is= (! t/val?) - t/nil?) - (is= (! t/val|by-class?) - t/nil?)) - (testing "DeMorgan's Law" - (is= (! (| i|a i|b)) - (& (! i|a) (! i|b))) - (is= (! (& i|a i|b)) - (| (! i|a) (! i|b))) - (is= (! (| (! i|a) (! i|b))) - (& i|a i|b)) - (is= (! (& (! i|a) (! i|b))) - (| i|a i|b))))) - -(deftest test|- - (testing "=" - (is= (t/- a a) - t/empty-set)) - (testing "<" - (is= (t/- a >a) - t/empty-set)) - (testing "<>" - (is= (t/- a b) - a)) - (testing ">" - (is= (t/- (| a b) a) - b) - (is= (t/- (| a b t/long?) a) - (| b t/long?))) - (testing "><" - )) - -(deftest test|or - (testing "equality" - (is= (| a b) (| a b))) - (testing "simplification" - (testing "via single-arg" - (is= (| a) - a)) - (testing "via identity" - (is= (| a a) - a) - (is= (| (| a a) a) - a) - (is= (| a (| a a)) - a) - (is= (| (| a b) (| b a)) - (| a b)) - (is= (| (| a b ><0) (| a ><0 b)) - (| a b ><0))) - (testing "nested `or` is expanded" - (is= (| (| a b) (| ><0 ><1)) - (| a b ><0 ><1)) - (is= (| (| a b) (| ><0 ><1)) - (| a b ><0 ><1))) - (testing "via `not`" - (is= (| a (! a)) - t/universal-set) - (is= (| a b (! a)) - t/universal-set) - (is= (| a b (| (! a) (! b))) - t/universal-set)) - (testing "nested" - (is= (t/or-spec>args (| (| t/string? t/double?) - t/char-seq?)) - [t/double? t/char-seq?]) - (is= (t/or-spec>args (| (| t/string? t/double?) - (| t/double? t/char-seq?))) - [t/double? t/char-seq?]) - (is= (t/or-spec>args (| (| t/string? t/double?) - (| t/char-seq? t/number?))) - [t/char-seq? t/number?])) - (testing "#{<+ =} -> #{<+}" - (is= (t/or-spec>args (| i|>a+b i|>a0 i|a)) - [i|>a+b i|>a0])) - (testing "#{<+ >+} -> #{<+}" - (is= (t/or-spec>args (| i|>a+b i|>a0 i|a+b i|>a0])) - (testing "#{>+ =} -> #{=}" - (is= (| i|+ ><+} -> #{<+ ><+}" - (is= (t/or-spec>args (| i|>a+b i|>a0 i|<0 i|><1)) - [i|>a+b i|>a0 i|><0 i|><1])) - (testing "#{<+ >+ <>+} -> #{<+ <>+}" - (is= (t/or-spec>args (| >a <0 ><1)) - [>a ><0 ><1])) - (testing "#{<+ =+ >+ ><+} -> #{<+ ><+}" - (is= (t/or-spec>args (| i|>a+b i|>a0 i|a i|<0 i|><1)) - [i|>a+b i|>a0 i|><0 i|><1])) - (testing "#{<+ =+ >+ <>+} -> #{<+ <>+}" - (is= (t/or-spec>args (| >a a <0 ><1)) - [>a ><0 ><1])))) - -(deftest test|and - (testing "equality" - (is= (& i|a i|b) (& i|a i|b))) - (testing "null set / universal set" - (is= (& t/universal-set t/universal-set) - t/universal-set) - (is= (& t/universal-set t/empty-set) - t/empty-set) - (is= (& t/empty-set t/universal-set) - t/empty-set) - (is= (& t/universal-set t/empty-set t/universal-set) - t/empty-set) - (is= (& t/universal-set t/string?) - t/string?) - (is= (& t/universal-set t/char-seq? t/string?) - t/string?) - (is= (& t/universal-set t/string? t/char-seq?) - t/string?) - (is= (& t/empty-set t/string?) - t/empty-set) - (is= (& t/empty-set t/char-seq? t/string?) - t/empty-set) - (is= (& t/empty-set t/string? t/char-seq?) - t/empty-set)) - (testing "simplification" - (testing "via single-arg" - (is= (& a) - a)) - (testing "via identity" - (is= (& a a) - a) - (is= (& (! a) (! a)) - (! a)) - (is= (& (& a a) a) - a) - (is= (& a (& a a)) - a) - (is= (& (| t/string? t/byte?) (| t/byte? t/string?)) - (| t/string? t/byte?)) - (is= (& (| a b) (| b a)) - (| a b)) - (is= (& (| a b ><0) (| a ><0 b)) - (| a b ><0))) - (testing "" - (is= (t/and-spec>args (& i|a i|b)) - [i|a i|b])) - (testing "empty-set" - (is= (& a b) - t/empty-set) - (is= (& t/string? t/byte?) - t/empty-set) - (is= (& a ><0) - t/empty-set) - (is= (& a ><0 ><1) - t/empty-set)) - (testing "nested `and` is expanded" - (is= (& (& a b) (& ><0 ><1)) - (& a b ><0 ><1)) - (is= (& (& a b) (& ><0 ><1)) - (& a b ><0 ><1))) - (testing "and + not" - (is= (& a (! a)) - t/empty-set) - (is= (& a (! b)) - a) - (is= (& (! b) a) - a) - (testing "+ or" - (is= (& (! a) a b) - t/empty-set) - (is= (& a (! a) b) - t/empty-set) - (is= (& a b (! a)) - t/empty-set) - (is= (& (| a b) (! a)) - b) - ;; TODO fix impls - #_(is= (& (! a) (| a b)) - b) - (is= (& (| a b) (! b) (| b a)) - a) - (is= (& (| a b) (! b) (| ><0 b)) - t/empty-set)) - (is= (& t/primitive? (! t/boolean?)) - (| t/byte? t/char? t/short? t/int? t/long? t/float? t/double?))) - (testing "#{<+ =} -> #{=}" - (is= (& i|>a+b i|>a0 i|a) - i|a)) - (testing "#{>+ =+} -> #{>+}" - (is= (t/and-spec>args (& i|+} -> #{>+}" - (is= (t/and-spec>args (& i|>a+b i|>a0 i|+ ∅+} -> #{>+ ∅+}" - (is= (t/and-spec>args (& i|>a+b i|>a0 i|<0 i|><1)) - [i|<0 i|><1])) - (testing "#{<+ =+ >+ ∅+} -> #{>+ ∅+}" - (is= (t/and-spec>args (& i|>a+b i|>a0 i|a i|<0 i|><1)) - [i|<0 i|><1])))) - -(deftest test|= - ;; Takes an inordinately long time to do `test-comparison 0 ...` even without instrumentation - (is= (| t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) - (& (| t/boolean? t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) - (! t/boolean?))) - (test-comparison 0 t/any? t/universal-set) - (testing "universal class(-set) identity" - (is (t/= t/val? (& t/any? t/val?))))) diff --git a/test/quantum/test/core/untyped/analyze/expr.cljc b/test/quantum/test/untyped/core/analyze/expr.cljc similarity index 100% rename from test/quantum/test/core/untyped/analyze/expr.cljc rename to test/quantum/test/untyped/core/analyze/expr.cljc diff --git a/test/quantum/test/core/untyped/collections.cljc b/test/quantum/test/untyped/core/collections.cljc similarity index 100% rename from test/quantum/test/core/untyped/collections.cljc rename to test/quantum/test/untyped/core/collections.cljc diff --git a/test/quantum/test/core/untyped/convert.cljc b/test/quantum/test/untyped/core/convert.cljc similarity index 100% rename from test/quantum/test/core/untyped/convert.cljc rename to test/quantum/test/untyped/core/convert.cljc diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index e3a98aae..8463b886 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -1,2 +1,996 @@ -(ns quantum.test.untyped.core.type) +(ns quantum.test.core.untyped.type + (:require + [clojure.core :as core] + [quantum.core.error :as err + :refer [>err]] + [quantum.core.fn :as fn + :refer [fn-> fn1]] + [quantum.core.test :as test + :refer [deftest testing is is= throws]] + [quantum.untyped.core.analyze.ast :as ast] + [quantum.untyped.core.analyze.expr :as xp + :refer [>expr]] + [quantum.untyped.core.logic + :refer [ifs]] + [quantum.untyped.core.numeric :as unum] + [quantum.untyped.core.numeric.combinatorics :as ucombo] + [quantum.untyped.core.spec :as s] + [quantum.untyped.core.type :as t + :refer [& | !]] + [quantum.untyped.core.defnt + :refer [defns]])) +;; Here, `NotSpec` labels on `testing` mean such *after* simplification + +(defmacro test-comparisons>comparisons [[_ _ a b]] + `[[~@(for [a* (rest a)] + `(t/compare ~a* ~b))] + [~@(for [b* (rest b)] + `(t/compare ~b* ~a))]]) + +;; TODO come back to this +#_(do (is= -1 (t/compare (t/value 1) t/numerically-byte?)) + + (is= (& t/long? (>expr (fn1 = 1))) + (t/value 1)) + + (is= (& (t/value 1) (>expr unum/integer-value?)) + (t/value 1)) + + (t/compare (t/value 1) (>expr unum/integer-value?)) + + (is= 0 (t/compare (t/value 1) (>expr (fn1 =|long 1)))) + (is= 0 (t/compare (t/value 1) (>expr (fn [^long x] (= x 1))))) + (is= 0 (t/compare (t/value 1) (>expr (fn [^long x] (== x 1))))) + (is= 0 (t/compare (t/value 1) (>expr (fn [x] (core/== (long x) 1))))) + (is= 0 (t/compare (t/value 1) (>expr (fn [x] (= (long x) 1)))))) + +;; ----- Example interface hierarchy ----- ;; + +(do + +(gen-interface :name i.>a+b) +(gen-interface :name i.>a0) +(gen-interface :name i.>a1) +(gen-interface :name i.>b0) +(gen-interface :name i.>b1) + +(gen-interface :name i.a :extends [i.>a0 i.>a1 i.>a+b]) +(gen-interface :name i.b :extends [i.>b0 i.>b1 i.>a+b]) + +(gen-interface :name i.<0) +(gen-interface :name i.><1) +(gen-interface :name i.><2) + +(def i|>a+b (t/isa? i.>a+b)) +(def i|>a0 (t/isa? i.>a0)) +(def i|>a1 (t/isa? i.>a1)) +(def i|>b0 (t/isa? i.>b0)) +(def i|>b1 (t/isa? i.>b1)) +(def i|a (t/isa? i.a)) +(def i|b (t/isa? i.b)) +(def i|<0 (t/isa? i.><0)) +(def i|><1 (t/isa? i.><1)) +(def i|><2 (t/isa? i.><2)) + +) + +;; ----- Hierarchy within existing non-interfaces ----- ;; + +(do (def >a+b (t/isa? java.util.AbstractCollection)) + (def >a (t/isa? java.util.AbstractList)) + (def >b (t/isa? java.util.AbstractSet)) + (def a (t/isa? java.util.ArrayList)) + (def b (t/isa? java.util.HashSet)) + (def <0 t/byte?) + (def ><1 t/short?) + (def ><2 t/long?)) + +(def Uc (t/isa? java.lang.Object)) + +;; ----- Example protocols ----- ;; + +(do + +(defprotocol AProtocolAll (a-protocol-all [this])) + +(extend-protocol AProtocolAll + nil (a-protocol-all [this]) + Object (a-protocol-all [this])) + +(defprotocol AProtocolString (a-protocol-string [this])) + +(extend-protocol AProtocolString + java.lang.String (a-protocol-string [this])) + +(defprotocol AProtocolNonNil (a-protocol-non-nil [this])) + +(extend-protocol AProtocolNonNil + Object (a-protocol-non-nil [this])) + +(defprotocol AProtocolOnlyNil (a-protocol-only-nil [this])) + +(extend-protocol AProtocolOnlyNil + nil (a-protocol-only-nil [this])) + +(defprotocol AProtocolNone (a-protocol-none [this])) + +(def protocol-specs + (->> [AProtocolAll AProtocolString AProtocolNonNil AProtocolOnlyNil AProtocolNone] + (map t/>spec) set)) + +) + +;; TESTS ;; + +(defns spec>spec-combos + "To generate all commutative possibilities for a given spec." + [spec t/spec? > (s/seq-of t/spec?)] + (ifs (t/and-spec? spec) (->> spec t/and-spec>args ucombo/permutations + (map #(t/->AndSpec (vec %) (atom nil)))) + (t/or-spec? spec) (->> spec t/or-spec>args ucombo/permutations + (map #(t/->OrSpec (vec %) (atom nil)))) + [spec])) + +#?(:clj +(defmacro test-comparison + "Performs a `t/compare` on `a` and `b`, ensuring that their relationship is symmetric, + and that the inputs are internally commutative if applicable (e.g. if `a` is an `AndSpec`, + ensures that it is commutative). + The basis comparison is the first input." + [c #_t/comparisons a #_t/spec? b #_t/spec?] + `(let [c# ~c] + (doseq ;; Commutativity + [a*# (spec>spec-combos ~a) + b*# (spec>spec-combos ~b)] + ;; Symmetry + (is= c# (t/compare a*# b*#)) + (is= (t/inverse c#) (t/compare b*# a*#)))))) + +(def comparison-combinations + ["#{<}" + "#{< =}" + "#{< = >}" + "#{< = > ><}" + "#{< = > >< <>}" + "#{< = > <>}" + "#{< = ><}" + "#{< = >< <>}" + "#{< = <>}" + "#{< >}" + "#{< > ><}" + "#{< > >< <>}" + "#{< > <>}" + "#{< ><}" + "#{< >< <>}" + "#{< <>}" + "#{=}" + "#{= >}" + "#{= > ><}" + "#{= > >< <>}" + "#{= > <>}" + "#{= ><}" + "#{= >< <>}" + "#{= <>}" + "#{>}" + "#{> ><}" + "#{> >< <>}" + "#{> <>}" + "#{><}" + "#{>< <>}" + "#{<>}"]) + +(deftest test|in|compare + (testing "UniversalSetSpec" + (testing "+ UniversalSetSpec" + (test-comparison 0 t/universal-set t/universal-set)) + (testing "+ NullSetSpec" + (test-comparison 1 t/universal-set t/empty-set)) + (testing "+ NotSpec" + (test-comparison 1 t/universal-set (! a))) + (testing "+ OrSpec" + (test-comparison 1 t/universal-set (| ><0 ><1))) + (testing "+ AndSpec") + (testing "+ InferSpec") + (testing "+ Expression") + (testing "+ ProtocolSpec" + (doseq [spec protocol-specs] + (test-comparison 1 t/universal-set spec))) + (testing "+ ClassSpec") + (testing "+ ValueSpec" + (doseq [spec [(t/value t/universal-set) + (t/value t/empty-set) + (t/value 0) + (t/value nil)]] + (test-comparison 1 t/universal-set spec)))) + ;; The null set is considered to always (vacuously) be a subset of any set + (testing "NullSetSpec" + (testing "+ NullSetSpec" + (test-comparison 0 t/empty-set t/empty-set)) + (testing "+ NotSpec" + (testing "Inner ClassSpec" + (test-comparison -1 t/empty-set (! a))) + (testing "Inner ValueSpec" + (test-comparison -1 t/empty-set (! (t/value 1))))) + (testing "+ OrSpec" + (test-comparison -1 t/empty-set (| ><0 ><1))) + (testing "+ AndSpec") + (testing "+ InferSpec") + (testing "+ Expression") + (testing "+ ProtocolSpec" + (doseq [spec protocol-specs] + (test-comparison -1 t/empty-set spec))) + (testing "+ ClassSpec") + (testing "+ ValueSpec" + (test-comparison -1 t/empty-set (t/value t/empty-set)) + (test-comparison -1 t/empty-set (t/value 0)))) + (testing "NotSpec" + (testing "+ NotSpec" + (test-comparison 0 (! a) (! a)) + (test-comparison 2 (! a) (! b)) + (test-comparison 2 (! i|a) (! i|b)) + (test-comparison 2 (! t/string?) (! t/byte?)) + (test-comparison 1 (! a) (! >a)) + (test-comparison -1 (! a) (! }") ; Impossible for `OrSpec` + #_(testing "#{< = > ><}") ; Impossible for `OrSpec` + #_(testing "#{< = > >< <>}") ; Impossible for `OrSpec` + #_(testing "#{< = > <>}") ; Impossible for `OrSpec` + #_(testing "#{< = ><}") ; Impossible for `OrSpec` + #_(testing "#{< = >< <>}") ; Impossible for `OrSpec` + #_(testing "#{< = <>}") ; Impossible for `OrSpec` + #_(testing "#{< >}") ; Impossible for `OrSpec` + #_(testing "#{< > ><}") ; Impossible for `OrSpec` + #_(testing "#{< > >< <>}") ; Impossible for `OrSpec` + #_(testing "#{< > <>}") ; Impossible for `OrSpec` + (testing "#{< ><}" + #_(test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1)) + #_(test-comparison -1 i|>a0 (| i|>a+b i|>a0))) + (testing "#{< >< <>}" + #_(test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1 t/string?))) + (testing "#{< <>}" + #_(test-comparison -1 a (| >a ><0 ><1))) + #_(testing "#{=}") ; Impossible for `OrSpec` + #_(testing "#{= >}") ; Impossible for `OrSpec` + #_(testing "#{= > ><}") ; Impossible for `OrSpec` + #_(testing "#{= > >< <>}") ; Impossible for `OrSpec` + #_(testing "#{= > <>}") ; Impossible for `OrSpec` + (testing "#{= ><}" + (test-comparison -1 (! a) (| (! a) i|><0 i|><1)) + (test-comparison -1 (! i|a) (| (! i|a) i|><0 i|><1))) + (testing "#{= >< <>}" + #_(test-comparison -1 i|a (| i|a i|><0 i|><1 t/string?))) + (testing "#{= <>}" + (test-comparison -1 (! a) (| (! a) }" + #_(test-comparison 1 a (| ><}" + #_(test-comparison 2 i|a (| i|<0 i|><1))) + (testing "#{> >< <>}" + #_(test-comparison 2 i|a (| i|<0 i|><1 t/string?))) + (testing "#{> <>}" + (test-comparison 2 (! a) (| b a)) + (test-comparison 2 (! b) (| a b)) + (test-comparison 2 (! ><0) (| ><0 ><1)) + (test-comparison 2 (! ><1) (| ><1 ><0))) + (testing "#{><}" + #_(test-comparison 2 i|a (| i|><0 i|><1))) + (testing "#{>< <>}" + #_(test-comparison 2 i|a (| i|><0 i|><1 t/string?))) + (testing "#{<>}" + (test-comparison 3 (! a) (| }" + (test-comparison ... (! a) (& a (! b))))) + (testing "+ InferSpec") + (testing "+ Expression") + (testing "+ ProtocolSpec") + (testing "+ ClassSpec" + (test-comparison 3 (! a) a) ; inner = + (test-comparison 3 (! i|a) i|a) ; inner = + (test-comparison 3 (! a) + (test-comparison 3 (! i|a) i| + (test-comparison 2 (! a) >a) ; inner < + (test-comparison 2 (! i|a) i|>a0) ; inner >< + (test-comparison 1 (! a ) ><0) ; inner <> + (test-comparison 2 (! i|a) i|><0) ; inner >< + (test-comparison 2 (! a) Uc) ; inner < + (test-comparison 2 (! i|a) Uc) ; inner < + (test-comparison 2 (! a) ; inner < + (test-comparison 2 (! i|a0) ; inner < + (test-comparison 1 (! <0) ; inner <> + (test-comparison 2 (! i|<0) ; inner >< + (test-comparison 2 (! a) a) ; inner > + (test-comparison 3 (! i|>a0) i|a) ; inner > + (test-comparison 3 (! >a) + (test-comparison 3 (! i|>a0) i| + (test-comparison 1 (! >a) ><0) ; inner <> + (test-comparison 2 (! i|>a0) i|><0) ; inner >< + (test-comparison 2 (! >a) Uc) ; inner < + (test-comparison 2 (! i|>a0) Uc) ; inner < + (test-comparison 1 (! ><0) a) ; inner <> + (test-comparison 2 (! i|><0) i|a) ; inner >< + (test-comparison 1 (! ><0) + (test-comparison 2 (! i|><0) i|< + (test-comparison 1 (! ><0) >a) ; inner <> + (test-comparison 2 (! i|><0) i|>a0) ; inner >< + (test-comparison 2 (! ><0) Uc) ; inner < + (test-comparison 2 (! i|><0) Uc) ; inner < + (testing "+ ValueSpec" + (test-comparison -1 (t/value 1) (! (t/value 2))) + (test-comparison 3 (t/value "") (! t/string?)))) + (testing "OrSpec" + (testing "+ OrSpec" + ;; Comparison annotations achieved by first comparing each element of the first/left + ;; to the entire second/right, then comparing each element of the second/right to the + ;; entire first/left + ;; TODO add complete comparisons via `comparison-combinations` + (testing "#{<}, #{<}" + ;; comparisons: < < < < + (test-comparison 0 (| a b) (| a b)) + ;; comparisons: < < < < + (test-comparison 0 (| i|>a+b i|>a0) (| i|>a+b i|>a0))) + (testing "#{<}, #{<, ><}" + ;; comparisons: < < < < >< >< + (test-comparison -1 (| i|>a+b i|>a0) (| i|>a+b i|>a0 i|><0 i|><1)) + ;; comparisons: < < < < >< >< >< + (test-comparison -1 (| i|>a+b i|>a0) (| i|>a+b i|>a0 i|>a1 i|><0 i|><1)) + ;; comparisons: < < < < < < >< >< + (test-comparison -1 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|>a0 i|>a1 i|><0 i|><1))) + (testing "#{<, ><}, #{<}" + ;; comparisons: < < >< < < + (test-comparison 1 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|>a0)) + ;; comparisons: >< < < < < + (test-comparison 1 (| i|a i|><0 i|><1) (| i|><0 i|><1))) + (testing "#{<, ><}, #{<, ><}" + ;; comparisons: < >< < >< + (test-comparison 2 (| i|>a+b i|>a0) (| i|>a+b i|><0)) + ;; comparisons: < >< >< < >< >< + (test-comparison 2 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|><0 i|><1)) + ;; comparisons: < < >< < < >< >< + (test-comparison 2 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|>a0 i|><0 i|><1)) + ;; comparisons: < < >< < >< + (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|a i|><0)) + ;; comparisons: < >< >< < >< >< + (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|a i|><0 i|><1)) + ;; comparisons: >< < < >< + (test-comparison 2 (| i|a i|><0) (| i|><0 i|><1)) + ;; comparisons: >< < >< >< < + (test-comparison 2 (| i|a i|><1 i|><2) (| i|><0 i|><1)) + ;; comparisons: >< >< < < >< + (test-comparison 2 (| i|a i|><0 i|><1) (| i|><1 i|><2))) + (testing "#{<, ><}, #{><}" + ;; comparisons: < >< >< >< + (test-comparison 2 (| i|a i|><0) (| i|>a+b i|>a0)) + ;; comparisons: < >< >< >< >< + (test-comparison 2 (| i|a i|><0 i|><1) (| i|>a+b i|>a0)) + ;; comparisons: < >< >< >< >< + (test-comparison 2 (| i|a i|><0) (| i|>a+b i|>a0 i|>a1)) + ;; comparisons: < >< >< >< >< >< + (test-comparison 2 (| i|a i|><0 i|><1) (| i|>a+b i|>a0 i|>a1))) + (testing "#{<, <>}, #{<, <>}" + ;; comparisons: < <> < <> + (test-comparison 2 (| a b) (| a ><1)) + ;; comparisons: <> < < <> + (test-comparison 2 (| a b) (| b ><1))) + (testing "#{<, <>}, #{><, <>}" + ;; comparisons: <, <> >< <> <> + (test-comparison 2 (| a b) (| >a ><0 ><1))) + (testing "#{><}, #{<, ><}" + ;; comparisons: >< >< >< < >< >< + (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|<0 i|><1)) + ;; comparisons: >< >< >< >< < >< >< + (test-comparison 2 (| i|a i|>a+b i|>a0 i|>a1) (| i|<0 i|><1)) + ;; comparisons: >< >< >< < < >< >< + (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|<0 i|><1)) + ;; comparisons: >< >< >< >< < < >< >< + (test-comparison 2 (| i|a i|>a+b i|>a0 i|>a1) (| i|<0 i|><1)) + ;; comparisons: >< >< >< < < < >< >< + (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|<0 i|><1)) + ;; comparisons: >< >< >< >< < < < >< >< + (test-comparison 2 (| i|a i|>a+b i|>a0 i|>a1) (| i|<0 i|><1))) + (testing "#{><}, #{><}" + ;; comparisons: >< >< >< >< + (test-comparison 2 (| i|a i|><2) (| i|><0 i|><1)) + ;; comparisons: >< >< >< >< + (test-comparison 2 (| i|a i|><0) (| i|><1 i|><2))) + (testing "#{<>}, #{<>}" + ;; comparisons: <> <> <> <> + (test-comparison 3 (| a b) (| ><0 ><1))))) + ;; TODO fix tests/impl + #_(testing "+ AndSpec" + ;; Comparison annotations achieved by first comparing each element of the first/left + ;; to the entire second/right, then comparing each element of the second/right to the + ;; entire first/left + (testing "#{= <+} -> #{<+}" + (testing "+ #{<+}" + ;; comparisons: [-1, -1], [-1, -1] + (test-comparison 1 (| a >a+b >a0) (& >a+b >a0)) + ;; comparisons: [-1, -1, 3], [-1, -1] + (test-comparison 1 (| a >a+b >a0 >a1) (& >a+b >a0)) + ;; comparisons: [-1, -1], [-1, -1, 3] + (test-comparison 3 (| a >a+b >a0) (& >a+b >a0 >a1)) + ;; comparisons: [-1, -1, -1], [-1, -1, -1] + (test-comparison 1 (| a >a+b >a0 >a1) (& >a+b >a0 >a1))) + (testing "+ #{∅+}" + ;; comparisons: [3, 3, 3], [3, 3] + (test-comparison 3 (| a >a+b >a0) (& ><0 ><1))) + (testing "+ #{<+ ∅+}" + ;; comparisons: [-1, 3], [-1, 3, 3] + (test-comparison 3 (| a >a+b >a0) (& >a+b ><0 ><1)) + ;; comparisons: [-1, 3, 3], [-1, 3, 3] + (test-comparison 3 (| a >a+b >a0 >a1) (& >a+b ><0 ><1)) + ;; comparisons: [-1, -1], [-1, -1, 3, 3] + (test-comparison 3 (| a >a+b >a0) (& >a+b >a0 ><0 ><1)) + ;; comparisons: [-1, -1, 3], [-1, -1, 3, 3] + (test-comparison 3 (| a >a+b >a0 >a1) (& >a+b >a0 ><0 ><1)) + ;; comparisons: [-1, -1], [-1, -1, 3, 3, 3] + (test-comparison 3 (| a >a+b >a0) (& >a+b >a0 >a1 ><0 ><1)) + ;; comparisons: [-1, -1, -], [-1, -1, -1, 3, 3] + (test-comparison 3 (| a >a+b >a0 >a1) (& >a+b >a0 >a1 ><0 ><1))) + (testing "+ #{= ∅+}" + ;; comparisons: [3, 3], [-1, 3] + (test-comparison 3 (| a >a+b >a0) (& a ><0)) + ;; comparisons: [3, 3], [-1, 3, 3] + (test-comparison 3 (| a >a+b >a0) (& a ><0 ><1))) + (testing "+ #{>+ ∅+}" + ;; comparisons: [3, 3], [-1, 3, 3] + (test-comparison 3 (| a >a+b >a0) (& <0 ><1)) + ;; comparisons: [3, 3, 3], [-1, 3, 3] + (test-comparison 3 (| a >a+b >a0 >a1) (& <0 ><1)) + ;; comparisons: [3, 3], [-1, -1, 3, 3] + (test-comparison 3 (| a >a+b >a0) (& <0 ><1)) + ;; comparisons: [3, 3, 3], [-1, -1, 3, 3] + (test-comparison 3 (| a >a+b >a0 >a1) (& <0 ><1)) + ;; comparisons: [3, 3], [-1, -1, 3, 3, 3] + (test-comparison 3 (| a >a+b >a0) (& <0 ><1)) + ;; comparisons: [3, 3, 3], [-1, -1, -1, 3, 3] + (test-comparison 3 (| a >a+b >a0 >a1) (& <0 ><1))))) + (testing "+ InferSpec") + (testing "+ Expression") + (testing "+ ProtocolSpec") + (testing "+ ClassSpec" + (testing "#{<}" + (test-comparison -1 i|a+b i|>a0 i|>a1))) + #_(testing "#{< =}") ; Impossible for `OrSpec` + #_(testing "#{< = >}") ; Impossible for `OrSpec` + #_(testing "#{< = > ><}") ; Impossible for `OrSpec` + #_(testing "#{< = > >< <>}") ; Impossible for `OrSpec` + #_(testing "#{< = > <>}") ; Impossible for `OrSpec` + #_(testing "#{< = ><}") ; Impossible for `OrSpec` + #_(testing "#{< = >< <>}") ; Impossible for `OrSpec` + #_(testing "#{< = <>}") ; Impossible for `OrSpec` + #_(testing "#{< >}") ; Impossible for `OrSpec` + #_(testing "#{< > ><}") ; Impossible for `OrSpec` + #_(testing "#{< > >< <>}") ; Impossible for `OrSpec` + #_(testing "#{< > <>}") ; Impossible for `OrSpec` + (testing "#{< ><}" + (test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1)) + (test-comparison -1 i|>a0 (| i|>a+b i|>a0))) + (testing "#{< >< <>}" + (test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1 t/string?))) + (testing "#{< <>}" + (test-comparison -1 a (| >a ><0 ><1))) + #_(testing "#{=}") ; Impossible for `OrSpec` + #_(testing "#{= >}") ; Impossible for `OrSpec` + #_(testing "#{= > ><}") ; Impossible for `OrSpec` + #_(testing "#{= > >< <>}") ; Impossible for `OrSpec` + #_(testing "#{= > <>}") ; Impossible for `OrSpec` + (testing "#{= ><}" + (test-comparison -1 i|a (| i|a i|><0 i|><1))) + (testing "#{= >< <>}" + (test-comparison -1 i|a (| i|a i|><0 i|><1 t/string?))) + (testing "#{= <>}" + (test-comparison -1 a (| a ><0 ><1))) + (testing "#{>}" + (test-comparison 1 a (| ><}" + (test-comparison 2 i|a (| i|<0 i|><1))) + (testing "#{> >< <>}" + (test-comparison 2 i|a (| i|<0 i|><1 t/string?))) + (testing "#{> <>}" + (test-comparison 2 a (| <0 ><1))) + (testing "#{><}" + (test-comparison 2 i|a (| i|><0 i|><1))) + (testing "#{>< <>}" + (test-comparison 2 i|a (| i|><0 i|><1 t/string?))) + (testing "#{<>}" + (test-comparison 3 a (| ><0 ><1))) + (testing "Nilable" + (testing "< nilabled: #{< <>}" + (test-comparison -1 t/long? (t/? t/object?))) + (testing "= nilabled: #{= <>}" + (test-comparison -1 t/long? (t/? t/long?))) + (testing "> nilabled: #{> <>}" + (test-comparison 2 t/object? (t/? t/long?))) + (testing ">< nilabled: #{>< <>}" + (test-comparison 2 t/iterable? (t/? t/comparable?))) + (testing "<> nilabled: #{<>}" + (test-comparison 3 t/long? (t/? t/string?))))) + (testing "+ ValueSpec" + (testing "arg <" + (testing "+ arg <") + (testing "+ arg =") + (testing "+ arg >") + (testing "+ arg ><") + (testing "+ arg <>" + (test-comparison -1 (t/value "a") (| t/string? t/byte?)) + (test-comparison -1 (t/value 1) (| (t/value 1) (t/value 2))) + (test-comparison -1 (t/value 1) (| (t/value 2) (t/value 1))) + (testing "+ arg <>" + (test-comparison -1 (t/value 1) (| (t/value 1) (t/value 2) (t/value 3))) + (test-comparison -1 (t/value 1) (| (t/value 2) (t/value 1) (t/value 3))) + (test-comparison -1 (t/value 1) (| (t/value 2) (t/value 3) (t/value 1)))))) + (testing "arg =" + (testing "+ arg <>" + (test-comparison -1 t/nil? (| t/nil? t/string?)))) + (testing "arg <>" + (testing "+ arg <>" + (test-comparison 3 (t/value "a") (| t/byte? t/long?)) + (test-comparison 3 (t/value 3) (| (t/value 1) (t/value 2))))))) + (testing "AndSpec" + (testing "+ AndSpec") + (testing "+ InferSpec") + (testing "+ Expression") + (testing "+ ProtocolSpec") + (testing "+ ClassSpec" + (testing "#{<}" + (testing "Boxed Primitive" + (test-comparison -1 t/byte? (& t/number? t/comparable?))) + (testing "Final Concrete" + (test-comparison -1 t/string? (& t/char-seq? t/comparable?))) + (testing "Extensible Concrete" + (test-comparison -1 a (& t/iterable? (t/isa? java.util.RandomAccess)))) + (testing "Abstract" + (test-comparison -1 (t/isa? java.util.AbstractMap$SimpleEntry) (& (t/isa? java.util.Map$Entry) (t/isa? java.io.Serializable)))) + (testing "Interface" + (test-comparison -1 i|a (& i|>a0 i|>a1)))) + (testing "#{<}" + (test-comparison -1 i|a (& i|>a0 i|>a1))) + #_(testing "#{< =}") ; Impossible for `AndSpec` + #_(testing "#{< = >}") ; Impossible for `AndSpec` + #_(testing "#{< = > ><}") ; Impossible for `AndSpec` + #_(testing "#{< = > >< <>}") ; Impossible for `AndSpec` + #_(testing "#{< = > <>}") ; Impossible for `AndSpec` + #_(testing "#{< = ><}") ; Impossible for `AndSpec` + #_(testing "#{< = >< <>}") ; Impossible for `AndSpec` + #_(testing "#{< = <>}") ; Impossible for `AndSpec` + #_(testing "#{< >}") ; Impossible for `AndSpec` + #_(testing "#{< > ><}") ; Impossible for `AndSpec` + #_(testing "#{< > >< <>}") ; Impossible for `AndSpec` + #_(testing "#{< > <>}") ; Impossible for `AndSpec` + (testing "#{< ><}" + (test-comparison 2 i|a (& i|>a+b i|>a0 i|>a1 i|><0 i|><1))) + (testing "#{< >< <>}" + (test-comparison 2 t/java-set? (& t/java-coll? t/char-seq? (t/isa? java.nio.ByteBuffer)))) + (testing "#{< <>}" + (test-comparison 3 t/string? (& t/char-seq? t/java-set?)) + (test-comparison 3 ><0 (& (! ><1) (! ><0))) + (test-comparison 3 a (& (! a) (! b)))) + #_(testing "#{=}") ; Impossible for `AndSpec` + #_(testing "#{= >}") ; Impossible for `AndSpec` + #_(testing "#{= > ><}") ; Impossible for `AndSpec` + #_(testing "#{= > >< <>}") ; Impossible for `AndSpec` + #_(testing "#{= > <>}") ; Impossible for `AndSpec` + (testing "#{= ><}" + (test-comparison 1 i|a (& i|a i|><0 i|><1)) + (test-comparison 1 t/char-seq? (& t/char-seq? t/java-set?)) + (test-comparison 1 t/char-seq? (& t/char-seq? t/java-set? a))) + (testing "#{= >< <>}") ; <- TODO comparison should be 1 + ;; TODO fix + (testing "#{= <>}" + (test-comparison 1 a (& a t/java-set?))) + (testing "#{>}" + (test-comparison 1 i|a (& i| ><}" + (test-comparison 2 i|a (& i|<0 i|><1)) + (test-comparison 2 a (& (t/isa? javax.management.AttributeList) t/java-set?)) + (test-comparison 2 t/comparable? (& (t/isa? java.nio.ByteBuffer) t/java-set?))) + (testing "#{> >< <>}" + (test-comparison 2 i|a (& i|<0 a))) + (testing "#{> <>}") ; <- TODO comparison should be 1 + (testing "#{><}" + (test-comparison 2 i|a (& i|><0 i|><1)) + (test-comparison 2 t/char-seq? (& t/java-set? a))) + (testing "#{>< <>}") ; <- TODO comparison should be 3 + (testing "#{<>}" + (test-comparison 3 t/string? (& a t/java-set?)))) + (testing "+ ValueSpec" + (testing "#{<}" + (test-comparison -1 (t/value "a") (& t/char-seq? t/comparable?))) + #_(testing "#{< =}") ; not possible for `AndSpec` + #_(testing "#{< = >}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` + #_(testing "#{< = > ><}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` + #_(testing "#{< = > >< <>}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` + #_(testing "#{< = > <>}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` + #_(testing "#{< = ><}") ; not possible for `AndSpec`; `><` not possible for `ValueSpec` + #_(testing "#{< = >< <>}") ; not possible for `AndSpec`; `><` not possible for `ValueSpec` + #_(testing "#{< = <>}") ; not possible for `AndSpec` + #_(testing "#{< >}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` + #_(testing "#{< > ><}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` + #_(testing "#{< > >< <>}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` + #_(testing "#{< > <>}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` + #_(testing "#{< ><}") ; `><` not possible for `ValueSpec` + #_(testing "#{< >< <>}") ; `><` not possible for `ValueSpec` + (testing "#{< <>}" + (test-comparison 3 (t/value "a") (& t/char-seq? a)) + (test-comparison 3 (t/value "a") (& t/char-seq? t/java-set?))) + #_(testing "#{=}") ; not possible for `AndSpec` + #_(testing "#{= >}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` + #_(testing "#{= > ><}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` + #_(testing "#{= > >< <>}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` + #_(testing "#{= > <>}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` + #_(testing "#{= ><}") ; `><` not possible for `ValueSpec` + #_(testing "#{= >< <>}") ; `><` not possible for `ValueSpec` + (testing "#{= <>}") + #_(testing "#{>}") ; `>` not possible for `ValueSpec` + #_(testing "#{> ><}") ; `>` and `><` not possible for `ValueSpec` + #_(testing "#{> >< <>}") ; `>` and `><` not possible for `ValueSpec` + #_(testing "#{> <>}") ; `>` not possible for `ValueSpec` + #_(testing "#{><}") ; `><` not possible for `ValueSpec` + #_(testing "#{>< <>}") ; `><` not possible for `ValueSpec` + (testing "#{<>}" + (test-comparison 3 (t/value "a") (& a t/java-set?))))) + (testing "InferSpec" + (testing "+ InferSpec") + (testing "+ Expression") + (testing "+ ProtocolSpec") + (testing "+ ClassSpec") + (testing "+ ValueSpec")) + (testing "Expression" + (testing "+ Expression") + (testing "+ ProtocolSpec") + (testing "+ ClassSpec") + (testing "+ ValueSpec")) + (testing "ProtocolSpec" + (testing "+ ProtocolSpec" + (test-comparison 0 (t/isa? AProtocolAll) (t/isa? AProtocolAll)) + (test-comparison 3 (t/isa? AProtocolAll) (t/isa? AProtocolNone))) + (testing "+ ClassSpec") + (testing "+ ValueSpec" + (let [values #{t/universal-set t/empty-set nil {} 1 "" AProtocolAll + quantum.test.core.untyped.type.AProtocolAll}] + (doseq [v values] + (test-comparison -1 (t/value v) (t/isa? AProtocolAll))) + (doseq [v [""]] + (test-comparison -1 (t/value v) (t/isa? AProtocolString))) + (doseq [v (disj values "")] + (test-comparison 3 (t/value v) (t/isa? AProtocolString))) + (doseq [v (disj values nil)] + (test-comparison -1 (t/value v) (t/isa? AProtocolNonNil))) + (doseq [v [nil]] + (test-comparison 3 (t/value v) (t/isa? AProtocolNonNil))) + (doseq [v [nil]] + (test-comparison -1 (t/value v) (t/isa? AProtocolOnlyNil))) + (doseq [v (disj values nil)] + (test-comparison 3 (t/value v) (t/isa? AProtocolOnlyNil))) + (doseq [v values] + (test-comparison 3 (t/value v) (t/isa? AProtocolNone)))))) + (testing "ClassSpec" + (testing "+ ClassSpec" + (testing "Boxed Primitive + Boxed Primitive" + (test-comparison 0 t/long? t/long?) + (test-comparison 3 t/long? t/int?)) + (testing "Boxed Primitive + Final Concrete" + (test-comparison 3 t/long? t/string?)) + (testing "Boxed Primitive + Extensible Concrete" + (testing "< , >" + (test-comparison -1 t/long? t/object?)) + (testing "<>" + (test-comparison 3 t/long? t/thread?))) + (testing "Boxed Primitive + Abstract" + (test-comparison 3 t/long? (t/isa? java.util.AbstractCollection))) + (testing "Boxed Primitive + Interface" + (test-comparison 3 t/long? t/char-seq?)) + (testing "Final Concrete + Final Concrete" + (test-comparison 0 t/string? t/string?)) + (testing "Final Concrete + Extensible Concrete" + (testing "< , >" + (test-comparison -1 t/string? t/object?)) + (testing "<>" + (test-comparison 3 t/string? a))) + (testing "Final Concrete + Abstract") + (testing "Final Concrete + Interface" + (testing "< , >" + (test-comparison -1 t/string? t/comparable?)) + (testing "<>" + (test-comparison 3 t/string? t/java-coll?))) + (testing "Extensible Concrete + Extensible Concrete" + (test-comparison 0 t/object? t/object?) + (testing "< , >" + (test-comparison -1 a t/object?)) + (testing "<>" + (test-comparison 3 a t/thread?))) + (testing "Extensible Concrete + Abstract" + (testing "< , >" + (test-comparison -1 (t/isa? java.util.AbstractCollection) t/object?) + (test-comparison -1 a (t/isa? java.util.AbstractCollection))) + (testing "<>" + (test-comparison 3 t/thread? (t/isa? java.util.AbstractCollection)) + (test-comparison 3 (t/isa? java.util.AbstractCollection) t/thread?))) + (testing "Extensible Concrete + Interface" + (test-comparison 2 a t/char-seq?)) + (testing "Abstract + Abstract" + (test-comparison 0 (t/isa? java.util.AbstractCollection) (t/isa? java.util.AbstractCollection)) + (testing "< , >" + (test-comparison -1 (t/isa? java.util.AbstractList) (t/isa? java.util.AbstractCollection))) + (testing "<>" + (test-comparison 3 (t/isa? java.util.AbstractList) (t/isa? java.util.AbstractQueue)))) + (testing "Abstract + Interface" + (testing "< , >" + (test-comparison -1 (t/isa? java.util.AbstractCollection) t/java-coll?)) + (testing "><" + (test-comparison 2 (t/isa? java.util.AbstractCollection) t/comparable?))) + (testing "Interface + Interface" + (testing "< , >" + (test-comparison -1 t/java-coll? t/iterable?)) + (testing "><" + (test-comparison 2 t/char-seq? t/comparable?)))) + (testing "+ ValueSpec" + (testing "<" + (testing "Class equality" + (test-comparison -1 (t/value "a") t/string?)) + (testing "Class inheritance" + (test-comparison -1 (t/value "a") t/char-seq?) + (test-comparison -1 (t/value "a") t/object?))) + (testing "<>" + (test-comparison 3 (t/value "a") t/byte?)))) + (testing "ValueSpec" + (testing "+ ValueSpec" + (testing "=" + (test-comparison 0 (t/value nil) (t/value nil)) + (test-comparison 0 (t/value 1 ) (t/value 1 )) + (test-comparison 0 (t/value "a") (t/value "a"))) + (testing "=, non-strict" + (test-comparison 0 (t/value (vector) ) (t/value (list) )) + (test-comparison 0 (t/value (vector (vector))) (t/value (vector (list)))) + (test-comparison 0 (t/value (hash-map) ) (t/value (sorted-map) ))) + (testing "<>" + (test-comparison 3 (t/value 1 ) (t/value 2 )) + (test-comparison 3 (t/value "a") (t/value "b")) + (test-comparison 3 (t/value 1 ) (t/value "a")) + (test-comparison 3 (t/value nil) (t/value "a")))))) + +(deftest test|not + (testing "simplification" + (testing "universal/null set" + (is= (! t/universal-set) + t/empty-set) + (is= (! t/empty-set) + t/universal-set)) + (testing "universal class-set" + (is= (! t/val?) + t/nil?) + (is= (! t/val|by-class?) + t/nil?)) + (testing "DeMorgan's Law" + (is= (! (| i|a i|b)) + (& (! i|a) (! i|b))) + (is= (! (& i|a i|b)) + (| (! i|a) (! i|b))) + (is= (! (| (! i|a) (! i|b))) + (& i|a i|b)) + (is= (! (& (! i|a) (! i|b))) + (| i|a i|b))))) + +(deftest test|- + (testing "=" + (is= (t/- a a) + t/empty-set)) + (testing "<" + (is= (t/- a >a) + t/empty-set)) + (testing "<>" + (is= (t/- a b) + a)) + (testing ">" + (is= (t/- (| a b) a) + b) + (is= (t/- (| a b t/long?) a) + (| b t/long?))) + (testing "><" + )) + +(deftest test|or + (testing "equality" + (is= (| a b) (| a b))) + (testing "simplification" + (testing "via single-arg" + (is= (| a) + a)) + (testing "via identity" + (is= (| a a) + a) + (is= (| (| a a) a) + a) + (is= (| a (| a a)) + a) + (is= (| (| a b) (| b a)) + (| a b)) + (is= (| (| a b ><0) (| a ><0 b)) + (| a b ><0))) + (testing "nested `or` is expanded" + (is= (| (| a b) (| ><0 ><1)) + (| a b ><0 ><1)) + (is= (| (| a b) (| ><0 ><1)) + (| a b ><0 ><1))) + (testing "via `not`" + (is= (| a (! a)) + t/universal-set) + (is= (| a b (! a)) + t/universal-set) + (is= (| a b (| (! a) (! b))) + t/universal-set)) + (testing "nested" + (is= (t/or-spec>args (| (| t/string? t/double?) + t/char-seq?)) + [t/double? t/char-seq?]) + (is= (t/or-spec>args (| (| t/string? t/double?) + (| t/double? t/char-seq?))) + [t/double? t/char-seq?]) + (is= (t/or-spec>args (| (| t/string? t/double?) + (| t/char-seq? t/number?))) + [t/char-seq? t/number?])) + (testing "#{<+ =} -> #{<+}" + (is= (t/or-spec>args (| i|>a+b i|>a0 i|a)) + [i|>a+b i|>a0])) + (testing "#{<+ >+} -> #{<+}" + (is= (t/or-spec>args (| i|>a+b i|>a0 i|a+b i|>a0])) + (testing "#{>+ =} -> #{=}" + (is= (| i|+ ><+} -> #{<+ ><+}" + (is= (t/or-spec>args (| i|>a+b i|>a0 i|<0 i|><1)) + [i|>a+b i|>a0 i|><0 i|><1])) + (testing "#{<+ >+ <>+} -> #{<+ <>+}" + (is= (t/or-spec>args (| >a <0 ><1)) + [>a ><0 ><1])) + (testing "#{<+ =+ >+ ><+} -> #{<+ ><+}" + (is= (t/or-spec>args (| i|>a+b i|>a0 i|a i|<0 i|><1)) + [i|>a+b i|>a0 i|><0 i|><1])) + (testing "#{<+ =+ >+ <>+} -> #{<+ <>+}" + (is= (t/or-spec>args (| >a a <0 ><1)) + [>a ><0 ><1])))) + +(deftest test|and + (testing "equality" + (is= (& i|a i|b) (& i|a i|b))) + (testing "null set / universal set" + (is= (& t/universal-set t/universal-set) + t/universal-set) + (is= (& t/universal-set t/empty-set) + t/empty-set) + (is= (& t/empty-set t/universal-set) + t/empty-set) + (is= (& t/universal-set t/empty-set t/universal-set) + t/empty-set) + (is= (& t/universal-set t/string?) + t/string?) + (is= (& t/universal-set t/char-seq? t/string?) + t/string?) + (is= (& t/universal-set t/string? t/char-seq?) + t/string?) + (is= (& t/empty-set t/string?) + t/empty-set) + (is= (& t/empty-set t/char-seq? t/string?) + t/empty-set) + (is= (& t/empty-set t/string? t/char-seq?) + t/empty-set)) + (testing "simplification" + (testing "via single-arg" + (is= (& a) + a)) + (testing "via identity" + (is= (& a a) + a) + (is= (& (! a) (! a)) + (! a)) + (is= (& (& a a) a) + a) + (is= (& a (& a a)) + a) + (is= (& (| t/string? t/byte?) (| t/byte? t/string?)) + (| t/string? t/byte?)) + (is= (& (| a b) (| b a)) + (| a b)) + (is= (& (| a b ><0) (| a ><0 b)) + (| a b ><0))) + (testing "" + (is= (t/and-spec>args (& i|a i|b)) + [i|a i|b])) + (testing "empty-set" + (is= (& a b) + t/empty-set) + (is= (& t/string? t/byte?) + t/empty-set) + (is= (& a ><0) + t/empty-set) + (is= (& a ><0 ><1) + t/empty-set)) + (testing "nested `and` is expanded" + (is= (& (& a b) (& ><0 ><1)) + (& a b ><0 ><1)) + (is= (& (& a b) (& ><0 ><1)) + (& a b ><0 ><1))) + (testing "and + not" + (is= (& a (! a)) + t/empty-set) + (is= (& a (! b)) + a) + (is= (& (! b) a) + a) + (testing "+ or" + (is= (& (! a) a b) + t/empty-set) + (is= (& a (! a) b) + t/empty-set) + (is= (& a b (! a)) + t/empty-set) + (is= (& (| a b) (! a)) + b) + ;; TODO fix impls + #_(is= (& (! a) (| a b)) + b) + (is= (& (| a b) (! b) (| b a)) + a) + (is= (& (| a b) (! b) (| ><0 b)) + t/empty-set)) + (is= (& t/primitive? (! t/boolean?)) + (| t/byte? t/char? t/short? t/int? t/long? t/float? t/double?))) + (testing "#{<+ =} -> #{=}" + (is= (& i|>a+b i|>a0 i|a) + i|a)) + (testing "#{>+ =+} -> #{>+}" + (is= (t/and-spec>args (& i|+} -> #{>+}" + (is= (t/and-spec>args (& i|>a+b i|>a0 i|+ ∅+} -> #{>+ ∅+}" + (is= (t/and-spec>args (& i|>a+b i|>a0 i|<0 i|><1)) + [i|<0 i|><1])) + (testing "#{<+ =+ >+ ∅+} -> #{>+ ∅+}" + (is= (t/and-spec>args (& i|>a+b i|>a0 i|a i|<0 i|><1)) + [i|<0 i|><1])))) + +(deftest test|= + ;; Takes an inordinately long time to do `test-comparison 0 ...` even without instrumentation + (is= (| t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) + (& (| t/boolean? t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) + (! t/boolean?))) + (test-comparison 0 t/any? t/universal-set) + (testing "universal class(-set) identity" + (is (t/= t/val? (& t/any? t/val?))))) From 3d7a924ba6d962d26d48a4016e927e8fb31bd8c5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 16 May 2018 15:49:39 -0600 Subject: [PATCH 048/810] Modularize test code structure --- src-untyped/quantum/untyped/core/test.cljc | 73 +- src-untyped/quantum/untyped/core/type.cljc | 8 +- src/quantum/core/test.cljc | 74 +- .../test/untyped/core/collections.cljc | 2 +- test/quantum/test/untyped/core/type.cljc | 839 +----------------- .../test/untyped/core/type/compare.cljc | 781 ++++++++++++++++ 6 files changed, 891 insertions(+), 886 deletions(-) create mode 100644 test/quantum/test/untyped/core/type/compare.cljc diff --git a/src-untyped/quantum/untyped/core/test.cljc b/src-untyped/quantum/untyped/core/test.cljc index da460b95..fa536144 100644 --- a/src-untyped/quantum/untyped/core/test.cljc +++ b/src-untyped/quantum/untyped/core/test.cljc @@ -1,11 +1,72 @@ (ns quantum.untyped.core.test (:require - [clojure.spec.alpha :as s] - [clojure.spec.test.alpha :as stest] - [clojure.string :as str] - [clojure.test :as test])) + [clojure.spec.alpha :as s] + [clojure.spec.test.alpha :as stest] + [clojure.string :as str] + [clojure.test :as test] + [quantum.untyped.core.error :as err] + [quantum.untyped.core.print + :refer [ppr-meta]] + [quantum.untyped.core.vars + :refer [defalias defmalias]])) -(defn report-results [check-results] +#?(:clj (defmalias is clojure.test/is cljs.test/is )) +#?(:clj (defmalias deftest clojure.test/deftest cljs.test/deftest)) +#?(:clj (defmalias testing clojure.test/testing cljs.test/testing)) +#?(:clj (defalias test/test-ns)) + +#?(:clj +(defn test-nss-where [pred] + (->> (all-ns) (filter #(-> % ns-name name pred)) (map test-ns) doall))) + +#?(:clj (defmacro is= [& args] `(is (= ~@args)))) +#?(:clj (defmacro throws + ([x] `(do (is (~'thrown? ~(err/env>generic-error &env) ~x)) true)) + ([expr err-pred] + `(try ~expr + (is (throws '~err-pred)) + (catch ~(err/env>generic-error &env) e# (is (~err-pred e#))))))) + +; Makes test failures and errors print prettily +; TODO CLJS +#?(:clj +(defmethod test/report :fail [m] + (test/with-test-out + (test/inc-report-counter :fail) + (println "\nFAIL in" (test/testing-vars-str m)) + (when (seq test/*testing-contexts*) (println (test/testing-contexts-str))) + (when-let [message (:message m)] (println message)) + (println "expected:" (with-out-str (ppr-meta (:expected m)))) + (println " actual:" (with-out-str (ppr-meta (:actual m))))))) + +#?(:clj +(defmethod test/report :error [m] + (test/with-test-out + (test/inc-report-counter :error) + (println "\nERROR in" (test/testing-vars-str m)) + (when (seq test/*testing-contexts*) (println (test/testing-contexts-str))) + (when-let [message (:message m)] (println message)) + (println "expected:" (with-out-str (ppr-meta (:expected m)))) + (print " actual: ") + (println (with-out-str (ppr-meta (:actual m))))))) + +#?(:clj +(defn test-syms! + "Tests the provided syms, in order, deduplicating them." + [& syms] + (try + (let [test-syms (distinct syms)] + (doseq [test-sym test-syms] + (try + (println "=====" "Testing" test-sym "..." "=====" ) + (let [v (find-var test-sym)] + (assert (some? v) (str "Test sym not found: " test-sym)) + (clojure.test/test-var v)) + (println "=====" "Done with" test-sym "=====" ) + (catch Throwable t + (println "ERROR in test" test-sym t)))))))) + +(defn report-generative-results [check-results] (let [checks-passed? (->> check-results (map :failure) (every? nil?))] (if checks-passed? (test/do-report {:type :pass @@ -30,5 +91,5 @@ ([name sym-or-syms opts] (when test/*load-tests* `(defn ~(vary-meta name assoc :test - `(fn [] (report-results (stest/check ~sym-or-syms ~opts)))) + `(fn [] (report-generative-results (stest/check ~sym-or-syms ~opts)))) [] (test/test-var (var ~name))))))) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 0bc75cb0..5e4b3bc2 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -262,7 +262,13 @@ #?(:clj (uvar/defalias -def define)) -(-def type? (isa? PType)) +(-def type? (isa? PType)) +(-def not-type? (isa? NotType)) +(-def or-type? (isa? OrType)) +(-def and-type? (isa? AndType)) +(-def protocol-type? (isa? ProtocolType)) +(-def class-type? (isa? ClassType)) +(-def value-type? (isa? ValueType)) ;; ===== Miscellaneous ===== ;; diff --git a/src/quantum/core/test.cljc b/src/quantum/core/test.cljc index bfeed230..e1cff915 100644 --- a/src/quantum/core/test.cljc +++ b/src/quantum/core/test.cljc @@ -1,24 +1,11 @@ (ns quantum.core.test (:require [clojure.test :as test] - [quantum.core.error :as err] - [quantum.core.fn :as fn - :refer [fn->]] - [quantum.core.print :as pr - :refer [ppr-meta]] [quantum.core.vars - :refer [#?(:clj defmalias) defalias]] - [quantum.untyped.core.test :as utest] - [quantum.untyped.core.type.predicates - :refer [val?]]) -#?(:cljs - (:require-macros - [quantum.core.test :as self]))) + :refer [defaliases]] + [quantum.untyped.core.test :as u])) ; TO EXPLORE -; - Generative testing -; - https://github.com/clojure/test.check -; - clojure/test.generative ; - A/B testing ; - https://github.com/ptaoussanis/touchstone ; - https://github.com/facebook/planout @@ -29,59 +16,4 @@ ; - myfreeweb/clj-http-fake ; =========================== -#?(:clj (defmalias is clojure.test/is cljs.test/is )) -#?(:clj (defmalias deftest clojure.test/deftest cljs.test/deftest)) -#?(:clj (defmalias testing clojure.test/testing cljs.test/testing)) -#?(:clj (defalias test/test-ns)) -#?(:clj (defalias utest/defspec-test)) - -#?(:clj -(defn test-nss-where [pred] - (->> (all-ns) (filter (fn/fn-> ns-name name pred)) (map test-ns) doall))) - -#?(:clj (defmacro is= [& args] `(is (= ~@args)))) -#?(:clj (defmacro throws - ([x] `(do (is (~'thrown? ~(err/env>generic-error &env) ~x)) true)) - ([expr err-pred] - `(try ~expr - (is (throws '~err-pred)) - (catch ~(err/env>generic-error &env) e# (is (~err-pred e#))))))) - -; Makes test failures and errors print prettily -; TODO CLJS -#?(:clj -(defmethod test/report :fail [m] - (test/with-test-out - (test/inc-report-counter :fail) - (println "\nFAIL in" (test/testing-vars-str m)) - (when (seq test/*testing-contexts*) (println (test/testing-contexts-str))) - (when-let [message (:message m)] (println message)) - (println "expected:" (with-out-str (ppr-meta (:expected m)))) - (println " actual:" (with-out-str (ppr-meta (:actual m))))))) - -#?(:clj -(defmethod test/report :error [m] - (test/with-test-out - (test/inc-report-counter :error) - (println "\nERROR in" (test/testing-vars-str m)) - (when (seq test/*testing-contexts*) (println (test/testing-contexts-str))) - (when-let [message (:message m)] (println message)) - (println "expected:" (with-out-str (ppr-meta (:expected m)))) - (print " actual: ") - (println (with-out-str (ppr-meta (:actual m))))))) - -#?(:clj -(defn test-syms! - "Tests the provided syms, in order, deduplicating them." - [& syms] - (try - (let [test-syms (distinct syms)] - (doseq [test-sym test-syms] - (try - (println "=====" "Testing" test-sym "..." "=====" ) - (let [v (find-var test-sym)] - (assert (val? v) (str "Test sym not found: " test-sym)) - (clojure.test/test-var v)) - (println "=====" "Done with" test-sym "=====" ) - (catch Throwable t - (println "ERROR in test" test-sym t)))))))) +#?(:clj (defaliases u is is= deftest defspec-test testing test-syms! test-ns test-nss-where throws)) diff --git a/test/quantum/test/untyped/core/collections.cljc b/test/quantum/test/untyped/core/collections.cljc index 7deaa95f..e7cde4b3 100644 --- a/test/quantum/test/untyped/core/collections.cljc +++ b/test/quantum/test/untyped/core/collections.cljc @@ -4,7 +4,7 @@ :refer [deftest is is= testing]] [quantum.untyped.core.collections :as this])) -(deftest test:flatten +(deftest test|flatten (is= (this/flatten [[0 1] [2 3 4]] 0) [[0 1] [2 3 4]]) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 8463b886..8d0efc13 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -1,787 +1,21 @@ -(ns quantum.test.core.untyped.type +(ns quantum.test.untyped.core.type (:require - [clojure.core :as core] - [quantum.core.error :as err - :refer [>err]] - [quantum.core.fn :as fn - :refer [fn-> fn1]] - [quantum.core.test :as test + [clojure.core :as core] + [quantum.untyped.core.test :refer [deftest testing is is= throws]] - [quantum.untyped.core.analyze.ast :as ast] - [quantum.untyped.core.analyze.expr :as xp - :refer [>expr]] - [quantum.untyped.core.logic - :refer [ifs]] - [quantum.untyped.core.numeric :as unum] - [quantum.untyped.core.numeric.combinatorics :as ucombo] - [quantum.untyped.core.spec :as s] - [quantum.untyped.core.type :as t + [quantum.untyped.core.type :as t :refer [& | !]] - [quantum.untyped.core.defnt - :refer [defns]])) - -;; Here, `NotSpec` labels on `testing` mean such *after* simplification - -(defmacro test-comparisons>comparisons [[_ _ a b]] - `[[~@(for [a* (rest a)] - `(t/compare ~a* ~b))] - [~@(for [b* (rest b)] - `(t/compare ~b* ~a))]]) - -;; TODO come back to this -#_(do (is= -1 (t/compare (t/value 1) t/numerically-byte?)) - - (is= (& t/long? (>expr (fn1 = 1))) - (t/value 1)) - - (is= (& (t/value 1) (>expr unum/integer-value?)) - (t/value 1)) - - (t/compare (t/value 1) (>expr unum/integer-value?)) - - (is= 0 (t/compare (t/value 1) (>expr (fn1 =|long 1)))) - (is= 0 (t/compare (t/value 1) (>expr (fn [^long x] (= x 1))))) - (is= 0 (t/compare (t/value 1) (>expr (fn [^long x] (== x 1))))) - (is= 0 (t/compare (t/value 1) (>expr (fn [x] (core/== (long x) 1))))) - (is= 0 (t/compare (t/value 1) (>expr (fn [x] (= (long x) 1)))))) - -;; ----- Example interface hierarchy ----- ;; - -(do - -(gen-interface :name i.>a+b) -(gen-interface :name i.>a0) -(gen-interface :name i.>a1) -(gen-interface :name i.>b0) -(gen-interface :name i.>b1) - -(gen-interface :name i.a :extends [i.>a0 i.>a1 i.>a+b]) -(gen-interface :name i.b :extends [i.>b0 i.>b1 i.>a+b]) - -(gen-interface :name i.<0) -(gen-interface :name i.><1) -(gen-interface :name i.><2) - -(def i|>a+b (t/isa? i.>a+b)) -(def i|>a0 (t/isa? i.>a0)) -(def i|>a1 (t/isa? i.>a1)) -(def i|>b0 (t/isa? i.>b0)) -(def i|>b1 (t/isa? i.>b1)) -(def i|a (t/isa? i.a)) -(def i|b (t/isa? i.b)) -(def i|<0 (t/isa? i.><0)) -(def i|><1 (t/isa? i.><1)) -(def i|><2 (t/isa? i.><2)) - -) - -;; ----- Hierarchy within existing non-interfaces ----- ;; - -(do (def >a+b (t/isa? java.util.AbstractCollection)) - (def >a (t/isa? java.util.AbstractList)) - (def >b (t/isa? java.util.AbstractSet)) - (def a (t/isa? java.util.ArrayList)) - (def b (t/isa? java.util.HashSet)) - (def <0 t/byte?) - (def ><1 t/short?) - (def ><2 t/long?)) - -(def Uc (t/isa? java.lang.Object)) - -;; ----- Example protocols ----- ;; - -(do - -(defprotocol AProtocolAll (a-protocol-all [this])) - -(extend-protocol AProtocolAll - nil (a-protocol-all [this]) - Object (a-protocol-all [this])) - -(defprotocol AProtocolString (a-protocol-string [this])) - -(extend-protocol AProtocolString - java.lang.String (a-protocol-string [this])) - -(defprotocol AProtocolNonNil (a-protocol-non-nil [this])) - -(extend-protocol AProtocolNonNil - Object (a-protocol-non-nil [this])) - -(defprotocol AProtocolOnlyNil (a-protocol-only-nil [this])) - -(extend-protocol AProtocolOnlyNil - nil (a-protocol-only-nil [this])) - -(defprotocol AProtocolNone (a-protocol-none [this])) - -(def protocol-specs - (->> [AProtocolAll AProtocolString AProtocolNonNil AProtocolOnlyNil AProtocolNone] - (map t/>spec) set)) - -) - -;; TESTS ;; - -(defns spec>spec-combos - "To generate all commutative possibilities for a given spec." - [spec t/spec? > (s/seq-of t/spec?)] - (ifs (t/and-spec? spec) (->> spec t/and-spec>args ucombo/permutations - (map #(t/->AndSpec (vec %) (atom nil)))) - (t/or-spec? spec) (->> spec t/or-spec>args ucombo/permutations - (map #(t/->OrSpec (vec %) (atom nil)))) - [spec])) - -#?(:clj -(defmacro test-comparison - "Performs a `t/compare` on `a` and `b`, ensuring that their relationship is symmetric, - and that the inputs are internally commutative if applicable (e.g. if `a` is an `AndSpec`, - ensures that it is commutative). - The basis comparison is the first input." - [c #_t/comparisons a #_t/spec? b #_t/spec?] - `(let [c# ~c] - (doseq ;; Commutativity - [a*# (spec>spec-combos ~a) - b*# (spec>spec-combos ~b)] - ;; Symmetry - (is= c# (t/compare a*# b*#)) - (is= (t/inverse c#) (t/compare b*# a*#)))))) - -(def comparison-combinations - ["#{<}" - "#{< =}" - "#{< = >}" - "#{< = > ><}" - "#{< = > >< <>}" - "#{< = > <>}" - "#{< = ><}" - "#{< = >< <>}" - "#{< = <>}" - "#{< >}" - "#{< > ><}" - "#{< > >< <>}" - "#{< > <>}" - "#{< ><}" - "#{< >< <>}" - "#{< <>}" - "#{=}" - "#{= >}" - "#{= > ><}" - "#{= > >< <>}" - "#{= > <>}" - "#{= ><}" - "#{= >< <>}" - "#{= <>}" - "#{>}" - "#{> ><}" - "#{> >< <>}" - "#{> <>}" - "#{><}" - "#{>< <>}" - "#{<>}"]) - -(deftest test|in|compare - (testing "UniversalSetSpec" - (testing "+ UniversalSetSpec" - (test-comparison 0 t/universal-set t/universal-set)) - (testing "+ NullSetSpec" - (test-comparison 1 t/universal-set t/empty-set)) - (testing "+ NotSpec" - (test-comparison 1 t/universal-set (! a))) - (testing "+ OrSpec" - (test-comparison 1 t/universal-set (| ><0 ><1))) - (testing "+ AndSpec") - (testing "+ InferSpec") - (testing "+ Expression") - (testing "+ ProtocolSpec" - (doseq [spec protocol-specs] - (test-comparison 1 t/universal-set spec))) - (testing "+ ClassSpec") - (testing "+ ValueSpec" - (doseq [spec [(t/value t/universal-set) - (t/value t/empty-set) - (t/value 0) - (t/value nil)]] - (test-comparison 1 t/universal-set spec)))) - ;; The null set is considered to always (vacuously) be a subset of any set - (testing "NullSetSpec" - (testing "+ NullSetSpec" - (test-comparison 0 t/empty-set t/empty-set)) - (testing "+ NotSpec" - (testing "Inner ClassSpec" - (test-comparison -1 t/empty-set (! a))) - (testing "Inner ValueSpec" - (test-comparison -1 t/empty-set (! (t/value 1))))) - (testing "+ OrSpec" - (test-comparison -1 t/empty-set (| ><0 ><1))) - (testing "+ AndSpec") - (testing "+ InferSpec") - (testing "+ Expression") - (testing "+ ProtocolSpec" - (doseq [spec protocol-specs] - (test-comparison -1 t/empty-set spec))) - (testing "+ ClassSpec") - (testing "+ ValueSpec" - (test-comparison -1 t/empty-set (t/value t/empty-set)) - (test-comparison -1 t/empty-set (t/value 0)))) - (testing "NotSpec" - (testing "+ NotSpec" - (test-comparison 0 (! a) (! a)) - (test-comparison 2 (! a) (! b)) - (test-comparison 2 (! i|a) (! i|b)) - (test-comparison 2 (! t/string?) (! t/byte?)) - (test-comparison 1 (! a) (! >a)) - (test-comparison -1 (! a) (! }") ; Impossible for `OrSpec` - #_(testing "#{< = > ><}") ; Impossible for `OrSpec` - #_(testing "#{< = > >< <>}") ; Impossible for `OrSpec` - #_(testing "#{< = > <>}") ; Impossible for `OrSpec` - #_(testing "#{< = ><}") ; Impossible for `OrSpec` - #_(testing "#{< = >< <>}") ; Impossible for `OrSpec` - #_(testing "#{< = <>}") ; Impossible for `OrSpec` - #_(testing "#{< >}") ; Impossible for `OrSpec` - #_(testing "#{< > ><}") ; Impossible for `OrSpec` - #_(testing "#{< > >< <>}") ; Impossible for `OrSpec` - #_(testing "#{< > <>}") ; Impossible for `OrSpec` - (testing "#{< ><}" - #_(test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1)) - #_(test-comparison -1 i|>a0 (| i|>a+b i|>a0))) - (testing "#{< >< <>}" - #_(test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1 t/string?))) - (testing "#{< <>}" - #_(test-comparison -1 a (| >a ><0 ><1))) - #_(testing "#{=}") ; Impossible for `OrSpec` - #_(testing "#{= >}") ; Impossible for `OrSpec` - #_(testing "#{= > ><}") ; Impossible for `OrSpec` - #_(testing "#{= > >< <>}") ; Impossible for `OrSpec` - #_(testing "#{= > <>}") ; Impossible for `OrSpec` - (testing "#{= ><}" - (test-comparison -1 (! a) (| (! a) i|><0 i|><1)) - (test-comparison -1 (! i|a) (| (! i|a) i|><0 i|><1))) - (testing "#{= >< <>}" - #_(test-comparison -1 i|a (| i|a i|><0 i|><1 t/string?))) - (testing "#{= <>}" - (test-comparison -1 (! a) (| (! a) }" - #_(test-comparison 1 a (| ><}" - #_(test-comparison 2 i|a (| i|<0 i|><1))) - (testing "#{> >< <>}" - #_(test-comparison 2 i|a (| i|<0 i|><1 t/string?))) - (testing "#{> <>}" - (test-comparison 2 (! a) (| b a)) - (test-comparison 2 (! b) (| a b)) - (test-comparison 2 (! ><0) (| ><0 ><1)) - (test-comparison 2 (! ><1) (| ><1 ><0))) - (testing "#{><}" - #_(test-comparison 2 i|a (| i|><0 i|><1))) - (testing "#{>< <>}" - #_(test-comparison 2 i|a (| i|><0 i|><1 t/string?))) - (testing "#{<>}" - (test-comparison 3 (! a) (| }" - (test-comparison ... (! a) (& a (! b))))) - (testing "+ InferSpec") - (testing "+ Expression") - (testing "+ ProtocolSpec") - (testing "+ ClassSpec" - (test-comparison 3 (! a) a) ; inner = - (test-comparison 3 (! i|a) i|a) ; inner = - (test-comparison 3 (! a) - (test-comparison 3 (! i|a) i| - (test-comparison 2 (! a) >a) ; inner < - (test-comparison 2 (! i|a) i|>a0) ; inner >< - (test-comparison 1 (! a ) ><0) ; inner <> - (test-comparison 2 (! i|a) i|><0) ; inner >< - (test-comparison 2 (! a) Uc) ; inner < - (test-comparison 2 (! i|a) Uc) ; inner < - (test-comparison 2 (! a) ; inner < - (test-comparison 2 (! i|a0) ; inner < - (test-comparison 1 (! <0) ; inner <> - (test-comparison 2 (! i|<0) ; inner >< - (test-comparison 2 (! a) a) ; inner > - (test-comparison 3 (! i|>a0) i|a) ; inner > - (test-comparison 3 (! >a) - (test-comparison 3 (! i|>a0) i| - (test-comparison 1 (! >a) ><0) ; inner <> - (test-comparison 2 (! i|>a0) i|><0) ; inner >< - (test-comparison 2 (! >a) Uc) ; inner < - (test-comparison 2 (! i|>a0) Uc) ; inner < - (test-comparison 1 (! ><0) a) ; inner <> - (test-comparison 2 (! i|><0) i|a) ; inner >< - (test-comparison 1 (! ><0) - (test-comparison 2 (! i|><0) i|< - (test-comparison 1 (! ><0) >a) ; inner <> - (test-comparison 2 (! i|><0) i|>a0) ; inner >< - (test-comparison 2 (! ><0) Uc) ; inner < - (test-comparison 2 (! i|><0) Uc) ; inner < - (testing "+ ValueSpec" - (test-comparison -1 (t/value 1) (! (t/value 2))) - (test-comparison 3 (t/value "") (! t/string?)))) - (testing "OrSpec" - (testing "+ OrSpec" - ;; Comparison annotations achieved by first comparing each element of the first/left - ;; to the entire second/right, then comparing each element of the second/right to the - ;; entire first/left - ;; TODO add complete comparisons via `comparison-combinations` - (testing "#{<}, #{<}" - ;; comparisons: < < < < - (test-comparison 0 (| a b) (| a b)) - ;; comparisons: < < < < - (test-comparison 0 (| i|>a+b i|>a0) (| i|>a+b i|>a0))) - (testing "#{<}, #{<, ><}" - ;; comparisons: < < < < >< >< - (test-comparison -1 (| i|>a+b i|>a0) (| i|>a+b i|>a0 i|><0 i|><1)) - ;; comparisons: < < < < >< >< >< - (test-comparison -1 (| i|>a+b i|>a0) (| i|>a+b i|>a0 i|>a1 i|><0 i|><1)) - ;; comparisons: < < < < < < >< >< - (test-comparison -1 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|>a0 i|>a1 i|><0 i|><1))) - (testing "#{<, ><}, #{<}" - ;; comparisons: < < >< < < - (test-comparison 1 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|>a0)) - ;; comparisons: >< < < < < - (test-comparison 1 (| i|a i|><0 i|><1) (| i|><0 i|><1))) - (testing "#{<, ><}, #{<, ><}" - ;; comparisons: < >< < >< - (test-comparison 2 (| i|>a+b i|>a0) (| i|>a+b i|><0)) - ;; comparisons: < >< >< < >< >< - (test-comparison 2 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|><0 i|><1)) - ;; comparisons: < < >< < < >< >< - (test-comparison 2 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|>a0 i|><0 i|><1)) - ;; comparisons: < < >< < >< - (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|a i|><0)) - ;; comparisons: < >< >< < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|a i|><0 i|><1)) - ;; comparisons: >< < < >< - (test-comparison 2 (| i|a i|><0) (| i|><0 i|><1)) - ;; comparisons: >< < >< >< < - (test-comparison 2 (| i|a i|><1 i|><2) (| i|><0 i|><1)) - ;; comparisons: >< >< < < >< - (test-comparison 2 (| i|a i|><0 i|><1) (| i|><1 i|><2))) - (testing "#{<, ><}, #{><}" - ;; comparisons: < >< >< >< - (test-comparison 2 (| i|a i|><0) (| i|>a+b i|>a0)) - ;; comparisons: < >< >< >< >< - (test-comparison 2 (| i|a i|><0 i|><1) (| i|>a+b i|>a0)) - ;; comparisons: < >< >< >< >< - (test-comparison 2 (| i|a i|><0) (| i|>a+b i|>a0 i|>a1)) - ;; comparisons: < >< >< >< >< >< - (test-comparison 2 (| i|a i|><0 i|><1) (| i|>a+b i|>a0 i|>a1))) - (testing "#{<, <>}, #{<, <>}" - ;; comparisons: < <> < <> - (test-comparison 2 (| a b) (| a ><1)) - ;; comparisons: <> < < <> - (test-comparison 2 (| a b) (| b ><1))) - (testing "#{<, <>}, #{><, <>}" - ;; comparisons: <, <> >< <> <> - (test-comparison 2 (| a b) (| >a ><0 ><1))) - (testing "#{><}, #{<, ><}" - ;; comparisons: >< >< >< < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|<0 i|><1)) - ;; comparisons: >< >< >< >< < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0 i|>a1) (| i|<0 i|><1)) - ;; comparisons: >< >< >< < < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|<0 i|><1)) - ;; comparisons: >< >< >< >< < < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0 i|>a1) (| i|<0 i|><1)) - ;; comparisons: >< >< >< < < < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|<0 i|><1)) - ;; comparisons: >< >< >< >< < < < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0 i|>a1) (| i|<0 i|><1))) - (testing "#{><}, #{><}" - ;; comparisons: >< >< >< >< - (test-comparison 2 (| i|a i|><2) (| i|><0 i|><1)) - ;; comparisons: >< >< >< >< - (test-comparison 2 (| i|a i|><0) (| i|><1 i|><2))) - (testing "#{<>}, #{<>}" - ;; comparisons: <> <> <> <> - (test-comparison 3 (| a b) (| ><0 ><1))))) - ;; TODO fix tests/impl - #_(testing "+ AndSpec" - ;; Comparison annotations achieved by first comparing each element of the first/left - ;; to the entire second/right, then comparing each element of the second/right to the - ;; entire first/left - (testing "#{= <+} -> #{<+}" - (testing "+ #{<+}" - ;; comparisons: [-1, -1], [-1, -1] - (test-comparison 1 (| a >a+b >a0) (& >a+b >a0)) - ;; comparisons: [-1, -1, 3], [-1, -1] - (test-comparison 1 (| a >a+b >a0 >a1) (& >a+b >a0)) - ;; comparisons: [-1, -1], [-1, -1, 3] - (test-comparison 3 (| a >a+b >a0) (& >a+b >a0 >a1)) - ;; comparisons: [-1, -1, -1], [-1, -1, -1] - (test-comparison 1 (| a >a+b >a0 >a1) (& >a+b >a0 >a1))) - (testing "+ #{∅+}" - ;; comparisons: [3, 3, 3], [3, 3] - (test-comparison 3 (| a >a+b >a0) (& ><0 ><1))) - (testing "+ #{<+ ∅+}" - ;; comparisons: [-1, 3], [-1, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& >a+b ><0 ><1)) - ;; comparisons: [-1, 3, 3], [-1, 3, 3] - (test-comparison 3 (| a >a+b >a0 >a1) (& >a+b ><0 ><1)) - ;; comparisons: [-1, -1], [-1, -1, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& >a+b >a0 ><0 ><1)) - ;; comparisons: [-1, -1, 3], [-1, -1, 3, 3] - (test-comparison 3 (| a >a+b >a0 >a1) (& >a+b >a0 ><0 ><1)) - ;; comparisons: [-1, -1], [-1, -1, 3, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& >a+b >a0 >a1 ><0 ><1)) - ;; comparisons: [-1, -1, -], [-1, -1, -1, 3, 3] - (test-comparison 3 (| a >a+b >a0 >a1) (& >a+b >a0 >a1 ><0 ><1))) - (testing "+ #{= ∅+}" - ;; comparisons: [3, 3], [-1, 3] - (test-comparison 3 (| a >a+b >a0) (& a ><0)) - ;; comparisons: [3, 3], [-1, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& a ><0 ><1))) - (testing "+ #{>+ ∅+}" - ;; comparisons: [3, 3], [-1, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& <0 ><1)) - ;; comparisons: [3, 3, 3], [-1, 3, 3] - (test-comparison 3 (| a >a+b >a0 >a1) (& <0 ><1)) - ;; comparisons: [3, 3], [-1, -1, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& <0 ><1)) - ;; comparisons: [3, 3, 3], [-1, -1, 3, 3] - (test-comparison 3 (| a >a+b >a0 >a1) (& <0 ><1)) - ;; comparisons: [3, 3], [-1, -1, 3, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& <0 ><1)) - ;; comparisons: [3, 3, 3], [-1, -1, -1, 3, 3] - (test-comparison 3 (| a >a+b >a0 >a1) (& <0 ><1))))) - (testing "+ InferSpec") - (testing "+ Expression") - (testing "+ ProtocolSpec") - (testing "+ ClassSpec" - (testing "#{<}" - (test-comparison -1 i|a+b i|>a0 i|>a1))) - #_(testing "#{< =}") ; Impossible for `OrSpec` - #_(testing "#{< = >}") ; Impossible for `OrSpec` - #_(testing "#{< = > ><}") ; Impossible for `OrSpec` - #_(testing "#{< = > >< <>}") ; Impossible for `OrSpec` - #_(testing "#{< = > <>}") ; Impossible for `OrSpec` - #_(testing "#{< = ><}") ; Impossible for `OrSpec` - #_(testing "#{< = >< <>}") ; Impossible for `OrSpec` - #_(testing "#{< = <>}") ; Impossible for `OrSpec` - #_(testing "#{< >}") ; Impossible for `OrSpec` - #_(testing "#{< > ><}") ; Impossible for `OrSpec` - #_(testing "#{< > >< <>}") ; Impossible for `OrSpec` - #_(testing "#{< > <>}") ; Impossible for `OrSpec` - (testing "#{< ><}" - (test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1)) - (test-comparison -1 i|>a0 (| i|>a+b i|>a0))) - (testing "#{< >< <>}" - (test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1 t/string?))) - (testing "#{< <>}" - (test-comparison -1 a (| >a ><0 ><1))) - #_(testing "#{=}") ; Impossible for `OrSpec` - #_(testing "#{= >}") ; Impossible for `OrSpec` - #_(testing "#{= > ><}") ; Impossible for `OrSpec` - #_(testing "#{= > >< <>}") ; Impossible for `OrSpec` - #_(testing "#{= > <>}") ; Impossible for `OrSpec` - (testing "#{= ><}" - (test-comparison -1 i|a (| i|a i|><0 i|><1))) - (testing "#{= >< <>}" - (test-comparison -1 i|a (| i|a i|><0 i|><1 t/string?))) - (testing "#{= <>}" - (test-comparison -1 a (| a ><0 ><1))) - (testing "#{>}" - (test-comparison 1 a (| ><}" - (test-comparison 2 i|a (| i|<0 i|><1))) - (testing "#{> >< <>}" - (test-comparison 2 i|a (| i|<0 i|><1 t/string?))) - (testing "#{> <>}" - (test-comparison 2 a (| <0 ><1))) - (testing "#{><}" - (test-comparison 2 i|a (| i|><0 i|><1))) - (testing "#{>< <>}" - (test-comparison 2 i|a (| i|><0 i|><1 t/string?))) - (testing "#{<>}" - (test-comparison 3 a (| ><0 ><1))) - (testing "Nilable" - (testing "< nilabled: #{< <>}" - (test-comparison -1 t/long? (t/? t/object?))) - (testing "= nilabled: #{= <>}" - (test-comparison -1 t/long? (t/? t/long?))) - (testing "> nilabled: #{> <>}" - (test-comparison 2 t/object? (t/? t/long?))) - (testing ">< nilabled: #{>< <>}" - (test-comparison 2 t/iterable? (t/? t/comparable?))) - (testing "<> nilabled: #{<>}" - (test-comparison 3 t/long? (t/? t/string?))))) - (testing "+ ValueSpec" - (testing "arg <" - (testing "+ arg <") - (testing "+ arg =") - (testing "+ arg >") - (testing "+ arg ><") - (testing "+ arg <>" - (test-comparison -1 (t/value "a") (| t/string? t/byte?)) - (test-comparison -1 (t/value 1) (| (t/value 1) (t/value 2))) - (test-comparison -1 (t/value 1) (| (t/value 2) (t/value 1))) - (testing "+ arg <>" - (test-comparison -1 (t/value 1) (| (t/value 1) (t/value 2) (t/value 3))) - (test-comparison -1 (t/value 1) (| (t/value 2) (t/value 1) (t/value 3))) - (test-comparison -1 (t/value 1) (| (t/value 2) (t/value 3) (t/value 1)))))) - (testing "arg =" - (testing "+ arg <>" - (test-comparison -1 t/nil? (| t/nil? t/string?)))) - (testing "arg <>" - (testing "+ arg <>" - (test-comparison 3 (t/value "a") (| t/byte? t/long?)) - (test-comparison 3 (t/value 3) (| (t/value 1) (t/value 2))))))) - (testing "AndSpec" - (testing "+ AndSpec") - (testing "+ InferSpec") - (testing "+ Expression") - (testing "+ ProtocolSpec") - (testing "+ ClassSpec" - (testing "#{<}" - (testing "Boxed Primitive" - (test-comparison -1 t/byte? (& t/number? t/comparable?))) - (testing "Final Concrete" - (test-comparison -1 t/string? (& t/char-seq? t/comparable?))) - (testing "Extensible Concrete" - (test-comparison -1 a (& t/iterable? (t/isa? java.util.RandomAccess)))) - (testing "Abstract" - (test-comparison -1 (t/isa? java.util.AbstractMap$SimpleEntry) (& (t/isa? java.util.Map$Entry) (t/isa? java.io.Serializable)))) - (testing "Interface" - (test-comparison -1 i|a (& i|>a0 i|>a1)))) - (testing "#{<}" - (test-comparison -1 i|a (& i|>a0 i|>a1))) - #_(testing "#{< =}") ; Impossible for `AndSpec` - #_(testing "#{< = >}") ; Impossible for `AndSpec` - #_(testing "#{< = > ><}") ; Impossible for `AndSpec` - #_(testing "#{< = > >< <>}") ; Impossible for `AndSpec` - #_(testing "#{< = > <>}") ; Impossible for `AndSpec` - #_(testing "#{< = ><}") ; Impossible for `AndSpec` - #_(testing "#{< = >< <>}") ; Impossible for `AndSpec` - #_(testing "#{< = <>}") ; Impossible for `AndSpec` - #_(testing "#{< >}") ; Impossible for `AndSpec` - #_(testing "#{< > ><}") ; Impossible for `AndSpec` - #_(testing "#{< > >< <>}") ; Impossible for `AndSpec` - #_(testing "#{< > <>}") ; Impossible for `AndSpec` - (testing "#{< ><}" - (test-comparison 2 i|a (& i|>a+b i|>a0 i|>a1 i|><0 i|><1))) - (testing "#{< >< <>}" - (test-comparison 2 t/java-set? (& t/java-coll? t/char-seq? (t/isa? java.nio.ByteBuffer)))) - (testing "#{< <>}" - (test-comparison 3 t/string? (& t/char-seq? t/java-set?)) - (test-comparison 3 ><0 (& (! ><1) (! ><0))) - (test-comparison 3 a (& (! a) (! b)))) - #_(testing "#{=}") ; Impossible for `AndSpec` - #_(testing "#{= >}") ; Impossible for `AndSpec` - #_(testing "#{= > ><}") ; Impossible for `AndSpec` - #_(testing "#{= > >< <>}") ; Impossible for `AndSpec` - #_(testing "#{= > <>}") ; Impossible for `AndSpec` - (testing "#{= ><}" - (test-comparison 1 i|a (& i|a i|><0 i|><1)) - (test-comparison 1 t/char-seq? (& t/char-seq? t/java-set?)) - (test-comparison 1 t/char-seq? (& t/char-seq? t/java-set? a))) - (testing "#{= >< <>}") ; <- TODO comparison should be 1 - ;; TODO fix - (testing "#{= <>}" - (test-comparison 1 a (& a t/java-set?))) - (testing "#{>}" - (test-comparison 1 i|a (& i| ><}" - (test-comparison 2 i|a (& i|<0 i|><1)) - (test-comparison 2 a (& (t/isa? javax.management.AttributeList) t/java-set?)) - (test-comparison 2 t/comparable? (& (t/isa? java.nio.ByteBuffer) t/java-set?))) - (testing "#{> >< <>}" - (test-comparison 2 i|a (& i|<0 a))) - (testing "#{> <>}") ; <- TODO comparison should be 1 - (testing "#{><}" - (test-comparison 2 i|a (& i|><0 i|><1)) - (test-comparison 2 t/char-seq? (& t/java-set? a))) - (testing "#{>< <>}") ; <- TODO comparison should be 3 - (testing "#{<>}" - (test-comparison 3 t/string? (& a t/java-set?)))) - (testing "+ ValueSpec" - (testing "#{<}" - (test-comparison -1 (t/value "a") (& t/char-seq? t/comparable?))) - #_(testing "#{< =}") ; not possible for `AndSpec` - #_(testing "#{< = >}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` - #_(testing "#{< = > ><}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` - #_(testing "#{< = > >< <>}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` - #_(testing "#{< = > <>}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` - #_(testing "#{< = ><}") ; not possible for `AndSpec`; `><` not possible for `ValueSpec` - #_(testing "#{< = >< <>}") ; not possible for `AndSpec`; `><` not possible for `ValueSpec` - #_(testing "#{< = <>}") ; not possible for `AndSpec` - #_(testing "#{< >}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` - #_(testing "#{< > ><}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` - #_(testing "#{< > >< <>}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` - #_(testing "#{< > <>}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` - #_(testing "#{< ><}") ; `><` not possible for `ValueSpec` - #_(testing "#{< >< <>}") ; `><` not possible for `ValueSpec` - (testing "#{< <>}" - (test-comparison 3 (t/value "a") (& t/char-seq? a)) - (test-comparison 3 (t/value "a") (& t/char-seq? t/java-set?))) - #_(testing "#{=}") ; not possible for `AndSpec` - #_(testing "#{= >}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` - #_(testing "#{= > ><}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` - #_(testing "#{= > >< <>}") ; not possible for `AndSpec`; `>` and `><` not possible for `ValueSpec` - #_(testing "#{= > <>}") ; not possible for `AndSpec`; `>` not possible for `ValueSpec` - #_(testing "#{= ><}") ; `><` not possible for `ValueSpec` - #_(testing "#{= >< <>}") ; `><` not possible for `ValueSpec` - (testing "#{= <>}") - #_(testing "#{>}") ; `>` not possible for `ValueSpec` - #_(testing "#{> ><}") ; `>` and `><` not possible for `ValueSpec` - #_(testing "#{> >< <>}") ; `>` and `><` not possible for `ValueSpec` - #_(testing "#{> <>}") ; `>` not possible for `ValueSpec` - #_(testing "#{><}") ; `><` not possible for `ValueSpec` - #_(testing "#{>< <>}") ; `><` not possible for `ValueSpec` - (testing "#{<>}" - (test-comparison 3 (t/value "a") (& a t/java-set?))))) - (testing "InferSpec" - (testing "+ InferSpec") - (testing "+ Expression") - (testing "+ ProtocolSpec") - (testing "+ ClassSpec") - (testing "+ ValueSpec")) - (testing "Expression" - (testing "+ Expression") - (testing "+ ProtocolSpec") - (testing "+ ClassSpec") - (testing "+ ValueSpec")) - (testing "ProtocolSpec" - (testing "+ ProtocolSpec" - (test-comparison 0 (t/isa? AProtocolAll) (t/isa? AProtocolAll)) - (test-comparison 3 (t/isa? AProtocolAll) (t/isa? AProtocolNone))) - (testing "+ ClassSpec") - (testing "+ ValueSpec" - (let [values #{t/universal-set t/empty-set nil {} 1 "" AProtocolAll - quantum.test.core.untyped.type.AProtocolAll}] - (doseq [v values] - (test-comparison -1 (t/value v) (t/isa? AProtocolAll))) - (doseq [v [""]] - (test-comparison -1 (t/value v) (t/isa? AProtocolString))) - (doseq [v (disj values "")] - (test-comparison 3 (t/value v) (t/isa? AProtocolString))) - (doseq [v (disj values nil)] - (test-comparison -1 (t/value v) (t/isa? AProtocolNonNil))) - (doseq [v [nil]] - (test-comparison 3 (t/value v) (t/isa? AProtocolNonNil))) - (doseq [v [nil]] - (test-comparison -1 (t/value v) (t/isa? AProtocolOnlyNil))) - (doseq [v (disj values nil)] - (test-comparison 3 (t/value v) (t/isa? AProtocolOnlyNil))) - (doseq [v values] - (test-comparison 3 (t/value v) (t/isa? AProtocolNone)))))) - (testing "ClassSpec" - (testing "+ ClassSpec" - (testing "Boxed Primitive + Boxed Primitive" - (test-comparison 0 t/long? t/long?) - (test-comparison 3 t/long? t/int?)) - (testing "Boxed Primitive + Final Concrete" - (test-comparison 3 t/long? t/string?)) - (testing "Boxed Primitive + Extensible Concrete" - (testing "< , >" - (test-comparison -1 t/long? t/object?)) - (testing "<>" - (test-comparison 3 t/long? t/thread?))) - (testing "Boxed Primitive + Abstract" - (test-comparison 3 t/long? (t/isa? java.util.AbstractCollection))) - (testing "Boxed Primitive + Interface" - (test-comparison 3 t/long? t/char-seq?)) - (testing "Final Concrete + Final Concrete" - (test-comparison 0 t/string? t/string?)) - (testing "Final Concrete + Extensible Concrete" - (testing "< , >" - (test-comparison -1 t/string? t/object?)) - (testing "<>" - (test-comparison 3 t/string? a))) - (testing "Final Concrete + Abstract") - (testing "Final Concrete + Interface" - (testing "< , >" - (test-comparison -1 t/string? t/comparable?)) - (testing "<>" - (test-comparison 3 t/string? t/java-coll?))) - (testing "Extensible Concrete + Extensible Concrete" - (test-comparison 0 t/object? t/object?) - (testing "< , >" - (test-comparison -1 a t/object?)) - (testing "<>" - (test-comparison 3 a t/thread?))) - (testing "Extensible Concrete + Abstract" - (testing "< , >" - (test-comparison -1 (t/isa? java.util.AbstractCollection) t/object?) - (test-comparison -1 a (t/isa? java.util.AbstractCollection))) - (testing "<>" - (test-comparison 3 t/thread? (t/isa? java.util.AbstractCollection)) - (test-comparison 3 (t/isa? java.util.AbstractCollection) t/thread?))) - (testing "Extensible Concrete + Interface" - (test-comparison 2 a t/char-seq?)) - (testing "Abstract + Abstract" - (test-comparison 0 (t/isa? java.util.AbstractCollection) (t/isa? java.util.AbstractCollection)) - (testing "< , >" - (test-comparison -1 (t/isa? java.util.AbstractList) (t/isa? java.util.AbstractCollection))) - (testing "<>" - (test-comparison 3 (t/isa? java.util.AbstractList) (t/isa? java.util.AbstractQueue)))) - (testing "Abstract + Interface" - (testing "< , >" - (test-comparison -1 (t/isa? java.util.AbstractCollection) t/java-coll?)) - (testing "><" - (test-comparison 2 (t/isa? java.util.AbstractCollection) t/comparable?))) - (testing "Interface + Interface" - (testing "< , >" - (test-comparison -1 t/java-coll? t/iterable?)) - (testing "><" - (test-comparison 2 t/char-seq? t/comparable?)))) - (testing "+ ValueSpec" - (testing "<" - (testing "Class equality" - (test-comparison -1 (t/value "a") t/string?)) - (testing "Class inheritance" - (test-comparison -1 (t/value "a") t/char-seq?) - (test-comparison -1 (t/value "a") t/object?))) - (testing "<>" - (test-comparison 3 (t/value "a") t/byte?)))) - (testing "ValueSpec" - (testing "+ ValueSpec" - (testing "=" - (test-comparison 0 (t/value nil) (t/value nil)) - (test-comparison 0 (t/value 1 ) (t/value 1 )) - (test-comparison 0 (t/value "a") (t/value "a"))) - (testing "=, non-strict" - (test-comparison 0 (t/value (vector) ) (t/value (list) )) - (test-comparison 0 (t/value (vector (vector))) (t/value (vector (list)))) - (test-comparison 0 (t/value (hash-map) ) (t/value (sorted-map) ))) - (testing "<>" - (test-comparison 3 (t/value 1 ) (t/value 2 )) - (test-comparison 3 (t/value "a") (t/value "b")) - (test-comparison 3 (t/value 1 ) (t/value "a")) - (test-comparison 3 (t/value nil) (t/value "a")))))) + [quantum.untyped.core.type.reifications :as utr] + [quantum.test.untyped.core.type.compare + :refer [i|>a+b i|>a0 i|>a1 i|>b0 i|>b1 + i|a i|b + i|<0 i|><1 i|><2 + + >a+b >a >b + a b + <0 ><1 ><2]])) (deftest test|not (testing "simplification" @@ -854,35 +88,35 @@ (is= (| a b (| (! a) (! b))) t/universal-set)) (testing "nested" - (is= (t/or-spec>args (| (| t/string? t/double?) - t/char-seq?)) + (is= (utr/or-type>args (| (| t/string? t/double?) + t/char-seq?)) [t/double? t/char-seq?]) - (is= (t/or-spec>args (| (| t/string? t/double?) - (| t/double? t/char-seq?))) + (is= (utr/or-type>args (| (| t/string? t/double?) + (| t/double? t/char-seq?))) [t/double? t/char-seq?]) - (is= (t/or-spec>args (| (| t/string? t/double?) - (| t/char-seq? t/number?))) + (is= (utr/or-type>args (| (| t/string? t/double?) + (| t/char-seq? t/number?))) [t/char-seq? t/number?])) (testing "#{<+ =} -> #{<+}" - (is= (t/or-spec>args (| i|>a+b i|>a0 i|a)) + (is= (utr/or-type>args (| i|>a+b i|>a0 i|a)) [i|>a+b i|>a0])) (testing "#{<+ >+} -> #{<+}" - (is= (t/or-spec>args (| i|>a+b i|>a0 i|args (| i|>a+b i|>a0 i|a+b i|>a0])) (testing "#{>+ =} -> #{=}" (is= (| i|+ ><+} -> #{<+ ><+}" - (is= (t/or-spec>args (| i|>a+b i|>a0 i|<0 i|><1)) + (is= (utr/or-type>args (| i|>a+b i|>a0 i|<0 i|><1)) [i|>a+b i|>a0 i|><0 i|><1])) (testing "#{<+ >+ <>+} -> #{<+ <>+}" - (is= (t/or-spec>args (| >a <0 ><1)) + (is= (utr/or-type>args (| >a <0 ><1)) [>a ><0 ><1])) (testing "#{<+ =+ >+ ><+} -> #{<+ ><+}" - (is= (t/or-spec>args (| i|>a+b i|>a0 i|a i|<0 i|><1)) + (is= (utr/or-type>args (| i|>a+b i|>a0 i|a i|<0 i|><1)) [i|>a+b i|>a0 i|><0 i|><1])) (testing "#{<+ =+ >+ <>+} -> #{<+ <>+}" - (is= (t/or-spec>args (| >a a <0 ><1)) + (is= (utr/or-type>args (| >a a <0 ><1)) [>a ><0 ><1])))) (deftest test|and @@ -929,7 +163,7 @@ (is= (& (| a b ><0) (| a ><0 b)) (| a b ><0))) (testing "" - (is= (t/and-spec>args (& i|a i|b)) + (is= (utr/and-type>args (& i|a i|b)) [i|a i|b])) (testing "empty-set" (is= (& a b) @@ -974,23 +208,14 @@ (is= (& i|>a+b i|>a0 i|a) i|a)) (testing "#{>+ =+} -> #{>+}" - (is= (t/and-spec>args (& i|args (& i|+} -> #{>+}" - (is= (t/and-spec>args (& i|>a+b i|>a0 i|args (& i|>a+b i|>a0 i|+ ∅+} -> #{>+ ∅+}" - (is= (t/and-spec>args (& i|>a+b i|>a0 i|<0 i|><1)) + (is= (utr/and-type>args (& i|>a+b i|>a0 i|<0 i|><1)) [i|<0 i|><1])) (testing "#{<+ =+ >+ ∅+} -> #{>+ ∅+}" - (is= (t/and-spec>args (& i|>a+b i|>a0 i|a i|<0 i|><1)) + (is= (utr/and-type>args (& i|>a+b i|>a0 i|a i|<0 i|><1)) [i|<0 i|><1])))) - -(deftest test|= - ;; Takes an inordinately long time to do `test-comparison 0 ...` even without instrumentation - (is= (| t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) - (& (| t/boolean? t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) - (! t/boolean?))) - (test-comparison 0 t/any? t/universal-set) - (testing "universal class(-set) identity" - (is (t/= t/val? (& t/any? t/val?))))) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc new file mode 100644 index 00000000..85c2bcfa --- /dev/null +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -0,0 +1,781 @@ +(ns quantum.test.untyped.core.type.compare + (:require + [clojure.core :as core] + [quantum.untyped.core.analyze.expr :as xp + :refer [>expr]] + [quantum.untyped.core.fn + :refer [fn1]] + [quantum.untyped.core.logic + :refer [ifs]] + [quantum.untyped.core.numeric :as unum] + [quantum.untyped.core.numeric.combinatorics :as ucombo] + [quantum.untyped.core.spec :as s] + [quantum.untyped.core.test + :refer [deftest testing is is= throws]] + [quantum.untyped.core.type :as t + :refer [& | !]] + [quantum.untyped.core.type.reifications :as utr] + [quantum.untyped.core.defnt + :refer [defns]])) + +;; Here, `NotType` labels on `testing` mean such *after* simplification + +#?(:clj +(defmacro test-comparisons>comparisons [[_ _ a b]] + `[[~@(for [a* (rest a)] + `(t/compare ~a* ~b))] + [~@(for [b* (rest b)] + `(t/compare ~b* ~a))]])) + +;; TODO come back to this +#_(do (is= -1 (t/compare (t/value 1) t/numerically-byte?)) + + (is= (& t/long? (>expr (fn1 = 1))) + (t/value 1)) + + (is= (& (t/value 1) (>expr unum/integer-value?)) + (t/value 1)) + + (t/compare (t/value 1) (>expr unum/integer-value?)) + + (is= 0 (t/compare (t/value 1) (>expr (fn1 =|long 1)))) + (is= 0 (t/compare (t/value 1) (>expr (fn [^long x] (= x 1))))) + (is= 0 (t/compare (t/value 1) (>expr (fn [^long x] (== x 1))))) + (is= 0 (t/compare (t/value 1) (>expr (fn [x] (core/== (long x) 1))))) + (is= 0 (t/compare (t/value 1) (>expr (fn [x] (= (long x) 1)))))) + +;; ----- Example interface hierarchy ----- ;; + +(do + +(gen-interface :name i.>a+b) +(gen-interface :name i.>a0) +(gen-interface :name i.>a1) +(gen-interface :name i.>b0) +(gen-interface :name i.>b1) + +(gen-interface :name i.a :extends [i.>a0 i.>a1 i.>a+b]) +(gen-interface :name i.b :extends [i.>b0 i.>b1 i.>a+b]) + +(gen-interface :name i.<0) +(gen-interface :name i.><1) +(gen-interface :name i.><2) + +(def i|>a+b (t/isa? i.>a+b)) +(def i|>a0 (t/isa? i.>a0)) +(def i|>a1 (t/isa? i.>a1)) +(def i|>b0 (t/isa? i.>b0)) +(def i|>b1 (t/isa? i.>b1)) +(def i|a (t/isa? i.a)) +(def i|b (t/isa? i.b)) +(def i|<0 (t/isa? i.><0)) +(def i|><1 (t/isa? i.><1)) +(def i|><2 (t/isa? i.><2)) + +) + +;; ----- Hierarchy within existing non-interfaces ----- ;; + +(do (def >a+b (t/isa? java.util.AbstractCollection)) + (def >a (t/isa? java.util.AbstractList)) + (def >b (t/isa? java.util.AbstractSet)) + (def a (t/isa? java.util.ArrayList)) + (def b (t/isa? java.util.HashSet)) + (def <0 t/byte?) + (def ><1 t/short?) + (def ><2 t/long?)) + +(def Uc (t/isa? java.lang.Object)) + +;; ----- Example protocols ----- ;; + +(do + +(defprotocol AProtocolAll (a-protocol-all [this])) + +(extend-protocol AProtocolAll + nil (a-protocol-all [this]) + Object (a-protocol-all [this])) + +(defprotocol AProtocolString (a-protocol-string [this])) + +(extend-protocol AProtocolString + java.lang.String (a-protocol-string [this])) + +(defprotocol AProtocolNonNil (a-protocol-non-nil [this])) + +(extend-protocol AProtocolNonNil + Object (a-protocol-non-nil [this])) + +(defprotocol AProtocolOnlyNil (a-protocol-only-nil [this])) + +(extend-protocol AProtocolOnlyNil + nil (a-protocol-only-nil [this])) + +(defprotocol AProtocolNone (a-protocol-none [this])) + +(def protocol-types + (->> [AProtocolAll AProtocolString AProtocolNonNil AProtocolOnlyNil AProtocolNone] + (map t/>type) set)) + +) + +;; TESTS ;; + +(defns type>type-combos + "To generate all commutative possibilities for a given type." + [t t/type? > (s/seq-of t/type?)] + (ifs (t/and-type? t) (->> t utr/and-type>args ucombo/permutations + (map #(utr/->AndType (vec %) (atom nil)))) + (t/or-type? t) (->> t utr/or-type>args ucombo/permutations + (map #(utr/->OrType (vec %) (atom nil)))) + [t])) + +#?(:clj +(defmacro test-comparison + "Performs a `t/compare` on `a` and `b`, ensuring that their relationship is symmetric, and that + the inputs are internally commutative if applicable (e.g. if `a` is an `AndType`, ensures that + it is commutative). + The basis comparison is the first input." + [c #_t/comparisons a #_t/type? b #_t/type?] + `(let [c# ~c] + (doseq ;; Commutativity + [a*# (type>type-combos ~a) + b*# (type>type-combos ~b)] + ;; Symmetry + (is= c# (t/compare a*# b*#)) + (is= (t/inverse c#) (t/compare b*# a*#)))))) + +(def comparison-combinations + ["#{<}" + "#{< =}" + "#{< = >}" + "#{< = > ><}" + "#{< = > >< <>}" + "#{< = > <>}" + "#{< = ><}" + "#{< = >< <>}" + "#{< = <>}" + "#{< >}" + "#{< > ><}" + "#{< > >< <>}" + "#{< > <>}" + "#{< ><}" + "#{< >< <>}" + "#{< <>}" + "#{=}" + "#{= >}" + "#{= > ><}" + "#{= > >< <>}" + "#{= > <>}" + "#{= ><}" + "#{= >< <>}" + "#{= <>}" + "#{>}" + "#{> ><}" + "#{> >< <>}" + "#{> <>}" + "#{><}" + "#{>< <>}" + "#{<>}"]) + +(deftest test|in|compare + (testing "UniversalSetType" + (testing "+ UniversalSetType" + (test-comparison 0 t/universal-set t/universal-set)) + (testing "+ EmptySetType" + (test-comparison 1 t/universal-set t/empty-set)) + (testing "+ NotType" + (test-comparison 1 t/universal-set (! a))) + (testing "+ OrType" + (test-comparison 1 t/universal-set (| ><0 ><1))) + (testing "+ AndType") + (testing "+ Expression") + (testing "+ ProtocolType" + (doseq [t protocol-types] + (test-comparison 1 t/universal-set t))) + (testing "+ ClassType") + (testing "+ ValueType" + (doseq [t [(t/value t/universal-set) + (t/value t/empty-set) + (t/value 0) + (t/value nil)]] + (test-comparison 1 t/universal-set t)))) + ;; The null set is considered to always (vacuously) be a subset of any set + (testing "EmptySetType" + (testing "+ EmptySetType" + (test-comparison 0 t/empty-set t/empty-set)) + (testing "+ NotType" + (testing "Inner ClassType" + (test-comparison -1 t/empty-set (! a))) + (testing "Inner ValueType" + (test-comparison -1 t/empty-set (! (t/value 1))))) + (testing "+ OrType" + (test-comparison -1 t/empty-set (| ><0 ><1))) + (testing "+ AndType") + (testing "+ Expression") + (testing "+ ProtocolType" + (doseq [t protocol-types] + (test-comparison -1 t/empty-set t))) + (testing "+ ClassType") + (testing "+ ValueType" + (test-comparison -1 t/empty-set (t/value t/empty-set)) + (test-comparison -1 t/empty-set (t/value 0)))) + (testing "NotType" + (testing "+ NotType" + (test-comparison 0 (! a) (! a)) + (test-comparison 2 (! a) (! b)) + (test-comparison 2 (! i|a) (! i|b)) + (test-comparison 2 (! t/string?) (! t/byte?)) + (test-comparison 1 (! a) (! >a)) + (test-comparison -1 (! a) (! }") ; Impossible for `OrType` + #_(testing "#{< = > ><}") ; Impossible for `OrType` + #_(testing "#{< = > >< <>}") ; Impossible for `OrType` + #_(testing "#{< = > <>}") ; Impossible for `OrType` + #_(testing "#{< = ><}") ; Impossible for `OrType` + #_(testing "#{< = >< <>}") ; Impossible for `OrType` + #_(testing "#{< = <>}") ; Impossible for `OrType` + #_(testing "#{< >}") ; Impossible for `OrType` + #_(testing "#{< > ><}") ; Impossible for `OrType` + #_(testing "#{< > >< <>}") ; Impossible for `OrType` + #_(testing "#{< > <>}") ; Impossible for `OrType` + (testing "#{< ><}" + #_(test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1)) + #_(test-comparison -1 i|>a0 (| i|>a+b i|>a0))) + (testing "#{< >< <>}" + #_(test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1 t/string?))) + (testing "#{< <>}" + #_(test-comparison -1 a (| >a ><0 ><1))) + #_(testing "#{=}") ; Impossible for `OrType` + #_(testing "#{= >}") ; Impossible for `OrType` + #_(testing "#{= > ><}") ; Impossible for `OrType` + #_(testing "#{= > >< <>}") ; Impossible for `OrType` + #_(testing "#{= > <>}") ; Impossible for `OrType` + (testing "#{= ><}" + (test-comparison -1 (! a) (| (! a) i|><0 i|><1)) + (test-comparison -1 (! i|a) (| (! i|a) i|><0 i|><1))) + (testing "#{= >< <>}" + #_(test-comparison -1 i|a (| i|a i|><0 i|><1 t/string?))) + (testing "#{= <>}" + (test-comparison -1 (! a) (| (! a) }" + #_(test-comparison 1 a (| ><}" + #_(test-comparison 2 i|a (| i|<0 i|><1))) + (testing "#{> >< <>}" + #_(test-comparison 2 i|a (| i|<0 i|><1 t/string?))) + (testing "#{> <>}" + (test-comparison 2 (! a) (| b a)) + (test-comparison 2 (! b) (| a b)) + (test-comparison 2 (! ><0) (| ><0 ><1)) + (test-comparison 2 (! ><1) (| ><1 ><0))) + (testing "#{><}" + #_(test-comparison 2 i|a (| i|><0 i|><1))) + (testing "#{>< <>}" + #_(test-comparison 2 i|a (| i|><0 i|><1 t/string?))) + (testing "#{<>}" + (test-comparison 3 (! a) (| }" + (test-comparison ... (! a) (& a (! b))))) + (testing "+ Expression") + (testing "+ ProtocolType") + (testing "+ ClassType" + (test-comparison 3 (! a) a) ; inner = + (test-comparison 3 (! i|a) i|a) ; inner = + (test-comparison 3 (! a) + (test-comparison 3 (! i|a) i| + (test-comparison 2 (! a) >a) ; inner < + (test-comparison 2 (! i|a) i|>a0) ; inner >< + (test-comparison 1 (! a ) ><0) ; inner <> + (test-comparison 2 (! i|a) i|><0) ; inner >< + (test-comparison 2 (! a) Uc) ; inner < + (test-comparison 2 (! i|a) Uc) ; inner < + (test-comparison 2 (! a) ; inner < + (test-comparison 2 (! i|a0) ; inner < + (test-comparison 1 (! <0) ; inner <> + (test-comparison 2 (! i|<0) ; inner >< + (test-comparison 2 (! a) a) ; inner > + (test-comparison 3 (! i|>a0) i|a) ; inner > + (test-comparison 3 (! >a) + (test-comparison 3 (! i|>a0) i| + (test-comparison 1 (! >a) ><0) ; inner <> + (test-comparison 2 (! i|>a0) i|><0) ; inner >< + (test-comparison 2 (! >a) Uc) ; inner < + (test-comparison 2 (! i|>a0) Uc) ; inner < + (test-comparison 1 (! ><0) a) ; inner <> + (test-comparison 2 (! i|><0) i|a) ; inner >< + (test-comparison 1 (! ><0) + (test-comparison 2 (! i|><0) i|< + (test-comparison 1 (! ><0) >a) ; inner <> + (test-comparison 2 (! i|><0) i|>a0) ; inner >< + (test-comparison 2 (! ><0) Uc) ; inner < + (test-comparison 2 (! i|><0) Uc) ; inner < + (testing "+ ValueType" + (test-comparison -1 (t/value 1) (! (t/value 2))) + (test-comparison 3 (t/value "") (! t/string?)))) + (testing "OrType" + (testing "+ OrType" + ;; Comparison annotations achieved by first comparing each element of the first/left + ;; to the entire second/right, then comparing each element of the second/right to the + ;; entire first/left + ;; TODO add complete comparisons via `comparison-combinations` + (testing "#{<}, #{<}" + ;; comparisons: < < < < + (test-comparison 0 (| a b) (| a b)) + ;; comparisons: < < < < + (test-comparison 0 (| i|>a+b i|>a0) (| i|>a+b i|>a0))) + (testing "#{<}, #{<, ><}" + ;; comparisons: < < < < >< >< + (test-comparison -1 (| i|>a+b i|>a0) (| i|>a+b i|>a0 i|><0 i|><1)) + ;; comparisons: < < < < >< >< >< + (test-comparison -1 (| i|>a+b i|>a0) (| i|>a+b i|>a0 i|>a1 i|><0 i|><1)) + ;; comparisons: < < < < < < >< >< + (test-comparison -1 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|>a0 i|>a1 i|><0 i|><1))) + (testing "#{<, ><}, #{<}" + ;; comparisons: < < >< < < + (test-comparison 1 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|>a0)) + ;; comparisons: >< < < < < + (test-comparison 1 (| i|a i|><0 i|><1) (| i|><0 i|><1))) + (testing "#{<, ><}, #{<, ><}" + ;; comparisons: < >< < >< + (test-comparison 2 (| i|>a+b i|>a0) (| i|>a+b i|><0)) + ;; comparisons: < >< >< < >< >< + (test-comparison 2 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|><0 i|><1)) + ;; comparisons: < < >< < < >< >< + (test-comparison 2 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|>a0 i|><0 i|><1)) + ;; comparisons: < < >< < >< + (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|a i|><0)) + ;; comparisons: < >< >< < >< >< + (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|a i|><0 i|><1)) + ;; comparisons: >< < < >< + (test-comparison 2 (| i|a i|><0) (| i|><0 i|><1)) + ;; comparisons: >< < >< >< < + (test-comparison 2 (| i|a i|><1 i|><2) (| i|><0 i|><1)) + ;; comparisons: >< >< < < >< + (test-comparison 2 (| i|a i|><0 i|><1) (| i|><1 i|><2))) + (testing "#{<, ><}, #{><}" + ;; comparisons: < >< >< >< + (test-comparison 2 (| i|a i|><0) (| i|>a+b i|>a0)) + ;; comparisons: < >< >< >< >< + (test-comparison 2 (| i|a i|><0 i|><1) (| i|>a+b i|>a0)) + ;; comparisons: < >< >< >< >< + (test-comparison 2 (| i|a i|><0) (| i|>a+b i|>a0 i|>a1)) + ;; comparisons: < >< >< >< >< >< + (test-comparison 2 (| i|a i|><0 i|><1) (| i|>a+b i|>a0 i|>a1))) + (testing "#{<, <>}, #{<, <>}" + ;; comparisons: < <> < <> + (test-comparison 2 (| a b) (| a ><1)) + ;; comparisons: <> < < <> + (test-comparison 2 (| a b) (| b ><1))) + (testing "#{<, <>}, #{><, <>}" + ;; comparisons: <, <> >< <> <> + (test-comparison 2 (| a b) (| >a ><0 ><1))) + (testing "#{><}, #{<, ><}" + ;; comparisons: >< >< >< < >< >< + (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|<0 i|><1)) + ;; comparisons: >< >< >< >< < >< >< + (test-comparison 2 (| i|a i|>a+b i|>a0 i|>a1) (| i|<0 i|><1)) + ;; comparisons: >< >< >< < < >< >< + (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|<0 i|><1)) + ;; comparisons: >< >< >< >< < < >< >< + (test-comparison 2 (| i|a i|>a+b i|>a0 i|>a1) (| i|<0 i|><1)) + ;; comparisons: >< >< >< < < < >< >< + (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|<0 i|><1)) + ;; comparisons: >< >< >< >< < < < >< >< + (test-comparison 2 (| i|a i|>a+b i|>a0 i|>a1) (| i|<0 i|><1))) + (testing "#{><}, #{><}" + ;; comparisons: >< >< >< >< + (test-comparison 2 (| i|a i|><2) (| i|><0 i|><1)) + ;; comparisons: >< >< >< >< + (test-comparison 2 (| i|a i|><0) (| i|><1 i|><2))) + (testing "#{<>}, #{<>}" + ;; comparisons: <> <> <> <> + (test-comparison 3 (| a b) (| ><0 ><1))))) + ;; TODO fix tests/impl + #_(testing "+ AndType" + ;; Comparison annotations achieved by first comparing each element of the first/left + ;; to the entire second/right, then comparing each element of the second/right to the + ;; entire first/left + (testing "#{= <+} -> #{<+}" + (testing "+ #{<+}" + ;; comparisons: [-1, -1], [-1, -1] + (test-comparison 1 (| a >a+b >a0) (& >a+b >a0)) + ;; comparisons: [-1, -1, 3], [-1, -1] + (test-comparison 1 (| a >a+b >a0 >a1) (& >a+b >a0)) + ;; comparisons: [-1, -1], [-1, -1, 3] + (test-comparison 3 (| a >a+b >a0) (& >a+b >a0 >a1)) + ;; comparisons: [-1, -1, -1], [-1, -1, -1] + (test-comparison 1 (| a >a+b >a0 >a1) (& >a+b >a0 >a1))) + (testing "+ #{∅+}" + ;; comparisons: [3, 3, 3], [3, 3] + (test-comparison 3 (| a >a+b >a0) (& ><0 ><1))) + (testing "+ #{<+ ∅+}" + ;; comparisons: [-1, 3], [-1, 3, 3] + (test-comparison 3 (| a >a+b >a0) (& >a+b ><0 ><1)) + ;; comparisons: [-1, 3, 3], [-1, 3, 3] + (test-comparison 3 (| a >a+b >a0 >a1) (& >a+b ><0 ><1)) + ;; comparisons: [-1, -1], [-1, -1, 3, 3] + (test-comparison 3 (| a >a+b >a0) (& >a+b >a0 ><0 ><1)) + ;; comparisons: [-1, -1, 3], [-1, -1, 3, 3] + (test-comparison 3 (| a >a+b >a0 >a1) (& >a+b >a0 ><0 ><1)) + ;; comparisons: [-1, -1], [-1, -1, 3, 3, 3] + (test-comparison 3 (| a >a+b >a0) (& >a+b >a0 >a1 ><0 ><1)) + ;; comparisons: [-1, -1, -], [-1, -1, -1, 3, 3] + (test-comparison 3 (| a >a+b >a0 >a1) (& >a+b >a0 >a1 ><0 ><1))) + (testing "+ #{= ∅+}" + ;; comparisons: [3, 3], [-1, 3] + (test-comparison 3 (| a >a+b >a0) (& a ><0)) + ;; comparisons: [3, 3], [-1, 3, 3] + (test-comparison 3 (| a >a+b >a0) (& a ><0 ><1))) + (testing "+ #{>+ ∅+}" + ;; comparisons: [3, 3], [-1, 3, 3] + (test-comparison 3 (| a >a+b >a0) (& <0 ><1)) + ;; comparisons: [3, 3, 3], [-1, 3, 3] + (test-comparison 3 (| a >a+b >a0 >a1) (& <0 ><1)) + ;; comparisons: [3, 3], [-1, -1, 3, 3] + (test-comparison 3 (| a >a+b >a0) (& <0 ><1)) + ;; comparisons: [3, 3, 3], [-1, -1, 3, 3] + (test-comparison 3 (| a >a+b >a0 >a1) (& <0 ><1)) + ;; comparisons: [3, 3], [-1, -1, 3, 3, 3] + (test-comparison 3 (| a >a+b >a0) (& <0 ><1)) + ;; comparisons: [3, 3, 3], [-1, -1, -1, 3, 3] + (test-comparison 3 (| a >a+b >a0 >a1) (& <0 ><1))))) + (testing "+ Expression") + (testing "+ ProtocolType") + (testing "+ ClassType" + (testing "#{<}" + (test-comparison -1 i|a+b i|>a0 i|>a1))) + #_(testing "#{< =}") ; Impossible for `OrType` + #_(testing "#{< = >}") ; Impossible for `OrType` + #_(testing "#{< = > ><}") ; Impossible for `OrType` + #_(testing "#{< = > >< <>}") ; Impossible for `OrType` + #_(testing "#{< = > <>}") ; Impossible for `OrType` + #_(testing "#{< = ><}") ; Impossible for `OrType` + #_(testing "#{< = >< <>}") ; Impossible for `OrType` + #_(testing "#{< = <>}") ; Impossible for `OrType` + #_(testing "#{< >}") ; Impossible for `OrType` + #_(testing "#{< > ><}") ; Impossible for `OrType` + #_(testing "#{< > >< <>}") ; Impossible for `OrType` + #_(testing "#{< > <>}") ; Impossible for `OrType` + (testing "#{< ><}" + (test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1)) + (test-comparison -1 i|>a0 (| i|>a+b i|>a0))) + (testing "#{< >< <>}" + (test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1 t/string?))) + (testing "#{< <>}" + (test-comparison -1 a (| >a ><0 ><1))) + #_(testing "#{=}") ; Impossible for `OrType` + #_(testing "#{= >}") ; Impossible for `OrType` + #_(testing "#{= > ><}") ; Impossible for `OrType` + #_(testing "#{= > >< <>}") ; Impossible for `OrType` + #_(testing "#{= > <>}") ; Impossible for `OrType` + (testing "#{= ><}" + (test-comparison -1 i|a (| i|a i|><0 i|><1))) + (testing "#{= >< <>}" + (test-comparison -1 i|a (| i|a i|><0 i|><1 t/string?))) + (testing "#{= <>}" + (test-comparison -1 a (| a ><0 ><1))) + (testing "#{>}" + (test-comparison 1 a (| ><}" + (test-comparison 2 i|a (| i|<0 i|><1))) + (testing "#{> >< <>}" + (test-comparison 2 i|a (| i|<0 i|><1 t/string?))) + (testing "#{> <>}" + (test-comparison 2 a (| <0 ><1))) + (testing "#{><}" + (test-comparison 2 i|a (| i|><0 i|><1))) + (testing "#{>< <>}" + (test-comparison 2 i|a (| i|><0 i|><1 t/string?))) + (testing "#{<>}" + (test-comparison 3 a (| ><0 ><1))) + (testing "Nilable" + (testing "< nilabled: #{< <>}" + (test-comparison -1 t/long? (t/? t/object?))) + (testing "= nilabled: #{= <>}" + (test-comparison -1 t/long? (t/? t/long?))) + (testing "> nilabled: #{> <>}" + (test-comparison 2 t/object? (t/? t/long?))) + (testing ">< nilabled: #{>< <>}" + (test-comparison 2 t/iterable? (t/? t/comparable?))) + (testing "<> nilabled: #{<>}" + (test-comparison 3 t/long? (t/? t/string?))))) + (testing "+ ValueType" + (testing "arg <" + (testing "+ arg <") + (testing "+ arg =") + (testing "+ arg >") + (testing "+ arg ><") + (testing "+ arg <>" + (test-comparison -1 (t/value "a") (| t/string? t/byte?)) + (test-comparison -1 (t/value 1) (| (t/value 1) (t/value 2))) + (test-comparison -1 (t/value 1) (| (t/value 2) (t/value 1))) + (testing "+ arg <>" + (test-comparison -1 (t/value 1) (| (t/value 1) (t/value 2) (t/value 3))) + (test-comparison -1 (t/value 1) (| (t/value 2) (t/value 1) (t/value 3))) + (test-comparison -1 (t/value 1) (| (t/value 2) (t/value 3) (t/value 1)))))) + (testing "arg =" + (testing "+ arg <>" + (test-comparison -1 t/nil? (| t/nil? t/string?)))) + (testing "arg <>" + (testing "+ arg <>" + (test-comparison 3 (t/value "a") (| t/byte? t/long?)) + (test-comparison 3 (t/value 3) (| (t/value 1) (t/value 2))))))) + (testing "AndType" + (testing "+ AndType") + (testing "+ Expression") + (testing "+ ProtocolType") + (testing "+ ClassType" + (testing "#{<}" + (testing "Boxed Primitive" + (test-comparison -1 t/byte? (& t/number? t/comparable?))) + (testing "Final Concrete" + (test-comparison -1 t/string? (& t/char-seq? t/comparable?))) + (testing "Extensible Concrete" + (test-comparison -1 a (& t/iterable? (t/isa? java.util.RandomAccess)))) + (testing "Abstract" + (test-comparison -1 (t/isa? java.util.AbstractMap$SimpleEntry) (& (t/isa? java.util.Map$Entry) (t/isa? java.io.Serializable)))) + (testing "Interface" + (test-comparison -1 i|a (& i|>a0 i|>a1)))) + (testing "#{<}" + (test-comparison -1 i|a (& i|>a0 i|>a1))) + #_(testing "#{< =}") ; Impossible for `AndType` + #_(testing "#{< = >}") ; Impossible for `AndType` + #_(testing "#{< = > ><}") ; Impossible for `AndType` + #_(testing "#{< = > >< <>}") ; Impossible for `AndType` + #_(testing "#{< = > <>}") ; Impossible for `AndType` + #_(testing "#{< = ><}") ; Impossible for `AndType` + #_(testing "#{< = >< <>}") ; Impossible for `AndType` + #_(testing "#{< = <>}") ; Impossible for `AndType` + #_(testing "#{< >}") ; Impossible for `AndType` + #_(testing "#{< > ><}") ; Impossible for `AndType` + #_(testing "#{< > >< <>}") ; Impossible for `AndType` + #_(testing "#{< > <>}") ; Impossible for `AndType` + (testing "#{< ><}" + (test-comparison 2 i|a (& i|>a+b i|>a0 i|>a1 i|><0 i|><1))) + (testing "#{< >< <>}" + (test-comparison 2 t/java-set? (& t/java-coll? t/char-seq? (t/isa? java.nio.ByteBuffer)))) + (testing "#{< <>}" + (test-comparison 3 t/string? (& t/char-seq? t/java-set?)) + (test-comparison 3 ><0 (& (! ><1) (! ><0))) + (test-comparison 3 a (& (! a) (! b)))) + #_(testing "#{=}") ; Impossible for `AndType` + #_(testing "#{= >}") ; Impossible for `AndType` + #_(testing "#{= > ><}") ; Impossible for `AndType` + #_(testing "#{= > >< <>}") ; Impossible for `AndType` + #_(testing "#{= > <>}") ; Impossible for `AndType` + (testing "#{= ><}" + (test-comparison 1 i|a (& i|a i|><0 i|><1)) + (test-comparison 1 t/char-seq? (& t/char-seq? t/java-set?)) + (test-comparison 1 t/char-seq? (& t/char-seq? t/java-set? a))) + (testing "#{= >< <>}") ; <- TODO comparison should be 1 + ;; TODO fix + (testing "#{= <>}" + (test-comparison 1 a (& a t/java-set?))) + (testing "#{>}" + (test-comparison 1 i|a (& i| ><}" + (test-comparison 2 i|a (& i|<0 i|><1)) + (test-comparison 2 a (& (t/isa? javax.management.AttributeList) t/java-set?)) + (test-comparison 2 t/comparable? (& (t/isa? java.nio.ByteBuffer) t/java-set?))) + (testing "#{> >< <>}" + (test-comparison 2 i|a (& i|<0 a))) + (testing "#{> <>}") ; <- TODO comparison should be 1 + (testing "#{><}" + (test-comparison 2 i|a (& i|><0 i|><1)) + (test-comparison 2 t/char-seq? (& t/java-set? a))) + (testing "#{>< <>}") ; <- TODO comparison should be 3 + (testing "#{<>}" + (test-comparison 3 t/string? (& a t/java-set?)))) + (testing "+ ValueType" + (testing "#{<}" + (test-comparison -1 (t/value "a") (& t/char-seq? t/comparable?))) + #_(testing "#{< =}") ; not possible for `AndType` + #_(testing "#{< = >}") ; not possible for `AndType`; `>` not possible for `ValueType` + #_(testing "#{< = > ><}") ; not possible for `AndType`; `>` and `><` not possible for `ValueType` + #_(testing "#{< = > >< <>}") ; not possible for `AndType`; `>` and `><` not possible for `ValueType` + #_(testing "#{< = > <>}") ; not possible for `AndType`; `>` not possible for `ValueType` + #_(testing "#{< = ><}") ; not possible for `AndType`; `><` not possible for `ValueType` + #_(testing "#{< = >< <>}") ; not possible for `AndType`; `><` not possible for `ValueType` + #_(testing "#{< = <>}") ; not possible for `AndType` + #_(testing "#{< >}") ; not possible for `AndType`; `>` not possible for `ValueType` + #_(testing "#{< > ><}") ; not possible for `AndType`; `>` and `><` not possible for `ValueType` + #_(testing "#{< > >< <>}") ; not possible for `AndType`; `>` and `><` not possible for `ValueType` + #_(testing "#{< > <>}") ; not possible for `AndType`; `>` not possible for `ValueType` + #_(testing "#{< ><}") ; `><` not possible for `ValueType` + #_(testing "#{< >< <>}") ; `><` not possible for `ValueType` + (testing "#{< <>}" + (test-comparison 3 (t/value "a") (& t/char-seq? a)) + (test-comparison 3 (t/value "a") (& t/char-seq? t/java-set?))) + #_(testing "#{=}") ; not possible for `AndType` + #_(testing "#{= >}") ; not possible for `AndType`; `>` not possible for `ValueType` + #_(testing "#{= > ><}") ; not possible for `AndType`; `>` and `><` not possible for `ValueType` + #_(testing "#{= > >< <>}") ; not possible for `AndType`; `>` and `><` not possible for `ValueType` + #_(testing "#{= > <>}") ; not possible for `AndType`; `>` not possible for `ValueType` + #_(testing "#{= ><}") ; `><` not possible for `ValueType` + #_(testing "#{= >< <>}") ; `><` not possible for `ValueType` + (testing "#{= <>}") + #_(testing "#{>}") ; `>` not possible for `ValueType` + #_(testing "#{> ><}") ; `>` and `><` not possible for `ValueType` + #_(testing "#{> >< <>}") ; `>` and `><` not possible for `ValueType` + #_(testing "#{> <>}") ; `>` not possible for `ValueType` + #_(testing "#{><}") ; `><` not possible for `ValueType` + #_(testing "#{>< <>}") ; `><` not possible for `ValueType` + (testing "#{<>}" + (test-comparison 3 (t/value "a") (& a t/java-set?))))) + (testing "Expression" + (testing "+ Expression") + (testing "+ ProtocolType") + (testing "+ ClassType") + (testing "+ ValueType")) + (testing "ProtocolType" + (testing "+ ProtocolType" + (test-comparison 0 (t/isa? AProtocolAll) (t/isa? AProtocolAll)) + (test-comparison 3 (t/isa? AProtocolAll) (t/isa? AProtocolNone))) + (testing "+ ClassType") + (testing "+ ValueType" + (let [values #{t/universal-set t/empty-set nil {} 1 "" AProtocolAll + quantum.test.untyped.core.type.compare.AProtocolAll}] + (doseq [v values] + (test-comparison -1 (t/value v) (t/isa? AProtocolAll))) + (doseq [v [""]] + (test-comparison -1 (t/value v) (t/isa? AProtocolString))) + (doseq [v (disj values "")] + (test-comparison 3 (t/value v) (t/isa? AProtocolString))) + (doseq [v (disj values nil)] + (test-comparison -1 (t/value v) (t/isa? AProtocolNonNil))) + (doseq [v [nil]] + (test-comparison 3 (t/value v) (t/isa? AProtocolNonNil))) + (doseq [v [nil]] + (test-comparison -1 (t/value v) (t/isa? AProtocolOnlyNil))) + (doseq [v (disj values nil)] + (test-comparison 3 (t/value v) (t/isa? AProtocolOnlyNil))) + (doseq [v values] + (test-comparison 3 (t/value v) (t/isa? AProtocolNone)))))) + (testing "ClassType" + (testing "+ ClassType" + (testing "Boxed Primitive + Boxed Primitive" + (test-comparison 0 t/long? t/long?) + (test-comparison 3 t/long? t/int?)) + (testing "Boxed Primitive + Final Concrete" + (test-comparison 3 t/long? t/string?)) + (testing "Boxed Primitive + Extensible Concrete" + (testing "< , >" + (test-comparison -1 t/long? t/object?)) + (testing "<>" + (test-comparison 3 t/long? t/thread?))) + (testing "Boxed Primitive + Abstract" + (test-comparison 3 t/long? (t/isa? java.util.AbstractCollection))) + (testing "Boxed Primitive + Interface" + (test-comparison 3 t/long? t/char-seq?)) + (testing "Final Concrete + Final Concrete" + (test-comparison 0 t/string? t/string?)) + (testing "Final Concrete + Extensible Concrete" + (testing "< , >" + (test-comparison -1 t/string? t/object?)) + (testing "<>" + (test-comparison 3 t/string? a))) + (testing "Final Concrete + Abstract") + (testing "Final Concrete + Interface" + (testing "< , >" + (test-comparison -1 t/string? t/comparable?)) + (testing "<>" + (test-comparison 3 t/string? t/java-coll?))) + (testing "Extensible Concrete + Extensible Concrete" + (test-comparison 0 t/object? t/object?) + (testing "< , >" + (test-comparison -1 a t/object?)) + (testing "<>" + (test-comparison 3 a t/thread?))) + (testing "Extensible Concrete + Abstract" + (testing "< , >" + (test-comparison -1 (t/isa? java.util.AbstractCollection) t/object?) + (test-comparison -1 a (t/isa? java.util.AbstractCollection))) + (testing "<>" + (test-comparison 3 t/thread? (t/isa? java.util.AbstractCollection)) + (test-comparison 3 (t/isa? java.util.AbstractCollection) t/thread?))) + (testing "Extensible Concrete + Interface" + (test-comparison 2 a t/char-seq?)) + (testing "Abstract + Abstract" + (test-comparison 0 (t/isa? java.util.AbstractCollection) (t/isa? java.util.AbstractCollection)) + (testing "< , >" + (test-comparison -1 (t/isa? java.util.AbstractList) (t/isa? java.util.AbstractCollection))) + (testing "<>" + (test-comparison 3 (t/isa? java.util.AbstractList) (t/isa? java.util.AbstractQueue)))) + (testing "Abstract + Interface" + (testing "< , >" + (test-comparison -1 (t/isa? java.util.AbstractCollection) t/java-coll?)) + (testing "><" + (test-comparison 2 (t/isa? java.util.AbstractCollection) t/comparable?))) + (testing "Interface + Interface" + (testing "< , >" + (test-comparison -1 t/java-coll? t/iterable?)) + (testing "><" + (test-comparison 2 t/char-seq? t/comparable?)))) + (testing "+ ValueType" + (testing "<" + (testing "Class equality" + (test-comparison -1 (t/value "a") t/string?)) + (testing "Class inheritance" + (test-comparison -1 (t/value "a") t/char-seq?) + (test-comparison -1 (t/value "a") t/object?))) + (testing "<>" + (test-comparison 3 (t/value "a") t/byte?)))) + (testing "ValueType" + (testing "+ ValueType" + (testing "=" + (test-comparison 0 (t/value nil) (t/value nil)) + (test-comparison 0 (t/value 1 ) (t/value 1 )) + (test-comparison 0 (t/value "a") (t/value "a"))) + (testing "=, non-strict" + (test-comparison 0 (t/value (vector) ) (t/value (list) )) + (test-comparison 0 (t/value (vector (vector))) (t/value (vector (list)))) + (test-comparison 0 (t/value (hash-map) ) (t/value (sorted-map) ))) + (testing "<>" + (test-comparison 3 (t/value 1 ) (t/value 2 )) + (test-comparison 3 (t/value "a") (t/value "b")) + (test-comparison 3 (t/value 1 ) (t/value "a")) + (test-comparison 3 (t/value nil) (t/value "a")))))) + +(deftest test|= + ;; Takes an inordinately long time to do `test-comparison 0 ...` even without instrumentation + (is= (| t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) + (& (| t/boolean? t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) + (! t/boolean?))) + (test-comparison 0 t/any? t/universal-set) + (testing "universal class(-set) identity" + (is (t/= t/val? (& t/any? t/val?))))) From 88fc3915eaac007f999222860c1f43c4863f9301 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 16 May 2018 16:26:42 -0600 Subject: [PATCH 049/810] move quantum.core.defnt from concept of specs to types --- src-dev/quantum/core/defnt.cljc | 373 +++++++++--------- src-dev/quantum/core/defnt_equivalences.cljc | 6 +- .../quantum/untyped/core/analyze/ast.cljc | 56 +-- src-untyped/quantum/untyped/core/test.cljc | 2 + src/quantum/core/core.cljc | 10 +- src/quantum/core/ns.cljc | 5 +- test/quantum/test/core/defnt.cljc | 57 +++ 7 files changed, 283 insertions(+), 226 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index acd1772a..d7c8fab7 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -2,75 +2,72 @@ (:refer-clojure :exclude [+ #_zero? odd? even? bit-and - == - macroexpand]) + ==]) (:require - [clojure.core :as core] - [clojure.string :as str] - [quantum.core.error :as err - :refer [TODO err!]] - [quantum.core.fn - :refer [aritoid fn1 fnl fn', fn-> fn->> <-, rcomp - firsta seconda]] - [quantum.core.log :as log - :refer [ppr! ppr prl! prlm!]] - [quantum.core.logic :as l - :refer [fn= fn-and fn-or fn-not ifs if-not-let]] - [quantum.core.macros - :refer [macroexpand]] - [quantum.core.print :as pr] - [quantum.core.type.core :as tcore] - [quantum.core.type.defs :as tdef] - [quantum.untyped.core.analyze.ast :as ast] - [quantum.untyped.core.analyze.expr :as xp] + [clojure.core :as core] + [clojure.string :as str] + [quantum.core.type.core :as tcore] + [quantum.core.type.defs :as tdef] + [quantum.untyped.core.analyze.ast :as ast] + [quantum.untyped.core.analyze.expr :as xp] [quantum.untyped.core.analyze.rewrite :as ana-rw] - [quantum.untyped.core.collections :as c + [quantum.untyped.core.collections :as c :refer [dissoc-if dissoc* lcat subview >vec >set lmap map+ map-vals+ mapcat+ filter+ remove+ partition-all+]] [quantum.untyped.core.collections.logic :as ucl :refer [seq-and seq-or]] - [quantum.untyped.core.collections.tree :as tree + [quantum.untyped.core.collections.tree :as tree :refer [prewalk postwalk walk]] - [quantum.untyped.core.compare :as comp + [quantum.untyped.core.compare :as comp :refer [==]] - [quantum.untyped.core.convert :as conv + [quantum.untyped.core.convert :as conv :refer [>symbol >name]] [quantum.untyped.core.core :refer [istr]] [quantum.untyped.core.data :refer [kw-map]] - [quantum.untyped.core.data.map :as map] - [quantum.untyped.core.data.set :as set] + [quantum.untyped.core.data.map :as map] + [quantum.untyped.core.data.set :as set] [quantum.untyped.core.defnt :refer [defns defns- fns]] - [quantum.untyped.core.form :as uform] - [quantum.untyped.core.form.evaluate :as ufeval] - [quantum.untyped.core.form.generate :as ufgen + [quantum.untyped.core.error :as err + :refer [TODO err!]] + [quantum.untyped.core.fn + :refer [aritoid fn1 fnl fn', fn-> fn->> <-, rcomp + firsta seconda]] + [quantum.untyped.core.form :as uform] + [quantum.untyped.core.form.evaluate :as ufeval] + [quantum.untyped.core.form.generate :as ufgen :refer [unify-gensyms]] - [quantum.untyped.core.form.type-hint :as ufth] - [quantum.untyped.core.loops :as loops + [quantum.untyped.core.form.type-hint :as ufth] + [quantum.untyped.core.log :as log + :refer [ppr! ppr prl! prlm!]] + [quantum.untyped.core.logic :as l + :refer [fn= fn-and fn-or fn-not ifs if-not-let]] + [quantum.untyped.core.loops :as loops :refer [reduce-2]] [quantum.untyped.core.numeric.combinatorics :as combo] - [quantum.untyped.core.qualify :as qual :refer [qualify]] - [quantum.untyped.core.reducers :as r + [quantum.untyped.core.print :as pr] + [quantum.untyped.core.qualify :as qual :refer [qualify]] + [quantum.untyped.core.reducers :as r :refer [join reducei educe]] - [quantum.untyped.core.refs :as ref + [quantum.untyped.core.refs :as ref :refer [?deref]] - [quantum.untyped.core.spec :as s] - [quantum.untyped.core.specs :as uss] - [quantum.untyped.core.type :as t + [quantum.untyped.core.spec :as s] + [quantum.untyped.core.specs :as uss] + [quantum.untyped.core.type :as t :refer [?]] - [quantum.untyped.core.type.predicates :as utpred] - [quantum.untyped.core.vars :as var + [quantum.untyped.core.type.predicates :as utpred] + [quantum.untyped.core.type.reifications :as utr] + [quantum.untyped.core.vars :as var :refer [update-meta]] - [quantum.format.clojure.core ; TODO temporary + #_[quantum.format.clojure.core ; TODO temporary :refer [reformat-string]]) (:import - [quantum.core Numeric] - [quantum.untyped.core.type ClassSpec])) + [quantum.core Numeric])) ;; TODO move -(defn ppr-code [code] +#_(defn ppr-code [code] (let [default-indentations '{do [[:inner 2 2]] if [[:inner 2 2]]}] (-> code pr/ppr-meta with-out-str @@ -114,22 +111,22 @@ (if nilable? c (or (tcore/boxed->unboxed c) c)))) #?(:clj -(defns spec>most-primitive-classes [spec t/spec? > (s/set-of (? t/class?))] - (let [cs (t/spec>classes spec) nilable? (contains? cs nil)] +(defns type>most-primitive-classes [t t/type? > (s/set-of (? t/class?))] + (let [cs (t/type>classes t) nilable? (contains? cs nil)] (->> cs (c/map+ #(class>most-primitive-class % nilable?)) (join #{}))))) #?(:clj -(defns spec>most-primitive-class [spec t/spec? > (? t/class?)] - (let [cs (spec>most-primitive-classes spec)] +(defns type>most-primitive-class [t t/type? > (? t/class?)] + (let [cs (type>most-primitive-classes t)] (if (-> cs count (not= 1)) - (err! "Not exactly 1 class found" (kw-map spec cs)) + (err! "Not exactly 1 class found" (kw-map t cs)) (first cs))))) #?(:clj -(defns out-spec>class [spec t/spec? > (? t/class?)] - (let [cs (t/spec>classes spec) cs' (disj cs nil)] +(defns out-type>class [t t/type? > (? t/class?)] + (let [cs (t/type>classes t) cs' (disj cs nil)] (if (-> cs' count (not= 1)) ;; NOTE: we don't need to vary the output class if there are multiple output possibilities or just nil java.lang.Object @@ -140,7 +137,7 @@ ;; NOTE: All this code can be defnt-ized after; this is just for bootstrapping purposes so performance isn't extremely important in most of these functions. -(defonce *fn->spec (atom {})) +(defonce *fn->type (atom {})) (defonce defnt-cache (atom {})) ; TODO For now — but maybe lock-free concurrent hash map to come @@ -172,7 +169,7 @@ (defonce class->methods|with-cache (memoize (fn [c] (class->methods c)))) -(defrecord Field [^String name ^Class type ^clojure.lang.Keyword kind] +(defrecord Field [^String name ^Class class ^clojure.lang.Keyword kind] fipp.ednize/IOverride fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "F") (into (array-map) this)))) @@ -265,7 +262,7 @@ (ast/do {:env env :form form :body (>vec body) - :spec t/nil?}) + :type t/nil?}) (let [expr (analyze-non-map-seqable env body [] (fn [accum expr _] ;; for types, only the last subexpression ever matters, as each is independent from the others @@ -275,7 +272,7 @@ (ast/do {:env env :form form :body (>vec body) - :spec (:spec expr)})))) + :type (:type expr)})))) (defns analyze-seq|let*|bindings [env ::env, bindings _] (TODO "`let*|bindings` analysis") @@ -312,36 +309,36 @@ (log/ppr :warn "Not sure how to handle non-local symbol; resolved it for now" (kw-map sym resolved)) resolved)))) -(defns methods->spec - "Creates a spec given ->`methods`." - [methods (s/seq-of method?) > t/spec?] +(defns methods->type + "Creates a type given ->`methods`." + [methods (s/seq-of method?) > t/type?] ;; TODO room for plenty of optimization here (let [methods|by-ct (->> methods (c/group-by (fn-> :argtypes count)) (sort-by first <)) ;; non-primitive classes in Java aren't guaranteed to be non-null - >class-spec (fn [x] + >class-type (fn [x] (ifs (class? x) - (-> x t/>spec (cond-> (not (t/primitive-class? x)) t/?)) - (t/spec? x) + (-> x t/>type (cond-> (not (t/primitive-class? x)) t/?)) + (t/type? x) x - (err/not-supported! `>class-spec x))) + (err/not-supported! `>class-type x))) partition-deep - (fn partition-deep [spec methods' arglist-size i|arg depth] + (fn partition-deep [t methods' arglist-size i|arg depth] (let [_ (when (> depth 3) (TODO)) methods'|by-class (->> methods' ;; TODO optimize further via `group-by-into` (c/group-by (fn-> :argtypes (c/get i|arg))) ;; classes will be sorted from most to least specific - (sort-by (fn-> first t/>spec) t/<))] + (sort-by (fn-> first t/>type) t/<))] (r/for [[c methods''] methods'|by-class - spec' spec] - (update spec' :clauses conj - [(>class-spec c) + t' t] + (update t' :clauses conj + [(>class-type c) (if (= (inc depth) arglist-size) ;; here, methods'' count will be = 1 - (-> methods'' first :rtype >class-spec) + (-> methods'' first :rtype >class-type) (partition-deep (xp/condpf-> t/<= (xp/get (inc i|arg))) methods'' @@ -349,19 +346,19 @@ (inc i|arg) (inc depth)))]))))] (r/for [[ct methods'] methods|by-ct - spec (xp/casef count)] + t (xp/casef count)] (if (zero? ct) - (c/assoc-in spec [:cases 0] (-> methods' first :rtype >class-spec)) - (c/assoc-in spec [:cases ct] (partition-deep (xp/condpf-> t/<= (xp/get 0)) methods' ct 0 0)))))) + (c/assoc-in t [:cases 0] (-> methods' first :rtype >class-type)) + (c/assoc-in t [:cases ct] (partition-deep (xp/condpf-> t/<= (xp/get 0)) methods' ct 0 0)))))) #?(:clj -(defns ?cast-call->spec +(defns ?cast-call->type "Given a cast call like `clojure.lang.RT/uncheckedBooleanCast`, returns the - corresponding spec. + corresponding type. Unchecked fns could be assumed to actually *want* to shift the range over if the range hits a certain point, but we do not make that assumption here." - [c t/class?, method t/symbol? > (? t/spec?)] + [c t/class?, method t/symbol? > (? t/type?)] (when (identical? c clojure.lang.RT) (case method (uncheckedBooleanCast booleanCast) @@ -387,7 +384,7 @@ If only one method is found, that is noted too. If no matching method is found, an exception is thrown." [env ::env, form _, target _, target-class t/class?, static? t/boolean?, method-form simple-symbol?, args-forms _ #_(seq-of form?)] - ;; TODO cache spec by method + ;; TODO cache type by method (if-not-let [methods-for-name (-> target-class class->methods|with-cache (c/get (name method-form)))] (if (empty? args-forms) (err! "No such method or field in class" {:class target-class :method-or-field method-form}) @@ -406,8 +403,8 @@ :target target :method method-form :args [] - :spec (methods->spec methods #_(count arg-forms))}) - with-arg-specs + :type (methods->type methods #_(count arg-forms))}) + with-arg-types (r/fori [arg-form args-forms call' call i|arg] @@ -415,14 +412,14 @@ (let [arg-node (analyze* env arg-form)] ;; TODO can incrementally calculate return value, but possibly not worth it (update call' :args conj arg-node))) - with-ret-spec - (update with-arg-specs :spec - (fn [ret-spec] (->> with-arg-specs :args (mapv :spec) ret-spec))) - ?cast-spec (?cast-call->spec target-class method-form) - _ (when ?cast-spec + with-ret-type + (update with-arg-types :type + (fn [ret-type] (->> with-arg-types :args (mapv :type) ret-type))) + ?cast-type (?cast-call->type target-class method-form) + _ (when ?cast-type (ppr :warn "Not yet able to statically validate whether primitive cast will succeed at runtime" {:form form}) - #_(s/validate (-> with-ret-spec :args first :spec) #(t/>= % (t/numerically ?cast-spec))))] - with-ret-spec)))))) + #_(s/validate (-> with-ret-type :args first :type) #(t/>= % (t/numerically ?cast-type))))] + with-ret-type)))))) (defns- analyze-seq|dot|field-access [env ::env, form _, target _, field-form simple-symbol?, field (t/isa? Field)] @@ -431,7 +428,7 @@ :form form :target target :field field-form - :spec (-> field :type t/>spec)})) + :type (-> field :class t/>type)})) (defns classes>class "Ensure that given a set of classes, that set consists of at most a class C and nil. @@ -442,23 +439,23 @@ (first cs') (err! "Found more than one class" cs)))) -;; TODO spec these arguments; e.g. check that ?method||field, if present, is an unqualified symbol +;; TODO type these arguments; e.g. check that ?method||field, if present, is an unqualified symbol (defns- analyze-seq|dot [env ::env, form _, [target-form _, ?method-or-field _ & ?args _] _] {:pre [(prl! env form target-form ?method-or-field ?args)] :post [(prl! %)]} (let [target (analyze* #_?resolve-with-env env target-form) method-or-field (if (symbol? ?method-or-field) ?method-or-field (first ?method-or-field)) args-forms (if (symbol? ?method-or-field) ?args (rest ?method-or-field))] - (if (t/= (:spec target) t/nil?) + (if (t/= (:type target) t/nil?) (err! "Cannot use the dot operator on nil." {:form form}) (let [;; `nilable?` because technically any non-primitive in Java is nilable and we can't ;; necessarily rely on all e.g. "@nonNull" annotations {:as ?target-static-class-map target-static-class :class target-static-class-nilable? :nilable?} - (-> target :spec t/spec>?class-value) + (-> target :type t/type>?class-value) target-classes (if ?target-static-class-map (cond-> #{target-static-class} target-static-class-nilable? (conj nil)) - (-> target :spec t/spec>classes)) + (-> target :type t/type>classes)) target-class-nilable? (contains? target-classes nil) target-class (classes>class target-classes)] ;; TODO determine how to handle `target-class-nilable?`; for now we will just let it slip through @@ -471,11 +468,11 @@ method-or-field args-forms)))))) ;; TODO move this -(defns truthy-expr? [{:as expr :keys [spec _]} _ > t/boolean?] - (ifs (or (t/= spec t/nil?) - (t/= spec t/false?)) false - (or (t/> spec t/nil?) - (t/> spec t/false?)) nil ; representing "unknown" +(defns truthy-expr? [{:as expr t [:type _]} _ > t/boolean?] + (ifs (or (t/= t t/nil?) + (t/= t t/false?)) false + (or (t/> t t/nil?) + (t/> t t/false?)) nil ; representing "unknown" true)) (defns- analyze-seq|if @@ -496,7 +493,7 @@ :pred-expr pred-expr :true-expr @true-expr :false-expr @false-expr - :spec (apply t/or (->> [(:spec @true-expr) (:spec @false-expr)] (remove nil?)))}))] + :type (apply t/or (->> [(:type @true-expr) (:type @false-expr)] (remove nil?)))}))] (case (truthy-expr? pred-expr) true (do (ppr :warn "Predicate in `if` expression is always true" {:pred pred-form}) (-> @true-expr (assoc :env env) @@ -515,16 +512,16 @@ (defns- analyze-seq|new [env ::env, form _ [c|form _ #_t/class? & args _ :as body] _] {:pre [(prl! env form body)]} (let [c|analyzed (analyze* env c|form)] - (if-not (and (-> c|analyzed :spec t/value-spec?) - (-> c|analyzed :spec t/value-spec>value class?)) + (if-not (and (-> c|analyzed :type t/value-type?) + (-> c|analyzed :type utr/value-type>value class?)) (err! "Supplied non-class to `new` expression" {:x c|form}) - (let [c (-> c|analyzed :spec t/value-spec>value) + (let [c (-> c|analyzed :type utr/value-type>value) args|analyzed (mapv #(analyze* env %) args)] (ast/new-expr {:env env :form (list* 'new c|form (map :form args|analyzed)) :class c :args args|analyzed - :spec (t/isa? c)}))))) + :type (t/isa? c)}))))) (defns- analyze-seq|throw [env ::env, form _ [arg _ :as body] _] {:pre [(prl! env form body)]} @@ -532,13 +529,13 @@ (err! "Must supply exactly one input to `throw`; supplied" {:body body}) (let [arg|analyzed (analyze* env arg)] ;; TODO this is not quite true for CLJS but it's nice at least - (if-not (-> arg|analyzed :spec (t/<= t/throwable?)) - (err! "`throw` requires a throwable; received" {:arg arg :spec (:spec arg|analyzed)}) + (if-not (-> arg|analyzed :type (t/<= t/throwable?)) + (err! "`throw` requires a throwable; received" {:arg arg :type (:type arg|analyzed)}) (ast/throw-expr {:env env :form (list 'throw (:form arg|analyzed)) :arg arg|analyzed ;; `t/none?` because nothing is actually returned - :spec t/none?}))))) + :type t/none?}))))) (defns- analyze-seq* "Analyze a seq after it has been macro-expanded. @@ -558,51 +555,51 @@ throw (analyze-seq|throw env form body)) ;; TODO support recursion (let [caller|expr (analyze* env caller|form) - caller|spec (:spec caller|expr) + caller|type (:type caller|expr) args-ct (count body)] - (case (t/compare caller|spec t/callable?) + (case (t/compare caller|type t/callable?) (1 2) (err! "It is not known whether expression be called" {:expr caller|expr}) 3 (err! "Expression cannot be called" {:expr caller|expr}) (-1 0) (let [assert-valid-args-ct - (ifs (or (t/<= caller|spec t/keyword?) (t/<= caller|spec t/+map|built-in?)) + (ifs (or (t/<= caller|type t/keyword?) (t/<= caller|type t/+map|built-in?)) (when-not (or (= args-ct 1) (= args-ct 2)) (err! (str "Keywords and `clojure.core` persistent maps must be provided " "with exactly one or two args when calling them") {:args-ct args-ct :caller caller|expr})) - (or (t/<= caller|spec t/+vector|built-in?) (t/<= caller|spec t/+set|built-in?)) + (or (t/<= caller|type t/+vector|built-in?) (t/<= caller|type t/+set|built-in?)) (when-not (= args-ct 1) (err! (str "`clojure.core` persistent vectors and `clojure.core` persistent " "sets must be provided with exactly one arg when calling them") {:args-ct args-ct :caller caller|expr})) - (t/<= caller|spec t/fnt?) - (TODO "Don't know how to handle spec'ed fns yet" {:caller caller|expr}) - ;; For non-speced fns, unknown; we will have to risk runtime exception + (t/<= caller|type t/fnt?) + (TODO "Don't know how to handle typed fns yet" {:caller caller|expr}) + ;; For non-typed fns, unknown; we will have to risk runtime exception ;; because we can't necessarily rely on metadata to tell us the whole truth - (t/<= caller|spec t/fn?) + (t/<= caller|type t/fn?) nil ;; If it's ifn but not fn, we might have missed something in this dispatch so for now we throw (err! "Don't know how how to handle non-fn ifn" {:caller caller|expr})) - {:keys [args spec]} + {:keys [args] t :type} (->> body (c/map+ #(analyze* env %)) - (reduce (fn [{:keys [args spec]} arg|analyzed] + (reduce (fn [{:keys [args]} arg|analyzed] (conj args))))] ;; TODO incrementally check by analyzing each arg in `reduce` and pruning branches of what the - ;; spec could be, and throwing if it's found something that's an impossible combination + ;; type could be, and throwing if it's found something that's an impossible combination (ast/call-expr {:env env :form form :caller caller|expr :args args - :spec spec})))))) + :type t})))))) (defns- analyze-seq [env ::env, form _] {:post [(prl! %)]} (prl! form) - (let [expanded-form (macroexpand form)] + (let [expanded-form (ufeval/macroexpand form)] (if (== form expanded-form) (analyze-seq* env expanded-form) (ast/macro-call {:env env :form form :expanded (analyze-seq* env expanded-form)})))) @@ -614,14 +611,14 @@ (err! "Could not resolve symbol" {:sym form}) (ast/symbol env form (ifs (ast/node? resolved) - (:spec resolved) + (:type resolved) (or (t/literal? resolved) (t/class? resolved)) (t/value resolved) (var? resolved) - (or (-> resolved meta :spec) + (or (-> resolved meta :type) (t/value @resolved)) (utpred/unbound? resolved) - ;; Because the var could be anything and cannot have metadata (spec or otherwise) + ;; Because the var could be anything and cannot have metadata (type or otherwise) t/any? (TODO "Unsure of what to do in this case" (kw-map env form resolved))))))) @@ -631,7 +628,7 @@ (ifs (symbol? form) (analyze-symbol env form) (t/literal? form) - (ast/literal env form (t/>spec form)) + (ast/literal env form (t/>type form)) (or (vector? form) (set? form)) (analyze-non-map-seqable env form (empty form) (fn stop [& [a b :as args]] (prl! args) (err! "STOP"))) @@ -652,19 +649,19 @@ #_(s/def :fnt|overload/arglist-code (t/vec-of arg?)) #_"Must evaluate to an `s/fspec`" -(s/def :fnt|overload/spec :quantum.core.specs/code) +(s/def :fnt|overload/type :quantum.core.specs/code) #_(s/def :fnt|overload/body-codelist (t/seq-of :quantum.core.specs/code)) ;; Internal (s/def ::fnt|overload (s/kv {:arg-classes (s/vec-of t/class?) - :arg-specs t/any? + :arg-types t/any? :arglist-code|fn|hinted t/any? :arglist-code|reify|unhinted t/any? :body-form t/any? :positional-args-ct (s/and t/integer? #(>= % 0)) - :out-spec t/spec? + :out-type t/type? :out-class (? t/class?) ;; When present, varargs are considered to be of class Object :variadic? t/boolean?})) @@ -685,10 +682,10 @@ (cond (not= k :spec) java.lang.Object; default class (symbol? spec) (pred->class lang spec)))) -(defn >with-post-spec - [body post-spec] +(defn >with-post-type + [body post-type] `(let [~'out ~body] - (s/validate ~'out ~(update-meta post-spec dissoc* :runtime?)))) + (s/validate ~'out ~(update-meta post-type dissoc* :runtime?)))) #?(:clj (var/def sort-guide "for use in arity sorting, in increasing conceptual size" @@ -703,8 +700,8 @@ tdef/double 8})) #?(:clj -(defns arg-specs>arg-classes-seq|primitivized - "'primitivized' meaning given an arglist whose specs are `[t/any?]` this will output: +(defns arg-types>arg-classes-seq|primitivized + "'primitivized' meaning given an arglist whose types are `[t/any?]` this will output: [[java.lang.Object] [boolean] [byte] @@ -714,13 +711,13 @@ [long] [float] [double]] - which includes all primitive subclasses of the spec." - [arg-specs (s/seq-of t/spec?) > (s/seq-of (s/vec-of t/class?))] - (->> arg-specs - (c/lmap (fn [spec #_t/spec?] - (if (-> spec meta :ref?) - (-> spec t/spec>classes (disj nil) seq) - (let [cs (spec>most-primitive-classes spec)] + which includes all primitive subclasses of the type." + [arg-types (s/seq-of t/type?) > (s/seq-of (s/vec-of t/class?))] + (->> arg-types + (c/lmap (fn [t #_t/type?] + (if (-> t meta :ref?) + (-> t t/type>classes (disj nil) seq) + (let [cs (type>most-primitive-classes t)] (let [base-classes (->> cs (c/map+ class>simplest-class) >set) base-classes (cond-> base-classes (contains? cs nil) (conj java.lang.Object))] (->> cs (c/map+ tcore/class>prim-subclasses) @@ -734,20 +731,20 @@ #?(:clj (defns- >fnt|overload - [{:keys [arg-bindings _, arg-classes|pre-analyze _, arg-specs|pre-analyze|base _, args _ + [{:keys [arg-bindings _, arg-classes|pre-analyze _, arg-types|pre-analyze|base _, args _ body-codelist|pre-analyze _, lang ::lang, post-form _, varargs _, varargs-binding _]} _ > ::fnt|overload] - (let [arg-specs|pre-analyze + (let [arg-types|pre-analyze (c/mergev-with - (fn [_ spec #_t/spec? c #_t/class?] - (cond-> spec (t/primitive-class? c) (t/and c))) - arg-specs|pre-analyze|base arg-classes|pre-analyze) - env (->> (zipmap arg-bindings arg-specs|pre-analyze) - (c/map' (fn [[arg-binding arg-spec]] - [arg-binding (ast/unbound nil arg-binding arg-spec)]))) + (fn [_ s #_t/type? c #_t/class?] + (cond-> s (t/primitive-class? c) (t/and c))) + arg-types|pre-analyze|base arg-classes|pre-analyze) + env (->> (zipmap arg-bindings arg-types|pre-analyze) + (c/map' (fn [[arg-binding arg-type]] + [arg-binding (ast/unbound nil arg-binding arg-type)]))) analyzed (analyze env (ufgen/?wrap-do body-codelist|pre-analyze)) - arg-specs (->> arg-bindings (mapv #(:spec (c/get (:env analyzed) %)))) - arg-classes (->> arg-specs (c/map spec>most-primitive-class)) + arg-types (->> arg-bindings (mapv #(:type (c/get (:env analyzed) %)))) + arg-classes (->> arg-types (c/map type>most-primitive-class)) arg-classes|simplest (->> arg-classes (c/map class>simplest-class)) hint-arg|fn (fn [i arg-binding] (ufth/with-type-hint arg-binding @@ -756,36 +753,36 @@ lang (c/count args) varargs))) - post-spec (cond (nil? post-form) nil + post-type (cond (nil? post-form) nil (= post-form '_) t/any? :else (eval post-form)) - post-spec|runtime? (-> post-spec meta :runtime?) - out-spec (if post-spec - (if post-spec|runtime? - (case (t/compare post-spec (:spec analyzed)) - -1 post-spec - 1 (:spec analyzed) - 0 post-spec - (2 3) (err! "Body and output spec comparison not handled" {:body analyzed :output-spec post-spec})) - (if (t/<= (:spec analyzed) post-spec) - (:spec analyzed) - (err! "Body does not match output spec" {:body analyzed :output-spec post-spec}))) - (:spec analyzed)) + post-type|runtime? (-> post-type meta :runtime?) + out-type (if post-type + (if post-type|runtime? + (case (t/compare post-type (:type analyzed)) + -1 post-type + 1 (:type analyzed) + 0 post-type + (2 3) (err! "Body and output type comparison not handled" {:body analyzed :output-type post-type})) + (if (t/<= (:type analyzed) post-type) + (:type analyzed) + (err! "Body does not match output type" {:body analyzed :output-type post-type}))) + (:type analyzed)) body-form (-> (:form analyzed) - (cond-> post-spec|runtime? (>with-post-spec post-spec)) + (cond-> post-type|runtime? (>with-post-type post-type)) (ufth/cast-bindings|code (->> (c/zipmap-into (map/om) arg-bindings arg-classes) (c/remove-vals' (fn-or nil? (fn= java.lang.Object) t/primitive-class?)))))] {:arg-classes arg-classes|simplest - :arg-specs arg-specs + :arg-types arg-types :arglist-code|fn|hinted (cond-> (->> arg-bindings (c/map-indexed hint-arg|fn)) varargs-binding (conj '& varargs-binding)) ; TODO use `` :arglist-code|reify|unhinted (cond-> arg-bindings varargs-binding (conj varargs-binding)) :body-form body-form :positional-args-ct (count args) - :out-spec out-spec - :out-class (out-spec>class out-spec) + :out-types out-type + :out-class (out-type>class out-type) :variadic? (boolean varargs)}))) #?(:clj ; really, reserve for metalanguage @@ -796,8 +793,8 @@ our own workflow 3) we wait for CLJS-in-CLJS to become mainstream, which could take years if it really ever happens - we decide instead to evaluate specs in languages in which the metalanguage (compiler language) is the same as - the object language (e.g. Clojure), and symbolically analyze specs in the rest (e.g. vanilla ClojureScript), + we decide instead to evaluate types in languages in which the metalanguage (compiler language) is the same as + the object language (e.g. Clojure), and symbolically analyze types in the rest (e.g. vanilla ClojureScript), deferring code analyzed as functions to be enforced at runtime." [{:as in {:keys [args varargs] pre-form :pre [post-type post-form] :post} :arglist body-codelist|pre-analyze :body} {:as opts :keys [lang #_::lang symbolic-analysis? #_t/boolean?]}] @@ -813,18 +810,18 @@ ;; TODO this assertion is purely temporary until destructuring is supported (assert kind :sym) binding-))) - arg-specs|pre-analyze|base + arg-types|pre-analyze|base (->> args - (mapv (fn [{[kind #_#{:any :spec}, spec #_t/form?] :spec}] + (mapv (fn [{[kind #_#{:any :spec}, t #_t/form?] :spec}] (case kind :any t/any? - :spec (-> spec eval t/>spec))))) - arg-classes-seq|pre-analyze (arg-specs>arg-classes-seq|primitivized arg-specs|pre-analyze|base) + :spec (-> t eval t/>type))))) + arg-classes-seq|pre-analyze (arg-types>arg-classes-seq|primitivized arg-types|pre-analyze|base) ;; `unprimitivized` is first because of class sorting [unprimitivized & primitivized] (->> arg-classes-seq|pre-analyze (mapv (fn [arg-classes|pre-analyze] (>fnt|overload - (kw-map arg-bindings arg-classes|pre-analyze arg-specs|pre-analyze|base args + (kw-map arg-bindings arg-classes|pre-analyze arg-types|pre-analyze|base args body-codelist|pre-analyze lang post-form varargs varargs-binding)))))] {:unprimitivized unprimitivized :primitivized primitivized})))) @@ -962,8 +959,8 @@ :remaining (next remaining)))) (get c)))) -(defn assert-monotonically-increasing-specs! - "Asserts that each spec in an overload of the same arity and arg-position +(defn assert-monotonically-increasing-types! + "Asserts that each type in an overload of the same arity and arg-position are in monotonically increasing order in terms of `t/compare`." [overloads|grouped-by-arity] (doseq [[arity-ct overloads] overloads|grouped-by-arity] @@ -971,16 +968,16 @@ (fn [prev-overload [i|overload overload]] (when prev-overload (reduce-2 - (fn [_ arg|spec|prev [i|arg arg|spec]] - (when (= (t/compare arg|spec arg|spec|prev) -1) + (fn [_ arg|type|prev [i|arg arg|type]] + (when (= (t/compare arg|type arg|type|prev) -1) ;; TODO provide code context, line number, etc. - (err! (istr "At overload ~{i|overload}, arg ~{i|arg}: spec is not in monotonically increasing order in terms of `t/compare`") + (err! (istr "At overload ~{i|overload}, arg ~{i|arg}: type is not in monotonically increasing order in terms of `t/compare`") {:overload overload :prev-overload prev-overload - :prev-spec arg|spec|prev - :spec arg|spec}))) - (:arg-specs prev-overload) - (c/lindexed (:arg-specs overload)))) + :prev-type arg|type|prev + :type arg|type}))) + (:arg-types prev-overload) + (c/lindexed (:arg-types overload)))) overload) nil overloads))) @@ -996,7 +993,7 @@ (when (->> overloads (seq-or :variadic?)) (TODO "Doesn't yet handle protocol creation for variadic overloads")) (let [overloads|grouped-by-arity (->> overloads c/indexed+ (c/group-by (fn-> second :positional-args-ct)))] - (assert-monotonically-increasing-specs! overloads|grouped-by-arity)) + (assert-monotonically-increasing-types! overloads|grouped-by-arity)) (let [all-arg-classes (->> overloads (mapv :arg-classes)) protocol|name (str fn|name "__Protocol__" ) extend-protocols nil #_(for [] @@ -1016,20 +1013,20 @@ ;; `String` is final, so they're mutually exclusive clojure.lang.Named (name|gen [x] (.invoke name|gen|__1 x)))) -(defns gen-register-spec - "Registers in the map of qualified symbol to input spec, to output spec +(defns gen-register-type + "Registers in the map of qualified symbol to input type, to output type Example output: (swap! ... assoc `abcde - (fn [args] (case (count args) 1 )))" - [{:keys [fn|name :quantum.core.specs/fn|name, arg-ct->spec _, variadic-overload _]} _] + (fn [args] (case (count args) 1 )))" + [{:keys [fn|name :quantum.core.specs/fn|name, arg-ct->type _, variadic-overload _]} _] (unify-gensyms - `(swap! *fn->spec assoc '~(qualify fn|name) + `(swap! *fn->type assoc '~(qualify fn|name) (xp/>expr - (fn [args##] (case (count args##) ~@arg-ct->spec + (fn [args##] (case (count args##) ~@arg-ct->type ~@(when variadic-overload [`(if (>= (count args##) (:positional-args-ct variadic-overload)) - (:out-spec variadic-overload) + (:out-type variadic-overload) (err! "Arg count not enough for variadic overload"))]))))) true)) @@ -1049,14 +1046,14 @@ ;; only one variadic arg allowed _ (s/validate fnt|overload-groups (fn->> (c/lmap :unprimitivized) (c/lfilter :variadic?) count (<- (<= 1)))) - arg-ct->spec (->> fnt|overload-groups + arg-ct->type (->> fnt|overload-groups (c/map+ :unprimitivized) (remove+ :variadic?) (c/group-by :positional-args-ct) - (map-vals+ :out-spec) + (map-vals+ :out-type) join (apply concat)) variadic-overload (->> fnt|overload-groups (c/lmap :unprimitivized) (c/lfilter :variadic?) first) - register-spec (gen-register-spec (kw-map fn|name arg-ct->spec variadic-overload)) + register-type (gen-register-type (kw-map fn|name arg-ct->type variadic-overload)) direct-dispatch-codelist (case lang :clj (for [[i fnt|overload-group] (c/lindexed fnt|overload-groups)] @@ -1084,7 +1081,7 @@ [fn|name] []) [overloads|code])) - :defn `(~'do #_~register-spec ; elide for now + :defn `(~'do #_~register-type ; elide for now ~@fn-codelist))] code)) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index af750017..4d580947 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -6,9 +6,6 @@ [clojure.core :as c] [quantum.core.defnt :refer [analyze defnt fnt|code *fn->spec]] - [quantum.core.spec :as s] - [quantum.core.test :as test - :refer [deftest testing is is= throws]] [quantum.untyped.core.analyze.expr :as xp] [quantum.untyped.core.collections.diff :as diff :refer [diff]] @@ -22,6 +19,9 @@ :refer [tag]] [quantum.untyped.core.logic :refer [ifs]] + [quantum.untyped.core.spec :as s] + [quantum.untyped.core.test :as test + :refer [deftest testing is is= throws]] [quantum.untyped.core.type :as t :refer [? *]]) (:import diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 7369c3fe..6ea801ac 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -15,73 +15,73 @@ (do -;; ===== CONSTITUENT SPECS ===== ;; +;; ===== Constituent types ===== ;; (#?(:clj definterface :cljs defprotocol) INode (getForm [#?(:cljs this)]) - (getSpec [#?(:cljs this)])) + (getType [#?(:cljs this)])) (defn node? [x] (instance? INode x)) #_(t/def ::node (t/isa? INode)) #_(t/def ::env (t/map-of t/symbol? ::node)) -;; ===== NODES ===== ;; +;; ===== Nodes ===== ;; -(defrecord Unbound [env #_::env, form #_t/symbol?, minimum-spec #_t/spec?, spec #_t/spec?] ;; TODO `spec` should be `t/deducible-spec?` +(defrecord Unbound [env #_::env, form #_t/symbol?, minimum-type #_t/type?, type #_t/type?] ;; TODO `type` should be `t/deducible-type?` INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `unbound form {:minimum minimum-spec :deduced spec}))) + (-edn [this] (list `unbound form {:minimum minimum-type :deduced type}))) (defn unbound - ([form spec] (unbound nil form spec)) - ([env form spec] (Unbound. env form spec spec))) ; TODO should wrap second `spec` in `t/deducible` + ([form t] (unbound nil form t)) + ([env form t] (Unbound. env form t t))) ; TODO should wrap second `t` in `t/deducible` (defn unbound? [x] (instance? Unbound x)) -(defrecord Literal [env #_::env, form #_::t/literal, spec #_::t/spec] +(defrecord Literal [env #_::env, form #_::t/literal, type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `literal form spec))) + (-edn [this] (list `literal form type))) (defn literal - ([form spec] (literal nil form spec)) - ([env form spec] (Literal. env form spec))) + ([form t] (literal nil form t)) + ([env form t] (Literal. env form t))) (defrecord Symbol [env #_::env form #_t/symbol? - spec #_::t/spec] + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn (-edn [this] (list `symbol (into (array-map) this)))) (defn symbol - ([form spec] (symbol nil form spec)) - ([env form spec] (Symbol. env form spec))) + ([form t] (symbol nil form t)) + ([env form t] (Symbol. env form t))) (defn symbol? [x] (instance? Symbol x)) -;; ===== SPECIAL CALLS ===== ;; +;; ===== Special calls ===== ;; (defrecord Quoted - [env #_::env, form #_::t/form, spec #_::t/spec] + [env #_::env, form #_::t/form, type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `quoted form spec))) + (-edn [this] (list `quoted form type))) -(defn quoted [form spec] (Quoted. nil form spec)) +(defn quoted [form t] (Quoted. nil form t)) (defrecord Let* [env #_::env form #_::t/body bindings #_::env body #_(t/and t/sequential? t/indexed? (t/every? ::node)) - spec #_::t/spec] + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -93,7 +93,7 @@ [env #_::env form #_::t/form body #_(t/and t/sequential? t/indexed? (t/every? ::node)) - spec #_::t/spec] + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -105,13 +105,13 @@ [env #_::env form #_::t/form expanded #_::node - spec #_::t/spec] + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn (-edn [this] (list `macro-call (into (array-map) this)))) -(defn macro-call [m] (-> m map->MacroCall (assoc :spec (-> m :expanded :spec)))) +(defn macro-call [m] (-> m map->MacroCall (assoc :type (-> m :expanded :type)))) (defrecord IfExpr [env #_::env @@ -119,7 +119,7 @@ pred-expr #_::node true-expr #_::node false-expr #_::node - spec #_::t/spec] + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -134,7 +134,7 @@ form #_::t/form target #_::node field #_t/unqualified-symbol? - spec #_::t/spec] + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -148,7 +148,7 @@ target #_::node method #_::t/unqualified-symbol? args #_(t/and t/sequential? t/indexed? (t/seq-and ::node)) - spec #_::t/spec] + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -161,7 +161,7 @@ form #_::t/form caller #_::node args #_(t/and t/sequential? t/indexed? (t/seq-and ::node)) - spec #_::t/spec] + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -174,7 +174,7 @@ form #_::t/form class #_t/class? args #_(t/and t/sequential? t/indexed? (t/seq-and ::node)) - spec #_::t/spec] + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -186,7 +186,7 @@ [env #_::env form #_::t/form arg #_::node - spec #_t/nil?] + type #_t/nil?] INode fipp.ednize/IOverride fipp.ednize/IEdn diff --git a/src-untyped/quantum/untyped/core/test.cljc b/src-untyped/quantum/untyped/core/test.cljc index fa536144..59905908 100644 --- a/src-untyped/quantum/untyped/core/test.cljc +++ b/src-untyped/quantum/untyped/core/test.cljc @@ -15,6 +15,8 @@ #?(:clj (defmalias testing clojure.test/testing cljs.test/testing)) #?(:clj (defalias test/test-ns)) +#?(:clj (defn test-nss [& ns-syms] (->> ns-syms (map test-ns) doall))) + #?(:clj (defn test-nss-where [pred] (->> (all-ns) (filter #(-> % ns-name name pred)) (map test-ns) doall))) diff --git a/src/quantum/core/core.cljc b/src/quantum/core/core.cljc index ff5a6634..c34fee84 100644 --- a/src/quantum/core/core.cljc +++ b/src/quantum/core/core.cljc @@ -5,7 +5,7 @@ #?(:clj [clojure.core.specs.alpha :as ss]) [cuerdas.core :as str+] #?(:clj [environ.core :as env]) - [quantum.core.type :as t + #_[quantum.core.type :as t :refer [defnt defmacrot defprotocolt]] [quantum.untyped.core.core :as u] [quantum.untyped.core.vars @@ -36,16 +36,16 @@ ;; ===== Mutability/Effects ===== ;; ;; TODO excise when typed -#_(defprotocol IValue +(defprotocol IValue (get [this]) (set [this newv])) -(defprotocolt IValue +#_(defprotocolt IValue (get [this _]) (set [this _, newv _])) ;; TODO excise when typed -#_(:clj +#?(:clj (defmacro with "Evaluates @expr, then @body, then returns @expr. For (side) effects." @@ -54,7 +54,7 @@ ~@body expr#))) -#?(:clj +#_(:clj (defmacrot with "Evaluates @expr, then @body, then returns @expr. For (side) effects." diff --git a/src/quantum/core/ns.cljc b/src/quantum/core/ns.cljc index ffcf3f57..cbfc581b 100644 --- a/src/quantum/core/ns.cljc +++ b/src/quantum/core/ns.cljc @@ -38,7 +38,8 @@ loaded-libs load-lib! load-package! load-dep! assert-ns-aliased) -#?(:clj +;; TODO type and enable +#_(:clj (defn alias-ns "Create vars in the current namespace to alias each of the public vars in the supplied namespace. @@ -47,4 +48,4 @@ [ns-name-] (require ns-name-) (doseq [[name var] (ns-publics (the-ns ns-name-))] - (alias-var name var)))) + (uvar/alias-var name var)))) diff --git a/test/quantum/test/core/defnt.cljc b/test/quantum/test/core/defnt.cljc index f3b80724..22d9be6e 100644 --- a/test/quantum/test/core/defnt.cljc +++ b/test/quantum/test/core/defnt.cljc @@ -601,3 +601,60 @@ :c ::example|c :d ::example|d) :fn ::example|__ret) + + + + + +;; ============== Taken from untyped tests; should be modified in lock step =============== ;; + +;; ----- Implicit compilation tests ----- ;; + +(this/defnt abcde "Documentation" {:metadata "fhgjik"} + ([a number? > number?] (inc a)) + ([a pos-int?, b pos-int? + | (> a b) + > (s/and number? #(> % a) #(> % b))] (+ a b)) + ([a #{"a" "b" "c"} + b boolean? + {:as c + :keys [ca keyword? cb string?] + {:as cc + {:as cca + :keys [ccaa keyword?] + [[ccabaa some? {:as ccabab :keys [ccababa some?]} some?] some? ccabb some? & ccabc some? :as ccab] + [:ccab seq?]} + [:cca map?]} + [:cc map?]} + #(-> % count (= 3)) + [da double? & db seq? :as d] sequential? + [ea symbol?] ^:gen? (s/coll-of symbol? :kind vector?) + & [fa #{"a" "b" "c"} :as f] seq? + | (and (> da 50) (contains? c a) + a b c ca cb cc cca ccaa ccab ccabaa ccabab ccababa ccabb ccabc d da db ea f fa) + > number?] 0)) + +(this/defns basic [a number? > number?] (rand)) + +(defspec-test test|basic `basic) + +(this/defns equality [a number? > #(= % a)] a) + +(defspec-test test|equality `equality) + +(this/defns pre-post [a number? | (> a 3) > #(> % 4)] (inc a)) + +(defspec-test test|pre-post `pre-post) + +(this/defns gen|seq|0 [[a number? b number? :as b] ^:gen? (s/tuple double? double?)]) + +(defspec-test test|gen|seq|0 `gen|seq|0) + +(this/defns gen|seq|1 + [[a number? b number? :as b] ^:gen? (s/nonconforming (s/cat :a double? :b double?))]) + +(defspec-test test|gen|seq|1 `gen|seq|1) + + + + From cfaa0beab0272010bf79f8498f8e7f840fcf2877 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 16 May 2018 17:31:05 -0600 Subject: [PATCH 050/810] Do some further exploration in dynamism and performance --- src-dev/quantum/core/defnt.cljc | 43 ++++--- src-dev/quantum/core/defnt_equivalences.cljc | 112 ++++++++++++------- test/quantum/test/core/defnt.cljc | 81 ++++++++++++-- 3 files changed, 172 insertions(+), 64 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index d7c8fab7..a0a73b60 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -76,24 +76,31 @@ #_(:clj (ns-unmap (find-ns 'quantum.core.defnt) 'reformat-string)) -;; TODO look at https://github.com/clojure/core.typed/blob/master/module-rt/src/main/clojure/clojure/core/typed/ - -;; Apparently I independently came up with an algorithm that is essentially Hindley-Milner (having not seen it before I implemented it)... -;; - `dotyped`, `defnt`, and `fnt` create typed contexts in which their internal forms are analyzed -;; and overloads are resolved. -;; - When a function with type overloads is referenced outside of a typed context, then the -;; overload resolution will be done via protocol dispatch unless the function's overloads only -;; differ by arity. In either case, runtime type checks are required. -;; - Even if the `defnt` is redefined, you won't have interface problems. - -;; Any `defnt` argument, if it requires a non-nilable primitive-like value, will be marked as a primitive. -;; If nilable, it will be boxed. -;; The same thing goes for return values. -;; All other cases of primitiveness fall out of these two. - -;; `defnt` is meant to enforce syntactic correctness. -;; It is intended to catch many runtime errors at compile time, but cannot catch -;; all of them; specs will very often have to be validated at runtime. +#_" +- With `defnt`, protocols and interfaces aren't needed. You can just create `t/fn`s that you can + then conform your fns to. +- `dotyped`, `defnt`, and `fnt` create typed contexts in which their internal forms are analyzed + and overloads are resolved. +- `defnt` is intended to catch many runtime errors at compile time, but cannot catch all of them; + types will very often have to be validated at runtime. + +[ ] Runtime dispatch + [—] Protocol generation + - For now we won't do it because we can very often find the correct overload at compile + time. For now, worst case it'll be a linear check of the specs, `cond`-style. + - It will be left as an optimization. +[ ] Interface generation + - Even if the `defnt` is redefined, you won't have interface problems. +[ ] Reify generation +[ ] Dispatch + - Any argument, if it requires a non-nilable primitive-like value, will be marked as a primitive. + - If nilable, will it be boxed or will there be one overload for nil and one for primitive? + - When a `fnt` with type overloads is referenced outside of a typed context, then the overload + resolution will be done via Runtime Dispatch. +[ ] Types yielding generative specs +[—] Types using the clojure.spec interface + - Not yet; wait for it to come out of alpha +" ; TODO associative sequence over top of a vector (so it'll display like a seq but behave like a vec) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 4d580947..d6abb012 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -315,7 +315,7 @@ ;; auto-upcasts to long or double (because 64-bit) unless you tell it otherwise ;; will error if not all return values can be safely converted to the return spec (macroexpand ' -(defnt #_:inline >int* > int? +(defnt #_:inline >int* > t/int? ([x (t/- t/primitive? t/boolean?)] (Primitive/uncheckedIntCast x)) ([x (t/ref (t/isa? Number))] (.intValue x))) ) @@ -678,7 +678,7 @@ ;; ----- expanded code ----- ;; #?(:clj -`(do (swap! fn->spec assoc #'seq +`(do (assoc-meta! #'seq :type (t/fn > (t/? (t/isa? ISeq)) [t/nil?] [t/array?] @@ -688,44 +688,78 @@ [t/char-seq?] [t/java-map?])) + ;; Each of these `(def ... (reify ...))`s will keep their label (`__2__0` or whatever) as long + ;; as the original type of the `reify` is `t/=` to the new type of that reify + ;; If a redefined `defnt` doesn't have that spec then the previous reify is uninterned and made + ;; unavailable + ;; That way, according to the dynamicity tests in `quantum.test.core.defnt`, we can redefine + ;; implementations at will as long as the specs don't change ~(case-env - :clj `(do ;; `nil?` - (def seq|__0 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] nil))) - ;; `array?` - (def seq|__1__0 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (ArraySeq/createFromObject xs)))) - ... - ;; `ASeq` - (def seq|__2 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] xs))) - ;; `LazySeq` - (def seq|__3__0 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (.seq ^LazySeq xs)))) - ;; `Seqable` - (def seq|__3__1 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (.seq ^Seqable xs)))) - ;; `Iterable` - (def seq|__4 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] - (clojure.lang.RT/chunkIteratorSeq (.iterator ^Iterator xs))))) - ;; `CharSequence` - (def seq|__5 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (StringSeq/create ^CharSequence xs)))) - ;; `Map` - (def seq|__6 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (seq (.entrySet ^Map xs))))) - - (defprotocol seq__Protocol - (seq [a0])) - (extend-protocol seq__Protocol - ;; `array?` - ... - ASeq (seq [^ASeq a0] (.invoke seq|__2 a0)) - LazySeq (seq [^LazySeq a0] (.invoke seq|__3__0 a0)) - Object (seq [a0] - ;; these are sequential dispatch because none of these are concrete or abstract classes - ;; (most are interfaces etc.) - (ifs (nil? a0) (.invoke seq|__0 a0) - (instance? ASeq a0) (.invoke seq|__2 a0) - (instance? Seqable a0) (.invoke seq|__3__1 a0) - (instance? Iterable a0) (.invoke seq|__4 a0) - (instance? CharSequence a0) (.invoke seq|__5 a0) - (instance? Map a0) (.invoke seq|__6 a0) - (unsupported! `seq a0))))) - :cljs `(do ...)))) + :clj + `(do ;; `nil?` + (def ^Object>Object seq|__0__0 + (reify Object>Object + (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] + nil))) + ;; `array?` + (def ^Object>Object seq|__1__0 + (reify Object>Object + (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] + (ArraySeq/createFromObject xs)))) + ... + ;; `(t/isa? ASeq)` + (def ^Object>Object seq|__2__0 + (reify Object>Object + (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] + (let [^ASeq xs xs] xs)))) + ;; `(t/or (t/isa? LazySeq) (t/isa? Seqable))` : `(t/isa? LazySeq)` + (def ^Object>Object seq|__3__0 + (reify Object>Object + (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] + (let [^LazySeq xs xs] (.seq xs))))) + ;; `(t/or (t/isa? LazySeq) (t/isa? Seqable))` : `(t/isa? Seqable)` + (def ^Object>Object seq|__3__1 + (reify Object>Object + (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] + (let [^Seqable xs xs] (.seq xs))))) + ;; `t/iterable?` + (def ^Object>Object seq|__4__0 + (reify Object>Object + (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] + (let [^Iterable xs xs] (clojure.lang.RT/chunkIteratorSeq (.iterator xs)))))) + ;; `t/char-seq?` + (def ^Object>Object seq|__5__0 + (reify Object>Object + (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] + (let [^CharSequence xs xs] (StringSeq/create xs))))) + ;; `t/java-map?` + (def ^Object>Object seq|__6 + (reify Object>Object + (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] + ;; This is after expansion; it's the first one that matches the overload + ;; If no overload is found it'll have to be dispatched at runtime (protocol or + ;; equivalent) and potentially a configurable warning can be emitted + (let [^Map xs xs] (.invoke seq|__4__0 (.entrySet xs)))))) + + (defprotocol seq__Protocol + (seq [a0])) + (extend-protocol seq__Protocol + ;; `array?` + ... + ASeq (seq [^ASeq a0] (.invoke seq|__2 a0)) + LazySeq (seq [^LazySeq a0] (.invoke seq|__3__0 a0)) + Object (seq [a0] + ;; these are sequential dispatch because none of these are concrete or abstract classes + ;; (most are interfaces etc.) + (ifs (nil? a0) (.invoke seq|__0 a0) + (instance? ASeq a0) (.invoke seq|__2 a0) + (instance? Seqable a0) (.invoke seq|__3__1 a0) + (instance? Iterable a0) (.invoke seq|__4 a0) + (instance? CharSequence a0) (.invoke seq|__5 a0) + (instance? Map a0) (.invoke seq|__6 a0) + (unsupported! `seq a0))))) + :cljs + `(do ...)))) ;; =====|=====|=====|=====|===== ;; diff --git a/test/quantum/test/core/defnt.cljc b/test/quantum/test/core/defnt.cljc index 22d9be6e..a3423a2b 100644 --- a/test/quantum/test/core/defnt.cljc +++ b/test/quantum/test/core/defnt.cljc @@ -1,6 +1,7 @@ (ns quantum.test.core.defnt (:require - [clojure.core :as core] + [clojure.core :as core] + [criterium.core :as bench] [quantum.core.fn :as fn :refer [fn->]] [quantum.core.logic @@ -8,20 +9,20 @@ [quantum.core.defnt :as this :refer [!ref analyze defnt]] [quantum.core.macros.type-hint :as th] - [quantum.core.spec :as s] - [quantum.core.test :as test - :refer [deftest testing is is= throws]] [quantum.core.type.defs :as tdef] [quantum.untyped.core.analyze.ast :as ast] [quantum.untyped.core.analyze.expr :as xp] + [quantum.untyped.core.core + :refer [code=]] [quantum.untyped.core.form :refer [$]] [quantum.untyped.core.form.type-hint :refer [tag]] - [quantum.untyped.core.core - :refer [code=]] + [quantum.untyped.core.spec :as s] [quantum.untyped.core.string :refer [istr]] + [quantum.untyped.core.test :as test + :refer [deftest testing is is= throws]] [quantum.untyped.core.type :as t]) #?(:clj (:import @@ -604,7 +605,73 @@ - +;; ===== Dynamicity ===== ;; + +(definterface Abcde (^long abcdemethod [^int a ^byte b])) +(def ^Abcde abcde (reify Abcde (abcdemethod [this a b] (inc a)))) +(defn fghij [] (.abcdemethod abcde 1 5)) +(is= (fghij) 2) +(def ^Abcde abcde (reify Abcde (abcdemethod [this a b] (+ a 2)))) +(is= (fghij) 3) +(def abcde nil) ; To simulate clearing of unnecessary/invalid code +(throws NullPointerException (fghij)) + +;; This approach then benefits from the optional staticizing of vars in 1.8 + +;; ===== Performance ===== ;; + +;; As we can see, there is definitely benefit (50% performance increase in this case) to be gained +;; from primitive overloads, but there is no apparent benefit to pre-casting in the reify for +;; reference types. +;; This is actually nice because we don't have to generate as much interface code. + +(definterface PrimitiveIntTest (^long invoke [^int a])) +(def ^PrimitiveIntTest primitive-int-test|reify + (reify PrimitiveIntTest (invoke [this a] (Numeric/add a 1)))) +(defn primitive-int-test|primitive-fn [^long a] (Numeric/add a 1)) +(defn primitive-int-test|fn [a] (Numeric/add (long a) 1)) + +(let [a (int 1) + ^PrimitiveIntTest primitive-int-test|reify|direct @#'primitive-int-test|reify + primitive-int-test|primitive-fn|direct @#'primitive-int-test|primitive-fn + primitive-int-test|fn|direct @#'primitive-int-test|fn] + ;; ~3.33 ns + (bench/quick-bench (.invoke primitive-int-test|reify|direct a)) + ;; ~7.24 ns + (bench/quick-bench (.invoke ^PrimitiveIntTest @#'primitive-int-test|reify a)) + ;; ~5.00 ns + (bench/quick-bench (primitive-int-test|primitive-fn|direct a)) + ;; ~7.93 ns + (bench/quick-bench (@#'primitive-int-test|primitive-fn a)) + ;; ~4.99 ns + (bench/quick-bench (primitive-int-test|fn|direct a)) + ;; ~7.98 ns + (bench/quick-bench (@#'primitive-int-test|fn a))) + +(definterface String>Object|Test (^Object invoke [^String a])) +(def ^String>Object|Test string-test|reify + (reify String>Object|Test (invoke [this a] (.length a)))) +(definterface Object>Object|Test (^Object invoke [^Object a])) +(def ^Object>Object|Test string-test|generic-reify + (reify Object>Object|Test (invoke [this a] (let [^String a a] (.length a))))) +(defn string-test|fn [^String a] (.length a)) + +(let [a "" + ^String>Object|Test string-test|reify|direct @#'string-test|reify + ^Object>Object|Test string-test|generic-reify|direct @#'string-test|generic-reify + string-test|fn|direct @#'string-test|fn] + ;; ~4.09 ns + (bench/quick-bench (.invoke string-test|reify|direct a)) + ;; ~7.60 ns + (bench/quick-bench (.invoke ^String>Object|Test @#'string-test|reify a)) + ;; ~3.94 ns + (bench/quick-bench (.invoke string-test|generic-reify|direct a)) + ;; ~7.61 ns + (bench/quick-bench (.invoke ^Object>Object|Test @#'string-test|generic-reify a)) + ;; ~3.94 ns + (bench/quick-bench (string-test|fn|direct a)) + ;; ~7.55 ns + (bench/quick-bench (@#'string-test|fn a))) ;; ============== Taken from untyped tests; should be modified in lock step =============== ;; From 6f149733ab03a3f4908fe617cda95d37de88fa97 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 17 May 2018 00:48:57 -0600 Subject: [PATCH 051/810] Now we can use untyped printing at the REPL --- project-base.clj | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/project-base.clj b/project-base.clj index 40618f75..b4851058 100644 --- a/project-base.clj +++ b/project-base.clj @@ -401,18 +401,18 @@ :repl-options {:init '(do (require '[no.disassemble :refer [disassemble]] - 'quantum.core.error - 'quantum.core.print - 'quantum.core.print.prettier - '[quantum.core.log :refer [prl!]]) - (quantum.core.print.prettier/extend-pretty-printing!) - (reset! quantum.core.error/*pr-data-to-str? true) + 'quantum.untyped.core.error + 'quantum.untyped.core.print + 'quantum.untyped.core.print.prettier + '[quantum.untyped.core.log :refer [prl!]]) + (quantum.untyped.core.print.prettier/extend-pretty-printing!) + (reset! quantum.untyped.core.error/*pr-data-to-str? true) (clojure.main/repl :print #(binding [*print-meta* true - quantum.core.print/*collapse-symbols?* true - quantum.core.print/*print-as-code?* true] - (quantum.core.print/ppr %)) - :caught #'quantum.core.print/ppr-error))}}) + quantum.untyped.core.print/*collapse-symbols?* true + quantum.untyped.core.print/*print-as-code?* true] + (quantum.untyped.core.print/ppr %)) + :caught #'quantum.untyped.core.print/ppr-error))}}) (defn >cljsbuild-builds "Note that for Figwheel to work, no character in the build IDs can necessitate an From 0a78da31c76833896a9c825e10a05872997eae6f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 17 May 2018 00:49:41 -0600 Subject: [PATCH 052/810] Seriously overhaul defnt equivalences; add todos; remove protocols for now --- src-dev/quantum/core/defnt.cljc | 132 +-- src-dev/quantum/core/defnt_equivalences.cljc | 991 ++++++++++++------- 2 files changed, 644 insertions(+), 479 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index a0a73b60..4eebe9e2 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -84,26 +84,43 @@ - `defnt` is intended to catch many runtime errors at compile time, but cannot catch all of them; types will very often have to be validated at runtime. -[ ] Runtime dispatch +[ ] Compile-Time (Direct) Dispatch + - Any argument, if it requires a non-nilable primitive-like value, will be marked as a primitive. + - If nilable, will it be boxed or will there be one overload for nil and one for primitive? + - When a `fnt` with type overloads is referenced outside of a typed context, then the overload + resolution will be done via Runtime Dispatch. +[ ] Runtime (Dynamic) Dispatch [—] Protocol generation - For now we won't do it because we can very often find the correct overload at compile - time. For now, worst case it'll be a linear check of the specs, `cond`-style. + time. We will resort to using the `fn`. - It will be left as an optimization. + [ ] `fn` generation + - Performs a worst-case linear check of the types, `cond`-style. [ ] Interface generation - Even if the `defnt` is redefined, you won't have interface problems. -[ ] Reify generation -[ ] Dispatch - - Any argument, if it requires a non-nilable primitive-like value, will be marked as a primitive. - - If nilable, will it be boxed or will there be one overload for nil and one for primitive? - - When a `fnt` with type overloads is referenced outside of a typed context, then the overload - resolution will be done via Runtime Dispatch. +[ ] `reify` generation + - Which `reify`s get generated is mainly up to the inputs but partially up to the fn body — + If any typed fns are called in the fn body then this can change what gets generated. + - TODO explain this more + - Each of the `reify`s will keep their label (`__2__0` or whatever) as long as the original type + of the `reify` is `t/=` to the new type of that reify + - If a redefined `defnt` doesn't have that type overload then the previous reify is uninterned + and thus made unavailable + - That way, according to the dynamicity tests in `quantum.test.core.defnt`, we can redefine + implementations at will as long as the specs don't change + + - [ ] One reify per type that cannot be split + - Only `t/or`s can be split for now + - [ ] `(= (hash (t/or t/long? t/float?)) (hash (t/or t/long? t/float?)))` + - Currently this isn't the case; we'd like to have it so, so we can more efficiently look + up what overloads we've generated so far [ ] Types yielding generative specs [—] Types using the clojure.spec interface - Not yet; wait for it to come out of alpha +[—] `extend-defnt!` + - Not yet; probably complicated and we don't need it right now " -; TODO associative sequence over top of a vector (so it'll display like a seq but behave like a vec) - #?(:clj (defns class>simplest-class "This ensures that special overloads are not created for non-primitive subclasses @@ -680,10 +697,6 @@ :reify/arglist-code :reify|overload/body-form])) -(s/def :protocol/overload - (s/keys :req-un [:protocol|overload/name #_simple-symbol? - :protocol|overload/arglist #_(t/vector-of simple-symbol?)])) - #_(:clj (defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] (cond (not= k :spec) java.lang.Object; default class @@ -891,58 +904,6 @@ ~arglist-code ~body-form)])) lcat)))))) -(defns >extend-protocol|code [{:keys [protocol|name t/symbol?]} _] - `(extend-protocol ~protocol|name)) - -(defns >defprotocol|code - ;; TODO ensure that overload names do not shadow each other - [{:keys [name :protocol/name - overloads (s/seq-of :protocol/overload)]} _] - `(defprotocol ~name - ~@(->> overloads - (sort-by (fn-> :arglist count)) - (sort-by :name) - (c/lmap (fn [{:keys [name arglist]}] - `(~name ~arglist)))))) - -(defn fnt|overload-groups>protocol [_]) - -#_(is (code= (defnt|code>protocols 'abc (do defnt|code|class|=|2|1) :clj) - [{:defprotocol - ($ (defprotocol ~'abc|__Protocol__java|io|FilterOutputStream - (~'abc|__protofn__java|io|FilterOutputStream [~'x0 ~'x1]))) - :extend-protocols - [($ (extend-protocol ~'abc|__Protocol__java|io|FilterOutputStream - java.io.FilterOutputStream - (~'abc|__protofn__java|io|FilterOutputStream - [~(tag "java.io.FilterOutputStream" 'x1) ~(tag "java.io.FilterOutputStream" 'x0)] - (.invoke ~'abc|__0 ~'x0 ~'x1))))] - :defn nil} - {:defprotocol - ($ (defprotocol ~'abc|__Protocol__long - (~'abc|__protofn__long [~'x0 ~'x1]))) - :extend-protocols - [($ (extend-protocol ~'abc|__Protocol__long - java.io.FilterOutputStream - (~'abc|__protofn__long - [~(tag "java.io.FilterOutputStream" 'x1) ~(tag "long" 'x0)] - (.invoke ~'abc|__0 ~'x0 ~'x1))))] - :defn nil} - {:defprotocol - ($ (defprotocol ~'abc|__Protocol - (~'abc [~'x0 ~'x1]))) - :extend-protocols - [($ (extend-protocol ~'abc|__Protocol - java.io.FilterOutputStream - (~'abc - [~(tag "java.io.FilterOutputStream" 'x0) ~'x1] - (~'abc|__protofn__java|io|FilterOutputStream ~'x1 ~'x0)) - java.lang.Long - (~'abc - [~(tag "long" 'x0) ~'x1] - (~'abc|__protofn__long ~'x1 ~'x0))))] - :defn nil}])) - (def allowed-shorthand-tag-chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") (defn >all-shorthand-tags [] @@ -989,37 +950,6 @@ nil overloads))) -(defns fnt|overloads>protocols - [{:keys [overloads (s/and t/indexed? (s/seq-of :fnt/overload)) - fn|name :quantum.core.specs/fn|name]} _ - > (s/kv {:defprotocol t/any? - :extend-protocols t/any? - :defn t/any?})] - (when (->> overloads (seq-or (fn-> :positional-args-ct (> 2)))) - (TODO "Doesn't yet handle protocol creation for arglist counts of > 2")) - (when (->> overloads (seq-or :variadic?)) - (TODO "Doesn't yet handle protocol creation for variadic overloads")) - (let [overloads|grouped-by-arity (->> overloads c/indexed+ (c/group-by (fn-> second :positional-args-ct)))] - (assert-monotonically-increasing-types! overloads|grouped-by-arity)) - (let [all-arg-classes (->> overloads (mapv :arg-classes)) - protocol|name (str fn|name "__Protocol__" ) - extend-protocols nil #_(for [] - (>extend-protocol|code (kw-map protocol|name)))] - {:defprotocol (>defprotocol|code {:name protocol|name - :overloads []}) - :extend-protocols extend-protocols - :defn nil #_defn-definition})) - -;; This protocol is so suffixed because of the position of the argument on which - ;; it dispatches -#_(do (defprotocol name|gen__Protocol__0 - (name|gen [~'x])) -(extend-protocol name|gen__Protocol__0 - java.lang.String (name|gen [x] (.invoke name|gen|__0 x)) - ;; this is part of the protocol because even though `Named` is an interface, - ;; `String` is final, so they're mutually exclusive - clojure.lang.Named (name|gen [x] (.invoke name|gen|__1 x)))) - (defns gen-register-type "Registers in the map of qualified symbol to input type, to output type @@ -1066,13 +996,7 @@ :clj (for [[i fnt|overload-group] (c/lindexed fnt|overload-groups)] (fnt|overload-group>reify (assoc (kw-map i fn|name) :overload-group fnt|overload-group))) :cljs (TODO)) - dynamic-dispatch-codelist - (case lang - :clj (let [protocol (fnt|overload-groups>protocol {:overload-groups fnt|overload-groups :fn|name fn|name})] - `[~(:defprotocol protocol) - ~@(:extend-protocols protocol)]) - :cljs (TODO)) - base-fn-codelist [] + base-fn-codelist [] ; TODO fn-codelist (case lang :clj (->> `[~@direct-dispatch-codelist diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index d6abb012..15e86740 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -11,6 +11,8 @@ :refer [diff]] [quantum.untyped.core.core :as ucore :refer [code=]] + [quantum.untyped.core.data.array + :refer [*<>]] [quantum.untyped.core.form :refer [$]] [quantum.untyped.core.form.evaluate @@ -23,7 +25,8 @@ [quantum.untyped.core.test :as test :refer [deftest testing is is= throws]] [quantum.untyped.core.type :as t - :refer [? *]]) + :refer [? *]] + [quantum.untyped.core.type.reifications :as utr]) (:import clojure.lang.Named clojure.lang.Reduced @@ -47,14 +50,14 @@ ;; ----- expanded code ----- ;; -($ (do (swap! *fn->spec assoc #'pid - (t/fn [:> (? t/string?)])) - - (def ~'pid|__0 +($ (do (def ~'pid|__0 (reify >Object (~(tag "java.lang.Object" 'invoke) [~'_] (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) - (.getName))))))) + (.getName))))) + + #_(defn ~'pid + {::t/spec (t/fn [:> (? t/string?)])}))) )) @@ -74,32 +77,30 @@ ;; ----- expanded code ----- ;; -($ (do (swap! *fn->spec assoc #'identity|uninlined - (t/fn [t/any?])) - - ~@(case (env-lang) - ;; Because for `any?` it includes primitives as well - :clj ($ [;; Direct dispatch - ;; One reify per overload - (def ~'identity|uninlined|__0 ; `[x t/any?]` - (reify - Object>Object (~(tag "java.lang.Object" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] ~'x) - boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] ~'x) - byte>byte (~(tag "byte" 'invoke) [~'_ ~(tag "byte" 'x)] ~'x) - short>short (~(tag "short" 'invoke) [~'_ ~(tag "short" 'x)] ~'x) - char>char (~(tag "char" 'invoke) [~'_ ~(tag "char" 'x)] ~'x) - int>int (~(tag "int" 'invoke) [~'_ ~(tag "int" 'x)] ~'x) - long>long (~(tag "long" 'invoke) [~'_ ~(tag "long" 'x)] ~'x) - float>float (~(tag "float" 'invoke) [~'_ ~(tag "float" 'x)] ~'x) - double>double (~(tag "double" 'invoke) [~'_ ~(tag "double" 'x)] ~'x))) - ;; TODO implement this - ;; Dynamic dispatch (invoked only if incomplete type information (incl. in untyped context)) - ;; in this case no protocol is necessary because it boxes arguments anyway - ;; Var indirection may be avoided by making and using static fields via the Clojure 1.8 flag - #_(defn ~'identity|uninlined [~'x] (.invoke identity|uninlined|__0 ~'x))]) - :cljs ;; Direct dispatch will be simple functions, not `reify`s; not necessary here - ;; Dynamic dispatch will be approached later; not clear yet whether there is a huge savings - ($ [(defn ~'identity|uninlined [~'x] ~'x)]))))) +(case (env-lang) + :clj ($ (do ;; [t/any?] + (def ~(tag "[Ljava.lang.Object;" 'identity|uninlined|__0|input-types) + (*<> t/any?)) + (def ~'identity|uninlined|__0 + (reify + Object>Object (~(tag "java.lang.Object" 'invoke) [_## ~(tag "java.lang.Object" 'x)] ~'x) + boolean>boolean (~(tag "boolean" 'invoke) [_## ~(tag "boolean" 'x)] ~'x) + byte>byte (~(tag "byte" 'invoke) [_## ~(tag "byte" 'x)] ~'x) + short>short (~(tag "short" 'invoke) [_## ~(tag "short" 'x)] ~'x) + char>char (~(tag "char" 'invoke) [_## ~(tag "char" 'x)] ~'x) + int>int (~(tag "int" 'invoke) [_## ~(tag "int" 'x)] ~'x) + long>long (~(tag "long" 'invoke) [_## ~(tag "long" 'x)] ~'x) + float>float (~(tag "float" 'invoke) [_## ~(tag "float" 'x)] ~'x) + double>double (~(tag "double" 'invoke) [_## ~(tag "double" 'x)] ~'x))) + + #_(defn ~'identity|uninlined + {::t/type (t/fn [t/any?])} + [a0##] + (ifs ((Array/get identity|uninlined|__0|input-types 0) a0##) + (.invoke identity|uninlined|__0 a0##) + (unsupported! `identity|uninlined [a0##] 0))))) + :cljs ;; Direct dispatch will be simple functions, not `reify`s + ($ (do (defn ~'identity|uninlined [~'x] ~'x))))) ) @@ -128,42 +129,47 @@ ;; ----- expanded code ----- ;; -($ (do (swap! *fn->spec assoc #'name - (t/fn [t/string? :> t/string?] - [(t/isa? Named) :> (* t/string?)] - [(t/isa? INamed) :> (* t/string?)])) - - ~@(case (env-lang) - :clj ($ [;; Only direct dispatch for primitives or for Object, not for subclasses of Object - ;; Return value can be primitive; in this case it's not - ;; The macro in a typed context will find the appropriate dispatch at compile time - (def ~'name|__0 - (reify Object>Object - (~(tag "java.lang.Object" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "java.lang.String" 'x) ~'x] - ~'x)))) - (def ~'name|__1 - (reify Object>Object - (~(tag "java.lang.Object" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "clojure.lang.Named" 'x) ~'x] - (let [~'out (.getName ~'x)] - (s/validate ~'out t/string?)))))) - ;; TODO implement this - ;; This protocol is so suffixed because of the position of the argument on which - ;; it dispatches - #_(defprotocol name__Protocol__0 - (name [~'x])) - #_(extend-protocol name__Protocol__0 - java.lang.String (name [x] (.invoke name|__0 x)) - ;; this is part of the protocol because even though `Named` is an interface, - ;; `String` is final, so they're mutually exclusive - clojure.lang.Named (name [x] (.invoke name|__1 x)))]) - :cljs ($ [;; No protocol in ClojureScript; consider adding this if a performance increase is - ;; demonstrated when using a protocol - (defn ~'name [~'x] - (ifs (string? x) x - (satisfies? INamed x) (-name x) - (err! "Not supported for type" {:fn `name :type (type x)})))])))) +(case (env-lang) + :clj ($ (do ;; Only direct dispatch for primitives or for Object, not for subclasses of + ;; Object + ;; Return value can be primitive; in this case it's not + ;; The macro in a typed context will find the appropriate dispatch at compile + ;; time + + ;; [t/string?] + + (def ~(tag "[Ljava.lang.Object;" 'name|__0|input-types) + (*<> t/string?)) + (def ~(tag `Object>Object 'name|__0) + (reify Object>Object + (~(tag "java.lang.Object" 'invoke) [_## ~(tag "java.lang.Object" 'x)] + (let* [~(tag "java.lang.String" 'x) ~'x] + ~'x)))) + + ;; [(t/isa? Named)] + + (def ~(tag "[Ljava.lang.Object;" 'name|__1|input-types) + (*<> (t/isa? Named))) + (def ~(tag `Object>Object 'name|__1) + (reify Object>Object + (~(tag "java.lang.Object" 'invoke) [_## ~(tag "java.lang.Object" 'x)] + (let* [~(tag "clojure.lang.Named" 'x) ~'x] + (let* [~'out (.getName ~'x)] + (t/validate ~'out t/string?)))))) + + #_(defn ~'name + {::t/type + (t/fn [t/string? :> t/string?] + #?(:clj [(t/isa? Named) :> (* t/string?)] + :cljs [(t/isa? INamed) :> (* t/string?)]))} + [a0##] + (ifs ((Array/get name|__0|input-types 0) a0##) + (.invoke name|__0 a0##) + (unsupported! `>name [a0##] 0))))) + :cljs ($ (do (defn ~'name [~'x] + (ifs (string? x) x + (satisfies? INamed x) (-name x) + (err! "Not supported for type" {:fn `name :type (type x)})))))) )) @@ -181,33 +187,35 @@ ;; ----- expanded code ----- ;; -($ (do (swap! fn->spec assoc #'some? - (t/fn [t/nil?] - [t/any?])) - - ~@(case (env-lang) - :clj ($ [(def ~'some?|__0 ; `[x t/nil?]` - (reify - Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] false))) - (def ~'some?|__1 ; `[x t/any?]` - (reify - Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] true) - boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] true) - byte>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "byte" 'x)] true) - short>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "short" 'x)] true) - char>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "char" 'x)] true) - int>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "int" 'x)] true) - long>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "long" 'x)] true) - float>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "float" 'x)] true) - double>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "double" 'x)] true))) - ;; TODO implement this - ;; Dynamic dispatch - #_(defn ~'some? [~'x] - (ifs (nil? x) (.invoke some?|__0 x) - (.invoke some?|__1 x)))]) - :cljs ($ [(defn ~'some? [~'x] - (ifs (nil? x) false - true))])))) +(case (env-lang) + :clj ($ (do ;; [x t/nil?] + + (def ~'some?|__0 + (reify + Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] false))) + + ;; [x t/any?] + + (def ~'some?|__1 + (reify + Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] true) + boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] true) + byte>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "byte" 'x)] true) + short>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "short" 'x)] true) + char>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "char" 'x)] true) + int>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "int" 'x)] true) + long>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "long" 'x)] true) + float>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "float" 'x)] true) + double>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "double" 'x)] true))) + + #_(defn ~'some? + {::t/type (t/fn [t/nil?] + [t/any?])} + ... + ))) + :cljs ($ (do (defn ~'some? [~'x] + (ifs (nil? x) false + true))))) )) @@ -225,34 +233,36 @@ ;; ----- expanded code ----- ;; -($ (do (swap! fn->spec assoc #'reduced? - (t/fn [(t/isa? Reduced)] - [t/any?])) - - ~@(case (env-lang) - :clj ($ [(def ~'reduced?|__0 ; `[x Reduced]` - (reify - Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "clojure.lang.Reduced" 'x) ~'x] - true)))) - (def ~'reduced?|__1 ; `[x t/any?]` - (reify - Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] false) - boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] false) - byte>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "byte" 'x)] false) - short>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "short" 'x)] false) - char>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "char" 'x)] false) - int>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "int" 'x)] false) - long>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "long" 'x)] false) - float>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "float" 'x)] false) - double>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "double" 'x)] false))) - ;; TODO implement - ;; No protocol because just one class; TODO evaluate whether this is better performance-wise? probably is - #_(defn ~'reduced? [~'x] - (ifs (instance? Reduced x) (.invoke reduced?|__0 ~'x) - (.invoke reduced?|__1 ~'x)))]) - :cljs ($ [(defn ~'reduced? [~'x] - (ifs (instance? Reduced x) true false))])))) +(case (env-lang) + :clj ($ (do ;;[(t/isa? Reduced)] + + (def ~'reduced?|__0 + (reify + Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] + (let* [~(tag "clojure.lang.Reduced" 'x) ~'x] + true)))) + + ;; [t/any?] + + (def ~'reduced?|__1 + (reify + Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] false) + boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] false) + byte>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "byte" 'x)] false) + short>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "short" 'x)] false) + char>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "char" 'x)] false) + int>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "int" 'x)] false) + long>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "long" 'x)] false) + float>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "float" 'x)] false) + double>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "double" 'x)] false))) + + #_(defn ~'reduced? + {::t/type (t/fn [(t/isa? Reduced)] + [t/any?])} + ... + ))) + :cljs ($ (do (defn ~'reduced? [~'x] + (ifs (instance? Reduced x) true false))))) )) @@ -263,6 +273,7 @@ (macroexpand ' (defnt #_:inline >boolean ([x t/boolean?] x) + ;; Implicitly, `(- t/nil? t/boolean?)` ([x t/nil?] false) ;; Implicitly, `(- t/any? t/nil? t/boolean?)` ([x t/any?] true)) @@ -270,41 +281,43 @@ ;; ----- expanded code ----- ;; -($ (do (swap! fn->spec assoc #'>boolean - (t/fn [t/boolean?] - [t/nil?] - [t/any?])) - - ~@(case (env-lang) - :clj ($ [(def ~'>boolean|__0 ; `[x t/boolean?]` - (reify - boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] ~'x))) - (def ~'>boolean|__1 ; `[x t/nil?]` - (reify - Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] false))) - (def ~'>boolean|__2 ; `[x t/any?]` - (reify - Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] true) - boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] true) - byte>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "byte" 'x)] true) - short>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "short" 'x)] true) - char>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "char" 'x)] true) - int>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "int" 'x)] true) - long>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "long" 'x)] true) - float>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "float" 'x)] true) - double>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "double" 'x)] true))) - ;; TODO implement this - #_(defprotocol >boolean__Protocol - (>boolean [~'x])) - #_(extend-protocol >boolean__Protocol - java.lang.Boolean (>boolean [^java.lang.Boolean x] (.invoke >boolean|__0 x)) - java.lang.Object (>boolean [x] - (ifs (nil? x) (.invoke >boolean|__1 x) - (.invoke >boolean|__2 x))))]) - :cljs ($ [(defn ~'>boolean [~'x] - (ifs (boolean? x) x - (nil? x) false - true))])))) +(case (env-lang) + :clj ($ (do ;; [t/boolean?] + + (def ~'>boolean|__0 + (reify + boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] ~'x))) + + ;; [t/nil?] + + (def ~'>boolean|__1 + (reify + Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] false))) + + ;; [t/any?] + + (def ~'>boolean|__2 + (reify + Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] true) + boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] true) + byte>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "byte" 'x)] true) + short>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "short" 'x)] true) + char>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "char" 'x)] true) + int>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "int" 'x)] true) + long>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "long" 'x)] true) + float>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "float" 'x)] true) + double>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "double" 'x)] true))) + + #_(defn ~'>boolean + {::t/type (t/fn [t/boolean?] + [t/nil?] + [t/any?])} + ... + ))) + :cljs ($ (do (defn ~'>boolean [~'x] + (ifs (boolean? x) x + (nil? x) false + true))))) )) @@ -356,126 +369,6 @@ ;; =====|=====|=====|=====|===== ;; -(is (code= - -(macroexpand ' -(defnt >long* - {:source "clojure.lang.RT.uncheckedLongCast"} - > t/long? - ([x (t/- t/primitive? t/boolean?)] (Primitive/uncheckedLongCast x)) - ([x (t/ref (t/isa? Number))] (.longValue x)))) - -;; ----- expanded code ----- ;; - -`(do ~@(case (env-lang) - :clj ($ [(def ~'>long*|__0 ; `(t/- t/primitive? t/boolean?)` - (reify byte>long (~(tag "long" 'invoke) [~'_ ~(tag "byte" 'x)] (~'Primitive/uncheckedLongCast ~'x)) - short>long (~(tag "long" 'invoke) [~'_ ~(tag "short" 'x)] (~'Primitive/uncheckedLongCast ~'x)) - char>long (~(tag "long" 'invoke) [~'_ ~(tag "char" 'x)] (~'Primitive/uncheckedLongCast ~'x)) - int>long (~(tag "long" 'invoke) [~'_ ~(tag "int" 'x)] (~'Primitive/uncheckedLongCast ~'x)) - long>long (~(tag "long" 'invoke) [~'_ ~(tag "long" 'x)] (~'Primitive/uncheckedLongCast ~'x)) - float>long (~(tag "long" 'invoke) [~'_ ~(tag "float" 'x)] (~'Primitive/uncheckedLongCast ~'x)) - double>long (~(tag "long" 'invoke) [~'_ ~(tag "double" 'x)] (~'Primitive/uncheckedLongCast ~'x)))) - (def ~'>long*|__1 ; `Number` - (reify Object>long (~(tag "long" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "java.lang.Number" 'x) ~'x] (.longValue ~'x))))) - ;; TODO implement this - #_(defprotocol >long*__Protocol - (>long* [~'x])) - #_(extend-protocol >int*|__Protocol - java.lang.Byte (>long* [~(tag "java.lang.Byte" x)] (.invoke >long*__0 x)) - java.lang.Short (>long* [~(tag "java.lang.Short" x)] (.invoke >long*__0 x)) - java.lang.Character (>long* [~(tag "java.lang.Character" x)] (.invoke >long*__0 x)) - java.lang.Integer (>long* [~(tag "java.lang.Integer" x)] (.invoke >long*__0 x)) - java.lang.Long (>long* [~(tag "java.lang.Long" x)] (.invoke >long*__0 x)) - java.lang.Float (>long* [~(tag "java.lang.Float" x)] (.invoke >long*__0 x)) - java.lang.Double (>long* [~(tag "java.lang.Double" x)] (.invoke >long*__0 x)) - java.lang.Number (>long* [~(tag "java.lang.Object" x)] (.invoke >long*__1 x)))]))) - -)) - -;; =====|=====|=====|=====|===== ;; - -(is (code= - -(macroexpand ' -(defnt >long - {:source "clojure.lang.RT.longCast"} - > t/long? - ([x (t/isa? clojure.lang.BigInt)] - (if (nil? (.bipart x)) - (.lpart x) - (throw (Exception. "Long out of range")))) - ([x (t/isa? java.math.BigInteger)] - (if (< (.bitLength x) 64) - (.longValue x) - (throw (Exception. "Long out of range")))) - ;; TODO handle recursion - #_([x t/ratio?] (>long (.bigIntegerValue x))) - ;; TODO handle calling of other `defnt`s - #_([x (t/- t/primitive? t/boolean?)] (>long* x)) - ([x t/float?] (clojure.lang.RT/longCast x)) ; Because primitive casting in Clojure is not supported ; TODO fix - ([x t/double?] (clojure.lang.RT/longCast x)) ; TODO fix - ([x t/boolean?] (if x 1 0)) - ;; TODO handle recursion - #_([x t/string?] (-> x Long/parseLong >long)) - ([x t/string?, radix t/int?] (Long/parseLong x radix)))) - -;; ----- expanded code ----- ;; - -`(do ~@(case (env-lang) - :clj ($ [ - ]))) - -)) - -;; =====|=====|=====|=====|===== ;; - -(macroexpand ' -(defnt !str > #?(:clj (t/isa? StringBuilder) - :cljs (t/isa? StringBuffer)) - ([] #?(:clj (StringBuilder.) :cljs (StringBuffer.))) - ;; If we had combined this arity, `t/or`ing the `t/string?` means it wouldn't have been - ;; handled any differently than `t/char-seq?` -#?(:clj ([x t/string?] (StringBuilder. x))) - ([x #?(:clj (t/or t/char-seq? t/int?) - :cljs t/val?)] - #?(:clj (StringBuilder. x) :cljs (StringBuffer. x)))) -) - -;; ----- expanded code ----- ;; - -`(do (swap! fn->spec assoc #'!str - (t/fn :> #?(:clj (t/isa? StringBuilder) - :cljs (t/isa? StringBuffer)) - [] - #?(:clj [t/string?]) - [#?(:clj (t/or t/char-seq? t/int?) - :cljs t/val?)])) - - ~(case-env - :clj `(do (def !str|__0 - (reify >Object (^java.lang.Object invoke [_# ] (StringBuilder.)))) - ;; `(?* {:any-in-numeric-range? true})` - (def !str|__1__0 ; (StringBuilder. ) - (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'x] (StringBuilder. ^CharSequence x)))) - (def !str|__1__1 ; (StringBuilder. <(range-of t/int?)>) - (reify int>Object (^java.lang.Object invoke [_# ^int ~'x] (StringBuilder. x))) - ...) - (def !str|__1__2 ; (StringBuilder. ) - (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'x] (StringBuilder. ^String x)))) - - (defprotocol !str__Protocol - (!str__protocol [~'x])) - (extend-protocol !str__Protocol - ...) - (defn !str ([ ] (.invoke !str|__0)) - ([a0] (!str__protocol a0)))) - :cljs `(do (defn !str ([] (StringBuffer.)) - ([a0] (let [x a0] (StringBuffer. x))))))) - -;; =====|=====|=====|=====|===== ;; - (macroexpand ' (defnt #_:inline > ;; This is admittedly a place where inference might be nice, but luckily there are no @@ -488,11 +381,7 @@ ;; ----- expanded code ----- ;; -`(do (swap! fn->spec assoc #'> - (t/fn #?(:clj [t/comparable-primitive? t/comparable-primitive? :> t/boolean?] - :cljs [t/double? t/double? :> (t/assume t/boolean?)]))) - - ~(case-env +`(do ~(case-env :clj `(do (def >|__0 (reify byte+byte>boolean (^boolean invoke [_# ^byte a ^byte b] (Numeric/gt a b)) byte+char>boolean (^boolean invoke [_# ^byte a ^char b] (Numeric/gt a b)) @@ -544,17 +433,353 @@ double+float>boolean (^boolean invoke [_# ^double a ^float b] (Numeric/gt a b)) double+double>boolean (^boolean invoke [_# ^double a ^double b] (Numeric/gt a b)))) - (defprotocol >__Protocol - (> [~'a0 ~'a1])) - (extend-protocol >__Protocol - ...)) + (defn > + {::t/type + (t/fn #?(:clj [t/comparable-primitive? t/comparable-primitive? + :> t/boolean?] + :cljs [t/double? t/double? + :> (t/assume t/boolean?)]))} + ([a0 a1] + (ifs (t/byte? a0) + (ifs (t/byte? a1) (.invoke ^byte+byte>boolean >|__0 a0 a1) + (t/char? a1) (.invoke ...) + ...) + (t/char? a0) + (ifs (t/byte? a1) (.invoke ^char+byte>boolean >|__0 a0 a1) + ...) + ... + (unsupported! `> [a0 a1] 0))))) :cljs `(do (defn > ([a0 a1] (ifs (double? a0) (ifs (double? a1) - (let [a a0 b a1] (cljs.core/> a b)) - (unsupported! `> [a0 a1])) - (unsupported! `> [a0 a1]))))))) + (let* [a a0 b a1] (cljs.core/> a b)) + (unsupported! `> [a0 a1] 1)) + (unsupported! `> [a0 a1] 0))))))) + +;; =====|=====|=====|=====|===== ;; + +(is (code= + +(macroexpand ' +(defnt #_:inline >long* + {:source "clojure.lang.RT.uncheckedLongCast"} + > t/long? + ([x (t/- t/primitive? t/boolean?)] (Primitive/uncheckedLongCast x)) + ([x (t/ref (t/isa? Number))] (.longValue x)))) + +;; ----- expanded code ----- ;; + +(case (env-lang) + :clj ($ (do ;; [(t/- t/primitive? t/boolean?)] + + (def ~'>long*|__0|input-types (*<> t/byte?)) + (def ~'>long*|__0 + (reify byte>long (~(tag "long" 'invoke) [_## ~(tag "byte" 'x)] + ~'(Primitive/uncheckedLongCast x)))) + + (def ~'>long*|__1|input-types (*<> t/char?)) + (def ~'>long*|__1 + (reify char>long (~(tag "long" 'invoke) [_## ~(tag "char" 'x)] + ~'(Primitive/uncheckedLongCast x)))) + + (def ~'>long*|__2|input-types (*<> t/short?)) + (def ~'>long*|__2 + (reify short>long (~(tag "long" 'invoke) [_## ~(tag "short" 'x)] + ~'(Primitive/uncheckedLongCast x)))) + + (def ~'>long*|__3|input-types (*<> t/int?)) + (def ~'>long*|__3 + (reify int>long (~(tag "long" 'invoke) [_## ~(tag "int" 'x)] + ~'(Primitive/uncheckedLongCast x)))) + + (def ~'>long*|__4|input-types (*<> t/long?)) + (def ~'>long*|__4 + (reify long>long (~(tag "long" 'invoke) [_## ~(tag "long" 'x)] + ~'(Primitive/uncheckedLongCast x)))) + + (def ~'>long*|__5|input-types (*<> t/float?)) + (def ~'>long*|__5 + (reify float>long (~(tag "long" 'invoke) [_## ~(tag "float" 'x)] + ~'(Primitive/uncheckedLongCast x)))) + + (def ~'>long*|__6|input-types (*<> t/double?)) + (def ~'>long*|__6 + (reify double>long (~(tag "long" 'invoke) [_## ~(tag "double" 'x)] + ~'(Primitive/uncheckedLongCast x)))) + + ;; [(t/ref (t/isa? Number))] + + (def ~'>long*|__7|input-types (*<> (t/isa? Number))) + (def ~'>long*|__7 + (reify Object>long (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] + (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(.longValue x))))) + + (defn >long* + {::t/type (t/fn [(t/- t/primitive? t/boolean?)] + [(t/ref (t/isa? Number))])} + [a0##] (ifs ((Array/get >long*|__0|input-types 0) a0##) + (.invoke >long*|__0 a0##) + ...)) + + ))) + +)) + +;; =====|=====|=====|=====|===== ;; + +(is (code= + +(macroexpand ' +(defnt >long + {:source "clojure.lang.RT.longCast"} + > t/long? + ([x (t/- t/primitive? t/boolean? t/float? t/double?)] (>long* x)) + ([x (t/and (t/or t/double? t/float?) + (fnt [x (t/or double? float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] + (>long* x)) + ([x (t/and (t/isa? clojure.lang.BigInt) + (fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] + (.lpart x)) + ([x (t/and (t/isa? java.math.BigInteger) + (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] + (.longValue x)) + ([x t/ratio?] (>long (.bigIntegerValue x))) + ([x (t/value true)] 1) + ([x (t/value false)] 0) + ([x t/string?] (Long/parseLong x)) + ([x t/string?, radix t/int?] (Long/parseLong x radix)))) + +;; ----- expanded code ----- ;; + +(case (env-lang) + :clj ($ (do + + + #_[(t/- t/primitive? t/boolean? t/float? t/double?)] + + (def ~'>long|__0|input-types (*<> t/byte?)) + (def ~'>long|__0 + (reify byte>long + (~(tag "long" 'invoke) [_## ~(tag "byte" 'x)] + ;; Resolved from `(>long* x)` + (.invoke >long*|__0 ~'x)))) + + (def ~'>long|__1|input-types (*<> t/char?)) + (def ~'>long|__1 + (reify char>long + (~(tag "long" 'invoke) [_## ~(tag "char" 'x)] + ;; Resolved from `(>long* x)` + (.invoke >long*|__1 ~'x)))) + + (def ~'>long|__2|input-types (*<> t/short?)) + (def ~'>long|__2 + (reify short>long + (~(tag "long" 'invoke) [_## ~(tag "short" 'x)] + ;; Resolved from `(>long* x)` + (.invoke >long*|__2 ~'x)))) + + (def ~'>long|__3|input-types (*<> t/int?)) + (def ~'>long|__3 + (reify int>long + (~(tag "long" 'invoke) [_## ~(tag "int" 'x)] + ;; Resolved from `(>long* x)` + (.invoke >long*|__3 ~'x)))) + + (def ~'>long|__4|input-types (*<> t/long?)) + (def ~'>long|__4 + (reify long>long + (~(tag "long" 'invoke) [_## ~(tag "long" 'x)] + ;; Resolved from `(>long* x)` + (.invoke >long*|__4 ~'x)))) + + #_[(t/and (t/or t/double? t/float?) + (fnt [x (t/or double? float?)] + (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] + + (def ~'>long|__5|input-types + (*<> (t/and t/double? + (fnt [x (t/or double? float?)] + (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE)))))) + (def ~'>long|__5 + (reify double>long + (~(tag "long" 'invoke) [_## ~(tag "double" 'x)] + ;; Resolved from `(>long* x)` + (.invoke >long*|__6 ~'x)))) + + (def ~'>long|__6|input-types + (*<> (t/and t/float? + (fnt [x (t/or double? float?)] + (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE)))))) + (def ~'>long|__6 + (reify float>long + (~(tag "long" 'invoke) [_## ~(tag "float" 'x)] + ;; Resolved from `(>long* x)` + (.invoke >long*|__5 ~'x)))) + + #_[(t/and (t/isa? clojure.lang.BigInt) + (fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] + + (def ~'>long|__7|input-types + (*<> (t/and (t/isa? clojure.lang.BigInt) + (fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x)))))) + (def ~'>long|__7 + (reify Object>long + (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] + (let* [~(tag "clojure.lang.BigInt" 'x) ~'x] ~'(.lpart x))))) + + #_[(t/and (t/isa? java.math.BigInteger) + (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] + + + (def ~'>long|__8|input-types + (*<> (t/and (t/isa? java.math.BigInteger) + (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64))))) + (def ~'>long|__8 + (reify Object>long + (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] + (let* [~(tag "java.math.BigInteger" 'x) ~'x] ~'(.longValue x))))) + + #_[t/ratio?] + + (def ~'>long|__9|input-types + (*<> t/ratio?)) + (def ~'>long|__9|conditions + (*<> (-> long|__8|input-types (get 0) utr/and-type>args (get 1)))) + (def ~'>long|__9 + (reify Object>long + (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] + (let* [~(tag "clojure.lang.Ratio" 'x) ~'x] + ;; Resolved from `(>long (.bigIntegerValue x))` + ;; In this case, `(t/compare (type-of '(.bigIntegerValue x)) overload-type)`: + ;; - `(t/- t/primitive? t/boolean? t/float? t/double?)` -> t/<> + ;; - `(t/and (t/or t/double? t/float?) ...)` -> t/<> + ;; - `(t/and (t/isa? clojure.lang.BigInt) ...)` -> t/<> + ;; - `(t/and (t/isa? java.math.BigInteger) ...)` -> t/> + ;; - `t/ratio?` -> t/<> + ;; - `(t/value true)` -> t/<> + ;; - `(t/value false)` -> t/<> + ;; - `t/string?` -> t/<> + ;; + ;; Since there is no overload that results in t/<, no compile-time match can + ;; be found, but a possible runtime match lies in the overload that results in + ;; t/>. The remaining uncertainty will have to be resolved at compile time. + ;; Note that if there had been multiple overloads with t/>, we would have had + ;; to dispatch on that and resolve accordingly. + (let [x## ~'(.bigIntegerValue x)] + (if ((Array/get >long|__9|conditions 0) x##) + (.invoke >long|__8 x##) + (unsupported! `>long x##))))))) + + #_[(t/value true)] + + (def ~'>long|__10|input-types + (*<> (t/value true))) + (def ~'>long|__10 + (reify boolean>long + (~(tag "long" 'invoke) [_## ~(tag "boolean" 'x)] 1))) + + #_[(t/value false)] + + (def ~'>long|__11|input-types + (*<> (t/value false))) + (def ~'>long|__11 + (reify boolean>long + (~(tag "long" 'invoke) [_## ~(tag "boolean" 'x)] 0))) + + #_[t/string?] + + (def ~'>long|__12|input-types + (*<> t/string?)) + (def ~'>long|__12 + (reify Object>long + (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] + ~'(Long/parseLong x)))) + + #_[t/string?] + + (def ~'>long|__13|input-types + (*<> t/string? t/int?)) + (def ~'>long|__13 + (reify Object+int>long + (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x) ~(tag "int" 'radix)] + ~'(Long/parseLong x radix)))) + + (defn >long + {::t/type + (t/fn + [(t/- t/primitive? t/boolean? t/float? t/double?)] + [(t/and (t/or t/double? t/float?) + (fnt [x (t/or double? float?)] + (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] + [(t/and (t/isa? clojure.lang.BigInt) + (fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] + [(t/and (t/isa? java.math.BigInteger) + (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] + [t/ratio?] + [(t/value true)] + [(t/value false)] + [t/string?] + [t/string? t/int?])} + ([x0##] (ifs ((Array/get >long|__0|input-types 0) x0##) + (.invoke >long|__0 x0##) + ((Array/get >long|__1|input-types 0) x0##) + (.invoke >long|__0 x0##) + ((Array/get >long|__2|input-types 0) x0##) + (.invoke >long|__2 x0##))) + ([x0## x1##] ...))))) + +)) + +;; =====|=====|=====|=====|===== ;; + +(macroexpand ' +(defnt !str > #?(:clj (t/isa? StringBuilder) + :cljs (t/isa? StringBuffer)) + ([] #?(:clj (StringBuilder.) :cljs (StringBuffer.))) + ;; If we had combined this arity, `t/or`ing the `t/string?` means it wouldn't have been + ;; handled any differently than `t/char-seq?` +#?(:clj ([x t/string?] (StringBuilder. x))) + ([x #?(:clj (t/or t/char-seq? t/int?) + :cljs t/val?)] + #?(:clj (StringBuilder. x) :cljs (StringBuffer. x)))) +) + +;; ----- expanded code ----- ;; + +`(do (swap! fn->spec assoc #'!str + (t/fn :> #?(:clj (t/isa? StringBuilder) + :cljs (t/isa? StringBuffer)) + [] + #?(:clj [t/string?]) + [#?(:clj (t/or t/char-seq? t/int?) + :cljs t/val?)])) + + ~(case-env + :clj `(do (def ^>Object !str|__0 + (reify >Object + (^java.lang.Object invoke [_#] + (StringBuilder.)))) + ;; `t/string?` + (def ^Object>Object !str|__1 ; `t/string?` + (reify Object>Object + (^java.lang.Object invoke [_# ^java.lang.Object ~'x] + (let* [^String x x] (StringBuilder. x))))) + ;; `(t/or t/char-seq? t/int?)` + (def ^Object>Object !str|__2 ; `t/char-seq?` + (reify Object>Object + (^java.lang.Object invoke [_# ^java.lang.Object ~'x] + (let* [^CharSequence x x] (StringBuilder. x))))) + (def ^int>Object !str|__3 ; `t/int?` + (reify int>Object (^java.lang.Object invoke [_# ^int ~'x] + (StringBuilder. x)))) + + (defn !str ([ ] (.invoke !str|__0)) + ([a0] (ifs (t/string? a0) (.invoke !str|__1 a0) + (t/char-seq? a0) (.invoke !str|__2 a0) + (t/int? a0) (.invoke !str|__3 a0))))) + :cljs `(do (defn !str ([] (StringBuffer.)) + ([a0] (let* [x a0] (StringBuffer. x))))))) ;; =====|=====|=====|=====|===== ;; @@ -571,7 +796,7 @@ ;; least pre-variadic args, if not variadic ;; TODO should have automatic currying? ([x (t/fn> str t/any?) & xs (? (t/seq-of t/any?)) #?@(:cljs [> (t/assume t/string?)])] - (let [sb (-> x str !str)] ; determined to be StringBuilder + (let* [sb (-> x str !str)] ; determined to be StringBuilder ;; TODO is `doseq` the right approach, or using reduction? (doseq [x' xs] (.append sb (str x'))) (.toString sb)))) @@ -579,15 +804,7 @@ ;; ----- expanded code ----- ;; -`(do (swap! fn->spec assoc #'str - (t/fn > t/string? - [] - [t/nil?] -#?(:clj [(t/isa? Object)]) -#?(:cljs [t/any? :> (t/assume t/string?)]) - [(t/fn> str t/any?) :& (? (t/seq-of t/any?)) #?@(:cljs [:> (t/assume t/string?)])])) - - ~(case-env +`(do ~(case-env :clj `(do (def str|__0 (reify >Object (^java.lang.Object invoke [_# ] ""))) (def str|__1 ; `nil?` @@ -595,22 +812,27 @@ (def str|__2 ; `Object` (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'x] (.toString x)))) - ;; No protocol needed because overloads of protocolizable arity (n>=1, not variadic) do not vary by class (defn str + {::t/type + (t/fn :> t/string? + [] + [t/nil?] + #?(:clj [(t/isa? Object)]) + #?(:cljs [t/any? :> (t/assume t/string?)]) + [(t/fn> str t/any?) :& (? (t/seq-of t/any?)) #?@(:cljs [:> (t/assume t/string?)])])} ([ ] (.invoke !str|__0)) ([a0] (ifs (nil? x) (.invoke !str|__1) (.invoke !str|__2 a0))) ([x & xs] - (let [sb (!str (str x))] + (let* [sb (!str (str x))] (doseq [x' xs] (.append sb (str x'))) ; TODO is `doseq` the right approach? (.toString sb))))) - :cljs `(do ;; No protocol needed because overloads of protocolizable arity (n>=1, not variadic) do not vary by class - (defn str + :cljs `(do (defn str ([ ] "") ([a0] (ifs (nil? x) "" (.join #js [x] ""))) ([x & xs] - (let [sb (!str (str x))] + (let* [sb (!str (str x))] (doseq [x' xs] (.append sb (str x'))) ; TODO is `doseq` the right approach? (.toString sb))))))) @@ -635,9 +857,7 @@ ~(case-env :clj `(do ;; `array?` (def count|__0__1 (reify Object>int (^int invoke [_# ^java.lang.Object ~'xs] (Array/count ^"[B" xs)))) - ... - - (defprotocol count__Protocol ...)) + ...) :cljs `(do ...))) ;; =====|=====|=====|=====|===== ;; @@ -666,74 +886,89 @@ (defnt seq "Taken from `clojure.lang.RT/seq`" > (t/? (t/isa? ISeq)) - ([xs t/nil? ] nil) - ([xs t/array? ] (ArraySeq/createFromObject xs)) - ([xs (t/isa? ASeq) ] xs) - ([xs (t/or (t/isa? LazySeq) (t/isa? Seqable))] (.seq xs)) - ([xs t/iterable? ] (clojure.lang.RT/chunkIteratorSeq (.iterator xs))) - ([xs t/char-seq? ] (StringSeq/create xs)) - ([xs t/java-map? ] (seq (.entrySet xs))))) + ([xs t/nil? ] nil) + ([xs t/array? ] (ArraySeq/createFromObject xs)) + ([xs (t/isa? ASeq) ] xs) + ([xs (t/or (t/isa? LazySeq) + (t/isa? Seqable))] (.seq xs)) + ([xs t/iterable? ] (clojure.lang.RT/chunkIteratorSeq (.iterator xs))) + ([xs t/char-seq? ] (StringSeq/create xs)) + ([xs (t/isa? Map) ] (seq (.entrySet xs))))) ) ;; ----- expanded code ----- ;; #?(:clj -`(do (assoc-meta! #'seq :type - (t/fn > (t/? (t/isa? ISeq)) - [t/nil?] - [t/array?] - [(t/isa? ASeq)] - [(t/or (t/isa? LazySeq) (t/isa? Seqable))] - [t/iterable?] - [t/char-seq?] - [t/java-map?])) - - ;; Each of these `(def ... (reify ...))`s will keep their label (`__2__0` or whatever) as long - ;; as the original type of the `reify` is `t/=` to the new type of that reify - ;; If a redefined `defnt` doesn't have that spec then the previous reify is uninterned and made - ;; unavailable - ;; That way, according to the dynamicity tests in `quantum.test.core.defnt`, we can redefine - ;; implementations at will as long as the specs don't change - ~(case-env +`(do ~(case-env :clj - `(do ;; `nil?` - (def ^Object>Object seq|__0__0 + `(do ;; [t/nil?] + + (def seq|__0|input-types (*<> t/nil?)) + (def ^Object>Object seq|__0 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] + ;; Notice, no casting for nil input nil))) - ;; `array?` - (def ^Object>Object seq|__1__0 + + ;; [t/array?] + + ;; TODO perhaps at some point figure out that it doesn't need to create any more + ;; overloads here than just one? + (def seq|__1|input-types (*<> (t/isa? (Class/forName "[Z")))) + (def ^Object>Object seq|__1 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] - (ArraySeq/createFromObject xs)))) + (let* [^"[Z" xs xs] (ArraySeq/createFromObject xs))))) + + (def seq|__2|input-types (*<> (t/isa? (Class/forName "[B")))) + (def ^Object>Object seq|__2 + (reify Object>Object + (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] + (let* [^"[B" xs xs] (ArraySeq/createFromObject xs))))) ... - ;; `(t/isa? ASeq)` - (def ^Object>Object seq|__2__0 + + ;; [(t/isa? ASeq)] + + (def seq|__30|input-types (*<> (t/isa? ASeq))) + (def ^Object>Object seq|__30 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] - (let [^ASeq xs xs] xs)))) - ;; `(t/or (t/isa? LazySeq) (t/isa? Seqable))` : `(t/isa? LazySeq)` - (def ^Object>Object seq|__3__0 + (let* [^ASeq xs xs] xs)))) + + ;; [(t/or (t/isa? LazySeq) (t/isa? Seqable))] + + (def seq|__31|input-types (*<> (t/isa? LazySeq))) + (def ^Object>Object seq|__31 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] - (let [^LazySeq xs xs] (.seq xs))))) - ;; `(t/or (t/isa? LazySeq) (t/isa? Seqable))` : `(t/isa? Seqable)` - (def ^Object>Object seq|__3__1 + (let* [^LazySeq xs xs] (.seq xs))))) + + (def seq|__32|input-types (*<> (t/isa? Seqable))) + (def ^Object>Object seq|__32 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] - (let [^Seqable xs xs] (.seq xs))))) - ;; `t/iterable?` - (def ^Object>Object seq|__4__0 + (let* [^Seqable xs xs] (.seq xs))))) + + ;; [t/iterable?] + + (def seq|__33|input-types (*<> t/iterable?)) + (def ^Object>Object seq|__33 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] - (let [^Iterable xs xs] (clojure.lang.RT/chunkIteratorSeq (.iterator xs)))))) - ;; `t/char-seq?` - (def ^Object>Object seq|__5__0 + (let* [^Iterable xs xs] (clojure.lang.RT/chunkIteratorSeq (.iterator xs)))))) + + ;; [t/char-seq?] + + (def seq|__34|input-types (*<> t/iterable?)) + (def ^Object>Object seq|__34 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] - (let [^CharSequence xs xs] (StringSeq/create xs))))) - ;; `t/java-map?` - (def ^Object>Object seq|__6 + (let* [^CharSequence xs xs] (StringSeq/create xs))))) + + ;; [(t/isa? Map)] + + (def seq|__35|input-types (*<> (t/isa? Map))) + (def ^Object>Object seq|__35 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] ;; This is after expansion; it's the first one that matches the overload @@ -741,23 +976,29 @@ ;; equivalent) and potentially a configurable warning can be emitted (let [^Map xs xs] (.invoke seq|__4__0 (.entrySet xs)))))) - (defprotocol seq__Protocol - (seq [a0])) - (extend-protocol seq__Protocol - ;; `array?` - ... - ASeq (seq [^ASeq a0] (.invoke seq|__2 a0)) - LazySeq (seq [^LazySeq a0] (.invoke seq|__3__0 a0)) - Object (seq [a0] - ;; these are sequential dispatch because none of these are concrete or abstract classes - ;; (most are interfaces etc.) - (ifs (nil? a0) (.invoke seq|__0 a0) - (instance? ASeq a0) (.invoke seq|__2 a0) - (instance? Seqable a0) (.invoke seq|__3__1 a0) - (instance? Iterable a0) (.invoke seq|__4 a0) - (instance? CharSequence a0) (.invoke seq|__5 a0) - (instance? Map a0) (.invoke seq|__6 a0) - (unsupported! `seq a0))))) + (defn seq + "Taken from `clojure.lang.RT/seq`" + {::t/type + (t/fn > (t/? (t/isa? ISeq)) + [t/nil?] + [t/array?] + [(t/isa? ASeq)] + [(t/or (t/isa? LazySeq) (t/isa? Seqable))] + [t/iterable?] + [t/char-seq?] + [(t/isa? Map)])} + [a0] + (ifs ((Array/get seq|__0|input-types 0) a0) (.invoke seq|__0 a0) + ((Array/get seq|__1|input-types 0) a0) (.invoke seq|__1 a0) + ... + ((Array/get seq|__30|input-types 0) a0) (.invoke seq|__30 a0) + ((Array/get seq|__31|input-types 0) a0) (.invoke seq|__31 a0) + ((Array/get seq|__32|input-types 0) a0) (.invoke seq|__32 a0) + ((Array/get seq|__33|input-types 0) a0) (.invoke seq|__33 a0) + ((Array/get seq|__34|input-types 0) a0) (.invoke seq|__34 a0) + ((Array/get seq|__35|input-types 0) a0) (.invoke seq|__35 a0) + (unsupported! `seq [a0] 0))) + )) :cljs `(do ...)))) @@ -995,10 +1236,10 @@ ; (optional) function — only when the `defnt` has an arity with 0 arguments ; (optional) inline macros — invoked only if in a typed context and not used as a function -(do #?(:clj (defmacro clj:name:java:lang:String [a0] `(let [~'x ~a0] ~'x))) - #?(:clj (defmacro cljs:name:string [a0] `(let [~'x ~a0] ~'x))) - #?(:clj (defmacro clj:name:clojure:lang:Named [a0] `(let [~'x ~a0] ~'(-name x)))) - #?(:clj (defmacro cljs:name:cljs:core:INamed [a0] `(let [~'x ~a0] ~'(.getName x))))) +(do #?(:clj (defmacro clj:name:java:lang:String [a0] `(let* [~'x ~a0] ~'x))) + #?(:clj (defmacro cljs:name:string [a0] `(let* [~'x ~a0] ~'x))) + #?(:clj (defmacro clj:name:clojure:lang:Named [a0] `(let* [~'x ~a0] ~'(-name x)))) + #?(:clj (defmacro cljs:name:cljs:core:INamed [a0] `(let* [~'x ~a0] ~'(.getName x))))) ) ; ================================================ ; From 1fadeeb59460a651cc2e8fb0fc75b6708a8d4da5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 17 May 2018 00:49:49 -0600 Subject: [PATCH 053/810] Add `uarr/*<>` --- .../quantum/untyped/core/data/array.cljc | 33 +++++++++++++++++++ 1 file changed, 33 insertions(+) create mode 100644 src-untyped/quantum/untyped/core/data/array.cljc diff --git a/src-untyped/quantum/untyped/core/data/array.cljc b/src-untyped/quantum/untyped/core/data/array.cljc new file mode 100644 index 00000000..e4ca4533 --- /dev/null +++ b/src-untyped/quantum/untyped/core/data/array.cljc @@ -0,0 +1,33 @@ +(ns quantum.untyped.core.data.array + (:refer-clojure :exclude + [array]) + (:require + [clojure.core :as core]) + #?(:clj (:import + [quantum.core.data Array]))) + +(defn ^"[Ljava.lang.Object;" *<> + ([] #?(:clj (Array/newUninitialized1dObjectArray 0) + :cljs #js [])) + ([a0] #?(:clj (Array/new1dObjectArray a0) + :cljs #js [a0])) + ([a0 a1] #?(:clj (Array/new1dObjectArray a0 a1) + :cljs #js [a0 a1])) + ([a0 a1 a2] #?(:clj (Array/new1dObjectArray a0 a1 a2) + :cljs #js [a0 a1 a2])) + ([a0 a1 a2 a3] #?(:clj (Array/new1dObjectArray a0 a1 a2 a3) + :cljs #js [a0 a1 a2 a3])) + ([a0 a1 a2 a3 a4] #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4) + :cljs #js [a0 a1 a2 a3 a4])) + ([a0 a1 a2 a3 a4 a5] #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5) + :cljs #js [a0 a1 a2 a3 a4 a5])) + ([a0 a1 a2 a3 a4 a5 a6] #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6) + :cljs #js [a0 a1 a2 a3 a4 a5 a6])) + ([a0 a1 a2 a3 a4 a5 a6 a7] #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6 a7) + :cljs #js [a0 a1 a2 a3 a4 a5 a6 a7])) + ([a0 a1 a2 a3 a4 a5 a6 a7 a8] #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6 a7 a8) + :cljs #js [a0 a1 a2 a3 a4 a5 a6 a7 a8])) + ([a0 a1 a2 a3 a4 a5 a6 a7 a8 a9] #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6 a7 a8 a9) + :cljs #js [a0 a1 a2 a3 a4 a5 a6 a7 a8 a9])) + ([a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10] #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) + :cljs #js [a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10]))) From 80e7756fae4228793bb5b04001790fbfb90747ed Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 17 May 2018 00:49:56 -0600 Subject: [PATCH 054/810] Add hashing fns --- .../quantum/untyped/core/data/hash.cljc | 58 +++++++++++++++++++ 1 file changed, 58 insertions(+) create mode 100644 src-untyped/quantum/untyped/core/data/hash.cljc diff --git a/src-untyped/quantum/untyped/core/data/hash.cljc b/src-untyped/quantum/untyped/core/data/hash.cljc new file mode 100644 index 00000000..7b70c5ec --- /dev/null +++ b/src-untyped/quantum/untyped/core/data/hash.cljc @@ -0,0 +1,58 @@ +(ns quantum.untyped.core.data.hash + (:refer-clojure :exclude + [hash]) + (:require + [clojure.core :as core])) + +(def hash core/hash) + +(defn code [x] + #?(:clj (clojure.lang.Util/hash x) + :cljs (hash x))) + +(def unordered hash-ordered-coll) +(def ordered hash-unordered-coll) +(def mix mix-collection-hash) + +#?(:clj +(defmacro caching-set-unordered! + "Tries to retrive an cached unordered hash value at the provided field. If not found, sets the + field with an unordered hash value computed using the provided args. + + See also https://clojure.org/reference/data_structures." + [field #_simple-symbol? & args] + `(if (identical? ~field -1) + (set! ~field + (-> 0 ~@(->> args (map (fn [arg] `(unchecked-add-int (hash ~arg))))) + (mix-collection-hash ~(count args)) + int)) + ~field))) + +#?(:clj +(defmacro caching-set-ordered! + "Tries to retrive an cached ordered hash value at the provided field. If not found, sets the + field with an ordered hash value computed using the provided args. + + See also https://clojure.org/reference/data_structures." + [field #_simple-symbol? & args] + `(if (identical? ~field -1) + (set! ~field + (-> 1 ~@(->> args (map (fn [arg] + `(-> (unchecked-multiply-int 31) + (unchecked-add-int (hash ~arg)))))) + (mix-collection-hash ~(count args)) + int)) + ~field))) + +(defn hash-unordered [collection] + (-> (reduce unchecked-add-int 0 (map hash collection)) + (mix-collection-hash (count collection)))) + +#?(:clj +(defmacro caching-set-code! + "Tries to retrive a cached hash-code value at the provided field. If not found, sets the field + with a computed hash-code using the sum of the hash-codes of the provided args." + [field #_simple-symbol? & args] + `(if (identical? ~field -1) + (set! ~field (-> 0 ~@(->> args (map (fn [arg] `(unchecked-add-int (code ~arg))))))) + ~field))) From f54ab79423f877f3e1d1d987b57606db9ea02655 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 17 May 2018 00:50:17 -0600 Subject: [PATCH 055/810] ## Gensyms can have underscores; better naming --- src-untyped/quantum/untyped/core/form.cljc | 2 +- src-untyped/quantum/untyped/core/form/generate.cljc | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index 55215baf..33e1ba37 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -50,5 +50,5 @@ "Reproducibly, unifiedly syntax quote without messing up the format as a literal syntax quote might do." [body] - `(binding [ufgen/*reproducible-gensym* (ufgen/reproducible-gensym|generator)] + `(binding [ufgen/*reproducible-gensym* (ufgen/>reproducible-gensym|generator)] (ufgen/unify-gensyms (syntax-quote ~body) true)))) diff --git a/src-untyped/quantum/untyped/core/form/generate.cljc b/src-untyped/quantum/untyped/core/form/generate.cljc index 44fc145e..0524fa49 100644 --- a/src-untyped/quantum/untyped/core/form/generate.cljc +++ b/src-untyped/quantum/untyped/core/form/generate.cljc @@ -60,9 +60,9 @@ ;; ===== Gensym unification ===== ;; ;; Adapted from Potemkin for use with both CLJ and CLJS -(def unified-gensym-regex #"([a-zA-Z0-9\-\'\*]+)#__\d+__auto__$") +(def unified-gensym-regex #"([a-zA-Z0-9\-\_\'\*]+)#__\d+__auto__$") -(def gensym-regex #"(_|[a-zA-Z0-9\-\'\*]+)#?_+(\d+_*#?)+(auto__)?$") +(def gensym-regex #"(_|[a-zA-Z0-9\-\_\'\*]+)#?_+(\d+_*#?)+(auto__)?$") (defn unified-gensym? {:attribution 'potemkin.macros} @@ -83,7 +83,7 @@ (def ^:dynamic *reproducible-gensym* nil) -(defn reproducible-gensym|generator [] +(defn >reproducible-gensym|generator [] (let [*counter (atom -1)] (memoize #(symbol (str % (swap! *counter inc)))))) @@ -96,7 +96,7 @@ ([body reproducible-gensyms?] (let [gensym* (or *reproducible-gensym* (memoize (if reproducible-gensyms? - (reproducible-gensym|generator) + (>reproducible-gensym|generator) gensym)))] (ucore/postwalk #(if (unified-gensym? %) From 155c10dcf307911c8e012b9f5a41e79f4f8b10b5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 17 May 2018 00:50:34 -0600 Subject: [PATCH 056/810] Prettier printing, untyped --- .../quantum/untyped/core/print/prettier.cljc | 174 +++++++++++++++++ src/quantum/core/print/prettier.cljc | 175 +----------------- 2 files changed, 178 insertions(+), 171 deletions(-) create mode 100644 src-untyped/quantum/untyped/core/print/prettier.cljc diff --git a/src-untyped/quantum/untyped/core/print/prettier.cljc b/src-untyped/quantum/untyped/core/print/prettier.cljc new file mode 100644 index 00000000..56359e8c --- /dev/null +++ b/src-untyped/quantum/untyped/core/print/prettier.cljc @@ -0,0 +1,174 @@ +(ns quantum.untyped.core.print.prettier + (:require + [fipp.edn] + [fipp.visit] + [fipp.ednize] + [quantum.untyped.core.convert :as uconv] + [quantum.untyped.core.fn :as fn + :refer [rcomp]] + [quantum.untyped.core.ns :as ns] + [quantum.untyped.core.print :as pr] + [quantum.untyped.core.qualify :as qual] + [quantum.untyped.core.vars :as var])) + +#?(:clj +(defmethod print-method fipp.ednize.IEdn [^fipp.ednize.IEdn v ^java.io.Writer w] + (print-method (._edn v) w))) + +#?(:clj (prefer-method print-method fipp.ednize.IEdn clojure.lang.IRecord)) +#?(:clj (prefer-method print-method fipp.ednize.IEdn clojure.lang.IPersistentMap)) +#?(:clj (prefer-method print-method fipp.ednize.IEdn java.util.Map)) +#?(:clj (prefer-method print-method fipp.ednize.IEdn clojure.lang.ISeq)) +#?(:clj (prefer-method print-method clojure.lang.IRecord Throwable)) + +(in-ns 'fipp.visit) + +(defn- transient-vector? [x] + (instance? #?(:clj clojure.lang.ITransientVector + :cljs cljs.core/TransientVector) x)) + +;; TODO more efficient +;; TODO move? +#?(:clj +(deftype IntIndexedIterator + [^long ^:unsynchronized-mutable i ^long ct ^clojure.lang.Indexed xs] + java.util.Iterator + (hasNext [this] (< i ct)) + (next [this] + (if (< i ct) + (let [i-prev i] + (set! i (unchecked-inc i)) + (.nth xs i-prev)) + (throw (java.util.NoSuchElementException.)))) + (remove [this] (throw (UnsupportedOperationException.))))) + +#?(:clj +(deftype IntIndexedIterable [^clojure.lang.Indexed xs] + Iterable + (iterator [this] (IntIndexedIterator. 0 (count xs) xs)))) + +(defn visit-symbol* [x] + [:text (cond-> x + quantum.core.print/*collapse-symbols?* + (quantum.untyped.core.qualify/collapse-symbol (not quantum.core.print/*print-as-code?*)))]) + +(defn visit-fn [visitor x] + [:group "#" "fn" " " (-> x quantum.untyped.core.convert/>symbol visit-symbol*)]) + +(defn visit* + "Visits objects, ignoring metadata." + [visitor x] + (cond + (nil? x) (visit-nil visitor) + (quantum.core.print/group? x) + (fipp.edn/pretty-coll visitor "" (.-xs ^quantum.untyped.core.print.Group x) :line "" visit) + (fipp.ednize/override? x) (visit-unknown visitor x) + (boolean? x) (visit-boolean visitor x) + (string? x) (visit-string visitor x) + (char? x) (visit-character visitor x) + (symbol? x) (visit-symbol* x) + (keyword? x) (visit-keyword visitor x) + (number? x) (visit-number visitor x) + (seq? x) (visit-seq visitor x) + (vector? x) (visit-vector visitor x) + (record? x) (visit-record visitor x) + (map? x) (visit-map visitor x) + (set? x) (visit-set visitor x) + (tagged-literal? x) (visit-tagged visitor x) + (var? x) (visit-var visitor x) + (regexp? x) (visit-pattern visitor x) + (fn? x) (visit-fn visitor x) + (transient-vector? x) + [:group "#" (pr-str '!+) + (when (and (:print-meta visitor) (meta (:form visitor))) " ") + (visit-vector visitor (IntIndexedIterable. x))] + :else (visit-unknown visitor x))) + +(defn visit [visitor x] + (let [m (meta x)] + (if (and m (not (var? x))) + (visit-meta visitor m x) + (visit* visitor x)))) + +(in-ns 'quantum.untyped.core.print.prettier) + +(defn extend-pretty-printing! [] + (extend-type java.util.ArrayList + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal '! (vec this)))) ; TODO faster + (extend-type it.unimi.dsi.fastutil.longs.LongArrayList + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal '!l (vec this)))) ; TODO faster + + (extend-type (Class/forName "[Z") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal '?<> (vec this)))) ; TODO faster + (extend-type (Class/forName "[B") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'b<> (vec this)))) ; TODO faster + (extend-type (Class/forName "[C") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'c<> (vec this)))) ; TODO faster + (extend-type (Class/forName "[[C") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'c<><> (into [] this)))) ; TODO faster + (extend-type (Class/forName "[S") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 's<> (vec this)))) ; TODO faster + (extend-type (Class/forName "[I") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'i<> (vec this)))) ; TODO faster + (extend-type (Class/forName "[J") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'l<> (vec this)))) ; TODO ->vec for this + (extend-type (Class/forName "[F") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'f<> (vec this)))) ; TODO faster + (extend-type (Class/forName "[D") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'd<> (vec this)))) ; TODO ->vec for this + (extend-type (Class/forName "[[D") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'd<><> (into [] this)))) ; TODO faster + (extend-type (Class/forName "[Ljava.lang.Object;") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal '*<> (vec this)))) ; TODO faster + (extend-type (Class/forName "[[Ljava.lang.Object;") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal '*<><> (into [] this)))) ; TODO faster + (extend-type (Class/forName "[Ljava.lang.Class;") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'class<> (vec this)))) ; TODO faster + + (extend-type java.util.HashMap + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal '! (into {} this)))) + (extend-type java.util.concurrent.ConcurrentHashMap + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal '!! (into {} this)))) ; TODO ->map + (extend-type quantum.core.error.Error + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'err (into {} this)))) + (extend-type (Class/forName "[Ljava.lang.StackTraceElement;") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (mapv (rcomp StackTraceElement->vec str symbol) this))) + ) diff --git a/src/quantum/core/print/prettier.cljc b/src/quantum/core/print/prettier.cljc index a27a893c..21fdeb18 100644 --- a/src/quantum/core/print/prettier.cljc +++ b/src/quantum/core/print/prettier.cljc @@ -1,174 +1,7 @@ (ns quantum.core.print.prettier (:require - [fipp.edn] - [fipp.visit] - [fipp.ednize] - [quantum.core.fn :as fn - :refer [rcomp]] - [quantum.core.print :as pr] - [quantum.core.ns :as ns] - [quantum.untyped.core.convert :as uconv] - [quantum.untyped.core.qualify :as qual] - [quantum.core.vars :as var])) + [quantum.core.vars + :refer [defalias]] + [quantum.untyped.core.print.prettier :as u])) -#?(:clj -(defmethod print-method fipp.ednize.IEdn [^fipp.ednize.IEdn v ^java.io.Writer w] - (print-method (._edn v) w))) - -#?(:clj (prefer-method print-method fipp.ednize.IEdn clojure.lang.IRecord)) -#?(:clj (prefer-method print-method fipp.ednize.IEdn clojure.lang.IPersistentMap)) -#?(:clj (prefer-method print-method fipp.ednize.IEdn java.util.Map)) -#?(:clj (prefer-method print-method fipp.ednize.IEdn clojure.lang.ISeq)) -#?(:clj (prefer-method print-method clojure.lang.IRecord Throwable)) - -(in-ns 'fipp.visit) - -(defn transient-vector? [x] - (instance? #?(:clj clojure.lang.ITransientVector - :cljs cljs.core/TransientVector) x)) - -;; TODO more efficient -;; TODO move? -#?(:clj -(deftype IntIndexedIterator - [^long ^:unsynchronized-mutable i ^long ct ^clojure.lang.Indexed xs] - java.util.Iterator - (hasNext [this] (< i ct)) - (next [this] - (if (< i ct) - (let [i-prev i] - (set! i (unchecked-inc i)) - (.nth xs i-prev)) - (throw (java.util.NoSuchElementException.)))) - (remove [this] (throw (UnsupportedOperationException.))))) - -#?(:clj -(deftype IntIndexedIterable [^clojure.lang.Indexed xs] - Iterable - (iterator [this] (IntIndexedIterator. 0 (count xs) xs)))) - -(defn visit-symbol* [x] - [:text (cond-> x - quantum.core.print/*collapse-symbols?* - (quantum.untyped.core.qualify/collapse-symbol (not quantum.core.print/*print-as-code?*)))]) - -(defn visit-fn [visitor x] - [:group "#" "fn" " " (-> x quantum.untyped.core.convert/>symbol visit-symbol*)]) - -(defn visit* - "Visits objects, ignoring metadata." - [visitor x] - (cond - (nil? x) (visit-nil visitor) - (quantum.core.print/group? x) - (fipp.edn/pretty-coll visitor "" (.-xs ^quantum.untyped.core.print.Group x) :line "" visit) - (fipp.ednize/override? x) (visit-unknown visitor x) - (boolean? x) (visit-boolean visitor x) - (string? x) (visit-string visitor x) - (char? x) (visit-character visitor x) - (symbol? x) (visit-symbol* x) - (keyword? x) (visit-keyword visitor x) - (number? x) (visit-number visitor x) - (seq? x) (visit-seq visitor x) - (vector? x) (visit-vector visitor x) - (record? x) (visit-record visitor x) - (map? x) (visit-map visitor x) - (set? x) (visit-set visitor x) - (tagged-literal? x) (visit-tagged visitor x) - (var? x) (visit-var visitor x) - (regexp? x) (visit-pattern visitor x) - (fn? x) (visit-fn visitor x) - (transient-vector? x) - [:group "#" (pr-str '!+) - (when (and (:print-meta visitor) (meta (:form visitor))) " ") - (visit-vector visitor (IntIndexedIterable. x))] - :else (visit-unknown visitor x))) - -(defn visit [visitor x] - (let [m (meta x)] - (if (and m (not (var? x))) - (visit-meta visitor m x) - (visit* visitor x)))) - -(in-ns 'quantum.core.print.prettier) - -(defn extend-pretty-printing! [] - (extend-type java.util.ArrayList - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal '! (vec this)))) ; TODO faster - (extend-type it.unimi.dsi.fastutil.longs.LongArrayList - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal '!l (vec this)))) ; TODO faster - - (extend-type (Class/forName "[Z") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal '?<> (vec this)))) ; TODO faster - (extend-type (Class/forName "[B") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'b<> (vec this)))) ; TODO faster - (extend-type (Class/forName "[C") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'c<> (vec this)))) ; TODO faster - (extend-type (Class/forName "[[C") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'c<><> (into [] this)))) ; TODO faster - (extend-type (Class/forName "[S") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 's<> (vec this)))) ; TODO faster - (extend-type (Class/forName "[I") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'i<> (vec this)))) ; TODO faster - (extend-type (Class/forName "[J") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'l<> (vec this)))) ; TODO ->vec for this - (extend-type (Class/forName "[F") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'f<> (vec this)))) ; TODO faster - (extend-type (Class/forName "[D") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'd<> (vec this)))) ; TODO ->vec for this - (extend-type (Class/forName "[[D") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'd<><> (into [] this)))) ; TODO faster - (extend-type (Class/forName "[Ljava.lang.Object;") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal '*<> (vec this)))) ; TODO faster - (extend-type (Class/forName "[[Ljava.lang.Object;") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal '*<><> (into [] this)))) ; TODO faster - (extend-type (Class/forName "[Ljava.lang.Class;") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'class<> (vec this)))) ; TODO faster - - (extend-type java.util.HashMap - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal '! (into {} this)))) - (extend-type java.util.concurrent.ConcurrentHashMap - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal '!! (into {} this)))) ; TODO ->map - (extend-type quantum.core.error.Error - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'err (into {} this)))) - (extend-type (Class/forName "[Ljava.lang.StackTraceElement;") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (mapv (rcomp StackTraceElement->vec str symbol) this))) - ) +(defalias u/extend-pretty-printing!) From f4f57cd1fc84f9701bfd8ecf9f00b13031407cd0 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 17 May 2018 00:50:52 -0600 Subject: [PATCH 057/810] hashing hashed out --- .../untyped/core/form/generate/deftype.cljc | 10 ++++----- src/quantum/core/data/finger_tree.cljc | 6 ++--- src/quantum/core/data/validated.cljc | 22 +++++++++---------- 3 files changed, 19 insertions(+), 19 deletions(-) diff --git a/src-untyped/quantum/untyped/core/form/generate/deftype.cljc b/src-untyped/quantum/untyped/core/form/generate/deftype.cljc index bd4c4204..d2fb14a8 100644 --- a/src-untyped/quantum/untyped/core/form/generate/deftype.cljc +++ b/src-untyped/quantum/untyped/core/form/generate/deftype.cljc @@ -23,7 +23,7 @@ (defn ?Counted [lang] (case lang :clj 'clojure.lang.Counted :cljs 'cljs.core/ICounted )) (defn ?Deref [lang] (case lang :clj 'clojure.lang.IDeref :cljs 'cljs.core/IDeref )) (defn ?Fn [lang] (case lang :clj 'clojure.lang.IFn :cljs 'cljs.core/IFn )) -(defn ?HashEq [lang] (case lang :clj 'clojure.lang.IHashEq :cljs 'cljs.core/IHash )) +(defn ?Hash [lang] (case lang :clj 'clojure.lang.IHashEq :cljs 'cljs.core/IHash )) (defn ?Indexed [lang] (case lang :clj 'clojure.lang.Indexed :cljs 'cljs.core/IIndexed )) (defn ?Iterable [lang] (case lang :clj 'java.lang.Iterable :cljs 'cljs.core/IIterable )) (defn ?Lookup [lang] (case lang :clj 'clojure.lang.ILookup :cljs 'cljs.core/ILookup )) @@ -112,14 +112,14 @@ (case lang :clj `[~(?Object lang) - ~@(p-arity 'equals (get impls 'equals)) - ~@(p-arity 'hashCode (get impls 'hash ))] + ~@(p-arity 'equals (get impls 'equals )) + ~@(p-arity 'hashCode (get impls 'hash-code))] :cljs `[~(?Object lang) ~@(p-arity 'equiv (get impls 'equals))]) ?Hash - `[~(?HashEq lang) - ~@(p-arity (case lang :clj 'hashEq :cljs '-hash) (get impls 'hash-eq))] + `[~(?Hash lang) + ~@(p-arity (case lang :clj 'hasheq :cljs '-hash) (get impls 'hash))] ?Meta (case lang :clj diff --git a/src/quantum/core/data/finger_tree.cljc b/src/quantum/core/data/finger_tree.cljc index 1c0a5c1d..f044aeca 100644 --- a/src/quantum/core/data/finger_tree.cljc +++ b/src/quantum/core/data/finger_tree.cljc @@ -343,9 +343,9 @@ (deftype/deftype CountedDoubleList [tree mdata] {?Object {equals ([_ x] (seq= tree x)) - hash ([this] (hashcode (map identity this)))} - ?HashEq - {hash-eq ([this] (hash-ordered this))} + hash-code ([this] (hashcode (map identity this)))} + ?Hash + {hash ([this] (hash-ordered this))} ?Meta {meta ([_] mdata) with-meta ([_ mdata] (CountedDoubleList. tree mdata))} diff --git a/src/quantum/core/data/validated.cljc b/src/quantum/core/data/validated.cljc index 12c5a122..8c190c77 100644 --- a/src/quantum/core/data/validated.cljc +++ b/src/quantum/core/data/validated.cljc @@ -258,16 +258,16 @@ code `(do (def ~conformer-sym ~conformer) (deftype/deftype ~(with-meta sym {:no-factory? true}) ~'[v] {~'?Object - {~'hash ([_#] (.hashCode ~'v)) - ~'equals ~(std-equals sym other '=)} - ~'?HashEq - {~'hash-eq ([_#] (int (bit-xor ~type-hash (~(case-env :clj '.hashEq :cljs '-hash) ~'v))))} + {~'hash-code ([_#] (.hashCode ~'v)) + ~'equals ~(std-equals sym other '=)} + ~'?Hash + {~'hash ([_#] (int (bit-xor ~type-hash (~(case-env :clj '.hashEq :cljs '-hash) ~'v))))} ~'?Deref - {~'deref ([_#] ~'v)} + {~'deref ([_#] ~'v)} quantum.core.core/IValue - {~'get ([_#] ~'v) - ~'set ([_# v#] (new ~sym (-> v# ~(if-not conformer `identity* conformer-sym) - (s/validate ~spec-name))))}}) + {~'get ([_#] ~'v) + ~'set ([_# v#] (new ~sym (-> v# ~(if-not conformer `identity* conformer-sym) + (s/validate ~spec-name))))}}) (def ~spec-base ~spec) (s/def ~spec-name (s/conformer (fn [x#] (if (instance? ~sym x#) @@ -468,7 +468,7 @@ #_(enforce-get ~empty-record ~sym ~spec-sym k#) (~(case-env :clj '.entryAt :cljs nil) ~'v k#))} ~'?Object - {~'hash ([_#] (.hashCode ~'v)) + {~'hash-code ([_#] (.hashCode ~'v)) ~'equals ~(std-equals sym other (case-env :clj '.equiv :cljs '.equiv))} ~'?Iterable {~'iterator ([_#] (~(case-env :clj '.iterator :cljs '-iterator) ~'v))} @@ -477,8 +477,8 @@ ~'with-meta ([_# new-meta#] (new ~sym (with-meta ~'v new-meta#)))} ~'?Print {~'pr ([_# w# opts#] (~'-pr-writer ~'v w# opts#))} - ~'?HashEq - {~'hash-eq ([_#] (int (bit-xor ~type-hash (~(case-env :clj '.hashEq :cljs '-hash) ~'v))))} + ~'?Hash + {~'hash ([_#] (int (bit-xor ~type-hash (~(case-env :clj '.hashEq :cljs '-hash) ~'v))))} quantum.core.core/IValue {~'get ([_#] ~'v) ~'set ([_# v#] (if (instance? ~sym v#) v# (new ~sym (~create v#))))}}) From e39ed6eab80a147413b8d9c0ebc95f043b5fcb3d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 17 May 2018 00:50:59 -0600 Subject: [PATCH 058/810] Better spacing --- .../quantum/untyped/core/type/compare.cljc | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index a2ed80f3..2b9f21f4 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -250,20 +250,20 @@ - ✓ `(t/<> c0 c1)` : the extension of ->`c0` is disjoint w.r.t. to that of ->`c1`. Unboxed primitives are considered to be less general (more specific) than boxed primitives." [^Class c0 class? ^Class c1 class? > comparison?] - #?(:clj (ifs (== c0 c1) =ident - (== c0 Object) >ident - (== c1 Object) unboxed c0) c1) >ident - (== c0 (utcore/boxed->unboxed c1)) ident + (== c1 Object) unboxed c0) c1) >ident + (== c0 (utcore/boxed->unboxed c1)) ident - (.isAssignableFrom c0 c1) >ident - (.isAssignableFrom c1 c0) ident + (.isAssignableFrom c1 c0) ident) :cljs (TODO))) From b4367eb84fec6eeaafba1705f2011f0ab772a0f9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 17 May 2018 00:51:28 -0600 Subject: [PATCH 059/810] Hashing and hash equality tests for some type reifications --- src-untyped/quantum/untyped/core/type.cljc | 54 +++++++------- .../untyped/core/type/reifications.cljc | 39 ++++++---- test/quantum/test/untyped/core/type.cljc | 72 ++++++++++++++----- 3 files changed, 109 insertions(+), 56 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 5e4b3bc2..bab6016a 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -86,8 +86,6 @@ and or val|by-class?) (defonce *type-registry (atom {})) -;; TODO remove this -(swap! *type-registry empty) ;; ===== Comparison ===== ;; @@ -114,7 +112,7 @@ (utr/or-type? t) (->> t utr/or-type>args (uc/lmap not) (apply and)) ;; DeMorgan's Law (utr/and-type? t) (->> t utr/and-type>args (uc/lmap not) (apply or )) - (NotType. t))) + (NotType. -1 -1 t))) (uvar/defalias ! not) @@ -166,26 +164,27 @@ If `t0` < `t1`, `∅` If `t0` <> `t1`, `t0` If `t0` > | >< `t1`, `t0` with all elements of `t1` removed" - [t0 utr/type?, t1 utr/type? > utr/type?] - (let [c (compare t0 t1)] - (case c - (0 -1) empty-set - 3 t0 - (1 2) - (let [c0 (c/class t0) c1 (c/class t1)] - ;; TODO add dispatch? - (condp == c0 - NotType (condp == (-> t0 utr/not-type>inner-type c/class) - ClassType (condp == c1 - ClassType (AndType. [t0 (not t1)] (atom nil))) - ValueType (condp == c1 - ValueType (AndType. [t0 (not t1)] (atom nil)))) - OrType (condp == c1 - ClassType (let [args (->> t0 utr/or-type>args (uc/remove (fn1 = t1)))] - (case (count args) - 0 empty-set - 1 (first args) - (OrType. args (atom nil)))))))))) + ([t0 utr/type?, t1 utr/type? > utr/type?] + (let [c (compare t0 t1)] + (case c + (0 -1) empty-set + 3 t0 + (1 2) + (let [c0 (c/class t0) c1 (c/class t1)] + ;; TODO add dispatch? + (condp == c0 + NotType (condp == (-> t0 utr/not-type>inner-type c/class) + ClassType (condp == c1 + ClassType (AndType. [t0 (not t1)] (atom nil))) + ValueType (condp == c1 + ValueType (AndType. [t0 (not t1)] (atom nil)))) + OrType (condp == c1 + ClassType (let [args (->> t0 utr/or-type>args (uc/remove (fn1 = t1)))] + (case (count args) + 0 empty-set + 1 (first args) + (OrType. args (atom nil)))))))))) + ([t0 utr/type?, t1 utr/type? & ts (s/seq-of utr/type?) > utr/type?] (reduce - (- t0 t1) ts))) (defn isa? [x] (ifs (utpred/protocol? x) @@ -425,7 +424,7 @@ [pred (<= iterable?), t utr/type?] (TODO)) ;; TODO do this -(do +#_(do (udt/deftype FnSpec [name #_(t/? t/symbol?) @@ -541,6 +540,13 @@ (type>?class-value (isa? String)) nil}} [t utr/type?] (-type>?class-value t false))) +;; ===== Validation and Conformance ===== ;; + +(defns validate [x _ t utr/type?] + (if-let [valid? (t x)] + x + (err! "Type-validation failed" {:type t :to-validate x}))) + ;; ---------------------- ;; ;; ===== Predicates ===== ;; ;; ---------------------- ;; diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index d3be23ab..8492ceb9 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -8,6 +8,7 @@ [quantum.untyped.core.compare :refer [== not==]] [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.data.hash :as uhash] [quantum.untyped.core.defnt :refer [defns]] [quantum.untyped.core.form.generate.deftype :as udt]) @@ -20,6 +21,8 @@ (defns type? [x _ > boolean?] (satisfies? PType x)) +;; Here `c/=` tests for structural equivalence + ;; ----- UniversalSetType (`t/U`) ----- ;; (udt/deftype @@ -27,8 +30,11 @@ Equivalent to `(constantly true)`."} UniversalSetType [] {PType nil + ?Hash {hash ([this] (hash UniversalSetType))} + ?Object {equals ([this that] (or (== this that) (instance? UniversalSetType that))) + hash-code ([this] (uhash/code UniversalSetType))} fedn/IOverride nil - fedn/IEdn {-edn ([this] 'quantum.untyped.core.type/U)}}) + fedn/IEdn {-edn ([this] 'quantum.untyped.core.type/U)}}) (def universal-set (UniversalSetType.)) @@ -38,24 +44,30 @@ ^{:doc "Represents the empty set. Equivalent to `(constantly false)`."} EmptySetType [] - {PType nil - fednIOverride nil - fednIEdn {-edn ([this] 'quantum.untyped.core.type/∅)}}) + {PType nil + ?Hash {hash ([this] (hash UniversalSetType))} + ?Object {equals ([this that] (or (== this that) (instance? EmptySetType that))) + hash-code ([this] (uhash/code EmptySetType))} + fedn/IOverride nil + fedn/IEdn {-edn ([this] 'quantum.untyped.core.type/∅)}}) (def empty-set (EmptySetType.)) ;; ----- NotType (`t/not` / `t/!`) ----- ;; -(udt/deftype NotType [t #_t/type?] +(udt/deftype NotType [^int ^:unsynchronized-mutable hash + ^int ^:unsynchronized-mutable hash-code + t #_t/type?] {PType nil + ?Hash {hash ([this] (uhash/caching-set-ordered! hash NotType t))} + ?Fn {invoke ([_ x] (t x))} + ?Object {equals ([this that] + (or (== this that) + (and (instance? NotType that) + (= t (.-t ^NotType that))))) + hash-code ([this] (uhash/caching-set-code! hash-code NotType t))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (list 'quantum.untyped.core.type/not t))} - ?Fn {invoke ([_ x] (t x))} - ?Object ;; Tests for structural equivalence - {equals ([this that] - (or (== this that) - (and (instance? NotType that) - (= t (.-t ^NotType that)))))}}) + fedn/IEdn {-edn ([this] (list 'quantum.untyped.core.type/not t))}}) (defns not-type? [x _ > boolean?] (instance? NotType x)) @@ -73,8 +85,7 @@ (and satisfies-type? (reduced satisfies-type?)))) true ; vacuously args))} - ?Object ;; Tests for structural equivalence - {equals ([this that] + ?Object {equals ([this that] (or (== this that) (and (instance? OrType that) (= args (.-args ^OrType that)))))}}) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 8d0efc13..3c9abc05 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -1,23 +1,51 @@ (ns quantum.test.untyped.core.type - (:require - [clojure.core :as core] - [quantum.untyped.core.test - :refer [deftest testing is is= throws]] - [quantum.untyped.core.type :as t - :refer [& | !]] - [quantum.untyped.core.type.reifications :as utr] - [quantum.test.untyped.core.type.compare - :refer [i|>a+b i|>a0 i|>a1 i|>b0 i|>b1 - i|a i|b - i|<0 i|><1 i|><2 + (:require + [clojure.core :as core] + [quantum.untyped.core.test + :refer [deftest testing is is= throws]] + [quantum.untyped.core.type :as t + :refer [& | !]] + [quantum.untyped.core.type.reifications :as utr + #?@(:cljs [:refer [UniversalSetType EmptySetType + NotType OrType AndType + ProtocolType ClassType + ValueType]])] + [quantum.test.untyped.core.type.compare + :refer [i|>a+b i|>a0 i|>a1 i|>b0 i|>b1 + i|a i|b + i|<0 i|><1 i|><2 - >a+b >a >b - a b - <0 ><1 ><2]])) + >a+b >a >b + a b + <0 ><1 ><2]]) +#?(:clj (:import + [quantum.untyped.core.type.reifications + UniversalSetType EmptySetType + NotType OrType AndType + ProtocolType ClassType + ValueType]))) + +(defn test-equality [genf] + (let [a (genf) b (genf)] + (testing "structural equality (`c/=`)" + (is= a b)) + (testing "hash(eq) equality" + (is= (hash a) (hash b))) + #?(:clj (testing "hash(code) equality" + (is= (.hashCode a) (.hashCode b)))) + (testing "collection equality" + (is= 1 (count (hash-set a b))))))) + +(deftest test|universal-set + (test-equality #(UniversalSetType.))) + +(deftest test|empty-set + (test-equality #(EmptySetType.))) (deftest test|not + (test-equality #(! (t/value 1))) (testing "simplification" (testing "universal/null set" (is= (! t/universal-set) @@ -58,8 +86,8 @@ )) (deftest test|or - (testing "equality" - (is= (| a b) (| a b))) + (test-equality #(| a b)) + (test-equality #(| (t/value 1) (t/value 2))) (testing "simplification" (testing "via single-arg" (is= (| a) @@ -219,3 +247,11 @@ (testing "#{<+ =+ >+ ∅+} -> #{>+ ∅+}" (is= (utr/and-type>args (& i|>a+b i|>a0 i|a i|<0 i|><1)) [i|<0 i|><1])))) + +(deftest test|value + (testing "equality" + (is= (t/value 1) (t/value 1))) + (testing "hash equality" + (is= (hash (t/value 1)) (hash (t/value 1))) + (is= 1 (count (hash-set (t/value 1) + (t/value 1)))))) From 453fd7a731436b4f897fc1a3c287f4aa19cf5bc7 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 17 May 2018 01:07:18 -0600 Subject: [PATCH 060/810] Hash equality works for all reifications --- .../quantum/untyped/core/data/hash.cljc | 8 +- src-untyped/quantum/untyped/core/type.cljc | 25 ++-- .../untyped/core/type/reifications.cljc | 115 +++++++++++------- test/quantum/test/untyped/core/type.cljc | 12 +- 4 files changed, 98 insertions(+), 62 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/hash.cljc b/src-untyped/quantum/untyped/core/data/hash.cljc index 7b70c5ec..d1f86729 100644 --- a/src-untyped/quantum/untyped/core/data/hash.cljc +++ b/src-untyped/quantum/untyped/core/data/hash.cljc @@ -4,6 +4,8 @@ (:require [clojure.core :as core])) +(def ^:const default -1) + (def hash core/hash) (defn code [x] @@ -21,7 +23,7 @@ See also https://clojure.org/reference/data_structures." [field #_simple-symbol? & args] - `(if (identical? ~field -1) + `(if (identical? ~field default) (set! ~field (-> 0 ~@(->> args (map (fn [arg] `(unchecked-add-int (hash ~arg))))) (mix-collection-hash ~(count args)) @@ -35,7 +37,7 @@ See also https://clojure.org/reference/data_structures." [field #_simple-symbol? & args] - `(if (identical? ~field -1) + `(if (identical? ~field default) (set! ~field (-> 1 ~@(->> args (map (fn [arg] `(-> (unchecked-multiply-int 31) @@ -53,6 +55,6 @@ "Tries to retrive a cached hash-code value at the provided field. If not found, sets the field with a computed hash-code using the sum of the hash-codes of the provided args." [field #_simple-symbol? & args] - `(if (identical? ~field -1) + `(if (identical? ~field default) (set! ~field (-> 0 ~@(->> args (map (fn [arg] `(unchecked-add-int (code ~arg))))))) ~field))) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index bab6016a..6c559c21 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -29,6 +29,7 @@ :refer [>symbol]] [quantum.untyped.core.core :as ucore] [quantum.untyped.core.data.bits :as ubit] + [quantum.untyped.core.data.hash :as uhash] [quantum.untyped.core.data.tuple] [quantum.untyped.core.defnt :refer [defns defns-]] @@ -112,7 +113,7 @@ (utr/or-type? t) (->> t utr/or-type>args (uc/lmap not) (apply and)) ;; DeMorgan's Law (utr/and-type? t) (->> t utr/and-type>args (uc/lmap not) (apply or )) - (NotType. -1 -1 t))) + (NotType. uhash/default uhash/default t))) (uvar/defalias ! not) @@ -144,17 +145,19 @@ ;; ----- ProtocolType ----- ;; -(defns- isa?|protocol [p utpred/protocol?] (ProtocolType. nil p nil)) +(defns- isa?|protocol [p utpred/protocol?] + (ProtocolType. uhash/default uhash/default nil p nil)) ;; ----- ClassType ----- ;; -(defns- isa?|class [c #?(:clj c/class? :cljs c/fn?)] (ClassType. nil c nil)) +(defns- isa?|class [c #?(:clj c/class? :cljs c/fn?)] + (ClassType. uhash/default uhash/default nil c nil)) ;; ----- ValueType ----- ;; (defns value "Creates a type whose extension is the singleton set containing only the value `v`." - [v _] (ValueType. v)) + [v _] (ValueType. uhash/default uhash/default v)) ;; ----- General ----- ;; @@ -175,15 +178,15 @@ (condp == c0 NotType (condp == (-> t0 utr/not-type>inner-type c/class) ClassType (condp == c1 - ClassType (AndType. [t0 (not t1)] (atom nil))) + ClassType (AndType. uhash/default uhash/default [t0 (not t1)] (atom nil))) ValueType (condp == c1 - ValueType (AndType. [t0 (not t1)] (atom nil)))) + ValueType (AndType. uhash/default uhash/default [t0 (not t1)] (atom nil)))) OrType (condp == c1 ClassType (let [args (->> t0 utr/or-type>args (uc/remove (fn1 = t1)))] (case (count args) 0 empty-set 1 (first args) - (OrType. args (atom nil)))))))))) + (OrType. uhash/default uhash/default args (atom nil)))))))))) ([t0 utr/type?, t1 utr/type? & ts (s/seq-of utr/type?) > utr/type?] (reduce - (- t0 t1) ts))) (defn isa? [x] @@ -212,11 +215,11 @@ (if (c/= (.-name ^ClassType t) name-sym) reg (err! "Class already registered with type; must first undef" {:class x :type-name name-sym})) - (let [t (ClassType. nil x name-sym)] + (let [t (ClassType. uhash/default uhash/default nil x name-sym)] (uc/assoc-in reg [name-sym] t [:by-class x] t))))))] (c/or (get-in reg [:by-class x]) - (ClassType. nil ^Class x name-sym))) + (ClassType. uhash/default uhash/default nil ^Class x name-sym))) (c/fn? x) (let [sym (c/or name-sym (>symbol x)) _ (when-not name-sym @@ -226,7 +229,7 @@ (c/nil? x) nil? (utpred/protocol? x) - (ProtocolType. nil x name-sym) + (ProtocolType. uhash/default uhash/default nil x name-sym) (value x)) :cljs nil))) @@ -414,7 +417,7 @@ (assert (-> simplified count (c/>= 1))) ; for internal implementation correctness (if (-> simplified count (c/= 1)) (first simplified) - (construct-fn simplified (atom nil)))))) + (construct-fn uhash/default uhash/default simplified (atom nil)))))) ;; TODO do this? #_(udt/deftype SequentialType) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 8492ceb9..b6748282 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -30,9 +30,10 @@ Equivalent to `(constantly true)`."} UniversalSetType [] {PType nil - ?Hash {hash ([this] (hash UniversalSetType))} - ?Object {equals ([this that] (or (== this that) (instance? UniversalSetType that))) - hash-code ([this] (uhash/code UniversalSetType))} + ?Fn {invoke ([_ x] true)} + ?Hash {hash ([this] (hash UniversalSetType))} + ?Object {hash-code ([this] (uhash/code UniversalSetType)) + equals ([this that] (or (== this that) (instance? UniversalSetType that)))} fedn/IOverride nil fedn/IEdn {-edn ([this] 'quantum.untyped.core.type/U)}}) @@ -45,9 +46,10 @@ Equivalent to `(constantly false)`."} EmptySetType [] {PType nil - ?Hash {hash ([this] (hash UniversalSetType))} - ?Object {equals ([this that] (or (== this that) (instance? EmptySetType that))) - hash-code ([this] (uhash/code EmptySetType))} + ?Fn {invoke ([_ x] false)} + ?Hash {hash ([this] (hash UniversalSetType))} + ?Object {hash-code ([this] (uhash/code EmptySetType)) + equals ([this that] (or (== this that) (instance? EmptySetType that)))} fedn/IOverride nil fedn/IEdn {-edn ([this] 'quantum.untyped.core.type/∅)}}) @@ -55,17 +57,18 @@ ;; ----- NotType (`t/not` / `t/!`) ----- ;; -(udt/deftype NotType [^int ^:unsynchronized-mutable hash - ^int ^:unsynchronized-mutable hash-code - t #_t/type?] +(udt/deftype NotType + [^int ^:unsynchronized-mutable hash + ^int ^:unsynchronized-mutable hash-code + t #_t/type?] {PType nil - ?Hash {hash ([this] (uhash/caching-set-ordered! hash NotType t))} - ?Fn {invoke ([_ x] (t x))} - ?Object {equals ([this that] + ?Fn {invoke ([_ x] (not (t x)))} + ?Hash {hash ([this] (uhash/caching-set-ordered! hash NotType t))} + ?Object {hash-code ([this] (uhash/caching-set-code! hash-code NotType t)) + equals ([this that] (or (== this that) (and (instance? NotType that) - (= t (.-t ^NotType that))))) - hash-code ([this] (uhash/caching-set-code! hash-code NotType t))} + (= t (.-t ^NotType that)))))} fedn/IOverride nil fedn/IEdn {-edn ([this] (list 'quantum.untyped.core.type/not t))}}) @@ -75,20 +78,26 @@ ;; ----- OrType (`t/or` / `t/|`) ----- ;; -(udt/deftype OrType [args #_(t/and t/indexed? (t/seq t/type?)) *logical-complement] +(udt/deftype OrType + [^int ^:unsynchronized-mutable hash + ^int ^:unsynchronized-mutable hash-code + args #_(t/and t/indexed? (t/seq t/type?)) + *logical-complement] {PType nil + ?Fn {invoke ([_ x] (reduce + (fn [_ t] + (let [satisfies-type? (t x)] + (and satisfies-type? (reduced satisfies-type?)))) + true ; vacuously + args))} + ?Hash {hash ([this] (uhash/caching-set-ordered! hash OrType args))} + ?Object {hash-code ([this] (uhash/caching-set-code! hash-code OrType args)) + equals ([this that] + (or (== this that) + (and (instance? OrType that) + (= args (.-args ^OrType that)))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (list* 'quantum.untyped.core.type/or args))} - ?Fn {invoke ([_ x] (reduce - (fn [_ t] - (let [satisfies-type? (t x)] - (and satisfies-type? (reduced satisfies-type?)))) - true ; vacuously - args))} - ?Object {equals ([this that] - (or (== this that) - (and (instance? OrType that) - (= args (.-args ^OrType that)))))}}) + fedn/IEdn {-edn ([this] (list* 'quantum.untyped.core.type/or args))}}) (defns or-type? [x _ > boolean?] (instance? OrType x)) @@ -96,18 +105,23 @@ ;; ----- AndType (`t/and` | `t/&`) ----- ;; -(udt/deftype AndType [args #_(t/and t/indexed? (t/seq t/type?)) *logical-complement] +(udt/deftype AndType + [^int ^:unsynchronized-mutable hash + ^int ^:unsynchronized-mutable hash-code + args #_(t/and t/indexed? (t/seq t/type?)) + *logical-complement] {PType nil fedn/IOverride nil - fedn/IEdn {-edn ([this] (list* 'quantum.untyped.core.type/and args))} - ?Fn {invoke ([_ x] (reduce (fn [_ t] (or (t x) (reduced false))) - true ; vacuously - args))} - ?Object ;; Tests for structural equivalence - {equals ([this that] - (or (== this that) - (and (instance? AndType that) - (= args (.-args ^AndType that)))))}}) + fedn/IEdn {-edn ([this] (list* 'quantum.untyped.core.type/and args))} + ?Fn {invoke ([_ x] (reduce (fn [_ t] (or (t x) (reduced false))) + true ; vacuously + args))} + ?Hash {hash ([this] (uhash/caching-set-ordered! hash AndType args))} + ?Object {hash-code ([this] (uhash/caching-set-code! hash-code AndType args)) + equals ([this that] + (or (== this that) + (and (instance? AndType that) + (= args (.-args ^AndType that)))))}}) (defns and-type? [x _ > boolean?] (instance? AndType x)) @@ -120,7 +134,9 @@ ;; ----- ProtocolType ----- ;; (udt/deftype ProtocolType - [meta #_(t/? ::meta) + [^int ^:unsynchronized-mutable hash + ^int ^:unsynchronized-mutable hash-code + meta #_(t/? ::meta) p #_t/protocol? name #_(t/? t/symbol?)] {PType nil @@ -128,8 +144,10 @@ fedn/IEdn {-edn ([this] (or name (list 'quantum.untyped.core.type/isa?|protocol (:on p))))} ?Fn {invoke ([_ x] (satisfies? p x))} ?Meta {meta ([this] meta) - with-meta ([this meta'] (ProtocolType. meta' p name))} - ?Object {equals ([this that #_any?] + with-meta ([this meta'] (ProtocolType. hash hash-code meta' p name))} + ?Hash {hash ([this] (uhash/caching-set-ordered! hash ProtocolType p))} + ?Object {hash-code ([this] (uhash/caching-set-code! hash-code ProtocolType p)) + equals ([this that #_any?] (or (== this that) (and (instance? ProtocolType that) (= p (.-p ^ProtocolType that)))))}}) @@ -141,7 +159,9 @@ ;; ----- ClassType ----- ;; (udt/deftype ClassType - [ meta #_(t/? ::meta) + [^int ^:unsynchronized-mutable hash + ^int ^:unsynchronized-mutable hash-code + meta #_(t/? ::meta) ^Class c #_t/class? name #_(t/? t/symbol?)] {PType nil @@ -149,8 +169,10 @@ fedn/IEdn {-edn ([this] (or name (list 'quantum.untyped.core.type/isa? c)))} ?Fn {invoke ([_ x] (instance? c x))} ?Meta {meta ([this] meta) - with-meta ([this meta'] (ClassType. meta' c name))} - ?Object {equals ([this that #_any?] + with-meta ([this meta'] (ClassType. hash hash-code meta' c name))} + ?Hash {hash ([this] (uhash/caching-set-ordered! hash ClassType c))} + ?Object {hash-code ([this] (uhash/caching-set-code! hash-code ClassType c)) + equals ([this that #_any?] (or (== this that) (and (instance? ClassType that) (= c (.-c ^ClassType that)))))}}) @@ -161,12 +183,17 @@ ;; ----- ValueType ----- ;; -(udt/deftype ValueType [v #_any?] +(udt/deftype ValueType + [^int ^:unsynchronized-mutable hash + ^int ^:unsynchronized-mutable hash-code + v #_any?] {PType nil fedn/IOverride nil fedn/IEdn {-edn ([this] (list 'quantum.untyped.core.type/value v))} ?Fn {invoke ([_ x] (= x v))} - ?Object {equals ([this that #_any?] + ?Hash {hash ([this] (uhash/caching-set-ordered! hash ValueType v))} + ?Object {hash-code ([this] (uhash/caching-set-code! hash-code ValueType v)) + equals ([this that #_any?] (or (== this that) (and (instance? ValueType that) (= v (.-v ^ValueType that)))))}}) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 3c9abc05..2500cd64 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -148,8 +148,7 @@ [>a ><0 ><1])))) (deftest test|and - (testing "equality" - (is= (& i|a i|b) (& i|a i|b))) + (test-equality #(& i|a i|b)) (testing "null set / universal set" (is= (& t/universal-set t/universal-set) t/universal-set) @@ -248,9 +247,14 @@ (is= (utr/and-type>args (& i|>a+b i|>a0 i|a i|<0 i|><1)) [i|<0 i|><1])))) +(deftest test|protocol + (test-equality #(t/isa? utr/PType))) + +(deftest test|class + (test-equality #(t/isa? Object))) + (deftest test|value - (testing "equality" - (is= (t/value 1) (t/value 1))) + (test-equality #(t/value 1)) (testing "hash equality" (is= (hash (t/value 1)) (hash (t/value 1))) (is= 1 (count (hash-set (t/value 1) From 23ea1830ea20033d95d19daa8ebc4e69b5344924 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 17 May 2018 01:42:47 -0600 Subject: [PATCH 061/810] Add some notes --- src-dev/quantum/core/defnt.cljc | 39 +++++++++++- src-dev/quantum/core/defnt_equivalences.cljc | 66 ++++++++++---------- 2 files changed, 69 insertions(+), 36 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 4eebe9e2..1e9ba266 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -89,25 +89,58 @@ - If nilable, will it be boxed or will there be one overload for nil and one for primitive? - When a `fnt` with type overloads is referenced outside of a typed context, then the overload resolution will be done via Runtime Dispatch. + - TODO Should we take into account 'actual' types (not just 'declared' types) when performing + dispatch / overload resolution? + - Let's take the example of `(f (rand/int-between -10 -2))`. + - Let's say `rand/int-between`'s output is labeled `t/int?`. However, we know based on + further static analysis of its implementation that the output is not only `t/int?` but + also `t/neg?`, or perhaps even further, `(< -10 % -2)`. + - In this case, should we take advantage of this knowledge? + - Let's say we do. Then `(.invoke reify|we-know-specifics (rand/int-between -10 -2))`. + Yay for efficiency! But let's then say we then change the implementation even if we + don't change the 'interface'/typedefs. Now `rand/int-between` returns `(<= -10 % -2)` — + that is, it's now numerically *inclusive* (for instance, maybe the implementation's + previous behavior of generating numbers numerically *exclusive*ly was mistaken). + `reify|we-know-specifics` would then still be invoked but incorrectly (and unsafely) so. + - To be fair, we'll tend to change output specs/typedefs all the time as we do + development. Do we need to keep track of every call site it affects and recompile + accordingly? Perhaps. It seems like overkill though. It should be configurable in any + case. + - I think that because of this last point, we can and should rely on implementational + specifics wherever available to boost performance (Maybe this should be configurable so + it doesn't slow down development? The more we change the implementation, the more it has + to recompile, ostensibly). We can take advantage of the output specs, certainly, if for + nothing else than to ensure that our implementation (as characterized by its 'actual' + output type) matches what we expect (as characterized by its 'expected'/'declared' + output type). [ ] Runtime (Dynamic) Dispatch [—] Protocol generation - For now we won't do it because we can very often find the correct overload at compile time. We will resort to using the `fn`. - It will be left as an optimization. [ ] `fn` generation - - Performs a worst-case linear check of the types, `cond`-style. + - Performs a worst-case linear check of the typedefs, `cond`-style. [ ] Interface generation - Even if the `defnt` is redefined, you won't have interface problems. [ ] `reify` generation - Which `reify`s get generated is mainly up to the inputs but partially up to the fn body — If any typed fns are called in the fn body then this can change what gets generated. - TODO explain this more - - Each of the `reify`s will keep their label (`__2__0` or whatever) as long as the original type - of the `reify` is `t/=` to the new type of that reify + - Each of the `reify`s will keep their label (`__2__0` or whatever) as long as the original + typedef of the `reify` is `t/=` to the new typedef of that reify - If a redefined `defnt` doesn't have that type overload then the previous reify is uninterned and thus made unavailable - That way, according to the dynamicity tests in `quantum.test.core.defnt`, we can redefine implementations at will as long as the specs don't change + - To make this process faster we maintain a set of typedefs so at least cheap c/= checks can + be performed + - If c/= succeeds, great; the `reify` corresponding the label (and reify-type) will be + replaced; the typedef-set will remain unchanged + - Else it must find a corresponding typedef by t/= + - Then if it is found by t/= it will replace the `reify` and the typedef corresponding + with that label and replace the typedef in the typedef-set + - Else a new label will be given to the `reify`; the typedef will be added to the + typedef-set - [ ] One reify per type that cannot be split - Only `t/or`s can be split for now diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 15e86740..3a06dad4 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -887,13 +887,13 @@ "Taken from `clojure.lang.RT/seq`" > (t/? (t/isa? ISeq)) ([xs t/nil? ] nil) - ([xs t/array? ] (ArraySeq/createFromObject xs)) ([xs (t/isa? ASeq) ] xs) ([xs (t/or (t/isa? LazySeq) (t/isa? Seqable))] (.seq xs)) ([xs t/iterable? ] (clojure.lang.RT/chunkIteratorSeq (.iterator xs))) ([xs t/char-seq? ] (StringSeq/create xs)) - ([xs (t/isa? Map) ] (seq (.entrySet xs))))) + ([xs (t/isa? Map) ] (seq (.entrySet xs))) + ([xs t/array? ] (ArraySeq/createFromObject xs)))) ) ;; ----- expanded code ----- ;; @@ -910,65 +910,48 @@ ;; Notice, no casting for nil input nil))) - ;; [t/array?] - - ;; TODO perhaps at some point figure out that it doesn't need to create any more - ;; overloads here than just one? - (def seq|__1|input-types (*<> (t/isa? (Class/forName "[Z")))) - (def ^Object>Object seq|__1 - (reify Object>Object - (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] - (let* [^"[Z" xs xs] (ArraySeq/createFromObject xs))))) - - (def seq|__2|input-types (*<> (t/isa? (Class/forName "[B")))) - (def ^Object>Object seq|__2 - (reify Object>Object - (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] - (let* [^"[B" xs xs] (ArraySeq/createFromObject xs))))) - ... - ;; [(t/isa? ASeq)] - (def seq|__30|input-types (*<> (t/isa? ASeq))) - (def ^Object>Object seq|__30 + (def seq|__2|input-types (*<> (t/isa? ASeq))) + (def ^Object>Object seq|__2 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (let* [^ASeq xs xs] xs)))) ;; [(t/or (t/isa? LazySeq) (t/isa? Seqable))] - (def seq|__31|input-types (*<> (t/isa? LazySeq))) - (def ^Object>Object seq|__31 + (def seq|__3|input-types (*<> (t/isa? LazySeq))) + (def ^Object>Object seq|__3 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (let* [^LazySeq xs xs] (.seq xs))))) - (def seq|__32|input-types (*<> (t/isa? Seqable))) - (def ^Object>Object seq|__32 + (def seq|__4|input-types (*<> (t/isa? Seqable))) + (def ^Object>Object seq|__4 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (let* [^Seqable xs xs] (.seq xs))))) ;; [t/iterable?] - (def seq|__33|input-types (*<> t/iterable?)) - (def ^Object>Object seq|__33 + (def seq|__5|input-types (*<> t/iterable?)) + (def ^Object>Object seq|__5 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (let* [^Iterable xs xs] (clojure.lang.RT/chunkIteratorSeq (.iterator xs)))))) ;; [t/char-seq?] - (def seq|__34|input-types (*<> t/iterable?)) - (def ^Object>Object seq|__34 + (def seq|__6|input-types (*<> t/iterable?)) + (def ^Object>Object seq|__6 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (let* [^CharSequence xs xs] (StringSeq/create xs))))) ;; [(t/isa? Map)] - (def seq|__35|input-types (*<> (t/isa? Map))) - (def ^Object>Object seq|__35 + (def seq|__7|input-types (*<> (t/isa? Map))) + (def ^Object>Object seq|__7 (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] ;; This is after expansion; it's the first one that matches the overload @@ -976,17 +959,34 @@ ;; equivalent) and potentially a configurable warning can be emitted (let [^Map xs xs] (.invoke seq|__4__0 (.entrySet xs)))))) + ;; [t/array?] + + ;; TODO perhaps at some point figure out that it doesn't need to create any more + ;; overloads here than just one? + (def seq|__8|input-types (*<> (t/isa? (Class/forName "[Z")))) + (def ^Object>Object seq|__8 + (reify Object>Object + (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] + (let* [^"[Z" xs xs] (ArraySeq/createFromObject xs))))) + + (def seq|__9|input-types (*<> (t/isa? (Class/forName "[B")))) + (def ^Object>Object seq|__9 + (reify Object>Object + (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] + (let* [^"[B" xs xs] (ArraySeq/createFromObject xs))))) + ... + (defn seq "Taken from `clojure.lang.RT/seq`" {::t/type (t/fn > (t/? (t/isa? ISeq)) [t/nil?] - [t/array?] [(t/isa? ASeq)] [(t/or (t/isa? LazySeq) (t/isa? Seqable))] [t/iterable?] [t/char-seq?] - [(t/isa? Map)])} + [(t/isa? Map)] + [t/array?])} [a0] (ifs ((Array/get seq|__0|input-types 0) a0) (.invoke seq|__0 a0) ((Array/get seq|__1|input-types 0) a0) (.invoke seq|__1 a0) From 3f031164d1087b43cd8cc47500669b346b665690 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 17 May 2018 02:28:18 -0600 Subject: [PATCH 062/810] Add closing notes for tonight --- src-dev/quantum/core/defnt.cljc | 25 +++++++++++++++++++++++-- 1 file changed, 23 insertions(+), 2 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 1e9ba266..1e078a3f 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -91,7 +91,7 @@ resolution will be done via Runtime Dispatch. - TODO Should we take into account 'actual' types (not just 'declared' types) when performing dispatch / overload resolution? - - Let's take the example of `(f (rand/int-between -10 -2))`. + - Let's take the example of `(defnt abcde [] (f (rand/int-between -10 -2)))`. - Let's say `rand/int-between`'s output is labeled `t/int?`. However, we know based on further static analysis of its implementation that the output is not only `t/int?` but also `t/neg?`, or perhaps even further, `(< -10 % -2)`. @@ -113,6 +113,25 @@ nothing else than to ensure that our implementation (as characterized by its 'actual' output type) matches what we expect (as characterized by its 'expected'/'declared' output type). + - One option (Option A) is to turn off compile-time overload resolution during development. + This would mean it might get very slow during that time. But if it's in the same `defnt` + (ignoring `extend-defnt!` for a minute) — like a recursive call — you could always leave + on compile-time resolution for that. + - Option B — probably better (though we'd still like to have all this configurable) — + is to have each function know its dependencies (this would actually have the bonus + property of enabling `clojure.tools.namespace.repl/refresh`-style function-level + smart auto-recompilation which is nice). So let's go back to the previous example. + `abcde` could keep track of (or the `defnt` ns could keep track of it, but you get the + point) the fact that it depends on `rand/int-between` and `f`. It has a compile-time- + resolvable call site that depends only on the output type of `rand/int-between` so if + `rand/int-between`'s computed/actual output type (when given the inputs in question) + ever changes, `abcde` needs to be recompiled and `abcde`'s output type recomputed. If, + on the other hand, `f`'s output type (given the input) ever changes, `abcde` need not be + recompiled, but rather, only its output type need be recomputed. + - I think this reactive approach (do we need a library for that? probably not?) should + solve our problems and let us code in a very flexible way. It'll just (currently) be a + way that depends on a compiler in which the metalanguage and object language are + identical. [ ] Runtime (Dynamic) Dispatch [—] Protocol generation - For now we won't do it because we can very often find the correct overload at compile @@ -141,7 +160,6 @@ with that label and replace the typedef in the typedef-set - Else a new label will be given to the `reify`; the typedef will be added to the typedef-set - - [ ] One reify per type that cannot be split - Only `t/or`s can be split for now - [ ] `(= (hash (t/or t/long? t/float?)) (hash (t/or t/long? t/float?)))` @@ -150,6 +168,9 @@ [ ] Types yielding generative specs [—] Types using the clojure.spec interface - Not yet; wait for it to come out of alpha +[—] Support for compilers in which the metalanguage differs from the object language (i.e. 'normal' + non-CLJS-in-CLJS CLJS) + - This will have to be approached later. We'll figure it out; maybe just not yet. [—] `extend-defnt!` - Not yet; probably complicated and we don't need it right now " From 6c25fce7407183943ad1c0264bc8fa465c9d9087 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 21 May 2018 22:12:52 -0600 Subject: [PATCH 063/810] VoltDB example --- doc/voltdb.sql | 85 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 85 insertions(+) create mode 100644 doc/voltdb.sql diff --git a/doc/voltdb.sql b/doc/voltdb.sql new file mode 100644 index 00000000..02f0176c --- /dev/null +++ b/doc/voltdb.sql @@ -0,0 +1,85 @@ +-- TODO performance-test this against Datomic! Generate a bunch of random data till it gets big + +drop table entities; + +-- TODO add a `tinyint` column for datatype for more efficient indexing +create table entities ( +-- time (transaction ID/instant; must be increasing; can be in nanos) +-- first for display purposes +t bigint not null, +-- entity ID +e bigint not null, +-- attribute +a varchar(128) not null, +-- value (serialized) +-- TODO change back to varbinary; just varchar for interactive testing +v varchar +); + +-- technically true as you should never assert the same thing in the same transaction +-- create unique index eavt on entities (e, a, v, t) + +-- Idea from https://docs.datomic.com/on-prem/indexes.html +-- TODO only index non- byte arrays +create index eavt on entities (e, a, v, t); +create index aevt on entities (a, e, v, t); +create index avet on entities (a, v, e, t); +create index vaet on entities (v, a, e, t); + +-- This is in order to do time-based iteration +create index t on entities (t); + +-- TODO is this wise? It seems the best partitioning but might not be +partition table entities on column t; + + +-- Multiple insert in one clause is not supported +insert into entities (t, e, a, v) values (0, -9223372036854775807, 'db|attribute' , 'db|attribute'); +insert into entities (t, e, a, v) values (0, -9223372036854775807, 'db|doc' , 'Marker for an attribute name'); +insert into entities (t, e, a, v) values (0, -9223372036854775806, 'db|attribute' , 'db|doc'); +insert into entities (t, e, a, v) values (0, -9223372036854775806, 'db|doc' , 'Attribute whose value supplies documentation'); +insert into entities (t, e, a, v) values (0, -9223372036854775805, 'db|attribute' , 'my|attribute'); +insert into entities (t, e, a, v) values (0, -9223372036854775805, 'db|doc' , 'Documentation for my attribute'); + +insert into entities (t, e, a, v) values (1, -9223372036854775804, 'my|attribute' , 'A value for my attribute. Yay!'); + +insert into entities (t, e, a, v) values (2, -9223372036854775803, 'db|attribute' , 'my|indexed-attribute'); + +-- Be careful to sanitize the names — shouldn't include `hash` in the name unless intentional +create index my_BAR_indexed_attribute__evt on entities (e, v, t) where a = 'db|attribute'; +create index my_BAR_indexed_attribute__vet on entities (v, e, t) where a = 'db|attribute'; + +insert into entities (t, e, a, v) values (3, -9223372036854775803, 'my|indexed-attribute', 'A value for my indexed attribute. Woohoo!'); + +-- next entity ID +select max(e) + 1 from entities; + +-- (BigInteger. (.getBytes "my-value!!")) -> "my-value!!" +-- (String. (.toByteArray (BigInteger. "516973278578607596577057"))) -> "my-value!!" + +-- Having a view of the DB at a point in time really is as trivial as `where t <= my_timestamp` + + + +-- [:find (count ?customer) . :in $ ?organization :where +-- [?concert :concert/organization ?organization] +-- [?booking :booking/concert ?concert] +-- [?booking :booking/customer ?customer]]-- + +-- TODO make sure revisions (changes in value of an identity across time) are addressed here +select customer.e + from entities as concert, + entities as booking, + entities as customer + where ( concert.a = "concert/organization" + and concert.v = "the-organization") + or ( booking.a = "booking/concert" + and booking.v = concert.e) + or ( booking.a = "booking/customer" + and booking.v = customer.e) + +-- This is probably as much effort as the type system. I think we should do it only when we start to +-- scale, and only if it proves to have performance gains that Datomic can't match. We should code +-- to the Datomic interface though. Plus if we preserve all the data in datom format, it's about the +-- easiest thing to migrate (in theory). Perhaps we should do it either way — having source code we +-- can configure and edit it really helpful. From 6f8f3c082ee3fd7e1078767fa3df866a5d9d5252 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 22 May 2018 13:54:55 -0600 Subject: [PATCH 064/810] Compilation fixes --- project-base.clj | 2 +- src-dev/quantum/core/defnt.cljc | 11 +++++------ src-dev/quantum/core/defnt_equivalences.cljc | 6 +++--- src-untyped/quantum/untyped/core/print/prettier.cljc | 7 ++++--- 4 files changed, 13 insertions(+), 13 deletions(-) diff --git a/project-base.clj b/project-base.clj index b4851058..c6bb39b0 100644 --- a/project-base.clj +++ b/project-base.clj @@ -407,7 +407,7 @@ '[quantum.untyped.core.log :refer [prl!]]) (quantum.untyped.core.print.prettier/extend-pretty-printing!) (reset! quantum.untyped.core.error/*pr-data-to-str? true) - (clojure.main/repl + #_(clojure.main/repl :print #(binding [*print-meta* true quantum.untyped.core.print/*collapse-symbols?* true quantum.untyped.core.print/*print-as-code?* true] diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 1e078a3f..10c805e8 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -113,11 +113,11 @@ nothing else than to ensure that our implementation (as characterized by its 'actual' output type) matches what we expect (as characterized by its 'expected'/'declared' output type). - - One option (Option A) is to turn off compile-time overload resolution during development. - This would mean it might get very slow during that time. But if it's in the same `defnt` - (ignoring `extend-defnt!` for a minute) — like a recursive call — you could always leave - on compile-time resolution for that. - - Option B — probably better (though we'd still like to have all this configurable) — + - One option (Option A) is to turn off compile-time overload resolution during + development. This would mean it might get very slow during that time. But if it's in + the same `defnt` (ignoring `extend-defnt!` for a minute) — like a recursive call — you + could always leave on compile-time resolution for that. + - Option B — probably better (though we'd still like to have all this configurable) — is to have each function know its dependencies (this would actually have the bonus property of enabling `clojure.tools.namespace.repl/refresh`-style function-level smart auto-recompilation which is nice). So let's go back to the previous example. @@ -1054,7 +1054,6 @@ fn-codelist (case lang :clj (->> `[~@direct-dispatch-codelist - ~@dynamic-dispatch-codelist ~@base-fn-codelist] (remove nil?)) :cljs (TODO)) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 3a06dad4..a5634c5c 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -5,7 +5,7 @@ (:require [clojure.core :as c] [quantum.core.defnt - :refer [analyze defnt fnt|code *fn->spec]] + :refer [analyze defnt fnt|code *fn->type]] [quantum.untyped.core.analyze.expr :as xp] [quantum.untyped.core.collections.diff :as diff :refer [diff]] @@ -53,8 +53,8 @@ ($ (do (def ~'pid|__0 (reify >Object (~(tag "java.lang.Object" 'invoke) [~'_] - (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) - (.getName))))) + ~'(->> (java.lang.management.ManagementFactory/getRuntimeMXBean) + (.getName))))) #_(defn ~'pid {::t/spec (t/fn [:> (? t/string?)])}))) diff --git a/src-untyped/quantum/untyped/core/print/prettier.cljc b/src-untyped/quantum/untyped/core/print/prettier.cljc index 56359e8c..62acda38 100644 --- a/src-untyped/quantum/untyped/core/print/prettier.cljc +++ b/src-untyped/quantum/untyped/core/print/prettier.cljc @@ -49,8 +49,9 @@ (defn visit-symbol* [x] [:text (cond-> x - quantum.core.print/*collapse-symbols?* - (quantum.untyped.core.qualify/collapse-symbol (not quantum.core.print/*print-as-code?*)))]) + quantum.untyped.core.print/*collapse-symbols?* + (quantum.untyped.core.qualify/collapse-symbol + (not quantum.untyped.core.print/*print-as-code?*)))]) (defn visit-fn [visitor x] [:group "#" "fn" " " (-> x quantum.untyped.core.convert/>symbol visit-symbol*)]) @@ -60,7 +61,7 @@ [visitor x] (cond (nil? x) (visit-nil visitor) - (quantum.core.print/group? x) + (quantum.untyped.core.print/group? x) (fipp.edn/pretty-coll visitor "" (.-xs ^quantum.untyped.core.print.Group x) :line "" visit) (fipp.ednize/override? x) (visit-unknown visitor x) (boolean? x) (visit-boolean visitor x) From 8373356bc69e3de0c14ce8e6121048d7e9b1de69 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 18 Jun 2018 01:43:46 -0600 Subject: [PATCH 065/810] Remove conflicting asset path --- project-base.clj | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/project-base.clj b/project-base.clj index c6bb39b0..8eacd058 100644 --- a/project-base.clj +++ b/project-base.clj @@ -427,10 +427,7 @@ ;; relative to `server-root-path` asset-path (str "generated" "/" (name kind) - "/" (if (and (#{:ios :android} id-base) - (= id-suffix :quantum-dynamic-source-untyped)) - (name id-base) - id) + "/" id "/" "js") output-dir (str server-root-path "/" asset-path)] (cond-> From da3ce1745afa5ca634e9e27066978db372a0159a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 18 Jun 2018 01:43:59 -0600 Subject: [PATCH 066/810] Fix arity error --- src-untyped/quantum/untyped/core/collections.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index 3bcb0c57..5a584147 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -31,7 +31,7 @@ (defn first [xs] (if (ur/transformer? xs) - (educe first|rf) + (educe first|rf xs) (core/first xs))) ;; ===== SOCIATIVE ===== ;; From d792fcc97a012a8a4303804176c08f4c83236743 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 18 Jun 2018 01:44:32 -0600 Subject: [PATCH 067/810] Fix some CLJS issues --- src-untyped/quantum/untyped/core/core.cljc | 9 +- .../quantum/untyped/core/print/prettier.cljc | 173 +++++++++--------- src-untyped/quantum/untyped/core/qualify.cljc | 2 +- .../quantum/untyped/core/reducers.cljc | 38 ++-- src-untyped/quantum/untyped/core/spec.cljc | 6 +- src-untyped/quantum/untyped/core/specs.cljc | 12 +- src-untyped/quantum/untyped/core/type.cljc | 37 ++-- src-untyped/quantum/untyped/core/vars.cljc | 18 +- .../quantum/untyped/ui/style/color.cljc | 6 +- src/quantum/core/string/regex.cljc | 4 +- 10 files changed, 160 insertions(+), 145 deletions(-) diff --git a/src-untyped/quantum/untyped/core/core.cljc b/src-untyped/quantum/untyped/core/core.cljc index 32d09b1d..7a4cdaf8 100644 --- a/src-untyped/quantum/untyped/core/core.cljc +++ b/src-untyped/quantum/untyped/core/core.cljc @@ -1,8 +1,9 @@ (ns quantum.untyped.core.core - (:require -#?@(:clj - [[environ.core :as env]]) - [cuerdas.core :as str+])) + (:require + #?@(:clj [[environ.core :as env]]) + [cuerdas.core :as str+]) +#?(:cljs (:require-macros + [quantum.untyped.core.core :as this]))) ;; ===== Environment ===== ;; diff --git a/src-untyped/quantum/untyped/core/print/prettier.cljc b/src-untyped/quantum/untyped/core/print/prettier.cljc index 62acda38..a05079eb 100644 --- a/src-untyped/quantum/untyped/core/print/prettier.cljc +++ b/src-untyped/quantum/untyped/core/print/prettier.cljc @@ -21,11 +21,12 @@ #?(:clj (prefer-method print-method fipp.ednize.IEdn clojure.lang.ISeq)) #?(:clj (prefer-method print-method clojure.lang.IRecord Throwable)) -(in-ns 'fipp.visit) +#?(:clj (in-ns 'fipp.visit)) +#?(:clj (defn- transient-vector? [x] (instance? #?(:clj clojure.lang.ITransientVector - :cljs cljs.core/TransientVector) x)) + :cljs cljs.core/TransientVector) x))) ;; TODO more efficient ;; TODO move? @@ -47,15 +48,18 @@ Iterable (iterator [this] (IntIndexedIterator. 0 (count xs) xs)))) +#?(:clj (defn visit-symbol* [x] [:text (cond-> x quantum.untyped.core.print/*collapse-symbols?* (quantum.untyped.core.qualify/collapse-symbol - (not quantum.untyped.core.print/*print-as-code?*)))]) + (not quantum.untyped.core.print/*print-as-code?*)))])) +#?(:clj (defn visit-fn [visitor x] - [:group "#" "fn" " " (-> x quantum.untyped.core.convert/>symbol visit-symbol*)]) + [:group "#" "fn" " " (-> x quantum.untyped.core.convert/>symbol visit-symbol*)])) +#?(:clj (defn visit* "Visits objects, ignoring metadata." [visitor x] @@ -83,93 +87,94 @@ [:group "#" (pr-str '!+) (when (and (:print-meta visitor) (meta (:form visitor))) " ") (visit-vector visitor (IntIndexedIterable. x))] - :else (visit-unknown visitor x))) + :else (visit-unknown visitor x)))) +#?(:clj (defn visit [visitor x] (let [m (meta x)] (if (and m (not (var? x))) (visit-meta visitor m x) - (visit* visitor x)))) + (visit* visitor x))))) -(in-ns 'quantum.untyped.core.print.prettier) +#?(:clj (in-ns 'quantum.untyped.core.print.prettier)) (defn extend-pretty-printing! [] - (extend-type java.util.ArrayList - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal '! (vec this)))) ; TODO faster - (extend-type it.unimi.dsi.fastutil.longs.LongArrayList - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal '!l (vec this)))) ; TODO faster + #?(:clj + (do (extend-type java.util.ArrayList + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal '! (vec this)))) ; TODO faster + (extend-type it.unimi.dsi.fastutil.longs.LongArrayList + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal '!l (vec this)))) ; TODO faster - (extend-type (Class/forName "[Z") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal '?<> (vec this)))) ; TODO faster - (extend-type (Class/forName "[B") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'b<> (vec this)))) ; TODO faster - (extend-type (Class/forName "[C") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'c<> (vec this)))) ; TODO faster - (extend-type (Class/forName "[[C") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'c<><> (into [] this)))) ; TODO faster - (extend-type (Class/forName "[S") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 's<> (vec this)))) ; TODO faster - (extend-type (Class/forName "[I") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'i<> (vec this)))) ; TODO faster - (extend-type (Class/forName "[J") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'l<> (vec this)))) ; TODO ->vec for this - (extend-type (Class/forName "[F") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'f<> (vec this)))) ; TODO faster - (extend-type (Class/forName "[D") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'd<> (vec this)))) ; TODO ->vec for this - (extend-type (Class/forName "[[D") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'd<><> (into [] this)))) ; TODO faster - (extend-type (Class/forName "[Ljava.lang.Object;") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal '*<> (vec this)))) ; TODO faster - (extend-type (Class/forName "[[Ljava.lang.Object;") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal '*<><> (into [] this)))) ; TODO faster - (extend-type (Class/forName "[Ljava.lang.Class;") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'class<> (vec this)))) ; TODO faster + (extend-type (Class/forName "[Z") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal '?<> (vec this)))) ; TODO faster + (extend-type (Class/forName "[B") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'b<> (vec this)))) ; TODO faster + (extend-type (Class/forName "[C") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'c<> (vec this)))) ; TODO faster + (extend-type (Class/forName "[[C") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'c<><> (into [] this)))) ; TODO faster + (extend-type (Class/forName "[S") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 's<> (vec this)))) ; TODO faster + (extend-type (Class/forName "[I") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'i<> (vec this)))) ; TODO faster + (extend-type (Class/forName "[J") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'l<> (vec this)))) ; TODO ->vec for this + (extend-type (Class/forName "[F") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'f<> (vec this)))) ; TODO faster + (extend-type (Class/forName "[D") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'd<> (vec this)))) ; TODO ->vec for this + (extend-type (Class/forName "[[D") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'd<><> (into [] this)))) ; TODO faster + (extend-type (Class/forName "[Ljava.lang.Object;") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal '*<> (vec this)))) ; TODO faster + (extend-type (Class/forName "[[Ljava.lang.Object;") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal '*<><> (into [] this)))) ; TODO faster + (extend-type (Class/forName "[Ljava.lang.Class;") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'class<> (vec this)))) ; TODO faster - (extend-type java.util.HashMap - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal '! (into {} this)))) - (extend-type java.util.concurrent.ConcurrentHashMap - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal '!! (into {} this)))) ; TODO ->map - (extend-type quantum.core.error.Error - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (tagged-literal 'err (into {} this)))) - (extend-type (Class/forName "[Ljava.lang.StackTraceElement;") - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (mapv (rcomp StackTraceElement->vec str symbol) this))) - ) + (extend-type java.util.HashMap + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal '! (into {} this)))) + (extend-type java.util.concurrent.ConcurrentHashMap + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal '!! (into {} this)))) ; TODO ->map + (extend-type quantum.core.error.Error + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal 'err (into {} this)))) + (extend-type (Class/forName "[Ljava.lang.StackTraceElement;") + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (mapv (rcomp StackTraceElement->vec str symbol) this)))))) diff --git a/src-untyped/quantum/untyped/core/qualify.cljc b/src-untyped/quantum/untyped/core/qualify.cljc index 18fc88ce..5e6ee36f 100644 --- a/src-untyped/quantum/untyped/core/qualify.cljc +++ b/src-untyped/quantum/untyped/core/qualify.cljc @@ -7,7 +7,7 @@ [quantum.untyped.core.core :as ucore] [quantum.untyped.core.ns :as uns] [quantum.untyped.core.type.predicates - :refer [namespace?]])) + #?@(:clj [:refer [namespace?]])])) (ucore/log-this-ns) diff --git a/src-untyped/quantum/untyped/core/reducers.cljc b/src-untyped/quantum/untyped/core/reducers.cljc index d35606b3..f89e53c9 100644 --- a/src-untyped/quantum/untyped/core/reducers.cljc +++ b/src-untyped/quantum/untyped/core/reducers.cljc @@ -1,22 +1,24 @@ (ns quantum.untyped.core.reducers - (:refer-clojure :exclude [apply every? vec == for seqable?]) - (:require - [clojure.core :as core] - [clojure.core.reducers :as r] - [fast-zip.core :as zip] - [quantum.untyped.core.compare :as comp - :refer [== not==]] - [quantum.untyped.core.core :as ucore - :refer [>sentinel]] - [quantum.untyped.core.error - :refer [err!]] - [quantum.untyped.core.form.evaluate - :refer [case-env]] - [quantum.untyped.core.qualify :as qual] - [quantum.untyped.core.type.predicates - :refer [seqable?]] - [quantum.untyped.core.vars :as uvar - :refer [defalias]])) + (:refer-clojure :exclude [apply every? vec == for seqable?]) + (:require + [clojure.core :as core] + [clojure.core.reducers :as r] + [fast-zip.core :as zip] + [quantum.untyped.core.compare :as comp + :refer [== not==]] + [quantum.untyped.core.core :as ucore + :refer [>sentinel]] + [quantum.untyped.core.error + :refer [err!]] + [quantum.untyped.core.form.evaluate + :refer [case-env]] + [quantum.untyped.core.qualify :as qual] + [quantum.untyped.core.type.predicates + :refer [seqable?]] + [quantum.untyped.core.vars :as uvar + :refer [defalias]]) +#?(:cljs (:require-macros + [quantum.untyped.core.reducers :as this]))) (ucore/log-this-ns) diff --git a/src-untyped/quantum/untyped/core/spec.cljc b/src-untyped/quantum/untyped/core/spec.cljc index ad90e48a..0a69d31b 100644 --- a/src-untyped/quantum/untyped/core/spec.cljc +++ b/src-untyped/quantum/untyped/core/spec.cljc @@ -133,6 +133,8 @@ #?(:clj (quantum.untyped.core.vars/defmalias conformer clojure.spec.alpha/conformer cljs.spec.alpha/conformer)) +#?(:clj (quantum.untyped.core.vars/defmalias nilable clojure.spec.alpha/nilable cljs.spec.alpha/nilable)) + (defalias s/conform) (defalias s/nonconforming) (defalias • nonconforming) @@ -140,8 +142,6 @@ (defalias s/explain-data) (defalias s/describe) -(defalias s/nilable) - #?(:clj (quantum.untyped.core.vars/defmalias cat clojure.spec.alpha/cat cljs.spec.alpha/cat)) #?(:clj (defmacro cat* "`or` :`or*` :: `cat` : `cat*`" [& args] `(cat ~@(udata/quote-map-base uconv/>keyword args true)))) @@ -289,7 +289,7 @@ "Based on `s/map-spec-impl`" ([k->s #_(s/map-of any? specable?)] (kv k->s nil)) ([k->s #_(s/map-of any? specable?) gen-fn #_(? fn?)] - (let [id (java.util.UUID/randomUUID) + (let [id (#?(:clj java.util.UUID/randomUUID :cljs random-uuid)) k->s|desc (->> k->s (map (fn [[k specable]] [k (if (ident? specable) specable (s/describe specable))])) diff --git a/src-untyped/quantum/untyped/core/specs.cljc b/src-untyped/quantum/untyped/core/specs.cljc index 31b1090f..e2b74b7b 100644 --- a/src-untyped/quantum/untyped/core/specs.cljc +++ b/src-untyped/quantum/untyped/core/specs.cljc @@ -9,7 +9,11 @@ :refer [fn1 fnl]] [quantum.untyped.core.spec :as s] [quantum.untyped.core.type.predicates - :refer [val?]])) + :refer [val?]]) +#?(:cljs + (:require-macros + [quantum.untyped.core.specs :as this + :refer [quotable]]))) ;;;; GENERAL @@ -88,9 +92,9 @@ :varargs (s/? (s/cat :amp #{'&} :form :quantum.core.specs/binding-form))))) (s/def :quantum.core.specs/fn|prepost - (s/and (s/keys :req-un [(or :quantum.core.specs/core/pre :quantum.core.specs/core/post)]) ; TODO we actually really only want to accept un-namespaced keys... - (s/conformer #(set/rename-keys % {:quantum.core.specs/core/pre :pre - :quantum.core.specs/core/post :post})))) + (s/and (s/keys :req-un [(or :quantum.core.specs.core/pre :quantum.core.specs.core/post)]) ; TODO we actually really only want to accept un-namespaced keys... + (s/conformer #(set/rename-keys % {:quantum.core.specs.core/pre :pre + :quantum.core.specs.core/post :post})))) (s/def :quantum.core.specs/fn|body (s/alt :prepost+body (s/cat :prepost :quantum.core.specs/fn|prepost diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 6c559c21..37dbbbab 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -10,7 +10,7 @@ nil? any? class? tagged-literal? #?(:cljs object?) number? decimal? bigdec? integer? ratio? true? false? keyword? string? symbol? - associative? coll? counted? indexed? list? map? map-entry? record? + array? associative? coll? counted? indexed? list? map? map-entry? record? seq? seqable? sequential? set? sorted? vector? fn? ifn? meta @@ -59,7 +59,7 @@ :refer [def- defmacro- update-meta]]) #?(:cljs (:require-macros [quantum.untyped.core.type :as self - :refer [-def]])) + :refer [-def def-preds|map|any def-preds|map|same-types]])) #?(:clj (:import [quantum.untyped.core.analyze.expr Expression] [quantum.untyped.core.type.reifications @@ -730,7 +730,7 @@ (isa? quantum.core.data.finger_tree.CountedDoubleList)) :cljs (isa? quantum.core.data.finger-tree/CountedDoubleList))) (-def +list? (isa? #?(:clj clojure.lang.IPersistentList :cljs cljs.core/IList))) - (-def !list? #?(:clj (isa? java.util.LinkedList))) + (-def !list? #?(:clj (isa? java.util.LinkedList) :cljs none?)) (-def list? #?(:clj (isa? java.util.List) :cljs +list?)) @@ -1541,13 +1541,15 @@ (-def !+sorted-set? none?) (-def ?!+sorted-set? (or +sorted-set? !+sorted-set?)) -#?(:clj (-def !sorted-set|byte? (isa? it.unimi.dsi.fastutil.bytes.ByteSortedSet))) -#?(:clj (-def !sorted-set|short? (isa? it.unimi.dsi.fastutil.shorts.ShortSortedSet))) -#?(:clj (-def !sorted-set|char? (isa? it.unimi.dsi.fastutil.chars.CharSortedSet))) -#?(:clj (-def !sorted-set|int? (isa? it.unimi.dsi.fastutil.ints.IntSortedSet))) -#?(:clj (-def !sorted-set|long? (isa? it.unimi.dsi.fastutil.longs.LongSortedSet))) -#?(:clj (-def !sorted-set|float? (isa? it.unimi.dsi.fastutil.floats.FloatSortedSet))) -#?(:clj (-def !sorted-set|double? (isa? it.unimi.dsi.fastutil.doubles.DoubleSortedSet))) + (-def !sorted-set|byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.ByteSortedSet) + :cljs none?)) + (-def !sorted-set|short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.ShortSortedSet) :cljs none?)) + (-def !sorted-set|char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.CharSortedSet) :cljs none?)) + (-def !sorted-set|int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.IntSortedSet) :cljs none?)) + (-def !sorted-set|long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.LongSortedSet) :cljs none?)) + (-def !sorted-set|float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.FloatSortedSet) :cljs none?)) + (-def !sorted-set|double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.DoubleSortedSet) + :cljs none?)) ;; CLJS technically can have via goog.structs.AVLTree with same KVs but this hasn't been implemented yet (-def !sorted-set|ref? #?(:clj (isa? java.util.TreeSet) :cljs none?)) @@ -1580,7 +1582,7 @@ ;; ----- General Sets ----- ;; (-def !+set? (isa? #?(:clj clojure.lang.ITransientSet - :cljs cljs.core/ITransientSet))) + :cljs cljs.core/ITransientSet))) (-def +set|built-in? (or (isa? #?(:clj clojure.lang.PersistentHashSet :cljs cljs.core/PersistentHashSet)) (isa? #?(:clj clojure.lang.PersistentTreeSet :cljs cljs.core/PersistentTreeSet)))) @@ -1603,7 +1605,6 @@ !set|int? !set|long? !set|float? !set|double?)) - (-def !set? (or !unsorted-set? !sorted-set?)) #?(:clj (-def !!set? (or !!unsorted-set? !!sorted-set?))) (-def set? (or ?!+set? !set? #?@(:clj [!!set? (isa? java.util.Set)]))) @@ -1680,12 +1681,12 @@ ;; ----- Collections ----- ;; - (-def sorted? #?(:clj (or (isa? #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) - #?@(:clj [(isa? java.util.SortedMap) - (isa? java.util.SortedSet)] - :cljs [(isa? goog.structs.AvlTree)]) - ;; TODO implement — monotonically <, <=, =, >=, > - #_(>expr monotonic?)))) + (-def sorted? (or (isa? #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) + #?@(:clj [(isa? java.util.SortedMap) + (isa? java.util.SortedSet)] + :cljs [(isa? goog.structs.AvlTree)]) + ;; TODO implement — monotonically <, <=, =, >=, > + #_(>expr monotonic?))) (-def transient? (isa? #?(:clj clojure.lang.ITransientCollection :cljs cljs.core/ITransientCollection))) diff --git a/src-untyped/quantum/untyped/core/vars.cljc b/src-untyped/quantum/untyped/core/vars.cljc index a3bdbed4..c1770f0e 100644 --- a/src-untyped/quantum/untyped/core/vars.cljc +++ b/src-untyped/quantum/untyped/core/vars.cljc @@ -1,12 +1,14 @@ (ns quantum.untyped.core.vars - (:refer-clojure :exclude [defonce]) - (:require - [clojure.core :as core] - [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.form :as uform] - [quantum.untyped.core.form.evaluate - :refer [case-env case-env*]] - [quantum.untyped.core.form.generate :as ufgen])) + (:refer-clojure :exclude [defonce]) + (:require + [clojure.core :as core] + [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.form :as uform] + [quantum.untyped.core.form.evaluate + :refer [case-env case-env*]] + [quantum.untyped.core.form.generate :as ufgen]) +#?(:cljs (:require-macros + [quantum.untyped.core.vars :as this]))) (ucore/log-this-ns) diff --git a/src-untyped/quantum/untyped/ui/style/color.cljc b/src-untyped/quantum/untyped/ui/style/color.cljc index 604be459..77a4ee4e 100644 --- a/src-untyped/quantum/untyped/ui/style/color.cljc +++ b/src-untyped/quantum/untyped/ui/style/color.cljc @@ -1,9 +1,9 @@ (ns quantum.untyped.ui.style.color (:require - [clojure.string :as str] - [garden.color :as color + [clojure.string :as str] + [garden.color :as color #?@(:cljs [:refer [CSSColor]])] - [quantum.core.vars :as var + [quantum.untyped.core.vars :as uvar :refer [defalias]]) #?(:clj (:import diff --git a/src/quantum/core/string/regex.cljc b/src/quantum/core/string/regex.cljc index c45e86ae..b277e9eb 100644 --- a/src/quantum/core/string/regex.cljc +++ b/src/quantum/core/string/regex.cljc @@ -29,8 +29,8 @@ #"\b") ; TODO: not using ccoll because this namespace is required for `defnt` -(defn conjr!* [#?(:clj ^StringBuilder !s :cljs StringBuffer !s) x] (.append !s x)) -(defn conjl!* [#?(:clj ^StringBuilder !s :cljs StringBuffer !s) x] +(defn conjr!* [#?(:clj ^StringBuilder !s :cljs ^StringBuffer !s) x] (.append !s x)) +(defn conjl!* [#?(:clj ^StringBuilder !s :cljs ^StringBuffer !s) x] #?(:clj (.insert !s 0 x) :cljs (-> (!str) (.append x) (.append !s)))) From 02d66e0dc46ce0516bc6d116d96021e27ee87624 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 18 Jun 2018 09:20:18 -0600 Subject: [PATCH 068/810] Fix CLJS compilation --- src-untyped/quantum/untyped/core/data/hash.cljc | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/hash.cljc b/src-untyped/quantum/untyped/core/data/hash.cljc index d1f86729..0feafd6f 100644 --- a/src-untyped/quantum/untyped/core/data/hash.cljc +++ b/src-untyped/quantum/untyped/core/data/hash.cljc @@ -1,8 +1,10 @@ (ns quantum.untyped.core.data.hash - (:refer-clojure :exclude - [hash]) - (:require - [clojure.core :as core])) + (:refer-clojure :exclude + [hash]) + (:require + [clojure.core :as core]) +#?(:cljs (:require-macros + [quantum.untyped.core.data.hash :as this]))) (def ^:const default -1) From 15dd17a3f52d5e458b78f60568f9909b538acba0 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 18 Jun 2018 09:20:34 -0600 Subject: [PATCH 069/810] CLJS had an obscure env issue --- project-base.clj | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/project-base.clj b/project-base.clj index 8eacd058..a740cb35 100644 --- a/project-base.clj +++ b/project-base.clj @@ -26,7 +26,7 @@ (reduce merge2 maps)))) (def clj-dependency '[org.clojure/clojure "1.9.0"]) -(def cljs-dependency '[org.clojure/clojurescript "1.9.946"]) +(def cljs-dependency '[org.clojure/clojurescript "1.10.312"]) (def latest-stable-quantum-version "fc7a78bc" ; stable for backend use; mainly stable for frontend @@ -97,8 +97,9 @@ [quantum/org.clojure.core.rrb-vector "0.0.12"] [org.clojure/data.finger-tree "0.0.2"] ; MAP / SET - ;; Superseded by `frankiesardo/linked` - #_[org.flatland/ordered "1.5.3"] + ;; Superseded by `frankiesardo/linked` but for now frankiesardo/linked doesn't have e.g. + ;; `.keySet` support so we keep `org.flatland/ordered` for Clojure + [org.flatland/ordered "1.5.3"] [frankiesardo/linked "1.2.9"] [org.clojure/data.avl "0.0.13"] [org.clojure/data.int-map "0.2.4"] From 5e8f13ed0697cd2227ab21787569281b23899d3d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 18 Jun 2018 09:20:48 -0600 Subject: [PATCH 070/810] CLJ to prefer flatland.ordered.map for now --- src-untyped/quantum/untyped/core/data/map.cljc | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/map.cljc b/src-untyped/quantum/untyped/core/data/map.cljc index 5f434eef..f8e0dd59 100644 --- a/src-untyped/quantum/untyped/core/data/map.cljc +++ b/src-untyped/quantum/untyped/core/data/map.cljc @@ -7,7 +7,8 @@ (:require [clojure.core :as core] [clojure.data.avl :as avl ] - [linked.core :as linked] +#?(:clj [flatland.ordered.map :as ordered-map] + :cljs [linked.core :as ordered-map]) #?@(:clj [[clojure.data.int-map :as imap] [seqspert.hash-map]]) @@ -38,7 +39,7 @@ (defalias array-map core/array-map) (defalias hash-map core/hash-map) - (defalias ordered-map linked/map) + (defalias ordered-map ordered-map/map) (defalias om ordered-map) #?(:clj (defn ^java.util.LinkedHashMap !ordered-map [] (java.util.LinkedHashMap.))) From b16dfe0b843829df6c42f367d8b472ec65ab721a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 18 Jun 2018 09:23:56 -0600 Subject: [PATCH 071/810] Compilation --- src-untyped/quantum/untyped/core/data/map.cljc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/map.cljc b/src-untyped/quantum/untyped/core/data/map.cljc index f8e0dd59..294a27d5 100644 --- a/src-untyped/quantum/untyped/core/data/map.cljc +++ b/src-untyped/quantum/untyped/core/data/map.cljc @@ -8,7 +8,7 @@ [clojure.core :as core] [clojure.data.avl :as avl ] #?(:clj [flatland.ordered.map :as ordered-map] - :cljs [linked.core :as ordered-map]) + :cljs [linked.core :as linked]) #?@(:clj [[clojure.data.int-map :as imap] [seqspert.hash-map]]) @@ -39,7 +39,7 @@ (defalias array-map core/array-map) (defalias hash-map core/hash-map) - (defalias ordered-map ordered-map/map) + (defalias ordered-map #?(:clj ordered-map/ordered-map :cljs linked/map)) (defalias om ordered-map) #?(:clj (defn ^java.util.LinkedHashMap !ordered-map [] (java.util.LinkedHashMap.))) From 4c46f164b5c745fa6fb19961a67f6a98119bfaf7 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 18 Jun 2018 09:26:25 -0600 Subject: [PATCH 072/810] CLJS compilation in quantum.untyped.core.defnt --- src-untyped/quantum/untyped/core/defnt.cljc | 131 +++++++++++--------- 1 file changed, 74 insertions(+), 57 deletions(-) diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index 8cb78152..960bbb59 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -1,20 +1,23 @@ (ns quantum.untyped.core.defnt - "Primarily for `(de)fns`." - (:refer-clojure :exclude [any? ident? qualified-keyword? seqable? simple-symbol?]) - (:require - [clojure.spec.alpha :as s] - [clojure.spec.gen.alpha :as gen] - [quantum.untyped.core.convert :as uconv] - [quantum.untyped.core.data.map - :refer [om]] - [quantum.untyped.core.form.evaluate :as ufeval] - [quantum.untyped.core.loops - :refer [reduce-2]] - [quantum.untyped.core.reducers :as ur] - [quantum.untyped.core.spec :as us] - [quantum.untyped.core.specs] - [quantum.untyped.core.type.predicates - :refer [any? ident? qualified-keyword? seqable? simple-symbol?]])) + "Primarily for `(de)fns`." + (:refer-clojure :exclude [any? ident? qualified-keyword? seqable? simple-symbol?]) + (:require + [clojure.spec.alpha :as s] + [clojure.spec.gen.alpha :as gen] + [quantum.untyped.core.convert :as uconv] + [quantum.untyped.core.data.map + :refer [om]] + [quantum.untyped.core.form.evaluate :as ufeval] + [quantum.untyped.core.loops + :refer [reduce-2]] + [quantum.untyped.core.reducers :as ur] + [quantum.untyped.core.spec :as us] + [quantum.untyped.core.specs] + [quantum.untyped.core.type.predicates + :refer [any? ident? qualified-keyword? seqable? simple-symbol?]]) +#?(:cljs + (:require-macros + [quantum.untyped.core.defnt :as this]))) ;; ===== Specs ===== ;; @@ -157,6 +160,10 @@ ;; ===== Implementation ===== ;; +(defn- qualify-spec [lang sym] + (symbol (name (case :clj 'clojure.spec.alpha :cljs 'cljs.spec.alpha)) + (name sym))) + (defn >seq-destructuring-spec "Creates a spec that performs seq destructuring, and provides a default generator for such based on the generators of the destructured args." @@ -190,34 +197,39 @@ (defmacro seq-destructure "If `generate-from-seq-spec?` is true, generates from `seq-spec`'s generator instead of the default generation strategy based on the generators of the destructured args." - [seq-spec #_any? args #_(s/* (s/cat :k keyword? :spec any?)) + [lang seq-spec #_any? args #_(s/* (s/cat :k keyword? :spec any?)) & [varargs #_(s/nilable (s/cat :k keyword? :spec any?))]] (let [opts (meta seq-spec) args (us/assert-conform (s/* (s/cat :k keyword? :spec any?)) args) varargs (us/assert-conform (s/nilable (s/cat :k keyword? :spec any?)) varargs) args-ct>args-kw #(keyword (str "args-" %)) arity>cat (fn [arg-i] - `(s/cat ~@(->> args (take arg-i) - (map (fn [{:keys [k spec]}] [k `any?])) - (apply concat)))) + `(~(qualify-spec lang 'cat) + ~@(->> args (take arg-i) + (map (fn [{:keys [k spec]}] [k `any?])) + (apply concat)))) most-complex-positional-destructurer-sym (gensym "most-complex-positional-destructurer")] `(let [~most-complex-positional-destructurer-sym - (s/cat ~@(->> args - (map (fn [{:keys [k]}] [k `any?])) - (apply concat)) - ~@(when varargs [(:k varargs) `(s/& (s/+ any?) (s/conformer seq identity))])) + (~(qualify-spec lang 'cat) + ~@(->> args + (map (fn [{:keys [k]}] [k `any?])) + (apply concat)) + ~@(when varargs [(:k varargs) + `(~(qualify-spec lang '&) + (~(qualify-spec lang '+) any?) + (~(qualify-spec lang 'conformer) seq identity))])) positional-destructurer# - (s/or :args-0 (s/cat) - ~@(->> (range (count args)) - (map (fn [i] [(args-ct>args-kw (inc i)) (arity>cat (inc i))])) - (apply concat)) - ~@(when varargs [:varargs most-complex-positional-destructurer-sym])) + (~(qualify-spec lang 'or) :args-0 (~(qualify-spec lang 'cat)) + ~@(->> (range (count args)) + (map (fn [i] [(args-ct>args-kw (inc i)) (arity>cat (inc i))])) + (apply concat)) + ~@(when varargs [:varargs most-complex-positional-destructurer-sym])) kv-spec# (us/kv (om ~@(apply concat (cond-> (->> args (map (fn [{:keys [k spec]}] [k spec]))) varargs (concat [[(:k varargs) (:spec varargs)]]))))) or|conformer# - (s/conformer + (~(qualify-spec lang 'conformer) (fn or|conformer# [m#] [(case (count m#) ~@(->> (range (inc (count args))) @@ -229,13 +241,14 @@ kv-spec# or|conformer# ~seq-spec ~opts))))) #?(:clj -(defmacro map-destructure [map-spec #_any? kv-specs #_(s/map-of any? any?)] +(defmacro map-destructure [lang map-spec #_any? kv-specs #_(s/map-of any? any?)] (let [kv-spec-sym (gensym "kv-spec") {:as opts generate-from-map-spec? :gen?} (meta map-spec)] `(let [~kv-spec-sym (us/kv ~kv-specs)] ~(if generate-from-map-spec? - `(s/and ~map-spec ~kv-spec-sym) - `(s/with-gen (s/and ~map-spec ~kv-spec-sym) (fn [] (s/gen ~kv-spec-sym)))))))) + `(~(qualify-spec lang 'and) ~map-spec ~kv-spec-sym) + `(~(qualify-spec lang 'with-gen) (~(qualify-spec lang 'and) ~map-spec ~kv-spec-sym) + (fn [] (~(qualify-spec lang 'gen) ~kv-spec-sym)))))))) (defn speced-binding>binding [{[kind binding-] :binding-form} #_:quantum.core.defnt/speced-binding] (case kind @@ -267,18 +280,18 @@ (declare speced-binding>spec) (defn- speced-binding|seq>spec - [{:as speced-binding [kind binding-] :binding-form [spec-kind spec] :spec}] - `(seq-destructure ~(if (= spec-kind :spec) spec `seqable?) + [lang {:as speced-binding [kind binding-] :binding-form [spec-kind spec] :spec}] + `(seq-destructure ~lang ~(if (= spec-kind :spec) spec `seqable?) ~(->> binding- :elems (map-indexed (fn [i|arg arg|speced-binding] [(speced-binding>arg-ident arg|speced-binding i|arg) - (speced-binding>spec arg|speced-binding)])) + (speced-binding>spec lang arg|speced-binding)])) (apply concat) vec) ~@(when-let [varargs|speced-binding (get-in binding- [:rest :form])] [[(speced-binding>arg-ident varargs|speced-binding) - (speced-binding>spec varargs|speced-binding)]]))) + (speced-binding>spec lang varargs|speced-binding)]]))) (defn- keys||strs||syms>key-specs [kind #_#{:keys :strs :syms} speced-bindings] (let [binding-form>key @@ -289,33 +302,34 @@ [(binding-form>key binding-form) spec]))))) (defn- speced-binding|map>spec - [{:as speced-binding [kind binding-] :binding-form [spec-kind spec] :spec}] - `(map-destructure ~(if (= spec-kind :spec) spec `map?) + [lang {:as speced-binding [kind binding-] :binding-form [spec-kind spec] :spec}] + `(map-destructure ~lang ~(if (= spec-kind :spec) spec `map?) ~(->> (dissoc binding- :as :or) (map (fn [[k v]] (case k (:keys :strs :syms) (keys||strs||syms>key-specs k (second v)) [[(get-in v [:key+spec :key]) - (speced-binding>spec + (speced-binding>spec lang (assoc v :spec (get-in v [:key+spec :spec])))]]))) (apply concat) (into {})))) (defn speced-binding>spec - [{:as speced-binding [kind binding-] :binding-form [spec-kind spec] :spec}] + [lang {:as speced-binding [kind binding-] :binding-form [spec-kind spec] :spec}] (case kind :sym (if (= spec-kind :spec) spec `any?) - :seq (speced-binding|seq>spec speced-binding) - :map (speced-binding|map>spec speced-binding))) + :seq (speced-binding|seq>spec lang speced-binding) + :map (speced-binding|map>spec lang speced-binding))) (defn arglist>spec-form|arglist - [args+varargs kw-args #_:quantum.core.specs/map-binding-form] - `(s/cat ~@(reduce-2 - (fn [ret speced-binding [_ kw-arg]] - (conj ret kw-arg (speced-binding>spec speced-binding))) - [] - args+varargs kw-args))) + [lang args+varargs kw-args #_:quantum.core.specs/map-binding-form] + `(~(qualify-spec lang 'cat) + ~@(reduce-2 + (fn [ret speced-binding [_ kw-arg]] + (conj ret kw-arg (speced-binding>spec lang speced-binding))) + [] + args+varargs kw-args))) ;; TODO handle duplicate bindings (e.g. `_`) by `s/cat` using unique keys — e.g. :b|arg-2 (defn fns|code [kind lang args] @@ -340,15 +354,17 @@ (cond-> args varargs (conj (assoc varargs :varargs? true)))) overload-form (list* fn-arglist body) arity-ident (keyword (str "arity-" (if varargs "varargs" (count args)))) - spec-form|arglist (arglist>spec-form|arglist (cond-> args varargs (conj varargs)) kw-args) + spec-form|arglist (arglist>spec-form|arglist lang + (cond-> args varargs (conj varargs)) kw-args) spec-form|pre (when (and (contains? arglist :pre) (= pre-kind :spec)) `(fn [~kw-args] ~pre)) spec-form|args* (if spec-form|pre - `(s/and ~spec-form|arglist ~spec-form|pre) + `(~(qualify-spec lang 'and) ~spec-form|arglist ~spec-form|pre) spec-form|arglist) spec-form|fn* (if (contains? arglist :post) - `(let [~kw-args ~args-sym] (s/spec ~post)) - `(s/spec any?))] + `(let [~kw-args ~args-sym] + (~(qualify-spec lang 'spec) ~post)) + `(~(qualify-spec lang 'spec) any?))] (-> ret (update :overload-forms conj overload-form) (update :spec-form|args conj arity-ident spec-form|args*) @@ -358,10 +374,11 @@ :spec-form|fn []} overloads) spec-form (when (#{:defn :defn-} kind) - `(s/fdef ~fn|name :args (s/or ~@spec-form|args) - :fn (us/with-gen-spec (fn [{~ret-sym :ret}] ~ret-sym) - (fn [{[~arity-kind-sym ~args-sym] :args}] - (case ~arity-kind-sym ~@spec-form|fn))))) + `(~(qualify-spec lang 'fdef) ~fn|name :args + (~(qualify-spec lang 'or) ~@spec-form|args) + :fn (us/with-gen-spec (fn [{~ret-sym :ret}] ~ret-sym) + (fn [{[~arity-kind-sym ~args-sym] :args}] + (case ~arity-kind-sym ~@spec-form|fn))))) fn-form (case kind :fn (list* 'fn (concat (when (contains? args' :quantum.core.specs/fn|name) [fn|name]) From 48af6a622599344cd61da941606e8b7a6f1ef374 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 18 Jun 2018 09:26:34 -0600 Subject: [PATCH 073/810] More CLJS compilation --- .../quantum/untyped/core/type/compare.cljc | 35 ++++++++++--------- 1 file changed, 18 insertions(+), 17 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index 2b9f21f4..342f2aad 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -234,6 +234,7 @@ ;; ----- ClassType ----- ;; +#?(:clj (defns compare|class+class* "Compare extension (generality|specificity) of ->`c0` to ->`c1`. `0` means they are equally general/specific: @@ -250,25 +251,25 @@ - ✓ `(t/<> c0 c1)` : the extension of ->`c0` is disjoint w.r.t. to that of ->`c1`. Unboxed primitives are considered to be less general (more specific) than boxed primitives." [^Class c0 class? ^Class c1 class? > comparison?] - #?(:clj (ifs (== c0 c1) =ident - (== c0 Object) >ident - (== c1 Object) unboxed c0) c1) >ident - (== c0 (utcore/boxed->unboxed c1)) ident - (.isAssignableFrom c0 c1) >ident - (.isAssignableFrom c1 c0) ident) - :cljs (TODO))) + (ifs (== c0 c1) =ident + (== c0 Object) >ident + (== c1 Object) unboxed c0) c1) >ident + (== c0 (utcore/boxed->unboxed c1)) ident + (.isAssignableFrom c0 c1) >ident + (.isAssignableFrom c1 c0) ident))) (defns- compare|class+class [t0 class-type?, t1 class-type? > comparison?] - (compare|class+class* (utr/class-type>class t0) (utr/class-type>class t1))) + #?(:clj (compare|class+class* (utr/class-type>class t0) (utr/class-type>class t1)) + :cljs (TODO))) (defns- compare|class+value [t0 class-type?, t1 value-type? > comparison?] (let [c (utr/class-type>class t0) From 74fed0de2fd0ba43cb0536ae73c56216947bf3b7 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 18 Jun 2018 09:37:28 -0600 Subject: [PATCH 074/810] More CLJS compilation fixes --- src-untyped/quantum/untyped/core/defnt.cljc | 4 ++-- src-untyped/quantum/untyped/core/type/compare.cljc | 8 +++++++- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index 960bbb59..800f6bf5 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -2,8 +2,8 @@ "Primarily for `(de)fns`." (:refer-clojure :exclude [any? ident? qualified-keyword? seqable? simple-symbol?]) (:require - [clojure.spec.alpha :as s] - [clojure.spec.gen.alpha :as gen] + [#?(:clj clojure.spec.alpha :cljs cljs.spec.alpha) :as s] + [#?(:clj clojure.spec.gen.alpha :cljs cljs.spec.gen.alpha) :as gen] [quantum.untyped.core.convert :as uconv] [quantum.untyped.core.data.map :refer [om]] diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index 342f2aad..20d516f5 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -4,6 +4,8 @@ [compare < <= = not= >= >, ==]) (:require [clojure.core :as c] + [quantum.untyped.core.analyze.expr + #?@(:cljs [:refer [Expression]])] [quantum.untyped.core.collections.logic :refer [seq-and seq-or]] ;; TODO remove this dependency @@ -27,7 +29,11 @@ universal-set empty-set not-type? or-type? and-type? protocol-type? class-type? - value-type?]] + value-type? + #?@(:cljs [UniversalSetType EmptySetType + NotType OrType AndType + ProtocolType ClassType + ValueType])]] [quantum.untyped.core.vars :refer [def-]]) #?(:clj (:import From 6d9f17145e1165d4f9a30d465bc55ccd83964673 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 18 Jun 2018 09:43:36 -0600 Subject: [PATCH 075/810] Fix hash logic --- src-untyped/quantum/untyped/core/type/reifications.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index b6748282..376a1721 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -47,7 +47,7 @@ EmptySetType [] {PType nil ?Fn {invoke ([_ x] false)} - ?Hash {hash ([this] (hash UniversalSetType))} + ?Hash {hash ([this] (hash EmptySetType))} ?Object {hash-code ([this] (uhash/code EmptySetType)) equals ([this that] (or (== this that) (instance? EmptySetType that)))} fedn/IOverride nil From 2386e572a786ba2907bab2afa86f32a553bfe683 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 18 Jun 2018 10:00:07 -0600 Subject: [PATCH 076/810] Fixed all CLJS compilation issues except one - Namespace quantum.untyped.core.type.compare clashes with var quantum.untyped.core.type/compare --- src-untyped/quantum/untyped/core/defnt.cljc | 38 +++++++++------------ src-untyped/quantum/untyped/core/spec.cljc | 2 ++ src-untyped/quantum/untyped/core/type.cljc | 17 +++++---- 3 files changed, 29 insertions(+), 28 deletions(-) diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index 800f6bf5..85477fc7 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -2,8 +2,8 @@ "Primarily for `(de)fns`." (:refer-clojure :exclude [any? ident? qualified-keyword? seqable? simple-symbol?]) (:require - [#?(:clj clojure.spec.alpha :cljs cljs.spec.alpha) :as s] - [#?(:clj clojure.spec.gen.alpha :cljs cljs.spec.gen.alpha) :as gen] + [clojure.spec.alpha :as s] + [clojure.spec.gen.alpha :as gen] [quantum.untyped.core.convert :as uconv] [quantum.untyped.core.data.map :refer [om]] @@ -160,10 +160,6 @@ ;; ===== Implementation ===== ;; -(defn- qualify-spec [lang sym] - (symbol (name (case :clj 'clojure.spec.alpha :cljs 'cljs.spec.alpha)) - (name sym))) - (defn >seq-destructuring-spec "Creates a spec that performs seq destructuring, and provides a default generator for such based on the generators of the destructured args." @@ -204,22 +200,20 @@ varargs (us/assert-conform (s/nilable (s/cat :k keyword? :spec any?)) varargs) args-ct>args-kw #(keyword (str "args-" %)) arity>cat (fn [arg-i] - `(~(qualify-spec lang 'cat) + `(us/cat ~@(->> args (take arg-i) (map (fn [{:keys [k spec]}] [k `any?])) (apply concat)))) most-complex-positional-destructurer-sym (gensym "most-complex-positional-destructurer")] `(let [~most-complex-positional-destructurer-sym - (~(qualify-spec lang 'cat) + (us/cat ~@(->> args (map (fn [{:keys [k]}] [k `any?])) (apply concat)) ~@(when varargs [(:k varargs) - `(~(qualify-spec lang '&) - (~(qualify-spec lang '+) any?) - (~(qualify-spec lang 'conformer) seq identity))])) + `(us/& (us/+ any?) (us/conformer seq identity))])) positional-destructurer# - (~(qualify-spec lang 'or) :args-0 (~(qualify-spec lang 'cat)) + (us/or :args-0 (us/cat) ~@(->> (range (count args)) (map (fn [i] [(args-ct>args-kw (inc i)) (arity>cat (inc i))])) (apply concat)) @@ -229,7 +223,7 @@ (cond-> (->> args (map (fn [{:keys [k spec]}] [k spec]))) varargs (concat [[(:k varargs) (:spec varargs)]]))))) or|conformer# - (~(qualify-spec lang 'conformer) + (us/conformer (fn or|conformer# [m#] [(case (count m#) ~@(->> (range (inc (count args))) @@ -246,9 +240,9 @@ {:as opts generate-from-map-spec? :gen?} (meta map-spec)] `(let [~kv-spec-sym (us/kv ~kv-specs)] ~(if generate-from-map-spec? - `(~(qualify-spec lang 'and) ~map-spec ~kv-spec-sym) - `(~(qualify-spec lang 'with-gen) (~(qualify-spec lang 'and) ~map-spec ~kv-spec-sym) - (fn [] (~(qualify-spec lang 'gen) ~kv-spec-sym)))))))) + `(us/and ~map-spec ~kv-spec-sym) + `(us/with-gen (us/and ~map-spec ~kv-spec-sym) + (fn [] (us/gen ~kv-spec-sym)))))))) (defn speced-binding>binding [{[kind binding-] :binding-form} #_:quantum.core.defnt/speced-binding] (case kind @@ -324,7 +318,7 @@ (defn arglist>spec-form|arglist [lang args+varargs kw-args #_:quantum.core.specs/map-binding-form] - `(~(qualify-spec lang 'cat) + `(us/cat ~@(reduce-2 (fn [ret speced-binding [_ kw-arg]] (conj ret kw-arg (speced-binding>spec lang speced-binding))) @@ -359,12 +353,12 @@ spec-form|pre (when (and (contains? arglist :pre) (= pre-kind :spec)) `(fn [~kw-args] ~pre)) spec-form|args* (if spec-form|pre - `(~(qualify-spec lang 'and) ~spec-form|arglist ~spec-form|pre) + `(us/and ~spec-form|arglist ~spec-form|pre) spec-form|arglist) spec-form|fn* (if (contains? arglist :post) `(let [~kw-args ~args-sym] - (~(qualify-spec lang 'spec) ~post)) - `(~(qualify-spec lang 'spec) any?))] + (us/spec ~post)) + `(us/spec any?))] (-> ret (update :overload-forms conj overload-form) (update :spec-form|args conj arity-ident spec-form|args*) @@ -374,8 +368,8 @@ :spec-form|fn []} overloads) spec-form (when (#{:defn :defn-} kind) - `(~(qualify-spec lang 'fdef) ~fn|name :args - (~(qualify-spec lang 'or) ~@spec-form|args) + `(us/fdef ~fn|name :args + (us/or ~@spec-form|args) :fn (us/with-gen-spec (fn [{~ret-sym :ret}] ~ret-sym) (fn [{[~arity-kind-sym ~args-sym] :args}] (case ~arity-kind-sym ~@spec-form|fn))))) diff --git a/src-untyped/quantum/untyped/core/spec.cljc b/src-untyped/quantum/untyped/core/spec.cljc index 0a69d31b..5ce3ebf8 100644 --- a/src-untyped/quantum/untyped/core/spec.cljc +++ b/src-untyped/quantum/untyped/core/spec.cljc @@ -141,6 +141,8 @@ (defalias s/explain) (defalias s/explain-data) (defalias s/describe) +(defalias s/gen) +(defalias s/with-gen) #?(:clj (quantum.untyped.core.vars/defmalias cat clojure.spec.alpha/cat cljs.spec.alpha/cat)) #?(:clj (defmacro cat* "`or` :`or*` :: `cat` : `cat*`" [& args] `(cat ~@(udata/quote-map-base uconv/>keyword args true)))) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 37dbbbab..e078dae5 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -10,7 +10,7 @@ nil? any? class? tagged-literal? #?(:cljs object?) number? decimal? bigdec? integer? ratio? true? false? keyword? string? symbol? - array? associative? coll? counted? indexed? list? map? map-entry? record? + array? associative? coll? counted? indexed? iterable? list? map? map-entry? record? seq? seqable? sequential? set? sorted? vector? fn? ifn? meta @@ -54,7 +54,11 @@ [quantum.untyped.core.type.defs :as utdef] [quantum.untyped.core.type.predicates :as utpred] [quantum.untyped.core.type.reifications :as utr - :refer [->AndType ->OrType PType]] + :refer [->AndType ->OrType PType + #?@(:cljs [UniversalSetType EmptySetType + NotType OrType AndType + ProtocolType ClassType + ValueType])]] [quantum.untyped.core.vars :as uvar :refer [def- defmacro- update-meta]]) #?(:cljs (:require-macros @@ -173,10 +177,10 @@ (0 -1) empty-set 3 t0 (1 2) - (let [c0 (c/class t0) c1 (c/class t1)] + (let [c0 (c/type t0) c1 (c/type t1)] ;; TODO add dispatch? (condp == c0 - NotType (condp == (-> t0 utr/not-type>inner-type c/class) + NotType (condp == (-> t0 utr/not-type>inner-type c/type) ClassType (condp == c1 ClassType (AndType. uhash/default uhash/default [t0 (not t1)] (atom nil))) ValueType (condp == c1 @@ -501,7 +505,8 @@ #?(:clj (def primitive-classes (->> unboxed-symbol->type-meta vals (uc/map+ :unboxed) (join #{})))) -(defns- -type>classes [t utr/type?, classes c/set? > (s/set-of (s/nilable c/class?))] +(defns- -type>classes + [t utr/type?, classes c/set? > (s/set-of (s/nilable #?(:clj c/class? :cljs c/fn?)))] (cond (utr/class-type? t) (conj classes (utr/class-type>class t)) (utr/value-type? t) @@ -523,7 +528,7 @@ (defns type>classes "Outputs the set of all the classes ->`t` can embody according to its various conditional branches, if any. Ignores nils, treating in Clojure simply as a `java.lang.Object`." - [t utr/type? > (s/set-of (s/nilable c/class?))] (-type>classes t #{})) + [t utr/type? > (s/set-of (s/nilable #?(:clj c/class? :cljs c/fn?)))] (-type>classes t #{})) #?(:clj (defns- -type>?class-value [t utr/type?, type-nilable? c/boolean?] From d17981027a772118835e80b479c78a576fd2dd8b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 18 Jun 2018 10:03:31 -0600 Subject: [PATCH 077/810] Fix CLJS compilation --- src-untyped/quantum/untyped/core/spec.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/spec.cljc b/src-untyped/quantum/untyped/core/spec.cljc index 5ce3ebf8..0f7e4b0d 100644 --- a/src-untyped/quantum/untyped/core/spec.cljc +++ b/src-untyped/quantum/untyped/core/spec.cljc @@ -137,7 +137,7 @@ (defalias s/conform) (defalias s/nonconforming) -(defalias • nonconforming) +#?(:clj (defalias • nonconforming)) (defalias s/explain) (defalias s/explain-data) (defalias s/describe) From ba98d5dda304ae47c8f57668ef92b0fa5dc21d33 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 19 Jun 2018 02:12:44 -0600 Subject: [PATCH 078/810] Add CLJS `MutableHashMap` and organize map-related fns --- .../quantum/untyped/core/data/map.cljc | 487 ++++++++++++++---- 1 file changed, 392 insertions(+), 95 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/map.cljc b/src-untyped/quantum/untyped/core/data/map.cljc index 294a27d5..9e371d76 100644 --- a/src-untyped/quantum/untyped/core/data/map.cljc +++ b/src-untyped/quantum/untyped/core/data/map.cljc @@ -19,13 +19,13 @@ [quantum.untyped.core.vars :refer [defalias]]) (:import -#?@(:clj - [java.util.HashMap - [it.unimi.dsi.fastutil.ints Int2ReferenceOpenHashMap] - [it.unimi.dsi.fastutil.longs Long2LongOpenHashMap - Long2ReferenceOpenHashMap] - [it.unimi.dsi.fastutil.doubles Double2ReferenceOpenHashMap] - [it.unimi.dsi.fastutil.objects Reference2LongOpenHashMap]]))) +#?@(:clj [[java.util HashMap IdentityHashMap LinkedHashMap TreeMap] + [it.unimi.dsi.fastutil.ints Int2ReferenceOpenHashMap] + [it.unimi.dsi.fastutil.longs Long2LongOpenHashMap + Long2ReferenceOpenHashMap] + [it.unimi.dsi.fastutil.doubles Double2ReferenceOpenHashMap] + [it.unimi.dsi.fastutil.objects Reference2LongOpenHashMap]] + :cljs [[goog.structs AvlTree LinkedMap]]))) ;; TO EXPLORE ;; - Optimizing Hash-Array Mapped Tries for Fast and Lean Immutable JVM Collections @@ -34,39 +34,7 @@ ;; - Alex Miller: "We have seen it and will probably investigate some of these ideas after 1.8." ;; ======================= -#?(:clj (def int-map imap/int-map)) -#?(:clj (defalias hash-map|long->ref int-map)) - (defalias array-map core/array-map) - (defalias hash-map core/hash-map) - - (defalias ordered-map #?(:clj ordered-map/ordered-map :cljs linked/map)) - (defalias om ordered-map) - -#?(:clj (defn ^java.util.LinkedHashMap !ordered-map [] (java.util.LinkedHashMap.))) - -#?(:clj -(defmacro kw-omap - "Like `kw-map`, but preserves insertion order." - [& ks] - (list* `om (udata/quote-map-base uconv/>keyword ks)))) - -(defalias core/sorted-map ) -(defalias core/sorted-map-by) - -(defn sorted-map-by-val [m-0] - (sorted-map-by (fn [k1 k2] - (compare [(get m-0 k2) k2] - [(get m-0 k1) k1])))) - -(defalias sorted-rank-map avl/sorted-map ) -(defalias sorted-rank-map-by avl/sorted-map-by ) -(defalias avl/nearest ) -(defalias avl/rank-of ) -(defalias avl/subrange ) -(defalias avl/split-key) -(defalias avl/split-at ) - -; TODO look at imap/merge +;; ===== Map entries ===== ;; ; `(apply hash-map pairs)` <~> `lodash/fromPairs` @@ -90,7 +58,7 @@ {:attribution "alexandergunnarson"} [k v] #?(:clj (clojure.lang.MapEntry. k v) - :cljs [k v])) + :cljs (cljs.core.MapEntry. k v nil))) (defn map-entry-seq [args] (loop [[k v :as args-n] args @@ -100,80 +68,41 @@ (recur (-> args-n rest rest) (conj accum (map-entry k v)))))) -#?(:clj (def hash-map? (partial instance? clojure.lang.PersistentHashMap))) - -; TODO use |clojure.data.int-map/merge and merge-with|, |update|, |update!| for int maps. -; Benchmark these. -(defn merge - "A performant drop-in replacement for |clojure.core/merge|. - - 398.815137 msecs (core/merge m1 m2) - 188.270844 msecs (seqspert.hash-map/sequential-splice-hash-maps m1 m2) - 25.401196 msecs (seqspert.hash-map/parallel-splice-hash-maps m1 m2)))" - {:attribution "alexandergunnarson" - :performance "782.922731 ms |merge+| vs. 1.133217 sec normal |merge| - on the CLJ version; 1.5 times faster!"} - ([] (hash-map)) - ([m0] m0) - ([m0 m1] - ; To avoid NullPointerException - #?(:clj (cond (nil? m0) m1 - (nil? m1) m0 - (and (hash-map? m0) (hash-map? m1)) - (seqspert.hash-map/sequential-splice-hash-maps m0 m1) - :else (core/merge m0 m1)) - :cljs (core/merge m0 m1))) - ([m0 m1 & ms] - #?(:clj (reduce merge (merge m0 m1) ms) - :cljs (if (satisfies? core/IEditableCollection m0) - (->> ms - (reduce conj! (transient m0)) - persistent!) - (reduce core/merge (core/merge m0 m1) ms))))) - -#?(:clj -(defn pmerge - ([] (hash-map)) - ([m0] m0) - ([m0 m1] (seqspert.hash-map/parallel-splice-hash-maps m0 m1)) - ([m0 m1 & ms] - (reduce pmerge - (pmerge m0 m1) ms)))) - -; TODO generate these functions via macros -(defn #?(:clj ^HashMap !hash-map :cljs !hash-map) - "Creates a single-threaded, mutable hash map. - On the JVM, this is a java.util.HashMap. +;; ===== Unordered identity-semantic maps ===== ;; +;; TODO generate these functions via macros +(defn #?(:clj ^IdentityHashMap !identity-map :cljs !identity-map) + "Creates a single-threaded, mutable identity map. + On the JVM, this is a `java.util.IdentityHashMap`. On JS, this is a `js/Map` (ECMAScript 6 Map)." - ([] #?(:clj (HashMap.) :cljs (js/Map.))) + ([] #?(:clj (IdentityHashMap.) :cljs (js/Map.))) ([k0 v0] - (doto #?(:clj (HashMap.) :cljs (js/Map.)) + (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0))) ([k0 v0 k1 v1] - (doto #?(:clj (HashMap.) :cljs (js/Map.)) + (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0) (#?(:clj .put :cljs .set) k1 v1))) ([k0 v0 k1 v1 k2 v2] - (doto #?(:clj (HashMap.) :cljs (js/Map.)) + (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0) (#?(:clj .put :cljs .set) k1 v1) (#?(:clj .put :cljs .set) k2 v2))) ([k0 v0 k1 v1 k2 v2 k3 v3] - (doto #?(:clj (HashMap.) :cljs (js/Map.)) + (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0) (#?(:clj .put :cljs .set) k1 v1) (#?(:clj .put :cljs .set) k2 v2) (#?(:clj .put :cljs .set) k3 v3))) ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4] - (doto #?(:clj (HashMap.) :cljs (js/Map.)) + (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0) (#?(:clj .put :cljs .set) k1 v1) (#?(:clj .put :cljs .set) k2 v2) (#?(:clj .put :cljs .set) k3 v3) (#?(:clj .put :cljs .set) k4 v4))) ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5] - (doto #?(:clj (HashMap.) :cljs (js/Map.)) + (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0) (#?(:clj .put :cljs .set) k1 v1) (#?(:clj .put :cljs .set) k2 v2) @@ -182,8 +111,8 @@ (#?(:clj .put :cljs .set) k5 v5))) ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 & kvs] (reduce-pair - (fn [#?(:clj ^HashMap m :cljs m) k v] (doto m (#?(:clj .put :cljs .set) k v))) - (doto #?(:clj (HashMap.) :cljs (js/Map.)) + (fn [#?(:clj ^IdentityHashMap m :cljs m) k v] (doto m (#?(:clj .put :cljs .set) k v))) + (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0) (#?(:clj .put :cljs .set) k1 v1) (#?(:clj .put :cljs .set) k2 v2) @@ -193,6 +122,183 @@ (#?(:clj .put :cljs .set) k6 v6)) kvs))) +;; ===== Unordered value-semantic maps ===== ;; + +(defalias array-map core/array-map) + +;; ----- Hash maps ----- ;; + +#?(:clj (def hash-map? (partial instance? clojure.lang.PersistentHashMap))) + + (defalias hash-map core/hash-map) + +#?(:clj (defalias hash-map|long->ref imap/int-map)) +#?(:clj (defalias int-map hash-map|long->ref)) + +#?(:cljs +(deftype MutableHashMap ; There can be no `undefined` values + [meta ^:mutable ct ^js/Map m #_"Keys are int hashes; vals are map entries from k to v" + ^:mutable ^boolean has-nil? ^:mutable nil-val ^:mutable __hash] + Object + (toString [this] (str (into {} (vals m)))) + (equiv [this other] (-equiv this other)) + (keys [this] (es6-iterator (keys this))) + (entries [this] (es6-entries-iterator (seq this))) + (values [this] (es6-iterator (vals this))) + (has [this k] (contains? this k)) + (get [this k not-found] (-lookup this k not-found)) + (forEach [this f] (doseq [[k v] this] (f v k))) + ICloneable + (-clone [_] (MutableHashMap. meta ct m has-nil? nil-val __hash)) + IIterable + (-iterator [this] (-iterator (vals this))) + IWithMeta + (-with-meta [this meta-] (MutableHashMap. meta- ct m has-nil? nil-val __hash)) + IMeta + (-meta [this] meta) + IEmptyableCollection + (-empty [this] (MutableHashMap. meta 0 (js/Map.) false nil 0)) + IEquiv + (-equiv [this that] (equiv-map this that)) + IHash + (-hash [this] (caching-hash this hash-unordered-coll __hash)) + ISeqable + (-seq [this] + (when (pos? ct) + (let [s (seq (.values m))] + (if has-nil? + (cons (map-entry nil nil-val) s) + s)))) + ICounted + (-count [this] ct) + ILookup + (-lookup [this k] (-lookup this k nil)) + (-lookup [this k not-found] + (if (nil? k) + (if has-nil? nil-val not-found) + (let [kv (.get m (hash k))] + (if (undefined? kv) not-found (-val kv))))) + IAssociative + (-contains-key? [this k] + (if (nil? k) + has-nil? + (.has m (hash k)))) + IFind + (-find [this k] + (if (nil? k) + (when has-nil? (map-entry nil nil-val)) + (let [kv (.get m (hash k))] + (if (undefined? kv) nil kv)))) + ITransientCollection + (-conj! [this entry] + (if (vector? entry) + (-assoc! this (-nth entry 0) (-nth entry 1)) + (loop [ret this es (seq entry)] + (if (nil? es) + ret + (let [e (first es)] + (if (vector? e) + (recur (-assoc! ret (-nth e 0) (-nth e 1)) + (next es)) + (throw (ex-info "conj on a map takes map entries or seqables of map entries" {})))))))) + ITransientAssociative + (-assoc! [this k v] + (cond + (undefined? v) + (throw (ex-info "Cannot `assoc` undefined value to `MutableHashMap`" {})) + (nil? k) + (if (and has-nil? (identical? v nil-val)) + this + (do (when-not has-nil? (set! ct (inc ct))) + (set! has-nil? true) + (set! nil-val v) + (set! __hash nil) ; TODO recalculate incrementally? + this)) + :else + (let [hash-k (hash k)] + (if (.has m hash-k) + this + (do (.set m (hash k) (map-entry k v)) + (set! ct (inc ct)) + (set! __hash nil) ; TODO recalculate incrementally? + this))))) + ITransientMap + (-dissoc! [this k] + (if (nil? k) + (if has-nil? + (do (set! ct (dec ct)) + (set! has-nil? false) + (set! nil-val nil) + (set! __hash nil) ; TODO recalculate incrementally? + this) + this) + (if (.delete m (hash k)) + (do (set! ct (dec ct)) + (set! __hash nil) ; TODO recalculate incrementally? + this) + this))) + IKVReduce + (-kv-reduce [this f init] + (let [init (if has-nil? (f init nil nil-val) init)] + (if (reduced? init) + @init + (unreduced (reduce (fn [ret kv] (f ret (-key kv) (-val kv))) init m))))) + IFn + (-invoke [this k] (-lookup this k)) + (-invoke [this k not-found] (-lookup this k not-found)))) + +;; TODO generate these functions via macros +(defn #?(:clj ^HashMap !hash-map :cljs !hash-map) + "Creates a single-threaded, mutable hash map. + On the JVM, this is a `java.util.HashMap`. + On JS, this is a `quantum.untyped.core.data.map.HashMap`." + ([] #?(:clj (HashMap.) :cljs (MutableHashMap. nil 0 (js/Map.) false nil nil))) + ([k0 v0] + (doto #?(:clj (HashMap.) :cljs (!hash-map)) + (#?(:clj .put :cljs assoc!) k0 v0))) + ([k0 v0 k1 v1] + (doto #?(:clj (HashMap.) :cljs (!hash-map)) + (#?(:clj .put :cljs assoc!) k0 v0) + (#?(:clj .put :cljs assoc!) k1 v1))) + ([k0 v0 k1 v1 k2 v2] + (doto #?(:clj (HashMap.) :cljs (!hash-map)) + (#?(:clj .put :cljs assoc!) k0 v0) + (#?(:clj .put :cljs assoc!) k1 v1) + (#?(:clj .put :cljs assoc!) k2 v2))) + ([k0 v0 k1 v1 k2 v2 k3 v3] + (doto #?(:clj (HashMap.) :cljs (!hash-map)) + (#?(:clj .put :cljs assoc!) k0 v0) + (#?(:clj .put :cljs assoc!) k1 v1) + (#?(:clj .put :cljs assoc!) k2 v2) + (#?(:clj .put :cljs assoc!) k3 v3))) + ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4] + (doto #?(:clj (HashMap.) :cljs (!hash-map)) + (#?(:clj .put :cljs assoc!) k0 v0) + (#?(:clj .put :cljs assoc!) k1 v1) + (#?(:clj .put :cljs assoc!) k2 v2) + (#?(:clj .put :cljs assoc!) k3 v3) + (#?(:clj .put :cljs assoc!) k4 v4))) + ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5] + (doto #?(:clj (HashMap.) :cljs (!hash-map)) + (#?(:clj .put :cljs assoc!) k0 v0) + (#?(:clj .put :cljs assoc!) k1 v1) + (#?(:clj .put :cljs assoc!) k2 v2) + (#?(:clj .put :cljs assoc!) k3 v3) + (#?(:clj .put :cljs assoc!) k4 v4) + (#?(:clj .put :cljs assoc!) k5 v5))) + ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 & kvs] + (reduce-pair + (fn [^HashMap m k v] (doto m (#?(:clj .put :cljs assoc!) k v))) + (doto #?(:clj (HashMap.) :cljs (!hash-map)) + (#?(:clj .put :cljs assoc!) k0 v0) + (#?(:clj .put :cljs assoc!) k1 v1) + (#?(:clj .put :cljs assoc!) k2 v2) + (#?(:clj .put :cljs assoc!) k3 v3) + (#?(:clj .put :cljs assoc!) k4 v4) + (#?(:clj .put :cljs assoc!) k5 v5) + (#?(:clj .put :cljs assoc!) k6 v6)) + kvs))) + ; TODO generate these functions via macros #?(:clj (defn ^Int2ReferenceOpenHashMap !hash-map|int->ref [] (Int2ReferenceOpenHashMap.))) #?(:clj (defalias !hash-map|int->object !hash-map|int->ref)) @@ -209,6 +315,198 @@ #?(:clj (defn ^Reference2LongOpenHashMap !hash-map|ref->long [] (Reference2LongOpenHashMap.))) #?(:clj (defalias !hash-map|object->long !hash-map|ref->long)) +;; ===== Ordered value-semantic maps ===== ;; + +;; ---- Insertion-ordered ----- ;; + +(defalias ordered-map #?(:clj ordered-map/ordered-map :cljs linked/map)) +(defalias om ordered-map) + +#?(:clj +(defmacro kw-omap + "Like `kw-map`, but preserves insertion order." + [& ks] + (list* `om (udata/quote-map-base uconv/>keyword ks)))) + +;; TODO generate these functions via macros +(defn #?(:clj ^LinkedHashMap !ordered-map :cljs !ordered-map) + "Creates a single-threaded, mutable insertion-ordered map. + On the JVM, this is a `java.util.LinkedHashMap`. + On JS, this is a `goog.structs.LinkedMap`." + ([] #?(:clj (LinkedHashMap.) :cljs (LinkedMap.))) + ([k0 v0] + (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) + (#?(:clj .put :cljs .add) k0 v0))) + ([k0 v0 k1 v1] + (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1))) + ([k0 v0 k1 v1 k2 v2] + (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2))) + ([k0 v0 k1 v1 k2 v2 k3 v3] + (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) + (#?(:clj .put :cl .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2) + (#?(:clj .put :cljs .add) k3 v3))) + ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4] + (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2) + (#?(:clj .put :cljs .add) k3 v3) + (#?(:clj .put :cljs .add) k4 v4))) + ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5] + (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2) + (#?(:clj .put :cljs .add) k3 v3) + (#?(:clj .put :cljs .add) k4 v4) + (#?(:clj .put :cljs .add) k5 v5))) + ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 & kvs] + (reduce-pair + (fn [#?(:clj ^LinkedHashMap m :cljs m) k v] (doto m (#?(:clj .put :cljs .add) k v))) + (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2) + (#?(:clj .put :cljs .add) k3 v3) + (#?(:clj .put :cljs .add) k4 v4) + (#?(:clj .put :cljs .add) k5 v5) + (#?(:clj .put :cljs .add) k6 v6)) + kvs))) + +;; ----- Comparison-ordered (sorted) ----- ;; + +(defalias core/sorted-map) +(defalias core/sorted-map-by) + +(defn gen-compare-by-val [m] (fn [k0 k1] (compare [(get m k1) k1] [(get m k0) k0]))) + +(defn sorted-map-by-val [m & kvs] (apply sorted-map-by (gen-compare-by-val m) kvs)) + +;; TODO generate these functions via macros +(defn #?(:clj ^TreeMap !sorted-map-by :cljs !sorted-map-by) + "Creates a single-threaded, mutable sorted map with the specified comparator. + On the JVM, this is a `java.util.TreeMap`. + On JS, this is a `goog.structs.AvlTree`." + ([compf] #?(:clj (TreeMap. compf) :cljs (AvlTree. compf))) + ([compf k0 v0] + (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) + (#?(:clj .put :cljs .add) k0 v0))) + ([compf k0 v0 k1 v1] + (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1))) + ([compf k0 v0 k1 v1 k2 v2] + (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2))) + ([compf k0 v0 k1 v1 k2 v2 k3 v3] + (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2) + (#?(:clj .put :cljs .add) k3 v3))) + ([compf k0 v0 k1 v1 k2 v2 k3 v3 k4 v4] + (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2) + (#?(:clj .put :cljs .add) k3 v3) + (#?(:clj .put :cljs .add) k4 v4))) + ([compf k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5] + (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2) + (#?(:clj .put :cljs .add) k3 v3) + (#?(:clj .put :cljs .add) k4 v4) + (#?(:clj .put :cljs .add) k5 v5))) + ([compf k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 & kvs] + (reduce-pair + (fn [#?(:clj ^TreeMap m :cljs m) k v] (doto m (#?(:clj .put :cljs .add) k v))) + (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2) + (#?(:clj .put :cljs .add) k3 v3) + (#?(:clj .put :cljs .add) k4 v4) + (#?(:clj .put :cljs .add) k5 v5) + (#?(:clj .put :cljs .add) k6 v6)) + kvs))) + +;; TODO generate these functions via macros +(defn #?(:clj ^TreeMap !sorted-map :cljs !sorted-map) + "Creates a single-threaded, mutable sorted map. + On the JVM, this is a `java.util.TreeMap`. + On JS, this is a `goog.structs.AvlTree`." + ([] (!sorted-map-by compare)) + ([k0 v0] (!sorted-map-by compare k0 v0)) + ([k0 v0 k1 v1] (!sorted-map-by compare k0 v0 k1 v1)) + ([k0 v0 k1 v1 k2 v2] (!sorted-map-by compare k0 v0 k1 v1 k2 v2)) + ([k0 v0 k1 v1 k2 v2 k3 v3] (!sorted-map-by compare k0 v0 k1 v1 k2 v2 k3 v3)) + ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4] (!sorted-map-by compare k0 v0 k1 v1 k2 v2 k3 v3 k4 v4)) + ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5] + (!sorted-map-by compare k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5)) + ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 & kvs] + (apply !sorted-map-by compare k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 kvs))) + +(defn !sorted-map-by-val [m & kvs] (apply !sorted-map-by (gen-compare-by-val m) kvs)) + +;; TODO `goog.structs.AvlTree` has similar to this; implement with `defnt` +(defalias sorted-rank-map avl/sorted-map) +(defalias sorted-rank-map-by avl/sorted-map-by) +(defalias avl/nearest) +(defalias avl/rank-of) +(defalias avl/subrange) +(defalias avl/split-key) +(defalias avl/split-at) + +; TODO look at imap/merge + +; TODO use |clojure.data.int-map/merge and merge-with|, |update|, |update!| for int maps. +; Benchmark these. +(defn merge + "A performant drop-in replacement for |clojure.core/merge|. + + 398.815137 msecs (core/merge m1 m2) + 188.270844 msecs (seqspert.hash-map/sequential-splice-hash-maps m1 m2) + 25.401196 msecs (seqspert.hash-map/parallel-splice-hash-maps m1 m2)))" + {:attribution "alexandergunnarson" + :performance "782.922731 ms |merge+| vs. 1.133217 sec normal |merge| + on the CLJ version; 1.5 times faster!"} + ([] (hash-map)) + ([m0] m0) + ([m0 m1] + ; To avoid NullPointerException + #?(:clj (cond (nil? m0) m1 + (nil? m1) m0 + (and (hash-map? m0) (hash-map? m1)) + (seqspert.hash-map/sequential-splice-hash-maps m0 m1) + :else (core/merge m0 m1)) + :cljs (core/merge m0 m1))) + ([m0 m1 & ms] + #?(:clj (reduce merge (merge m0 m1) ms) + :cljs (if (satisfies? core/IEditableCollection m0) + (->> ms + (reduce conj! (transient m0)) + persistent!) + (reduce core/merge (core/merge m0 m1) ms))))) + +#?(:clj +(defn pmerge + ([] (hash-map)) + ([m0] m0) + ([m0 m1] (seqspert.hash-map/parallel-splice-hash-maps m0 m1)) + ([m0 m1 & ms] + (reduce pmerge + (pmerge m0 m1) ms)))) (defn bubble-max-key [k coll] ; TODO move "Move a maximal element of coll according to fn k (which returns a number) @@ -247,4 +545,3 @@ ([m0 m1 & ms] (let [bubbled-ms (bubble-max-key #(- (count %)) (conj ms m1 m0))] (reduce intersection-by-key (first bubbled-ms) (rest bubbled-ms))))) - From 10b0a58cdc51aeb31b37e5a9b50d98cabd360532 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 19 Jun 2018 02:12:58 -0600 Subject: [PATCH 079/810] Organize more map/set related concepts --- src-untyped/quantum/untyped/core/type.cljc | 13 ++++++--- src/quantum/core/data/set.cljc | 32 ++++++++++------------ 2 files changed, 23 insertions(+), 22 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index e078dae5..1995703a 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -1486,7 +1486,14 @@ #?(:clj (-def java-set? (isa? java.util.Set))) -;; ----- Hash Sets ----- ;; +;; ----- Identity Sets (identity-based equality) ----- ;; + + (-def !identity-set? #?(:clj none? #_(isa? java.util.IdentityHashSet) + :cljs (or (isa? js/Set) (isa? goog.structs.Set)))) + + (-def identity-set? !identity-set?) + +;; ----- Hash Sets (value-based equality) ----- ;; (-def +hash-set? (isa? #?(:clj clojure.lang.PersistentHashSet :cljs cljs.core/PersistentHashSet))) @@ -1502,10 +1509,8 @@ (-def !hash-set|float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.FloatOpenHashSet) :cljs none?)) (-def !hash-set|double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.DoubleOpenHashSet) :cljs none?)) (-def !hash-set|ref? #?(:clj (or (isa? java.util.HashSet) - ;; Because this has different semantics - #_(isa? java.util.IdentityHashSet) (isa? it.unimi.dsi.fastutil.objects.ReferenceOpenHashSet)) - :cljs (isa? goog.structs.Set))) + :cljs none?)) (-def !hash-set? (or !hash-set|ref? !hash-set|byte? !hash-set|short? !hash-set|char? diff --git a/src/quantum/core/data/set.cljc b/src/quantum/core/data/set.cljc index 9f17957a..3d655d28 100644 --- a/src/quantum/core/data/set.cljc +++ b/src/quantum/core/data/set.cljc @@ -20,14 +20,11 @@ [[clojure.data.finger-tree :as ftree] [seqspert.hash-set] [clojure.data.int-map :as imap]])) - (:import -#?@(:clj - [java.util.HashSet - [it.unimi.dsi.fastutil.ints IntOpenHashSet] - [it.unimi.dsi.fastutil.longs LongOpenHashSet] - [it.unimi.dsi.fastutil.doubles DoubleOpenHashSet]] - :cljs - [goog.structs.Set]))) +#?(:clj (:import + java.util.HashSet + [it.unimi.dsi.fastutil.ints IntOpenHashSet] + [it.unimi.dsi.fastutil.longs LongOpenHashSet] + [it.unimi.dsi.fastutil.doubles DoubleOpenHashSet]))) ; ============ STRUCTURES ============ @@ -158,36 +155,35 @@ "Creates a single-threaded, mutable hash set. On the JVM, this is a java.util.HashSet. - On JS, this is a goog.structs.Set." - {:todo #{"Compare performance on CLJS with ECMAScript 6 Set"}} - ([] #?(:clj (HashSet.) :cljs (Set.))) + On JS, this is a ECMAScript 6 Set (`js/Set`)." + ([] #?(:clj (HashSet.) :cljs (js/Set.))) ([v0] - (doto #?(:clj (HashSet.) :cljs (Set.)) + (doto #?(:clj (HashSet.) :cljs (js/Set.)) (.add v0))) ([v0 v1] - (doto #?(:clj (HashSet.) :cljs (Set.)) + (doto #?(:clj (HashSet.) :cljs (js/Set.)) (.add v0) (.add v1))) ([v0 v1 v2] - (doto #?(:clj (HashSet.) :cljs (Set.)) + (doto #?(:clj (HashSet.) :cljs (js/Set.)) (.add v0) (.add v1) (.add v2))) ([v0 v1 v2 v3] - (doto #?(:clj (HashSet.) :cljs (Set.)) + (doto #?(:clj (HashSet.) :cljs (js/Set.)) (.add v0) (.add v1) (.add v2) (.add v3))) ([v0 v1 v2 v3 v4] - (doto #?(:clj (HashSet.) :cljs (Set.)) + (doto #?(:clj (HashSet.) :cljs (js/Set.)) (.add v0) (.add v1) (.add v2) (.add v3) (.add v4))) ([v0 v1 v2 v3 v4 v5] - (doto #?(:clj (HashSet.) :cljs (Set.)) + (doto #?(:clj (HashSet.) :cljs (js/Set.)) (.add v0) (.add v1) (.add v2) @@ -197,7 +193,7 @@ ([v0 v1 v2 v3 v4 v5 v6 & vs] (reduce (fn [#?(:clj ^HashSet xs :cljs xs) v] (doto xs (.add v))) - (doto #?(:clj (HashSet.) :cljs (Set.)) + (doto #?(:clj (HashSet.) :cljs (js/Set.)) (.add v0) (.add v1) (.add v2) From ec151695a514786ed410ae938ff8a18b1c8682d5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 19 Jun 2018 02:41:56 -0600 Subject: [PATCH 080/810] `seq` now works on `MutableHashMap`! --- src-untyped/quantum/untyped/core/data/map.cljc | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/map.cljc b/src-untyped/quantum/untyped/core/data/map.cljc index 9e371d76..05ac0fd5 100644 --- a/src-untyped/quantum/untyped/core/data/map.cljc +++ b/src-untyped/quantum/untyped/core/data/map.cljc @@ -140,9 +140,9 @@ [meta ^:mutable ct ^js/Map m #_"Keys are int hashes; vals are map entries from k to v" ^:mutable ^boolean has-nil? ^:mutable nil-val ^:mutable __hash] Object - (toString [this] (str (into {} (vals m)))) + (toString [this] (str (into {} (es6-iterator-seq (.values m))))) (equiv [this other] (-equiv this other)) - (keys [this] (es6-iterator (keys this))) + (keys [this] (es6-iterator (cljs.core/keys this))) (entries [this] (es6-entries-iterator (seq this))) (values [this] (es6-iterator (vals this))) (has [this k] (contains? this k)) @@ -165,7 +165,7 @@ ISeqable (-seq [this] (when (pos? ct) - (let [s (seq (.values m))] + (let [s (es6-iterator-seq (.values m))] (if has-nil? (cons (map-entry nil nil-val) s) s)))) From e1ce160ce45cab37193a43b1b6769978cfb53553 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 19 Jun 2018 02:48:10 -0600 Subject: [PATCH 081/810] Touch up maps/sets in core.type --- src-untyped/quantum/untyped/core/type.cljc | 77 +++++++++++++++------- 1 file changed, 54 insertions(+), 23 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 1995703a..02b587cd 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -30,6 +30,8 @@ [quantum.untyped.core.core :as ucore] [quantum.untyped.core.data.bits :as ubit] [quantum.untyped.core.data.hash :as uhash] + [quantum.untyped.core.data.map + #?@(:cljs [:refer [MutableHashMap]])] [quantum.untyped.core.data.tuple] [quantum.untyped.core.defnt :refer [defns defns-]] @@ -906,7 +908,18 @@ ;; ===== Maps ===== ;; Associative -;; ----- Hash Maps ----- ;; +;; ----- Identity Maps (identity-based equality) ----- ;; + + (-def !identity-map|ref->ref? #?(:clj (isa? java.util.IdentityHashMap) + :cljs (isa? js/Map))) + + (-def !identity-map? !identity-map|ref->ref?) + +#?(:clj (-def !!identity-map? none?)) + + (-def identity-map? (or !identity-map? #?(:clj !!identity-map?))) + +;; ----- Hash Maps (value-based equality) ----- ;; (-def +hash-map? (isa? #?(:clj clojure.lang.PersistentHashMap :cljs cljs.core/PersistentHashMap))) @@ -1010,7 +1023,7 @@ #_(isa? java.util.IdentityHashMap) (isa? it.unimi.dsi.fastutil.objects.Reference2ReferenceOpenHashMap) (isa? it.unimi.dsi.fastutil.objects.Reference2ReferenceOpenCustomHashMap)] - :cljs [(isa? goog.structs.Map)]))) + :cljs [MutableHashMap]))) (def-preds|map|any !hash-map) @@ -1207,25 +1220,43 @@ (-def !unsorted-map|float->double? (or !hash-map|float->double? !array-map|float->double?)) (-def !unsorted-map|float->ref? (or !hash-map|float->ref? !array-map|float->ref?)) - (-def !unsorted-map|double->boolean? (or !hash-map|double->boolean? !array-map|double->boolean?)) - (-def !unsorted-map|double->byte? (or !hash-map|double->byte? !array-map|double->byte?)) - (-def !unsorted-map|double->char? (or !hash-map|double->char? !array-map|double->char?)) - (-def !unsorted-map|double->short? (or !hash-map|double->short? !array-map|double->short?)) - (-def !unsorted-map|double->int? (or !hash-map|double->int? !array-map|double->int?)) - (-def !unsorted-map|double->long? (or !hash-map|double->long? !array-map|double->long?)) - (-def !unsorted-map|double->float? (or !hash-map|double->float? !array-map|double->float?)) - (-def !unsorted-map|double->double? (or !hash-map|double->double? !array-map|double->double?)) - (-def !unsorted-map|double->ref? (or !hash-map|double->ref? !array-map|double->ref?)) - - (-def !unsorted-map|ref->boolean? (or !hash-map|ref->boolean? !array-map|ref->boolean?)) - (-def !unsorted-map|ref->byte? (or !hash-map|ref->byte? !array-map|ref->byte?)) - (-def !unsorted-map|ref->char? (or !hash-map|ref->char? !array-map|ref->char?)) - (-def !unsorted-map|ref->short? (or !hash-map|ref->short? !array-map|ref->short?)) - (-def !unsorted-map|ref->int? (or !hash-map|ref->int? !array-map|ref->int?)) - (-def !unsorted-map|ref->long? (or !hash-map|ref->long? !array-map|ref->long?)) - (-def !unsorted-map|ref->float? (or !hash-map|ref->float? !array-map|ref->float?)) - (-def !unsorted-map|ref->double? (or !hash-map|ref->double? !array-map|ref->double?)) - (-def !unsorted-map|ref->ref? (or !hash-map|ref->ref? !array-map|ref->ref?)) + (-def !unsorted-map|double->boolean? + (or !hash-map|double->boolean? !array-map|double->boolean?)) + (-def !unsorted-map|double->byte? + (or !hash-map|double->byte? !array-map|double->byte?)) + (-def !unsorted-map|double->char? + (or !hash-map|double->char? !array-map|double->char?)) + (-def !unsorted-map|double->short? + (or !hash-map|double->short? !array-map|double->short?)) + (-def !unsorted-map|double->int? + (or !hash-map|double->int? !array-map|double->int?)) + (-def !unsorted-map|double->long? + (or !hash-map|double->long? !array-map|double->long?)) + (-def !unsorted-map|double->float? + (or !hash-map|double->float? !array-map|double->float?)) + (-def !unsorted-map|double->double? + (or !hash-map|double->double? !array-map|double->double?)) + (-def !unsorted-map|double->ref? + (or !hash-map|double->ref? !array-map|double->ref?)) + + (-def !unsorted-map|ref->boolean? + (or !hash-map|ref->boolean? !array-map|ref->boolean?)) + (-def !unsorted-map|ref->byte? + (or !hash-map|ref->byte? !array-map|ref->byte?)) + (-def !unsorted-map|ref->char? + (or !hash-map|ref->char? !array-map|ref->char?)) + (-def !unsorted-map|ref->short? + (or !hash-map|ref->short? !array-map|ref->short?)) + (-def !unsorted-map|ref->int? + (or !hash-map|ref->int? !array-map|ref->int?)) + (-def !unsorted-map|ref->long? + (or !hash-map|ref->long? !array-map|ref->long?)) + (-def !unsorted-map|ref->float? + (or !hash-map|ref->float? !array-map|ref->float?)) + (-def !unsorted-map|ref->double? + (or !hash-map|ref->double? !array-map|ref->double?)) + (-def !unsorted-map|ref->ref? + (or !identity-map|ref->ref? !hash-map|ref->ref? !array-map|ref->ref?)) (def-preds|map|any !unsorted-map) @@ -1488,8 +1519,8 @@ ;; ----- Identity Sets (identity-based equality) ----- ;; - (-def !identity-set? #?(:clj none? #_(isa? java.util.IdentityHashSet) - :cljs (or (isa? js/Set) (isa? goog.structs.Set)))) + (-def !identity-set? #?(:clj none? #_(isa? java.util.IdentityHashSet) ; TODO implement + :cljs (isa? js/Set))) (-def identity-set? !identity-set?) From a90bbb0e05113c8c1e1282436147ef46b9b743f1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 19 Jun 2018 13:28:14 -0600 Subject: [PATCH 082/810] Fix compilation --- src-untyped/quantum/untyped/core/spec.cljc | 1 + test/quantum/test/untyped/core/type.cljc | 2 +- test/quantum/test/untyped/core/type/compare.cljc | 5 +++-- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/src-untyped/quantum/untyped/core/spec.cljc b/src-untyped/quantum/untyped/core/spec.cljc index 0f7e4b0d..2116117a 100644 --- a/src-untyped/quantum/untyped/core/spec.cljc +++ b/src-untyped/quantum/untyped/core/spec.cljc @@ -125,6 +125,7 @@ #?(:clj (quantum.untyped.core.vars/defmalias + clojure.spec.alpha/+ cljs.spec.alpha/+ )) #?(:clj (quantum.untyped.core.vars/defmalias * clojure.spec.alpha/* cljs.spec.alpha/* )) #?(:clj (quantum.untyped.core.vars/defmalias ? clojure.spec.alpha/? cljs.spec.alpha/? )) +#?(:clj (quantum.untyped.core.vars/defmalias & clojure.spec.alpha/& cljs.spec.alpha/& )) ;; Note that `and` results in a spec, and as such creates a new regex context :/ #?(:clj (quantum.untyped.core.vars/defmalias and clojure.spec.alpha/and cljs.spec.alpha/and )) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 2500cd64..7bca3717 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -36,7 +36,7 @@ #?(:clj (testing "hash(code) equality" (is= (.hashCode a) (.hashCode b)))) (testing "collection equality" - (is= 1 (count (hash-set a b))))))) + (is= 1 (count (hash-set a b)))))) (deftest test|universal-set (test-equality #(UniversalSetType.))) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 85c2bcfa..57f2fda3 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -3,6 +3,7 @@ [clojure.core :as core] [quantum.untyped.core.analyze.expr :as xp :refer [>expr]] + [quantum.untyped.core.data.hash :as uhash] [quantum.untyped.core.fn :refer [fn1]] [quantum.untyped.core.logic @@ -141,9 +142,9 @@ "To generate all commutative possibilities for a given type." [t t/type? > (s/seq-of t/type?)] (ifs (t/and-type? t) (->> t utr/and-type>args ucombo/permutations - (map #(utr/->AndType (vec %) (atom nil)))) + (map #(utr/->AndType uhash/default uhash/default (vec %) (atom nil)))) (t/or-type? t) (->> t utr/or-type>args ucombo/permutations - (map #(utr/->OrType (vec %) (atom nil)))) + (map #(utr/->OrType uhash/default uhash/default (vec %) (atom nil)))) [t])) #?(:clj From 664dea279afe07ee19f00219060ecc68d47f26e4 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 19 Jun 2018 13:28:30 -0600 Subject: [PATCH 083/810] `code=` no longer factors in :line and :column in metadata --- src-untyped/quantum/untyped/core/core.cljc | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src-untyped/quantum/untyped/core/core.cljc b/src-untyped/quantum/untyped/core/core.cljc index 7a4cdaf8..a3f9d5e9 100644 --- a/src-untyped/quantum/untyped/core/core.cljc +++ b/src-untyped/quantum/untyped/core/core.cljc @@ -60,11 +60,12 @@ (defn code= "Ensures that two pieces of code are equivalent. This means ensuring that seqs, vectors, and maps are only allowed to be compared with - each other, and that metadata is equivalent." + each other, and that metadata (minus line and column metadata) is equivalent." ([code0 code1] (if (metable? code0) (and (metable? code1) - (= (meta code0) (meta code1)) + (= (-> code0 meta (dissoc :line :column)) + (-> code1 meta (dissoc :line :column))) (cond (seq? code0) (and (seq? code1) (seq= code0 code1 code=)) (vector? code0) (and (vector? code1) (seq= (seq code0) (seq code1) code=)) (map? code0) (and (map? code1) (seq= (seq code0) (seq code1) code=)) From 2ff30cbcc647b79611035c0190893f4bd82f132a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 19 Jun 2018 14:18:53 -0600 Subject: [PATCH 084/810] Clean up arg-types and arg-classes --- src-dev/quantum/core/defnt.cljc | 76 +++++++++++++++++++-------------- 1 file changed, 43 insertions(+), 33 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 10c805e8..ee359d93 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -85,8 +85,9 @@ types will very often have to be validated at runtime. [ ] Compile-Time (Direct) Dispatch - - Any argument, if it requires a non-nilable primitive-like value, will be marked as a primitive. - - If nilable, will it be boxed or will there be one overload for nil and one for primitive? + - Any argument, if it requires a non-nilable primitive-like value, will be marked as a + primitive. + - If nilable, there will be one overload for nil and one for primitive. - When a `fnt` with type overloads is referenced outside of a typed context, then the overload resolution will be done via Runtime Dispatch. - TODO Should we take into account 'actual' types (not just 'declared' types) when performing @@ -153,14 +154,14 @@ implementations at will as long as the specs don't change - To make this process faster we maintain a set of typedefs so at least cheap c/= checks can be performed - - If c/= succeeds, great; the `reify` corresponding the label (and reify-type) will be + - If c/= succeeds, great; the `reify` corresponding to the label (and reify-type) will be replaced; the typedef-set will remain unchanged - Else it must find a corresponding typedef by t/= - Then if it is found by t/= it will replace the `reify` and the typedef corresponding with that label and replace the typedef in the typedef-set - Else a new label will be given to the `reify`; the typedef will be added to the typedef-set - - [ ] One reify per type that cannot be split + - [ ] One reify per type-that-cannot-be-split - Only `t/or`s can be split for now - [ ] `(= (hash (t/or t/long? t/float?)) (hash (t/or t/long? t/float?)))` - Currently this isn't the case; we'd like to have it so, so we can more efficiently look @@ -206,7 +207,8 @@ (defns out-type>class [t t/type? > (? t/class?)] (let [cs (t/type>classes t) cs' (disj cs nil)] (if (-> cs' count (not= 1)) - ;; NOTE: we don't need to vary the output class if there are multiple output possibilities or just nil + ;; NOTE: we don't need to vary the output class if there are multiple output possibilities + ;; or just nil java.lang.Object (-> (class>most-primitive-class (first cs') (contains? cs nil)) class>simplest-class))))) @@ -805,20 +807,16 @@ #?(:clj (defns- >fnt|overload - [{:keys [arg-bindings _, arg-classes|pre-analyze _, arg-types|pre-analyze|base _, args _ - body-codelist|pre-analyze _, lang ::lang, post-form _, varargs _, varargs-binding _]} _ + "Is given `arg-classes` and `arg-types`. In order to determine the out-type, performs an analysis + using (in part) these pieces of data, but does not use the possibly-updated `arg-types` as + computed in the analysis. As a result, does not yet support type inference." + [{:keys [arg-bindings _, arg-classes _, arg-types _, args _, body-codelist|pre-analyze _, + lang ::lang, post-form _, varargs _, varargs-binding _]} _ > ::fnt|overload] - (let [arg-types|pre-analyze - (c/mergev-with - (fn [_ s #_t/type? c #_t/class?] - (cond-> s (t/primitive-class? c) (t/and c))) - arg-types|pre-analyze|base arg-classes|pre-analyze) - env (->> (zipmap arg-bindings arg-types|pre-analyze) + (let [env (->> (zipmap arg-bindings arg-types) (c/map' (fn [[arg-binding arg-type]] [arg-binding (ast/unbound nil arg-binding arg-type)]))) analyzed (analyze env (ufgen/?wrap-do body-codelist|pre-analyze)) - arg-types (->> arg-bindings (mapv #(:type (c/get (:env analyzed) %)))) - arg-classes (->> arg-types (c/map type>most-primitive-class)) arg-classes|simplest (->> arg-classes (c/map class>simplest-class)) hint-arg|fn (fn [i arg-binding] (ufth/with-type-hint arg-binding @@ -842,6 +840,7 @@ (:type analyzed) (err! "Body does not match output type" {:body analyzed :output-type post-type}))) (:type analyzed)) + _ (prl! arg-bindings args arg-classes arg-types out-type) body-form (-> (:form analyzed) (cond-> post-type|runtime? (>with-post-type post-type)) @@ -862,41 +861,52 @@ #?(:clj ; really, reserve for metalanguage (defn fnt|overload-data>overload-group "Rather than rigging together something in which either: - 1) the Clojure compiler will try to cross its fingers and evaluate code meant to be evaluated in ClojureScript - 2) we use a CLJS-in-CLJS compiler and alienate the mainstream CLJS-in-CLJ (cljsbuild) workflow, which includes - our own workflow - 3) we wait for CLJS-in-CLJS to become mainstream, which could take years if it really ever happens - - we decide instead to evaluate types in languages in which the metalanguage (compiler language) is the same as - the object language (e.g. Clojure), and symbolically analyze types in the rest (e.g. vanilla ClojureScript), - deferring code analyzed as functions to be enforced at runtime." - [{:as in {:keys [args varargs] pre-form :pre [post-type post-form] :post} :arglist body-codelist|pre-analyze :body} + 1) the Clojure compiler will try to cross its fingers and evaluate code meant to be evaluated in + ClojureScript + 2) we use a CLJS-in-CLJS compiler and alienate the mainstream CLJS-in-CLJ (cljsbuild) workflow, + which includes our own workflow + 3) we wait for CLJS-in-CLJS to become mainstream, which could take years if it really ever + happens + + we decide instead to evaluate types in languages in which the metalanguage (compiler language) + is the same as the object language (e.g. Clojure), and symbolically analyze types in the rest + (e.g. vanilla ClojureScript), deferring code analyzed as functions to be enforced at runtime." + [{:as in {:keys [args varargs] pre-form :pre [post-type post-form] :post} :arglist + body-codelist|pre-analyze :body} {:as opts :keys [lang #_::lang symbolic-analysis? #_t/boolean?]}] (if symbolic-analysis? (err! "Symbolic analysis not supported yet") (let [_ (when pre-form (TODO "Need to handle pre")) varargs-binding (when varargs - ;; TODO this assertion is purely temporary until destructuring is supported + ;; TODO this assertion is purely temporary until destructuring is + ;; supported (assert (-> varargs :binding-form first (= :sym)))) arg-bindings (->> args (mapv (fn [{[kind binding-] :binding-form}] - ;; TODO this assertion is purely temporary until destructuring is supported + ;; TODO this assertion is purely temporary until destructuring is + ;; supported (assert kind :sym) binding-))) - arg-types|pre-analyze|base + arg-types|unprimitivized (->> args (mapv (fn [{[kind #_#{:any :spec}, t #_t/form?] :spec}] (case kind :any t/any? :spec (-> t eval t/>type))))) - arg-classes-seq|pre-analyze (arg-types>arg-classes-seq|primitivized arg-types|pre-analyze|base) + arg-classes-seq (arg-types>arg-classes-seq|primitivized arg-types|unprimitivized) ;; `unprimitivized` is first because of class sorting [unprimitivized & primitivized] - (->> arg-classes-seq|pre-analyze - (mapv (fn [arg-classes|pre-analyze] - (>fnt|overload - (kw-map arg-bindings arg-classes|pre-analyze arg-types|pre-analyze|base args - body-codelist|pre-analyze lang post-form varargs varargs-binding)))))] + (->> arg-classes-seq + (mapv (fn [arg-classes] + (let [arg-types + (c/mergev-with + (fn [_ s #_t/type? c #_t/class?] + (cond-> s (t/primitive-class? c) (t/and c))) + arg-types|unprimitivized arg-classes)] + (>fnt|overload + (kw-map arg-bindings arg-classes arg-types args + body-codelist|pre-analyze lang post-form varargs + varargs-binding))))))] {:unprimitivized unprimitivized :primitivized primitivized})))) From b446b28c232c1d003384129032362b985e10ecd8 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 21 Jun 2018 23:23:59 -0600 Subject: [PATCH 085/810] Reproducible gensym enhancement --- src-dev/quantum/core/defnt.cljc | 23 ++++++++---- src-dev/quantum/core/defnt_equivalences.cljc | 35 ++++++++++++------- src-untyped/quantum/untyped/core/form.cljc | 2 +- .../quantum/untyped/core/form/generate.cljc | 10 +++--- 4 files changed, 45 insertions(+), 25 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index ee359d93..1dbe098f 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -936,6 +936,7 @@ (defns fnt|overload>reify-overload [{:as overload :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, out-class t/class?]} :fnt/overload + gen-gensym fn? > (s/seq-of ::reify|overload)] (let [interface-k {:out out-class :in arg-classes} interface @@ -943,11 +944,13 @@ (swap! update interface-k #(or % (eval (fnt-overload>interface arg-classes out-class)))) (c/get interface-k)) arglist-code - (>vec (concat ['_] + (>vec (concat [(gen-gensym '_)] (doto (->> arglist-code|reify|unhinted - (map-indexed - (fn [i arg] (ufth/with-type-hint arg (-> arg-classes (doto pr/ppr-meta) (c/get i) (doto pr/ppr-meta) ufth/>arglist-embeddable-tag))))) - pr/ppr-meta)))] + (map-indexed + (fn [i arg] + (ufth/with-type-hint arg (-> arg-classes (doto pr/ppr-meta) + (c/get i) (doto pr/ppr-meta) ufth/>arglist-embeddable-tag))))) + pr/ppr-meta)))] {:arglist-code arglist-code :body-form body-form :interface interface @@ -956,10 +959,13 @@ #?(:clj (defns fnt|overload-group>reify - [{:keys [overload-group :fnt/overload-group, i t/integer?, fn|name :quantum.core.specs/fn|name]} _] + [{:keys [overload-group :fnt/overload-group + i t/integer? + fn|name :quantum.core.specs/fn|name]} _ + gen-gensym fn?] (let [reify-overloads (->> (concat [(:unprimitivized overload-group)] (:primitivized overload-group)) - (c/map fnt|overload>reify-overload))] + (c/map #(fnt|overload>reify-overload % gen-gensym)))] `(~'def ~(>symbol (str fn|name "|__" i)) (reify ~@(->> reify-overloads (c/lmap (fn [{:keys [interface out-class method-sym arglist-code body-form]} #_::reify|overload] @@ -1035,6 +1041,8 @@ (prl! kind lang args) (let [{:keys [:quantum.core.specs/fn|name overloads :quantum.core.specs/meta] :as args'} (s/validate args (case kind :defn ::defnt :fn ::fnt)) + gen-gensym-base (ufgen/>reproducible-gensym|generator) + gen-gensym (fn [x] (symbol (str (gen-gensym-base x) "__"))) _ (prl! args') inline? (s/validate (-> fn|name core/meta :inline) (t/? t/boolean?)) @@ -1058,7 +1066,8 @@ direct-dispatch-codelist (case lang :clj (for [[i fnt|overload-group] (c/lindexed fnt|overload-groups)] - (fnt|overload-group>reify (assoc (kw-map i fn|name) :overload-group fnt|overload-group))) + (fnt|overload-group>reify + (assoc (kw-map i fn|name) :overload-group fnt|overload-group) gen-gensym)) :cljs (TODO)) base-fn-codelist [] ; TODO fn-codelist diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index a5634c5c..77a6f85b 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -83,15 +83,24 @@ (*<> t/any?)) (def ~'identity|uninlined|__0 (reify - Object>Object (~(tag "java.lang.Object" 'invoke) [_## ~(tag "java.lang.Object" 'x)] ~'x) - boolean>boolean (~(tag "boolean" 'invoke) [_## ~(tag "boolean" 'x)] ~'x) - byte>byte (~(tag "byte" 'invoke) [_## ~(tag "byte" 'x)] ~'x) - short>short (~(tag "short" 'invoke) [_## ~(tag "short" 'x)] ~'x) - char>char (~(tag "char" 'invoke) [_## ~(tag "char" 'x)] ~'x) - int>int (~(tag "int" 'invoke) [_## ~(tag "int" 'x)] ~'x) - long>long (~(tag "long" 'invoke) [_## ~(tag "long" 'x)] ~'x) - float>float (~(tag "float" 'invoke) [_## ~(tag "float" 'x)] ~'x) - double>double (~(tag "double" 'invoke) [_## ~(tag "double" 'x)] ~'x))) + Object>Object + (~(tag "java.lang.Object" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] ~'x) + boolean>boolean + (~(tag "boolean" 'invoke) [~'_1__ ~(tag "boolean" 'x)] ~'x) + byte>byte + (~(tag "byte" 'invoke) [~'_2__ ~(tag "byte" 'x)] ~'x) + short>short + (~(tag "short" 'invoke) [~'_3__ ~(tag "short" 'x)] ~'x) + char>char + (~(tag "char" 'invoke) [~'_4__ ~(tag "char" 'x)] ~'x) + int>int + (~(tag "int" 'invoke) [~'_5__ ~(tag "int" 'x)] ~'x) + long>long + (~(tag "long" 'invoke) [~'_6__ ~(tag "long" 'x)] ~'x) + float>float + (~(tag "float" 'invoke) [~'_7__ ~(tag "float" 'x)] ~'x) + double>double + (~(tag "double" 'invoke) [~'_8__ ~(tag "double" 'x)] ~'x))) #_(defn ~'identity|uninlined {::t/type (t/fn [t/any?])} @@ -138,21 +147,21 @@ ;; [t/string?] - (def ~(tag "[Ljava.lang.Object;" 'name|__0|input-types) + #_(def ~(tag "[Ljava.lang.Object;" 'name|__0|input-types) (*<> t/string?)) (def ~(tag `Object>Object 'name|__0) (reify Object>Object - (~(tag "java.lang.Object" 'invoke) [_## ~(tag "java.lang.Object" 'x)] + (~(tag "java.lang.Object" 'invoke) [_0__ ~(tag "java.lang.Object" 'x)] (let* [~(tag "java.lang.String" 'x) ~'x] ~'x)))) ;; [(t/isa? Named)] - (def ~(tag "[Ljava.lang.Object;" 'name|__1|input-types) + #_(def ~(tag "[Ljava.lang.Object;" 'name|__1|input-types) (*<> (t/isa? Named))) (def ~(tag `Object>Object 'name|__1) (reify Object>Object - (~(tag "java.lang.Object" 'invoke) [_## ~(tag "java.lang.Object" 'x)] + (~(tag "java.lang.Object" 'invoke) [_1__ ~(tag "java.lang.Object" 'x)] (let* [~(tag "clojure.lang.Named" 'x) ~'x] (let* [~'out (.getName ~'x)] (t/validate ~'out t/string?)))))) diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index 33e1ba37..90df0312 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -50,5 +50,5 @@ "Reproducibly, unifiedly syntax quote without messing up the format as a literal syntax quote might do." [body] - `(binding [ufgen/*reproducible-gensym* (ufgen/>reproducible-gensym|generator)] + `(binding [ufgen/*reproducible-gensym* (ufgen/>reproducible-gensym|generator true)] (ufgen/unify-gensyms (syntax-quote ~body) true)))) diff --git a/src-untyped/quantum/untyped/core/form/generate.cljc b/src-untyped/quantum/untyped/core/form/generate.cljc index 0524fa49..8083b1c6 100644 --- a/src-untyped/quantum/untyped/core/form/generate.cljc +++ b/src-untyped/quantum/untyped/core/form/generate.cljc @@ -83,9 +83,10 @@ (def ^:dynamic *reproducible-gensym* nil) -(defn >reproducible-gensym|generator [] +(defn >reproducible-gensym|generator [& memoize?] (let [*counter (atom -1)] - (memoize #(symbol (str % (swap! *counter inc)))))) + (cond-> #(symbol (str % (swap! *counter inc))) + memoize? memoize))) (defn unify-gensyms "All gensyms defined using two hash symbols are unified to the same @@ -96,10 +97,11 @@ ([body reproducible-gensyms?] (let [gensym* (or *reproducible-gensym* (memoize (if reproducible-gensyms? - (>reproducible-gensym|generator) + (>reproducible-gensym|generator true) gensym)))] (ucore/postwalk #(if (unified-gensym? %) - (symbol (str (gensym* (str (un-gensym %) "__")) (when-not reproducible-gensyms? "__auto__"))) + (symbol (str (gensym* (str (un-gensym %) "__")) + (when-not reproducible-gensyms? "__auto__"))) %) body)))) From 5f4fa92ef3c91d2aa0dd82560fefce3f3df77900 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 21 Jun 2018 23:30:44 -0600 Subject: [PATCH 086/810] No need for tag --- src-dev/quantum/core/defnt.cljc | 11 ++++++++--- src-dev/quantum/core/defnt_equivalences.cljc | 8 ++++---- 2 files changed, 12 insertions(+), 7 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 1dbe098f..53971b38 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -926,7 +926,8 @@ (defns fnt-overload>interface [args-classes _, out-class t/class?] (let [interface-sym (fnt-overload>interface-sym args-classes out-class) - hinted-method-sym (ufth/with-type-hint fnt-method-sym (ufth/>interface-method-tag out-class)) + hinted-method-sym (ufth/with-type-hint fnt-method-sym + (ufth/>interface-method-tag out-class)) hinted-args (ufth/hint-arglist-with (ufgen/gen-args (count args-classes)) (map ufth/>interface-method-tag args-classes))] @@ -1051,7 +1052,8 @@ (do (log/pr :warn "requested `:inline`; ignoring until feature is implemented") (update-meta fn|name dissoc :inline)) fn|name) - fnt|overload-groups (->> overloads (mapv #(fnt|overload-data>overload-group % {:lang lang}))) + fnt|overload-groups + (->> overloads (mapv #(fnt|overload-data>overload-group % {:lang lang}))) ;; only one variadic arg allowed _ (s/validate fnt|overload-groups (fn->> (c/lmap :unprimitivized) (c/lfilter :variadic?) count (<- (<= 1)))) @@ -1061,7 +1063,10 @@ (c/group-by :positional-args-ct) (map-vals+ :out-type) join (apply concat)) - variadic-overload (->> fnt|overload-groups (c/lmap :unprimitivized) (c/lfilter :variadic?) first) + variadic-overload (->> fnt|overload-groups + (c/lmap :unprimitivized) + (c/lfilter :variadic?) + first) register-type (gen-register-type (kw-map fn|name arg-ct->type variadic-overload)) direct-dispatch-codelist (case lang diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 77a6f85b..4a1a4222 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -149,9 +149,9 @@ #_(def ~(tag "[Ljava.lang.Object;" 'name|__0|input-types) (*<> t/string?)) - (def ~(tag `Object>Object 'name|__0) + (def ~'name|__0 (reify Object>Object - (~(tag "java.lang.Object" 'invoke) [_0__ ~(tag "java.lang.Object" 'x)] + (~(tag "java.lang.Object" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] (let* [~(tag "java.lang.String" 'x) ~'x] ~'x)))) @@ -159,9 +159,9 @@ #_(def ~(tag "[Ljava.lang.Object;" 'name|__1|input-types) (*<> (t/isa? Named))) - (def ~(tag `Object>Object 'name|__1) + (def ~'name|__1 (reify Object>Object - (~(tag "java.lang.Object" 'invoke) [_1__ ~(tag "java.lang.Object" 'x)] + (~(tag "java.lang.Object" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] (let* [~(tag "clojure.lang.Named" 'x) ~'x] (let* [~'out (.getName ~'x)] (t/validate ~'out t/string?)))))) From e8ff338cd30ced1abed03dcd00148c9f2ee6ee0f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 22 Jun 2018 00:22:59 -0600 Subject: [PATCH 087/810] Some more fixes --- src-dev/quantum/core/defnt.cljc | 30 +++++++++++--------- src-dev/quantum/core/defnt_equivalences.cljc | 5 ++-- 2 files changed, 19 insertions(+), 16 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 53971b38..f3ea09f1 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -758,10 +758,9 @@ (cond (not= k :spec) java.lang.Object; default class (symbol? spec) (pred->class lang spec)))) -(defn >with-post-type - [body post-type] - `(let [~'out ~body] - (s/validate ~'out ~(update-meta post-type dissoc* :runtime?)))) +;; TODO optimize such that `post-form` doesn't create a new type-validator wholesale every time the +;; function gets run; e.g. extern it +(defn >with-post-form [body post-form] `(let* [~'out ~body] (t/validate ~'out ~post-form))) #?(:clj (var/def sort-guide "for use in arity sorting, in increasing conceptual size" @@ -793,13 +792,15 @@ (c/lmap (fn [t #_t/type?] (if (-> t meta :ref?) (-> t t/type>classes (disj nil) seq) - (let [cs (type>most-primitive-classes t)] - (let [base-classes (->> cs (c/map+ class>simplest-class) >set) - base-classes (cond-> base-classes (contains? cs nil) (conj java.lang.Object))] - (->> cs (c/map+ tcore/class>prim-subclasses) - (educe (aritoid nil identity set/union) base-classes) - ;; for purposes of cleanliness and reproducibility in tests - (sort-by sort-guide))))))) + (let [cs (type>most-primitive-classes t) + base-classes + (cond-> (>set cs) + (contains? cs nil) (-> (disj nil) (conj java.lang.Object)))] + (->> cs + (c/map+ tcore/class>prim-subclasses) + (educe (aritoid nil identity set/union) base-classes) + ;; for purposes of cleanliness and reproducibility in tests + (sort-by sort-guide)))))) (apply combo/cartesian-product) (c/lmap >vec)))) @@ -825,8 +826,12 @@ lang (c/count args) varargs))) + post-form|embeddable (if (or (nil? post-form) (= post-form '_)) + `t/any? + post-form) post-type (cond (nil? post-form) nil (= post-form '_) t/any? + ;; TODO this becomes an issue when `post-form` references local bindings :else (eval post-form)) post-type|runtime? (-> post-type meta :runtime?) out-type (if post-type @@ -840,10 +845,9 @@ (:type analyzed) (err! "Body does not match output type" {:body analyzed :output-type post-type}))) (:type analyzed)) - _ (prl! arg-bindings args arg-classes arg-types out-type) body-form (-> (:form analyzed) - (cond-> post-type|runtime? (>with-post-type post-type)) + (cond-> post-type|runtime? (>with-post-form post-form|embeddable)) (ufth/cast-bindings|code (->> (c/zipmap-into (map/om) arg-bindings arg-classes) (c/remove-vals' (fn-or nil? (fn= java.lang.Object) t/primitive-class?)))))] diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 4a1a4222..243cdcc5 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -152,8 +152,7 @@ (def ~'name|__0 (reify Object>Object (~(tag "java.lang.Object" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "java.lang.String" 'x) ~'x] - ~'x)))) + (let* [~(tag "java.lang.String" 'x) ~'x] ~'x)))) ;; [(t/isa? Named)] @@ -164,7 +163,7 @@ (~(tag "java.lang.Object" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] (let* [~(tag "clojure.lang.Named" 'x) ~'x] (let* [~'out (.getName ~'x)] - (t/validate ~'out t/string?)))))) + (t/validate ~'out ~'(* t/string?))))))) #_(defn ~'name {::t/type From 865ec9180258e6a510b1efe2f2cfae17d699037e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 22 Jun 2018 15:50:42 -0600 Subject: [PATCH 088/810] Track down code equality errors more easily --- src-dev/quantum/core/defnt_equivalences.cljc | 37 +++++++++++++------- src-untyped/quantum/untyped/core/test.cljc | 24 +++++++++++++ 2 files changed, 48 insertions(+), 13 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 243cdcc5..429696e6 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -23,7 +23,7 @@ :refer [ifs]] [quantum.untyped.core.spec :as s] [quantum.untyped.core.test :as test - :refer [deftest testing is is= throws]] + :refer [deftest testing is is= is-code= throws]] [quantum.untyped.core.type :as t :refer [? *]] [quantum.untyped.core.type.reifications :as utr]) @@ -183,7 +183,7 @@ ;; =====|=====|=====|=====|===== ;; -(is (code= +(is-code= ;; Perhaps silly in ClojureScript, but avoids boxing in Clojure (macroexpand ' @@ -195,26 +195,37 @@ ;; ----- expanded code ----- ;; +;; TODO for some reason it doesn't recognize that it's a boolean return value (case (env-lang) :clj ($ (do ;; [x t/nil?] (def ~'some?|__0 (reify - Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] false))) + Object>boolean + (~(tag "boolean" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] false))) ;; [x t/any?] (def ~'some?|__1 (reify - Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] true) - boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] true) - byte>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "byte" 'x)] true) - short>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "short" 'x)] true) - char>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "char" 'x)] true) - int>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "int" 'x)] true) - long>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "long" 'x)] true) - float>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "float" 'x)] true) - double>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "double" 'x)] true))) + Object>boolean + (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] true) + boolean>boolean + (~(tag "boolean" 'invoke) [~'_2__ ~(tag "boolean" 'x)] true) + byte>boolean + (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'x)] true) + short>boolean + (~(tag "boolean" 'invoke) [~'_4__ ~(tag "short" 'x)] true) + char>boolean + (~(tag "boolean" 'invoke) [~'_5__ ~(tag "char" 'x)] true) + int>boolean + (~(tag "boolean" 'invoke) [~'_6__ ~(tag "int" 'x)] true) + long>boolean + (~(tag "boolean" 'invoke) [~'_7__ ~(tag "long" 'x)] true) + float>boolean + (~(tag "boolean" 'invoke) [~'_8__ ~(tag "float" 'x)] true) + double>boolean + (~(tag "boolean" 'invoke) [~'_9__ ~(tag "double" 'x)] true))) #_(defn ~'some? {::t/type (t/fn [t/nil?] @@ -225,7 +236,7 @@ (ifs (nil? x) false true))))) -)) +) ;; =====|=====|=====|=====|===== ;; diff --git a/src-untyped/quantum/untyped/core/test.cljc b/src-untyped/quantum/untyped/core/test.cljc index 59905908..f2a5b829 100644 --- a/src-untyped/quantum/untyped/core/test.cljc +++ b/src-untyped/quantum/untyped/core/test.cljc @@ -4,6 +4,7 @@ [clojure.spec.test.alpha :as stest] [clojure.string :as str] [clojure.test :as test] + [quantum.untyped.core.core :as ucore] [quantum.untyped.core.error :as err] [quantum.untyped.core.print :refer [ppr-meta]] @@ -21,7 +22,30 @@ (defn test-nss-where [pred] (->> (all-ns) (filter #(-> % ns-name name pred)) (map test-ns) doall))) +(defn code= + "`code=` but with helpful test-related logging" + ([code0 code1] + (if (ucore/metable? code0) + (and (ucore/metable? code1) + (let [meta0 (-> code0 meta (dissoc :line :column)) + meta1 (-> code1 meta (dissoc :line :column))] + (or (= meta0 meta1) + (println "FAIL: meta not match for" meta0 meta1))) + (cond + (seq? code0) (and (seq? code1) (ucore/seq= code0 code1 code=)) + (vector? code0) (and (vector? code1) (ucore/seq= (seq code0) (seq code1) code=)) + (map? code0) (and (map? code1) (ucore/seq= (seq code0) (seq code1) code=)) + :else (or (= code0 code1) + (println "FAIL in `:else` `(= code0 code1)`" code0 code1)))) + (and (not (ucore/metable? code1)) + (or (= code0 code1) + (println "FAIL in non-metable `(= code0 code1)`" code0 code1))))) + ([code0 code1 & codes] (and (code= code0 code1) (every? #(code= code0 %) codes)))) + +#?(:clj (defmacro is-code= [& args] `(is (code= ~@args)))) + #?(:clj (defmacro is= [& args] `(is (= ~@args)))) + #?(:clj (defmacro throws ([x] `(do (is (~'thrown? ~(err/env>generic-error &env) ~x)) true)) ([expr err-pred] From fbcd32c4800b056d7539c2335c7cd41b48af2887 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 22 Jun 2018 16:04:48 -0600 Subject: [PATCH 089/810] Ensure class of a value-type is correct --- src-untyped/quantum/untyped/core/type.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 02b587cd..6e290502 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -512,7 +512,7 @@ (cond (utr/class-type? t) (conj classes (utr/class-type>class t)) (utr/value-type? t) - (conj classes (utr/value-type>value t)) + (conj classes (-> t utr/value-type>value c/type)) (c/= t universal-set) #?(:clj #{nil java.lang.Object} :cljs (TODO "Not sure what to do in the case of universal CLJS set")) From 27b38ded9b776f531d7789f387aba71b25507fe1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 22 Jun 2018 16:04:57 -0600 Subject: [PATCH 090/810] More passing tests --- src-dev/quantum/core/defnt.cljc | 6 ++-- src-dev/quantum/core/defnt_equivalences.cljc | 37 ++++++++++---------- 2 files changed, 22 insertions(+), 21 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index f3ea09f1..2a27d1d7 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -840,10 +840,12 @@ -1 post-type 1 (:type analyzed) 0 post-type - (2 3) (err! "Body and output type comparison not handled" {:body analyzed :output-type post-type})) + (2 3) (err! "Body and output type comparison not handled" + {:body analyzed :output-type post-type})) (if (t/<= (:type analyzed) post-type) (:type analyzed) - (err! "Body does not match output type" {:body analyzed :output-type post-type}))) + (err! "Body does not match output type" + {:body analyzed :output-type post-type}))) (:type analyzed)) body-form (-> (:form analyzed) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 429696e6..c9d970e1 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -39,7 +39,7 @@ ;; =====|=====|=====|=====|===== ;; -(is (code= +(is-code= ;; ----- implementation ----- ;; @@ -52,18 +52,18 @@ ($ (do (def ~'pid|__0 (reify >Object - (~(tag "java.lang.Object" 'invoke) [~'_] + (~(tag "java.lang.Object" 'invoke) [~'_0__] ~'(->> (java.lang.management.ManagementFactory/getRuntimeMXBean) (.getName))))) #_(defn ~'pid {::t/spec (t/fn [:> (? t/string?)])}))) -)) +) ;; =====|=====|=====|=====|===== ;; -(is (code= +(is-code= (macroexpand ' (defnt identity|uninlined ([x _] x)) @@ -79,7 +79,7 @@ (case (env-lang) :clj ($ (do ;; [t/any?] - (def ~(tag "[Ljava.lang.Object;" 'identity|uninlined|__0|input-types) + #_(def ~(tag "[Ljava.lang.Object;" 'identity|uninlined|__0|input-types) (*<> t/any?)) (def ~'identity|uninlined|__0 (reify @@ -126,7 +126,7 @@ ;; =====|=====|=====|=====|===== ;; -(is (code= +(is-code= ;; TODO don't ignore `:inline` (macroexpand ' @@ -179,7 +179,7 @@ (satisfies? INamed x) (-name x) (err! "Not supported for type" {:fn `name :type (type x)})))))) -)) +) ;; =====|=====|=====|=====|===== ;; @@ -257,23 +257,22 @@ (def ~'reduced?|__0 (reify - Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "clojure.lang.Reduced" 'x) ~'x] - true)))) + Object>boolean (~(tag "boolean" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] + (let* [~(tag "clojure.lang.Reduced" 'x) ~'x] true)))) ;; [t/any?] (def ~'reduced?|__1 (reify - Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] false) - boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] false) - byte>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "byte" 'x)] false) - short>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "short" 'x)] false) - char>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "char" 'x)] false) - int>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "int" 'x)] false) - long>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "long" 'x)] false) - float>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "float" 'x)] false) - double>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "double" 'x)] false))) + Object>boolean (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false) + boolean>boolean (~(tag "boolean" 'invoke) [~'_2__ ~(tag "boolean" 'x)] false) + byte>boolean (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'x)] false) + short>boolean (~(tag "boolean" 'invoke) [~'_4__ ~(tag "short" 'x)] false) + char>boolean (~(tag "boolean" 'invoke) [~'_5__ ~(tag "char" 'x)] false) + int>boolean (~(tag "boolean" 'invoke) [~'_6__ ~(tag "int" 'x)] false) + long>boolean (~(tag "boolean" 'invoke) [~'_7__ ~(tag "long" 'x)] false) + float>boolean (~(tag "boolean" 'invoke) [~'_8__ ~(tag "float" 'x)] false) + double>boolean (~(tag "boolean" 'invoke) [~'_9__ ~(tag "double" 'x)] false))) #_(defn ~'reduced? {::t/type (t/fn [(t/isa? Reduced)] From 911c3af0c5c63c026010679ea4c50a55bb712ba8 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 22 Jun 2018 16:40:05 -0600 Subject: [PATCH 091/810] More bulletproofing on `code=` --- src-untyped/quantum/untyped/core/core.cljc | 11 +++++++++ src-untyped/quantum/untyped/core/test.cljc | 27 ++++++++++++++-------- 2 files changed, 29 insertions(+), 9 deletions(-) diff --git a/src-untyped/quantum/untyped/core/core.cljc b/src-untyped/quantum/untyped/core/core.cljc index a3f9d5e9..ab0f67f9 100644 --- a/src-untyped/quantum/untyped/core/core.cljc +++ b/src-untyped/quantum/untyped/core/core.cljc @@ -66,6 +66,17 @@ (and (metable? code1) (= (-> code0 meta (dissoc :line :column)) (-> code1 meta (dissoc :line :column))) + (let [similar-class? + (cond (seq? code0) (seq? code1) + (seq? code1) (seq? code0) + (vector? code0) (vector? code1) + (vector? code1) (vector? code0) + (map? code0) (map? code1) + (map? code1) (map? code0) + :else ::not-applicable)] + (if (= similar-class? ::not-applicable) + (= code0 code1) + (and similar-class? (ucore/seq= (seq code0) (seq code1) code=)))) (cond (seq? code0) (and (seq? code1) (seq= code0 code1 code=)) (vector? code0) (and (vector? code1) (seq= (seq code0) (seq code1) code=)) (map? code0) (and (map? code1) (seq= (seq code0) (seq code1) code=)) diff --git a/src-untyped/quantum/untyped/core/test.cljc b/src-untyped/quantum/untyped/core/test.cljc index f2a5b829..30e33f5b 100644 --- a/src-untyped/quantum/untyped/core/test.cljc +++ b/src-untyped/quantum/untyped/core/test.cljc @@ -30,19 +30,28 @@ (let [meta0 (-> code0 meta (dissoc :line :column)) meta1 (-> code1 meta (dissoc :line :column))] (or (= meta0 meta1) - (println "FAIL: meta not match for" meta0 meta1))) - (cond - (seq? code0) (and (seq? code1) (ucore/seq= code0 code1 code=)) - (vector? code0) (and (vector? code1) (ucore/seq= (seq code0) (seq code1) code=)) - (map? code0) (and (map? code1) (ucore/seq= (seq code0) (seq code1) code=)) - :else (or (= code0 code1) - (println "FAIL in `:else` `(= code0 code1)`" code0 code1)))) + (println "FAIL: meta should be match for" meta0 meta1))) + (let [similar-class? + (cond (seq? code0) (seq? code1) + (seq? code1) (seq? code0) + (vector? code0) (vector? code1) + (vector? code1) (vector? code0) + (map? code0) (map? code1) + (map? code1) (map? code0) + :else ::not-applicable)] + (if (= similar-class? ::not-applicable) + (or (= code0 code1) + (println "FAIL: should be `(= code0 code1)`" code0 code1)) + (and (or similar-class? + (println "FAIL: should be similar class" code0 code1)) + (or (ucore/seq= (seq code0) (seq code1) code=) + (println "FAIL: `(ucore/seq= code0 code1 code=)`" code0 code1)))))) (and (not (ucore/metable? code1)) (or (= code0 code1) - (println "FAIL in non-metable `(= code0 code1)`" code0 code1))))) + (println "FAIL: should be `(= code0 code1)`" code0 code1))))) ([code0 code1 & codes] (and (code= code0 code1) (every? #(code= code0 %) codes)))) -#?(:clj (defmacro is-code= [& args] `(is (code= ~@args)))) +(defn is-code= [& args] (is (apply code= args)))) #?(:clj (defmacro is= [& args] `(is (= ~@args)))) From 79955a01ffa7764bdf970a9fd0c41e97367d57b9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 22 Jun 2018 16:40:27 -0600 Subject: [PATCH 092/810] Closer to passing tests; cleanups --- src-dev/quantum/core/defnt_equivalences.cljc | 228 ++++++++----------- 1 file changed, 101 insertions(+), 127 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index c9d970e1..16bcfef4 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -286,7 +286,7 @@ ;; =====|=====|=====|=====|===== ;; -(is (code= +(is-code= (macroexpand ' (defnt #_:inline >boolean @@ -304,27 +304,38 @@ (def ~'>boolean|__0 (reify - boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] ~'x))) + boolean>boolean + (~(tag "boolean" 'invoke) [~'_0__ ~(tag "boolean" 'x)] ~'x))) ;; [t/nil?] (def ~'>boolean|__1 (reify - Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] false))) + Object>boolean + (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false))) ;; [t/any?] (def ~'>boolean|__2 (reify - Object>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] true) - boolean>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "boolean" 'x)] true) - byte>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "byte" 'x)] true) - short>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "short" 'x)] true) - char>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "char" 'x)] true) - int>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "int" 'x)] true) - long>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "long" 'x)] true) - float>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "float" 'x)] true) - double>boolean (~(tag "boolean" 'invoke) [~'_ ~(tag "double" 'x)] true))) + Object>boolean + (~(tag "boolean" 'invoke) [~'_2__ ~(tag "java.lang.Object" 'x)] true) + boolean>boolean + (~(tag "boolean" 'invoke) [~'_3__ ~(tag "boolean" 'x)] true) + byte>boolean + (~(tag "boolean" 'invoke) [~'_4__ ~(tag "byte" 'x)] true) + short>boolean + (~(tag "boolean" 'invoke) [~'_5__ ~(tag "short" 'x)] true) + char>boolean + (~(tag "boolean" 'invoke) [~'_6__ ~(tag "char" 'x)] true) + int>boolean + (~(tag "boolean" 'invoke) [~'_7__ ~(tag "int" 'x)] true) + long>boolean + (~(tag "boolean" 'invoke) [~'_8__ ~(tag "long" 'x)] true) + float>boolean + (~(tag "boolean" 'invoke) [~'_9__ ~(tag "float" 'x)] true) + double>boolean + (~(tag "boolean" 'invoke) [~'_10__ ~(tag "double" 'x)] true))) #_(defn ~'>boolean {::t/type (t/fn [t/boolean?] @@ -337,11 +348,11 @@ (nil? x) false true))))) -)) +) ;; =====|=====|=====|=====|===== ;; -(is (code= +(is-code= ;; auto-upcasts to long or double (because 64-bit) unless you tell it otherwise ;; will error if not all return values can be safely converted to the return spec @@ -353,40 +364,43 @@ ;; ----- expanded code ----- ;; -#?(:clj -`(do (swap! fn->spec assoc #'>int* - (t/fn [(t/- t/primitive? t/boolean?)] - [(t/ref (t/isa? Number))])) - - ~@(case (env-lang) - :clj ($ [(def ~'>int*|__0 ; `(t/- t/primitive? t/boolean?)` - (reify byte>int (~(tag "int" 'invoke) [~'_ ~(tag "byte" 'x)] (Primitive/uncheckedIntCast x)) - short>int (~(tag "int" 'invoke) [~'_ ~(tag "short" 'x)] (Primitive/uncheckedIntCast x)) - char>int (~(tag "int" 'invoke) [~'_ ~(tag "char" 'x)] (Primitive/uncheckedIntCast x)) - int>int (~(tag "int" 'invoke) [~'_ ~(tag "int" 'x)] (Primitive/uncheckedIntCast x)) - long>int (~(tag "int" 'invoke) [~'_ ~(tag "long" 'x)] (Primitive/uncheckedIntCast x)) - float>int (~(tag "int" 'invoke) [~'_ ~(tag "float" 'x)] (Primitive/uncheckedIntCast x)) - double>int (~(tag "int" 'invoke) [~'_ ~(tag "double" 'x)] (Primitive/uncheckedIntCast x)))) - (def ~'>int*|__1 ; `Number` - (reify Object>int (~(tag "int" 'invoke) [~'_ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "java.lang.Number" 'x) ~'x] (.intValue x))))) - ;; TODO implement this - #_(defprotocol >int*_Protocol - (>int* [~'x])) - #_(extend-protocol >int*__Protocol - java.lang.Byte (>int* [~(tag "java.lang.Byte" x)] (.invoke >int*|__0 x)) - java.lang.Short (>int* [~(tag "java.lang.Short" x)] (.invoke >int*|__0 x)) - java.lang.Character (>int* [~(tag "java.lang.Character" x)] (.invoke >int*|__0 x)) - java.lang.Integer (>int* [~(tag "java.lang.Integer" x)] (.invoke >int*|__0 x)) - java.lang.Long (>int* [~(tag "java.lang.Long" x)] (.invoke >int*|__0 x)) - java.lang.Float (>int* [~(tag "java.lang.Float" x)] (.invoke >int*|__0 x)) - java.lang.Double (>int* [~(tag "java.lang.Double" x)] (.invoke >int*|__0 x)) - java.lang.Number (>int* [~(tag "java.lang.Object" x)] (.invoke >int*|__1 x)))])))) +(case (env-lang) + :clj ($ (do #_(swap! fn->spec assoc #'>int* + (t/fn [(t/- t/primitive? t/boolean?)] + [(t/ref (t/isa? Number))])) + + ;; [(t/- t/primitive? t/boolean?)] + + (def ~'>int*|__0 + (reify + byte>int (~(tag "int" 'invoke) [~'_0__ ~(tag "byte" 'x)] + ~'(Primitive/uncheckedIntCast x)) + short>int (~(tag "int" 'invoke) [~'_1__ ~(tag "short" 'x)] + ~'(Primitive/uncheckedIntCast x)) + char>int (~(tag "int" 'invoke) [~'_2__ ~(tag "char" 'x)] + ~'(Primitive/uncheckedIntCast x)) + int>int (~(tag "int" 'invoke) [~'_3__ ~(tag "int" 'x)] + ~'(Primitive/uncheckedIntCast x)) + long>int (~(tag "int" 'invoke) [~'_4__ ~(tag "long" 'x)] + ~'(Primitive/uncheckedIntCast x)) + float>int (~(tag "int" 'invoke) [~'_5__ ~(tag "float" 'x)] + ~'(Primitive/uncheckedIntCast x)) + double>int (~(tag "int" 'invoke) [~'_6__ ~(tag "double" 'x)] + ~'(Primitive/uncheckedIntCast x)))) -)) + ;; [(t/ref (t/isa? Number))] + + (def ~'>int*|__1 + (reify + Object>int (~(tag "int" 'invoke) [~'_7__ ~(tag "java.lang.Object" 'x)] + (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(.intValue x)))))))) + +) ;; =====|=====|=====|=====|===== ;; +(is-code= + (macroexpand ' (defnt #_:inline > ;; This is admittedly a place where inference might be nice, but luckily there are no @@ -399,7 +413,8 @@ ;; ----- expanded code ----- ;; -`(do ~(case-env +;; TODO `method code too large!` +`(do ~(case (env-lang) :clj `(do (def >|__0 (reify byte+byte>boolean (^boolean invoke [_# ^byte a ^byte b] (Numeric/gt a b)) byte+char>boolean (^boolean invoke [_# ^byte a ^char b] (Numeric/gt a b)) @@ -473,11 +488,12 @@ (ifs (double? a1) (let* [a a0 b a1] (cljs.core/> a b)) (unsupported! `> [a0 a1] 1)) - (unsupported! `> [a0 a1] 0))))))) + (unsupported! `> [a0 a1] 0)))))))) ;; =====|=====|=====|=====|===== ;; -(is (code= +;; TODO fix +(is-code= (macroexpand ' (defnt #_:inline >long* @@ -491,49 +507,49 @@ (case (env-lang) :clj ($ (do ;; [(t/- t/primitive? t/boolean?)] - (def ~'>long*|__0|input-types (*<> t/byte?)) + #_(def ~'>long*|__0|input-types (*<> t/byte?)) (def ~'>long*|__0 - (reify byte>long (~(tag "long" 'invoke) [_## ~(tag "byte" 'x)] + (reify byte>long (~(tag "long" 'invoke) [~'_0__ ~(tag "byte" 'x)] ~'(Primitive/uncheckedLongCast x)))) - (def ~'>long*|__1|input-types (*<> t/char?)) + #_(def ~'>long*|__1|input-types (*<> t/char?)) (def ~'>long*|__1 - (reify char>long (~(tag "long" 'invoke) [_## ~(tag "char" 'x)] + (reify char>long (~(tag "long" 'invoke) [~'_1__ ~(tag "char" 'x)] ~'(Primitive/uncheckedLongCast x)))) - (def ~'>long*|__2|input-types (*<> t/short?)) + #_(def ~'>long*|__2|input-types (*<> t/short?)) (def ~'>long*|__2 - (reify short>long (~(tag "long" 'invoke) [_## ~(tag "short" 'x)] + (reify short>long (~(tag "long" 'invoke) [~'_2__ ~(tag "short" 'x)] ~'(Primitive/uncheckedLongCast x)))) - (def ~'>long*|__3|input-types (*<> t/int?)) + #_(def ~'>long*|__3|input-types (*<> t/int?)) (def ~'>long*|__3 - (reify int>long (~(tag "long" 'invoke) [_## ~(tag "int" 'x)] + (reify int>long (~(tag "long" 'invoke) [~'_3__ ~(tag "int" 'x)] ~'(Primitive/uncheckedLongCast x)))) - (def ~'>long*|__4|input-types (*<> t/long?)) + #_(def ~'>long*|__4|input-types (*<> t/long?)) (def ~'>long*|__4 - (reify long>long (~(tag "long" 'invoke) [_## ~(tag "long" 'x)] + (reify long>long (~(tag "long" 'invoke) [~'_4__ ~(tag "long" 'x)] ~'(Primitive/uncheckedLongCast x)))) - (def ~'>long*|__5|input-types (*<> t/float?)) + #_(def ~'>long*|__5|input-types (*<> t/float?)) (def ~'>long*|__5 - (reify float>long (~(tag "long" 'invoke) [_## ~(tag "float" 'x)] + (reify float>long (~(tag "long" 'invoke) [~'_5__ ~(tag "float" 'x)] ~'(Primitive/uncheckedLongCast x)))) - (def ~'>long*|__6|input-types (*<> t/double?)) + #_(def ~'>long*|__6|input-types (*<> t/double?)) (def ~'>long*|__6 - (reify double>long (~(tag "long" 'invoke) [_## ~(tag "double" 'x)] + (reify double>long (~(tag "long" 'invoke) [~'_6__ ~(tag "double" 'x)] ~'(Primitive/uncheckedLongCast x)))) ;; [(t/ref (t/isa? Number))] - (def ~'>long*|__7|input-types (*<> (t/isa? Number))) + #_(def ~'>long*|__7|input-types (*<> (t/isa? Number))) (def ~'>long*|__7 - (reify Object>long (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] + (reify Object>long (~(tag "long" 'invoke) [~'_7__ ~(tag "java.lang.Object" 'x)] (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(.longValue x))))) - (defn >long* + #_(defn >long* {::t/type (t/fn [(t/- t/primitive? t/boolean?)] [(t/ref (t/isa? Number))])} [a0##] (ifs ((Array/get >long*|__0|input-types 0) a0##) @@ -542,11 +558,12 @@ ))) -)) +) ;; =====|=====|=====|=====|===== ;; -(is (code= +;; TODO requires `>long*` being defined for it to work +(is-code= (macroexpand ' (defnt >long @@ -572,39 +589,37 @@ (case (env-lang) :clj ($ (do - - #_[(t/- t/primitive? t/boolean? t/float? t/double?)] - (def ~'>long|__0|input-types (*<> t/byte?)) + #_(def ~'>long|__0|input-types (*<> t/byte?)) (def ~'>long|__0 (reify byte>long (~(tag "long" 'invoke) [_## ~(tag "byte" 'x)] ;; Resolved from `(>long* x)` (.invoke >long*|__0 ~'x)))) - (def ~'>long|__1|input-types (*<> t/char?)) + #_(def ~'>long|__1|input-types (*<> t/char?)) (def ~'>long|__1 (reify char>long (~(tag "long" 'invoke) [_## ~(tag "char" 'x)] ;; Resolved from `(>long* x)` (.invoke >long*|__1 ~'x)))) - (def ~'>long|__2|input-types (*<> t/short?)) + #_(def ~'>long|__2|input-types (*<> t/short?)) (def ~'>long|__2 (reify short>long (~(tag "long" 'invoke) [_## ~(tag "short" 'x)] ;; Resolved from `(>long* x)` (.invoke >long*|__2 ~'x)))) - (def ~'>long|__3|input-types (*<> t/int?)) + #_(def ~'>long|__3|input-types (*<> t/int?)) (def ~'>long|__3 (reify int>long (~(tag "long" 'invoke) [_## ~(tag "int" 'x)] ;; Resolved from `(>long* x)` (.invoke >long*|__3 ~'x)))) - (def ~'>long|__4|input-types (*<> t/long?)) + #_(def ~'>long|__4|input-types (*<> t/long?)) (def ~'>long|__4 (reify long>long (~(tag "long" 'invoke) [_## ~(tag "long" 'x)] @@ -615,7 +630,7 @@ (fnt [x (t/or double? float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] - (def ~'>long|__5|input-types + #_(def ~'>long|__5|input-types (*<> (t/and t/double? (fnt [x (t/or double? float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE)))))) @@ -625,7 +640,7 @@ ;; Resolved from `(>long* x)` (.invoke >long*|__6 ~'x)))) - (def ~'>long|__6|input-types + #_(def ~'>long|__6|input-types (*<> (t/and t/float? (fnt [x (t/or double? float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE)))))) @@ -638,7 +653,7 @@ #_[(t/and (t/isa? clojure.lang.BigInt) (fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] - (def ~'>long|__7|input-types + #_(def ~'>long|__7|input-types (*<> (t/and (t/isa? clojure.lang.BigInt) (fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x)))))) (def ~'>long|__7 @@ -649,8 +664,7 @@ #_[(t/and (t/isa? java.math.BigInteger) (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] - - (def ~'>long|__8|input-types + #_(def ~'>long|__8|input-types (*<> (t/and (t/isa? java.math.BigInteger) (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64))))) (def ~'>long|__8 @@ -660,9 +674,9 @@ #_[t/ratio?] - (def ~'>long|__9|input-types + #_(def ~'>long|__9|input-types (*<> t/ratio?)) - (def ~'>long|__9|conditions + #_(def ~'>long|__9|conditions (*<> (-> long|__8|input-types (get 0) utr/and-type>args (get 1)))) (def ~'>long|__9 (reify Object>long @@ -691,7 +705,7 @@ #_[(t/value true)] - (def ~'>long|__10|input-types + #_(def ~'>long|__10|input-types (*<> (t/value true))) (def ~'>long|__10 (reify boolean>long @@ -699,7 +713,7 @@ #_[(t/value false)] - (def ~'>long|__11|input-types + #_(def ~'>long|__11|input-types (*<> (t/value false))) (def ~'>long|__11 (reify boolean>long @@ -707,7 +721,7 @@ #_[t/string?] - (def ~'>long|__12|input-types + #_(def ~'>long|__12|input-types (*<> t/string?)) (def ~'>long|__12 (reify Object>long @@ -716,14 +730,14 @@ #_[t/string?] - (def ~'>long|__13|input-types + #_(def ~'>long|__13|input-types (*<> t/string? t/int?)) (def ~'>long|__13 (reify Object+int>long (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x) ~(tag "int" 'radix)] ~'(Long/parseLong x radix)))) - (defn >long + #_(defn >long {::t/type (t/fn [(t/- t/primitive? t/boolean? t/float? t/double?)] @@ -747,7 +761,7 @@ (.invoke >long|__2 x0##))) ([x0## x1##] ...))))) -)) +) ;; =====|=====|=====|=====|===== ;; @@ -1022,14 +1036,12 @@ ;; =====|=====|=====|=====|===== ;; -#?(:clj (macroexpand ' (defnt first ([xs t/nil? ] nil) ([xs (t/and t/sequential? t/indexed?)] (get xs 0)) ([xs (t/isa? ISeq) ] (.first xs)) ([xs ... ] (-> xs seq first)))) -) #?(:clj `(do (swap! fn->spec assoc #'seq @@ -1209,47 +1221,9 @@ (extend-defnt abc/name ; for use outside of ns ([a ?, b ?] (...))) +;; This is necessarily dynamic dispatch (name (read )) -(defn def-interfaces - [{:keys [::*interfaces]}] - *interfaces) - -(defn atom? [x] (instance? clojure.lang.IAtom x)) - -(s/def ::*interfaces (s/and atom? (fn-> deref map?))) -(s/def ::signatures (s/coll-of (s/tuple symbol? (s/+ symbol?)) :kind sequential?)) - -(s/fdef def-interfaces - :args (s/cat :a0 (s/keys :req [::signatures ::*interfaces])) - #_:ret #_int? - #_:fn #_(s/and #(>= (:ret %) (-> % :args :start)) - #(< (:ret %) (-> % :args :end)))) - -(s/def ::lang #{:clj :cljs}) - -(s/def ::expand-signatures:opts (s/keys :opt-un [::lang])) - -(s/fdef expand-signatures - :args (s/cat :signatures ::signatures - :opts (s/? ::expand-signatures:opts)) - :ret ::signatures) - -(defn expand-signatures [signatures & [opts]] - signatures) - -(instrument) -(def-interfaces {::signatures [['boolean ['nil?]] - ['boolean ['boolean]] - ['boolean ['any?]]] - ::*interfaces (atom {})}) - -(expand-signatures - [['boolean ['nil?]] - ['boolean ['boolean]] - ['boolean ['any?]]] - {:lang :clj}) - (do ; (optional) function — only when the `defnt` has an arity with 0 arguments From 432d432539e9aae237285da1366d7cfd6682550e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 25 Jun 2018 12:14:59 -0600 Subject: [PATCH 093/810] Update system property --- src-untyped/quantum/untyped/core/core.cljc | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src-untyped/quantum/untyped/core/core.cljc b/src-untyped/quantum/untyped/core/core.cljc index ab0f67f9..3fe91e0f 100644 --- a/src-untyped/quantum/untyped/core/core.cljc +++ b/src-untyped/quantum/untyped/core/core.cljc @@ -207,15 +207,15 @@ (zipmap #{:always :error :warn :ns} (repeat true))))) (defonce *outs - (atom #?(:clj (if-let [out-path (or (System/getProperty "quantum.core.log:out-file") - (System/getProperty "quantum.core.log|out-file"))] - (let [_ (binding [*out* *err*] (println "Logging to" out-path)) - fos (-> out-path - (java.io.FileOutputStream. ) - (java.io.OutputStreamWriter.) - (java.io.BufferedWriter. ))] - (fn [] [*err* fos])) - (fn [] [*err*])) ; in order to not print to file + (atom #?(:clj (let [out-path (System/getProperty "quantum.core.log|out-file") + print-to-stderr? (System/getProperty "quantum.core.log|pr-to-stderr")] + (let [_ (binding [*out* *err*] (println "Logging to" out-path)) + fos (-> out-path + (java.io.FileOutputStream. ) + (java.io.OutputStreamWriter.) + (java.io.BufferedWriter. ))] + (fn [] [*err* fos])) + (fn [] [*err*])) :cljs (fn [] [*out*])))) (defn print-ns-name-to-outs! [ns-name-] From b512873f6d4dadb516c20d9a39bedd9a9b449c0c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 25 Jun 2018 17:28:30 -0600 Subject: [PATCH 094/810] Compilation fixes --- src-untyped/quantum/untyped/core/core.cljc | 22 ++++++++++++---------- src-untyped/quantum/untyped/core/test.cljc | 2 +- 2 files changed, 13 insertions(+), 11 deletions(-) diff --git a/src-untyped/quantum/untyped/core/core.cljc b/src-untyped/quantum/untyped/core/core.cljc index 3fe91e0f..648211cb 100644 --- a/src-untyped/quantum/untyped/core/core.cljc +++ b/src-untyped/quantum/untyped/core/core.cljc @@ -76,7 +76,7 @@ :else ::not-applicable)] (if (= similar-class? ::not-applicable) (= code0 code1) - (and similar-class? (ucore/seq= (seq code0) (seq code1) code=)))) + (and similar-class? (seq= (seq code0) (seq code1) code=)))) (cond (seq? code0) (and (seq? code1) (seq= code0 code1 code=)) (vector? code0) (and (vector? code1) (seq= (seq code0) (seq code1) code=)) (map? code0) (and (map? code1) (seq= (seq code0) (seq code1) code=)) @@ -207,15 +207,17 @@ (zipmap #{:always :error :warn :ns} (repeat true))))) (defonce *outs - (atom #?(:clj (let [out-path (System/getProperty "quantum.core.log|out-file") - print-to-stderr? (System/getProperty "quantum.core.log|pr-to-stderr")] - (let [_ (binding [*out* *err*] (println "Logging to" out-path)) - fos (-> out-path - (java.io.FileOutputStream. ) - (java.io.OutputStreamWriter.) - (java.io.BufferedWriter. ))] - (fn [] [*err* fos])) - (fn [] [*err*])) + (atom #?(:clj (let [file-stream (when-let [path (System/getProperty "quantum.core.log|out-file")] + (binding [*out* *err*] (println "Logging to" path)) + (-> path + (java.io.FileOutputStream.) + (java.io.OutputStreamWriter.) + (java.io.BufferedWriter.))) + print-to-stderror (System/getProperty "quantum.core.log|print-to-stderror") + out-stream + (when (not= "false" print-to-stderror) *err*) + outs (->> [out-stream file-stream] (filterv some?))] + (fn [] outs)) :cljs (fn [] [*out*])))) (defn print-ns-name-to-outs! [ns-name-] diff --git a/src-untyped/quantum/untyped/core/test.cljc b/src-untyped/quantum/untyped/core/test.cljc index 30e33f5b..eebbabf5 100644 --- a/src-untyped/quantum/untyped/core/test.cljc +++ b/src-untyped/quantum/untyped/core/test.cljc @@ -51,7 +51,7 @@ (println "FAIL: should be `(= code0 code1)`" code0 code1))))) ([code0 code1 & codes] (and (code= code0 code1) (every? #(code= code0 %) codes)))) -(defn is-code= [& args] (is (apply code= args)))) +(defn is-code= [& args] (is (apply code= args))) #?(:clj (defmacro is= [& args] `(is (= ~@args)))) From 8785e4b826616e66a1499ee6367927a52bfcf365 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 25 Jun 2018 17:28:42 -0600 Subject: [PATCH 095/810] Begin to fix the longest equivalence test --- src-dev/quantum/core/defnt_equivalences.cljc | 271 +++++++++++++------ 1 file changed, 184 insertions(+), 87 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 16bcfef4..4598d642 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -35,7 +35,7 @@ clojure.lang.LazySeq clojure.lang.Seqable quantum.core.data.Array - quantum.core.Primitive)) + [quantum.core Numeric Primitive])) ;; =====|=====|=====|=====|===== ;; @@ -195,7 +195,6 @@ ;; ----- expanded code ----- ;; -;; TODO for some reason it doesn't recognize that it's a boolean return value (case (env-lang) :clj ($ (do ;; [x t/nil?] @@ -240,7 +239,7 @@ ;; =====|=====|=====|=====|===== ;; -(is (code= +(is-code= ;; Perhaps silly in ClojureScript, but avoids boxing in Clojure (macroexpand ' @@ -282,7 +281,7 @@ :cljs ($ (do (defn ~'reduced? [~'x] (ifs (instance? Reduced x) true false))))) -)) +) ;; =====|=====|=====|=====|===== ;; @@ -291,51 +290,49 @@ (macroexpand ' (defnt #_:inline >boolean ([x t/boolean?] x) - ;; Implicitly, `(- t/nil? t/boolean?)` ([x t/nil?] false) - ;; Implicitly, `(- t/any? t/nil? t/boolean?)` ([x t/any?] true)) ) ;; ----- expanded code ----- ;; (case (env-lang) - :clj ($ (do ;; [t/boolean?] + :clj ($ (do ;; [x t/boolean?] (def ~'>boolean|__0 (reify boolean>boolean (~(tag "boolean" 'invoke) [~'_0__ ~(tag "boolean" 'x)] ~'x))) - ;; [t/nil?] + ;; [x t/nil? -> (- t/nil? t/boolean?)] (def ~'>boolean|__1 (reify Object>boolean (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false))) - ;; [t/any?] + ;; [x t/any? -> (- t/any? t/nil? t/boolean?)] (def ~'>boolean|__2 (reify Object>boolean - (~(tag "boolean" 'invoke) [~'_2__ ~(tag "java.lang.Object" 'x)] true) + (~(tag "boolean" 'invoke) [~'_2__ ~(tag "java.lang.Object" 'x)] true) boolean>boolean - (~(tag "boolean" 'invoke) [~'_3__ ~(tag "boolean" 'x)] true) + (~(tag "boolean" 'invoke) [~'_3__ ~(tag "boolean" 'x)] true) byte>boolean - (~(tag "boolean" 'invoke) [~'_4__ ~(tag "byte" 'x)] true) + (~(tag "boolean" 'invoke) [~'_4__ ~(tag "byte" 'x)] true) short>boolean - (~(tag "boolean" 'invoke) [~'_5__ ~(tag "short" 'x)] true) + (~(tag "boolean" 'invoke) [~'_5__ ~(tag "short" 'x)] true) char>boolean - (~(tag "boolean" 'invoke) [~'_6__ ~(tag "char" 'x)] true) + (~(tag "boolean" 'invoke) [~'_6__ ~(tag "char" 'x)] true) int>boolean - (~(tag "boolean" 'invoke) [~'_7__ ~(tag "int" 'x)] true) + (~(tag "boolean" 'invoke) [~'_7__ ~(tag "int" 'x)] true) long>boolean - (~(tag "boolean" 'invoke) [~'_8__ ~(tag "long" 'x)] true) + (~(tag "boolean" 'invoke) [~'_8__ ~(tag "long" 'x)] true) float>boolean - (~(tag "boolean" 'invoke) [~'_9__ ~(tag "float" 'x)] true) + (~(tag "boolean" 'invoke) [~'_9__ ~(tag "float" 'x)] true) double>boolean - (~(tag "boolean" 'invoke) [~'_10__ ~(tag "double" 'x)] true))) + (~(tag "boolean" 'invoke) [~'_10__ ~(tag "double" 'x)] true))) #_(defn ~'>boolean {::t/type (t/fn [t/boolean?] @@ -388,7 +385,8 @@ double>int (~(tag "int" 'invoke) [~'_6__ ~(tag "double" 'x)] ~'(Primitive/uncheckedIntCast x)))) - ;; [(t/ref (t/isa? Number))] + ;; [(t/ref (t/isa? Number)) + ;; -> (t/- (t/ref (t/isa? Number)) (t/- t/primitive? t/boolean?))] (def ~'>int*|__1 (reify @@ -406,65 +404,163 @@ ;; This is admittedly a place where inference might be nice, but luckily there are no ;; "sparse" combinations #?(:clj ([a t/comparable-primitive? b t/comparable-primitive? > t/boolean?] - (quantum.core.Numeric/gt a b)) + (Numeric/gt a b)) :cljs ([a t/double? b t/double? > (t/assume t/boolean?)] (cljs.core/> a b)))) ) ;; ----- expanded code ----- ;; -;; TODO `method code too large!` -`(do ~(case (env-lang) - :clj `(do (def >|__0 - (reify byte+byte>boolean (^boolean invoke [_# ^byte a ^byte b] (Numeric/gt a b)) - byte+char>boolean (^boolean invoke [_# ^byte a ^char b] (Numeric/gt a b)) - byte+short>boolean (^boolean invoke [_# ^byte a ^short b] (Numeric/gt a b)) - byte+int>boolean (^boolean invoke [_# ^byte a ^int b] (Numeric/gt a b)) - byte+long>boolean (^boolean invoke [_# ^byte a ^long b] (Numeric/gt a b)) - byte+float>boolean (^boolean invoke [_# ^byte a ^float b] (Numeric/gt a b)) - byte+double>boolean (^boolean invoke [_# ^byte a ^double b] (Numeric/gt a b)) - char+byte>boolean (^boolean invoke [_# ^char a ^byte b] (Numeric/gt a b)) - char+char>boolean (^boolean invoke [_# ^char a ^char b] (Numeric/gt a b)) - char+short>boolean (^boolean invoke [_# ^char a ^short b] (Numeric/gt a b)) - char+int>boolean (^boolean invoke [_# ^char a ^int b] (Numeric/gt a b)) - char+long>boolean (^boolean invoke [_# ^char a ^long b] (Numeric/gt a b)) - char+float>boolean (^boolean invoke [_# ^char a ^float b] (Numeric/gt a b)) - char+double>boolean (^boolean invoke [_# ^char a ^double b] (Numeric/gt a b)) - short+byte>boolean (^boolean invoke [_# ^short a ^byte b] (Numeric/gt a b)) - short+char>boolean (^boolean invoke [_# ^short a ^char b] (Numeric/gt a b)) - short+short>boolean (^boolean invoke [_# ^short a ^short b] (Numeric/gt a b)) - short+int>boolean (^boolean invoke [_# ^short a ^int b] (Numeric/gt a b)) - short+long>boolean (^boolean invoke [_# ^short a ^long b] (Numeric/gt a b)) - short+float>boolean (^boolean invoke [_# ^short a ^float b] (Numeric/gt a b)) - short+double>boolean (^boolean invoke [_# ^short a ^double b] (Numeric/gt a b)) - int+byte>boolean (^boolean invoke [_# ^int a ^byte b] (Numeric/gt a b)) - int+char>boolean (^boolean invoke [_# ^int a ^char b] (Numeric/gt a b)) - int+short>boolean (^boolean invoke [_# ^int a ^short b] (Numeric/gt a b)) - int+int>boolean (^boolean invoke [_# ^int a ^int b] (Numeric/gt a b)) - int+long>boolean (^boolean invoke [_# ^int a ^long b] (Numeric/gt a b)) - int+float>boolean (^boolean invoke [_# ^int a ^float b] (Numeric/gt a b)) - int+double>boolean (^boolean invoke [_# ^int a ^double b] (Numeric/gt a b)) - long+byte>boolean (^boolean invoke [_# ^long a ^byte b] (Numeric/gt a b)) - long+char>boolean (^boolean invoke [_# ^long a ^char b] (Numeric/gt a b)) - long+short>boolean (^boolean invoke [_# ^long a ^short b] (Numeric/gt a b)) - long+int>boolean (^boolean invoke [_# ^long a ^int b] (Numeric/gt a b)) - long+long>boolean (^boolean invoke [_# ^long a ^long b] (Numeric/gt a b)) - long+float>boolean (^boolean invoke [_# ^long a ^float b] (Numeric/gt a b)) - long+double>boolean (^boolean invoke [_# ^long a ^double b] (Numeric/gt a b)) - float+byte>boolean (^boolean invoke [_# ^float a ^byte b] (Numeric/gt a b)) - float+char>boolean (^boolean invoke [_# ^float a ^char b] (Numeric/gt a b)) - float+short>boolean (^boolean invoke [_# ^float a ^short b] (Numeric/gt a b)) - float+int>boolean (^boolean invoke [_# ^float a ^int b] (Numeric/gt a b)) - float+long>boolean (^boolean invoke [_# ^float a ^long b] (Numeric/gt a b)) - float+float>boolean (^boolean invoke [_# ^float a ^float b] (Numeric/gt a b)) - float+double>boolean (^boolean invoke [_# ^float a ^double b] (Numeric/gt a b)) - double+byte>boolean (^boolean invoke [_# ^double a ^byte b] (Numeric/gt a b)) - double+char>boolean (^boolean invoke [_# ^double a ^char b] (Numeric/gt a b)) - double+short>boolean (^boolean invoke [_# ^double a ^short b] (Numeric/gt a b)) - double+int>boolean (^boolean invoke [_# ^double a ^int b] (Numeric/gt a b)) - double+long>boolean (^boolean invoke [_# ^double a ^long b] (Numeric/gt a b)) - double+float>boolean (^boolean invoke [_# ^double a ^float b] (Numeric/gt a b)) - double+double>boolean (^boolean invoke [_# ^double a ^double b] (Numeric/gt a b)))) +(case (env-lang) + :clj ($ (do (def ~'>|__0 + (reify + byte+byte>boolean + (~(tag "boolean" 'invoke) [~'_0__ ~(tag "byte" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)) + byte+short>boolean + (~(tag "boolean" 'invoke) [~'_1__ ~(tag "byte" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)) + byte+char>boolean + (~(tag "boolean" 'invoke) [~'_2__ ~(tag "byte" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)) + byte+int>boolean + (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)) + byte+long>boolean + (~(tag "boolean" 'invoke) [~'_4__ ~(tag "byte" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)) + byte+float>boolean + (~(tag "boolean" 'invoke) [~'_5__ ~(tag "byte" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)) + byte+double>boolean + (~(tag "boolean" 'invoke) [~'_6__ ~(tag "byte" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)) + short+byte>boolean + (~(tag "boolean" 'invoke) [~'_7__ ~(tag "short" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)) + short+short>boolean + (~(tag "boolean" 'invoke) [~'_8__ ~(tag "short" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)) + short+char>boolean + (~(tag "boolean" 'invoke) [~'_9__ ~(tag "short" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)) + short+int>boolean + (~(tag "boolean" 'invoke) [~'_10__ ~(tag "short" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)) + short+long>boolean + (~(tag "boolean" 'invoke) [~'_11__ ~(tag "short" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)) + short+float>boolean + (~(tag "boolean" 'invoke) [~'_12__ ~(tag "short" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)) + short+double>boolean + (~(tag "boolean" 'invoke) [~'_13__ ~(tag "short" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)) + char+byte>boolean + (~(tag "boolean" 'invoke) [~'_14__ ~(tag "char" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)) + char+short>boolean + (~(tag "boolean" 'invoke) [~'_15__ ~(tag "char" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)) + char+char>boolean + (~(tag "boolean" 'invoke) [~'_16__ ~(tag "char" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)) + char+int>boolean + (~(tag "boolean" 'invoke) [~'_17__ ~(tag "char" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)) + char+long>boolean + (~(tag "boolean" 'invoke) [~'_18__ ~(tag "char" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)) + char+float>boolean + (~(tag "boolean" 'invoke) [~'_19__ ~(tag "char" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)) + char+double>boolean + (~(tag "boolean" 'invoke) [~'_20__ ~(tag "char" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)) + int+byte>boolean + (~(tag "boolean" 'invoke) [~'_21__ ~(tag "int" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)) + int+short>boolean + (~(tag "boolean" 'invoke) [~'_22__ ~(tag "int" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)) + int+char>boolean + (~(tag "boolean" 'invoke) [~'_23__ ~(tag "int" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)) + int+int>boolean + (~(tag "boolean" 'invoke) [~'_24__ ~(tag "int" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)) + int+long>boolean + (~(tag "boolean" 'invoke) [~'_25__ ~(tag "int" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)) + int+float>boolean + (~(tag "boolean" 'invoke) [~'_26__ ~(tag "int" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)) + int+double>boolean + (~(tag "boolean" 'invoke) [~'_27__ ~(tag "int" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)) + long+byte>boolean + (~(tag "boolean" 'invoke) [~'_28__ ~(tag "long" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)) + long+short>boolean + (~(tag "boolean" 'invoke) [~'_29__ ~(tag "long" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)) + long+char>boolean + (~(tag "boolean" 'invoke) [~'_30__ ~(tag "long" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)) + long+int>boolean + (~(tag "boolean" 'invoke) [~'_31__ ~(tag "long" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)) + long+long>boolean + (~(tag "boolean" 'invoke) [~'_32__ ~(tag "long" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)) + long+float>boolean + (~(tag "boolean" 'invoke) [~'_33__ ~(tag "long" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)) + long+double>boolean + (~(tag "boolean" 'invoke) [~'_34__ ~(tag "long" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)) + float+byte>boolean + (~(tag "boolean" 'invoke) [~'_35__ ~(tag "float" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)) + float+short>boolean + (~(tag "boolean" 'invoke) [~'_36__ ~(tag "float" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)) + float+char>boolean + (~(tag "boolean" 'invoke) [~'_37__ ~(tag "float" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)) + float+int>boolean + (~(tag "boolean" 'invoke) [~'_38__ ~(tag "float" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)) + float+long>boolean + (~(tag "boolean" 'invoke) [~'_39__ ~(tag "float" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)) + float+float>boolean + (~(tag "boolean" 'invoke) [~'_40__ ~(tag "float" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)) + float+double>boolean + (~(tag "boolean" 'invoke) [~'_41__ ~(tag "float" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)) + double+byte>boolean + (~(tag "boolean" 'invoke) [~'_42__ ~(tag "double" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)) + double+char>boolean + (~(tag "boolean" 'invoke) [~'_43__ ~(tag "double" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)) + double+short>boolean + (~(tag "boolean" 'invoke) [~'_44__ ~(tag "double" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)) + double+int>boolean + (~(tag "boolean" 'invoke) [~'_45__ ~(tag "double" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)) + double+long>boolean + (~(tag "boolean" 'invoke) [~'_46__ ~(tag "double" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)) + double+float>boolean + (~(tag "boolean" 'invoke) [~'_47__ ~(tag "double" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)) + double+double>boolean + (~(tag "boolean" 'invoke) [~'_48__ ~(tag "double" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)))) (defn > {::t/type @@ -481,14 +577,14 @@ (ifs (t/byte? a1) (.invoke ^char+byte>boolean >|__0 a0 a1) ...) ... - (unsupported! `> [a0 a1] 0))))) + (unsupported! `> [a0 a1] 0)))))) :cljs `(do (defn > ([a0 a1] (ifs (double? a0) (ifs (double? a1) (let* [a a0 b a1] (cljs.core/> a b)) (unsupported! `> [a0 a1] 1)) - (unsupported! `> [a0 a1] 0)))))))) + (unsupported! `> [a0 a1] 0))))))) ;; =====|=====|=====|=====|===== ;; @@ -505,7 +601,7 @@ ;; ----- expanded code ----- ;; (case (env-lang) - :clj ($ (do ;; [(t/- t/primitive? t/boolean?)] + :clj ($ (do ;; [x (t/- t/primitive? t/boolean?)] #_(def ~'>long*|__0|input-types (*<> t/byte?)) (def ~'>long*|__0 @@ -542,7 +638,7 @@ (reify double>long (~(tag "long" 'invoke) [~'_6__ ~(tag "double" 'x)] ~'(Primitive/uncheckedLongCast x)))) - ;; [(t/ref (t/isa? Number))] + ;; [x (t/ref (t/isa? Number))] #_(def ~'>long*|__7|input-types (*<> (t/isa? Number))) (def ~'>long*|__7 @@ -1197,9 +1293,9 @@ (t/fn [rf? :> rf?])) (defnt transduce - ([ f rf?, xs t/reducible?] (transduce identity f xs)) - ([xf xf?, f rf?, xs t/reducible?] (transduce xf f (f) xs)) - ([xf xf?, f rf?, init _ xs t/reducible?] + ([ f rf?, xs t/reducible?] (transduce identity f xs)) + ([xf xf?, f rf?, xs t/reducible?] (transduce xf f (f) xs)) + ([xf xf?, f rf?, init _, xs t/reducible?] (let [f' (xf f)] (f' (reduce f' init xs)))))) ;; ----- expanded code ----- ;; @@ -1246,11 +1342,12 @@ ;; ===== CLOJURESCRIPT ===== ;; -;; In order for specs to be enforceable at compile time, they must be able to be executed by the compilation -;; language. The case of one language compiled in a different one (e.g. ClojureScript in Clojure/Java) is -;; thus problematic. +;; In order for specs to be enforceable at compile time, they must be able to be executed by the +;; compilation language. The case of one language compiled in a different one (e.g. ClojureScript +;; in Clojure/Java) is thus problematic. -;; For instance, this is only able to be checked in CLJS, because `js-object?` is not implemented in CLJ: +;; For instance, this is only able to be checked in CLJS, because `js-object?` is not implemented +;; in CLJ: (defnt abcde1 [x #?(:clj string? :cljs js-object?)] ...) @@ -1260,8 +1357,9 @@ (defnt abcde2 [x my-spec] ...) -;; So what is the solution? The solution is to forgo some functionality in ClojureScript and instead rely -;; fundamentally on the aggregative relationships among predicates created using the `defnt` spec system. +;; So what is the solution? One solution is to forgo some functionality in ClojureScript and +;; instead rely fundamentally on the aggregative relationships among predicates created using the +;; `defnt` spec system. ;; For instance: @@ -1276,7 +1374,6 @@ ;; Because the spec was registered using the `defnt` spec system, the quoted forms can be analyzed and ;; at least some things can be deduced. -;; In this case, the spec of `x` is deducible: `abcde1|x?` (`js-object?` deeper down). The return spec -;; is also deducible as being the return spec of `abcde1`: +;; In this case, the spec of `x` is deducible: `abcde1|x?` (`js-object?` deeper down). The return spec is also deducible as being the return spec of `abcde1`: (defnt abcde2 [x ?] (abcde1 x)) From 4dc441a976ec9123095ae75342b12c636b6d9d1e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 25 Jun 2018 21:25:01 -0600 Subject: [PATCH 096/810] Update flag --- project-base.clj | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/project-base.clj b/project-base.clj index a740cb35..d63ad74e 100644 --- a/project-base.clj +++ b/project-base.clj @@ -631,7 +631,7 @@ ;; ----- Telemetry ----- ;; "-XX:-OmitStackTraceInFastThrow" "-XX:ErrorFile=./JVMErrorDump.log" - "-Dquantum.core.log:out-file=./out.log" + "-Dquantum.core.log|out-file=./out.log" ;; ----- Compilation ----- ;; #_(case system-type "t2.micro" From c9750ce8cd95313ca08fd2f9dc3506a99038a0c6 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 25 Jun 2018 21:28:27 -0600 Subject: [PATCH 097/810] More tests pass! --- src-dev/quantum/core/defnt_equivalences.cljc | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 4598d642..23a9e938 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -543,11 +543,11 @@ double+byte>boolean (~(tag "boolean" 'invoke) [~'_42__ ~(tag "double" 'a) ~(tag "byte" 'b)] ~'(Numeric/gt a b)) - double+char>boolean - (~(tag "boolean" 'invoke) [~'_43__ ~(tag "double" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)) double+short>boolean - (~(tag "boolean" 'invoke) [~'_44__ ~(tag "double" 'a) ~(tag "short" 'b)] + (~(tag "boolean" 'invoke) [~'_43__ ~(tag "double" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)) + double+char>boolean + (~(tag "boolean" 'invoke) [~'_44__ ~(tag "double" 'a) ~(tag "char" 'b)] ~'(Numeric/gt a b)) double+int>boolean (~(tag "boolean" 'invoke) [~'_45__ ~(tag "double" 'a) ~(tag "int" 'b)] @@ -562,7 +562,7 @@ (~(tag "boolean" 'invoke) [~'_48__ ~(tag "double" 'a) ~(tag "double" 'b)] ~'(Numeric/gt a b)))) - (defn > + #_(defn > {::t/type (t/fn #?(:clj [t/comparable-primitive? t/comparable-primitive? :> t/boolean?] From 3a482c28b8ec751abe85c6f4f056c3c5ccff23be Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 25 Jun 2018 23:06:13 -0600 Subject: [PATCH 098/810] `fnt|overload-group>input-types-decl` --- src-dev/quantum/core/defnt.cljc | 54 ++++++++++++++----- src-dev/quantum/core/defnt_equivalences.cljc | 56 ++++++++++---------- 2 files changed, 71 insertions(+), 39 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 2a27d1d7..43dd51a9 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -26,6 +26,7 @@ :refer [istr]] [quantum.untyped.core.data :refer [kw-map]] + [quantum.untyped.core.data.array :as arr] [quantum.untyped.core.data.map :as map] [quantum.untyped.core.data.set :as set] [quantum.untyped.core.defnt @@ -894,11 +895,11 @@ ;; supported (assert kind :sym) binding-))) - arg-types|unprimitivized + arg-types|form (->> args (mapv (fn [{[kind #_#{:any :spec}, t #_t/form?] :spec}] - (case kind :any t/any? - :spec (-> t eval t/>type))))) + (case kind :any `t/any? :spec t)))) + arg-types|unprimitivized (->> arg-types|form (mapv (fn-> eval t/>type))) arg-classes-seq (arg-types>arg-classes-seq|primitivized arg-types|unprimitivized) ;; `unprimitivized` is first because of class sorting [unprimitivized & primitivized] @@ -913,7 +914,8 @@ (kw-map arg-bindings arg-classes arg-types args body-codelist|pre-analyze lang post-form varargs varargs-binding))))))] - {:unprimitivized unprimitivized + {:arg-types|form arg-types|form + :unprimitivized unprimitivized :primitivized primitivized})))) (def fnt-method-sym 'invoke) @@ -942,7 +944,8 @@ #?(:clj (defns fnt|overload>reify-overload [{:as overload - :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, out-class t/class?]} :fnt/overload + :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, out-class t/class?]} + :fnt/overload gen-gensym fn? > (s/seq-of ::reify|overload)] (let [interface-k {:out out-class :in arg-classes} @@ -966,9 +969,7 @@ #?(:clj (defns fnt|overload-group>reify - [{:keys [overload-group :fnt/overload-group - i t/integer? - fn|name :quantum.core.specs/fn|name]} _ + [{:keys [fn|name :quantum.core.specs/fn|name, i t/integer?, overload-group :fnt/overload-group]} _ gen-gensym fn?] (let [reify-overloads (->> (concat [(:unprimitivized overload-group)] (:primitivized overload-group)) @@ -981,6 +982,14 @@ ~arglist-code ~body-form)])) lcat)))))) +#?(:clj +(defns fnt|overload-group>input-types-decl + [{:keys [fn|name :quantum.core.specs/fn|name + i t/integer? + overload-group :fnt/overload-group]} _] + `(def ~(ufth/with-type-hint (>symbol (str fn|name "|__" i "|input-types")) "[Ljava.lang.Object;") + (arr/*<> ~(get-in overload-group [:arg-types|form i]))))) + (def allowed-shorthand-tag-chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") (defn >all-shorthand-tags [] @@ -1027,6 +1036,9 @@ nil overloads))) +(defns unsupported! [name- _ #_t/qualified-symbol?, args t/indexed?, i _ #_index?] + (TODO)) + (defns gen-register-type "Registers in the map of qualified symbol to input type, to output type @@ -1044,6 +1056,17 @@ (err! "Arg count not enough for variadic overload"))]))))) true)) +#_(defns >base-fn [...] + #_(defn ~'identity|uninlined + {::t/type (t/fn [t/any?])} + [~'a00__] + (ifs ((Array/get ~'identity|uninlined|__0|input-types 0) ~'a00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" + 'identity|uninlined|__0) ~'a00__) + (unsupported! (quote quantum.core.test.defnt-equivalences/identity|uninlined) + [~'a00__] 0))) + ) + (defns fnt|code [kind #{:fn :defn}, lang ::lang, args _] (prl! kind lang args) (let [{:keys [:quantum.core.specs/fn|name overloads :quantum.core.specs/meta] :as args'} @@ -1076,11 +1099,18 @@ register-type (gen-register-type (kw-map fn|name arg-ct->type variadic-overload)) direct-dispatch-codelist (case lang - :clj (for [[i fnt|overload-group] (c/lindexed fnt|overload-groups)] - (fnt|overload-group>reify - (assoc (kw-map i fn|name) :overload-group fnt|overload-group) gen-gensym)) + :clj (->> fnt|overload-groups + (map-indexed + (fn [i {:as fnt|overload-group :keys [arg-types|form]}] + (let [in {:i i :fn|name fn|name :overload-group fnt|overload-group}] + (cond-> [] + (c/contains? arg-types|form) + (conj (fnt|overload-group>input-types-decl in)) + true + (conj (fnt|overload-group>reify in gen-gensym)))))) + (apply concat)) :cljs (TODO)) - base-fn-codelist [] ; TODO + base-fn (>base-fn ...) fn-codelist (case lang :clj (->> `[~@direct-dispatch-codelist diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 23a9e938..35ae764c 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -5,7 +5,7 @@ (:require [clojure.core :as c] [quantum.core.defnt - :refer [analyze defnt fnt|code *fn->type]] + :refer [analyze defnt fnt|code *fn->type unsupported!]] [quantum.untyped.core.analyze.expr :as xp] [quantum.untyped.core.collections.diff :as diff :refer [diff]] @@ -57,7 +57,8 @@ (.getName))))) #_(defn ~'pid - {::t/spec (t/fn [:> (? t/string?)])}))) + {::t/type (t/fn [:> (? t/string?)])} + ))) ) @@ -65,10 +66,6 @@ (is-code= -(macroexpand ' -(defnt identity|uninlined ([x _] x)) -) - ;; ----- implementation ----- ;; (macroexpand ' @@ -78,9 +75,12 @@ ;; ----- expanded code ----- ;; (case (env-lang) - :clj ($ (do ;; [t/any?] - #_(def ~(tag "[Ljava.lang.Object;" 'identity|uninlined|__0|input-types) - (*<> t/any?)) + :clj ($ (do ;; [x t/any?] + + (def ~(tag "[Ljava.lang.Object;" 'identity|uninlined|__0|input-types) + (*<> ~'t/any?)) + + ;; One `reify` because `t/any?` in CLJ does not have any `t/or`-separability (def ~'identity|uninlined|__0 (reify Object>Object @@ -104,10 +104,12 @@ #_(defn ~'identity|uninlined {::t/type (t/fn [t/any?])} - [a0##] - (ifs ((Array/get identity|uninlined|__0|input-types 0) a0##) - (.invoke identity|uninlined|__0 a0##) - (unsupported! `identity|uninlined [a0##] 0))))) + [~'a00__] + (ifs ((Array/get ~'identity|uninlined|__0|input-types 0) ~'a00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" + 'identity|uninlined|__0) ~'a00__) + (unsupported! (quote quantum.core.test.defnt-equivalences/identity|uninlined) + [~'a00__] 0))))) :cljs ;; Direct dispatch will be simple functions, not `reify`s ($ (do (defn ~'identity|uninlined [~'x] ~'x))))) @@ -406,7 +408,7 @@ #?(:clj ([a t/comparable-primitive? b t/comparable-primitive? > t/boolean?] (Numeric/gt a b)) :cljs ([a t/double? b t/double? > (t/assume t/boolean?)] - (cljs.core/> a b)))) + (cljs.core/> a b)))) ) ;; ----- expanded code ----- ;; @@ -588,7 +590,8 @@ ;; =====|=====|=====|=====|===== ;; -;; TODO fix +;; TODO fix: current implementation prefers to consolidate into one `reify` rather than splitting it +;; up as below (is-code= (macroexpand ' @@ -684,8 +687,7 @@ ;; ----- expanded code ----- ;; (case (env-lang) - :clj ($ (do - #_[(t/- t/primitive? t/boolean? t/float? t/double?)] + :clj ($ (do #_[x (t/- t/primitive? t/boolean? t/float? t/double?)] #_(def ~'>long|__0|input-types (*<> t/byte?)) (def ~'>long|__0 @@ -722,9 +724,9 @@ ;; Resolved from `(>long* x)` (.invoke >long*|__4 ~'x)))) - #_[(t/and (t/or t/double? t/float?) - (fnt [x (t/or double? float?)] - (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] + #_[x (t/and (t/or t/double? t/float?) + (fnt [x (t/or double? float?)] + (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] #_(def ~'>long|__5|input-types (*<> (t/and t/double? @@ -757,8 +759,8 @@ (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] (let* [~(tag "clojure.lang.BigInt" 'x) ~'x] ~'(.lpart x))))) - #_[(t/and (t/isa? java.math.BigInteger) - (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] + #_[x (t/and (t/isa? java.math.BigInteger) + (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] #_(def ~'>long|__8|input-types (*<> (t/and (t/isa? java.math.BigInteger) @@ -768,7 +770,7 @@ (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] (let* [~(tag "java.math.BigInteger" 'x) ~'x] ~'(.longValue x))))) - #_[t/ratio?] + #_[x t/ratio?] #_(def ~'>long|__9|input-types (*<> t/ratio?)) @@ -799,7 +801,7 @@ (.invoke >long|__8 x##) (unsupported! `>long x##))))))) - #_[(t/value true)] + #_[x (t/value true)] #_(def ~'>long|__10|input-types (*<> (t/value true))) @@ -807,7 +809,7 @@ (reify boolean>long (~(tag "long" 'invoke) [_## ~(tag "boolean" 'x)] 1))) - #_[(t/value false)] + #_[x (t/value false)] #_(def ~'>long|__11|input-types (*<> (t/value false))) @@ -815,7 +817,7 @@ (reify boolean>long (~(tag "long" 'invoke) [_## ~(tag "boolean" 'x)] 0))) - #_[t/string?] + #_[x t/string?] #_(def ~'>long|__12|input-types (*<> t/string?)) @@ -824,7 +826,7 @@ (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] ~'(Long/parseLong x)))) - #_[t/string?] + #_[x t/string?] #_(def ~'>long|__13|input-types (*<> t/string? t/int?)) From 8421595e71fdc4e642c2986e990ab716cfd5746b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 26 Jun 2018 01:08:55 -0600 Subject: [PATCH 099/810] Got a lot further! Now creating the `defn` portion --- src-dev/quantum/core/defnt.cljc | 154 +++++++++++------- .../quantum/untyped/core/form/generate.cljc | 6 +- src-untyped/quantum/untyped/core/qualify.cljc | 2 +- src-untyped/quantum/untyped/core/type.cljc | 5 + src/quantum/core/fn.cljc | 2 +- src/quantum/core/reducers.cljc | 3 +- 6 files changed, 110 insertions(+), 62 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 43dd51a9..e63b7bb6 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -741,7 +741,7 @@ :arglist-code|fn|hinted t/any? :arglist-code|reify|unhinted t/any? :body-form t/any? - :positional-args-ct (s/and t/integer? #(>= % 0)) + :positional-args-ct t/nneg-int? :out-type t/type? :out-class (? t/class?) ;; When present, varargs are considered to be of class Object @@ -867,7 +867,10 @@ #?(:clj ; really, reserve for metalanguage (defn fnt|overload-data>overload-group - "Rather than rigging together something in which either: + "Given an `fnt` overload, computes an 'overload group', which is the foundation for potentially + multiple direct-dispatch `reify`s. + + Rather than rigging together something in which either: 1) the Clojure compiler will try to cross its fingers and evaluate code meant to be evaluated in ClojureScript 2) we use a CLJS-in-CLJS compiler and alienate the mainstream CLJS-in-CLJ (cljsbuild) workflow, @@ -902,7 +905,9 @@ arg-types|unprimitivized (->> arg-types|form (mapv (fn-> eval t/>type))) arg-classes-seq (arg-types>arg-classes-seq|primitivized arg-types|unprimitivized) ;; `unprimitivized` is first because of class sorting - [unprimitivized & primitivized] + ;; TODO `unprimitivized` might actually not be just the first one here due to + ;; `or`-splitting + [unprimitivized & primitivized :as overloads] (->> arg-classes-seq (mapv (fn [arg-classes] (let [arg-types @@ -932,12 +937,12 @@ (>symbol (str (->> args-classes (lmap class>interface-part-name) (str/join "+")) ">" (class>interface-part-name out-class)))) -(defns fnt-overload>interface [args-classes _, out-class t/class?] +(defns fnt-overload>interface [args-classes _, out-class t/class?, gen-gensym fn?] (let [interface-sym (fnt-overload>interface-sym args-classes out-class) hinted-method-sym (ufth/with-type-hint fnt-method-sym (ufth/>interface-method-tag out-class)) hinted-args (ufth/hint-arglist-with - (ufgen/gen-args (count args-classes)) + (ufgen/gen-args 0 (count args-classes) "x" gen-gensym) (map ufth/>interface-method-tag args-classes))] `(~'definterface ~interface-sym (~hinted-method-sym ~hinted-args)))) @@ -951,7 +956,8 @@ (let [interface-k {:out out-class :in arg-classes} interface (-> *interfaces - (swap! update interface-k #(or % (eval (fnt-overload>interface arg-classes out-class)))) + (swap! update interface-k + #(or % (eval (fnt-overload>interface arg-classes out-class gen-gensym)))) (c/get interface-k)) arglist-code (>vec (concat [(gen-gensym '_)] @@ -961,41 +967,54 @@ (ufth/with-type-hint arg (-> arg-classes (doto pr/ppr-meta) (c/get i) (doto pr/ppr-meta) ufth/>arglist-embeddable-tag))))) pr/ppr-meta)))] - {:arglist-code arglist-code - :body-form body-form - :interface interface - :method-sym fnt-method-sym - :out-class out-class}))) + {:arglist-code arglist-code + :body-form body-form + :interface interface + :method-sym fnt-method-sym + :out-class out-class}))) + +(defns >fnt|reify|name [fn|name :quantum.core.specs/fn|name, i t/index? > simple-symbol?] + (>symbol (str fn|name "|__" i))) #?(:clj (defns fnt|overload-group>reify - [{:keys [fn|name :quantum.core.specs/fn|name, i t/integer?, overload-group :fnt/overload-group]} _ + [{:keys [fn|name :quantum.core.specs/fn|name, i t/index?, overload-group :fnt/overload-group]} _ gen-gensym fn?] (let [reify-overloads (->> (concat [(:unprimitivized overload-group)] (:primitivized overload-group)) - (c/map #(fnt|overload>reify-overload % gen-gensym)))] - `(~'def ~(>symbol (str fn|name "|__" i)) - (reify ~@(->> reify-overloads - (c/lmap (fn [{:keys [interface out-class method-sym arglist-code body-form]} #_::reify|overload] - [(-> interface >name >symbol) - `(~(ufth/with-type-hint method-sym (ufth/>arglist-embeddable-tag out-class)) - ~arglist-code ~body-form)])) - lcat)))))) + (c/map #(fnt|overload>reify-overload % gen-gensym))) + reify-name (>fnt|reify|name fn|name i) + form `(~'def ~reify-name + (reify + ~@(->> reify-overloads + (c/lmap (fn [{:keys [interface out-class method-sym arglist-code + body-form]} #_::reify|overload] + [(-> interface >name >symbol) + `(~(ufth/with-type-hint method-sym + (ufth/>arglist-embeddable-tag out-class)) + ~arglist-code ~body-form)])) + lcat)))] + {:form form + :name reify-name + :overloads reify-overloads}))) + +(defns >input-types-decl|name [fn|name :quantum.core.specs/fn|name, i t/index? > simple-symbol?] + (>symbol (str fn|name "|__" i "|input-types"))) #?(:clj (defns fnt|overload-group>input-types-decl - [{:keys [fn|name :quantum.core.specs/fn|name - i t/integer? - overload-group :fnt/overload-group]} _] - `(def ~(ufth/with-type-hint (>symbol (str fn|name "|__" i "|input-types")) "[Ljava.lang.Object;") - (arr/*<> ~(get-in overload-group [:arg-types|form i]))))) + [{:keys [fn|name :quantum.core.specs/fn|name, i t/index?, overload-group :fnt/overload-group]} _] + (when (c/contains? (:arg-types|form overload-group)) + (let [decl-name (ufth/with-type-hint (>input-types-decl|name fn|name i) "[Ljava.lang.Object;")] + {:form `(def ~decl-name (arr/*<> ~(get-in overload-group [:arg-types|form i]))) + :name decl-name})))) (def allowed-shorthand-tag-chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") (defn >all-shorthand-tags [] - (->> (apply concat - (for [n (c/unchunk (range 1 (inc 64)))] ; just up to length 64 for now - (apply combo/cartesian-product (repeat n allowed-shorthand-tag-chars)))) + (->> (for [n (c/unchunk (range 1 (inc 64)))] ; just up to length 64 for now + (apply combo/cartesian-product (repeat n allowed-shorthand-tag-chars))) + lcat (c/lmap #(apply str %)) c/unchunk)) @@ -1056,16 +1075,52 @@ (err! "Arg count not enough for variadic overload"))]))))) true)) -#_(defns >base-fn [...] - #_(defn ~'identity|uninlined - {::t/type (t/fn [t/any?])} - [~'a00__] - (ifs ((Array/get ~'identity|uninlined|__0|input-types 0) ~'a00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" - 'identity|uninlined|__0) ~'a00__) - (unsupported! (quote quantum.core.test.defnt-equivalences/identity|uninlined) - [~'a00__] 0))) - ) +(defns >direct-dispatch + [{:keys [fn|name _, fnt|overload-groups _, gen-gensym fn?, lang _]} _] + (case lang + :clj (let [reify-groups + (->> fnt|overload-groups + (map-indexed + (fn [i {:as fnt|overload-group :keys [arg-types|form]}] + (let [in {:i i :fn|name fn|name :overload-group fnt|overload-group}] + {:fnt|reify (fnt|overload-group>reify in gen-gensym) + :input-types-decl (fnt|overload-group>input-types-decl in)})))) + form (->> reify-groups + (map (fn [{:keys [fnt|reify input-types-decl]}] + (cond-> [] + input-types-decl (:form input-types-decl) + true (:form fnt|reify)))) + lcat)] + {:form form :reify-groups reify-groups}) + :cljs (TODO))) + +;; TODO extend to more than just assuming always one arity +;; TODO check whether it even needs to get created based on arglist length etc. +;; TODO `get-relevant-reify`, `get-relevant-reify-overload` +(defns >dynamic-dispatch-fn|form + [{:keys [fn|name _, fnt|overload-groups _, lang _, reify-groups _]} _] + (let [fnt|overload-group (first fnt|overload-groups) + arglist (ufgen/gen-args 0 (count fnt|overload-group) "x" gen-gensym) + i|arg 0 + arg-sym (get arglist i|arg)] + `(defn ~fn|name + {::t/type (t/fn ~@(->> fnt|overload-groups (map :arg-types|form)))} + ~arglist + (ifs ~@(->> reify-groups + (map-indexed + (fn [i|reify {:keys [fnt|reify input-types-decl]}] + ;; TODO this part is very rough so far + (let [relevant-reify-overload (get-relevant-reify-overload fnt|reify) + hinted-reify-sym + (ufth/with-type-hint (:name fnt|reify) + (-> relevant-reify-overload :interface >name >symbol)) + dotted-reify-method-sym + (symbol (str "." (:method-sym relevant-reify-overload)))] + [`((quantum.core.Array/get ~(:name input-types-decl) ~i|arg) + ~arg-sym) + `(~dotted-reify-method-sym ~hinted-reify-sym ~arg-sym)]))) + lcat) + (unsupported! (quote ~(qualify fn|name)) [~@arglist] ~i))))) (defns fnt|code [kind #{:fn :defn}, lang ::lang, args _] (prl! kind lang args) @@ -1091,30 +1146,19 @@ (remove+ :variadic?) (c/group-by :positional-args-ct) (map-vals+ :out-type) - join (apply concat)) + join lcat) variadic-overload (->> fnt|overload-groups (c/lmap :unprimitivized) (c/lfilter :variadic?) first) register-type (gen-register-type (kw-map fn|name arg-ct->type variadic-overload)) - direct-dispatch-codelist - (case lang - :clj (->> fnt|overload-groups - (map-indexed - (fn [i {:as fnt|overload-group :keys [arg-types|form]}] - (let [in {:i i :fn|name fn|name :overload-group fnt|overload-group}] - (cond-> [] - (c/contains? arg-types|form) - (conj (fnt|overload-group>input-types-decl in)) - true - (conj (fnt|overload-group>reify in gen-gensym)))))) - (apply concat)) - :cljs (TODO)) - base-fn (>base-fn ...) + {:as direct-dispatch :keys [reify-groups]} + (>direct-dispatch (kw-map fn|name fnt|overload-groups gen-gensym lang)) fn-codelist (case lang - :clj (->> `[~@direct-dispatch-codelist - ~@base-fn-codelist] + :clj (->> `[~@(:form direct-dispatch) + ~(>dynamic-dispatch-fn|form + (kw-map fnt|overload-groups lang reify-groups))] (remove nil?)) :cljs (TODO)) overloads|code (->> fnt|overload-groups (c/map+ :unprimitivized) (c/map :code)) diff --git a/src-untyped/quantum/untyped/core/form/generate.cljc b/src-untyped/quantum/untyped/core/form/generate.cljc index 8083b1c6..998733f4 100644 --- a/src-untyped/quantum/untyped/core/form/generate.cljc +++ b/src-untyped/quantum/untyped/core/form/generate.cljc @@ -35,9 +35,9 @@ (defn gen-args ([max-n] (gen-args 0 max-n)) ([min-n max-n] (gen-args min-n max-n "x")) - ([min-n max-n s] (gen-args min-n max-n s false)) - ([min-n max-n s gensym?] - (->> (range min-n max-n) (mapv (fn [i] (symbol (str (if gensym? (gensym s) s) i))))))) + ([min-n max-n s] (gen-args min-n max-n s identity)) + ([min-n max-n s gen-gensym] + (->> (range min-n max-n) (mapv (fn [i] (gen-gensym (str s i))))))) (defn arity-builder [positionalf variadicf & [min-positional-arity max-positional-arity sym-genf no-gensym?]] (let [mina (or min-positional-arity 0) diff --git a/src-untyped/quantum/untyped/core/qualify.cljc b/src-untyped/quantum/untyped/core/qualify.cljc index 5e6ee36f..d7f13198 100644 --- a/src-untyped/quantum/untyped/core/qualify.cljc +++ b/src-untyped/quantum/untyped/core/qualify.cljc @@ -25,7 +25,7 @@ (defn qualify #?(:clj ([sym] (qualify *ns* sym))) - ([?ns sym] (symbol (?ns->name ?ns) (name sym)))) + ([?ns sym] (symbol (?ns->name ?ns) (name sym)))) (defn qualify|dot [sym ns-] (symbol (str (?ns->name ns-) "." (name sym)))) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 6e290502..fe0233ea 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -1812,3 +1812,8 @@ ;; Standard "uncuttable" types (-def integral? (or primitive? number?)) + + ;; TODO make into a type + (def nneg-int? #(and (integer? %) (c/>= % 0))) + ;; TODO make into a type + (def index? nneg-int?) diff --git a/src/quantum/core/fn.cljc b/src/quantum/core/fn.cljc index 616477be..7ab437da 100644 --- a/src/quantum/core/fn.cljc +++ b/src/quantum/core/fn.cljc @@ -13,7 +13,7 @@ [quantum.untyped.core.form.evaluate :refer [case-env compile-if]] [quantum.untyped.core.form.generate - :refer [arity-builder gen-args max-positional-arity unify-gensyms]] + :refer [arity-builder max-positional-arity unify-gensyms]] [quantum.untyped.core.fn :as u] [quantum.untyped.core.print :as upr] [quantum.untyped.core.vars :as uvar diff --git a/src/quantum/core/reducers.cljc b/src/quantum/core/reducers.cljc index 647351aa..d4f77c64 100644 --- a/src/quantum/core/reducers.cljc +++ b/src/quantum/core/reducers.cljc @@ -50,8 +50,7 @@ [quantum.untyped.core.qualify :as qual] [quantum.untyped.core.reducers :as ur] [quantum.untyped.core.form.generate - :refer [gen-args arity-builder max-positional-arity - unify-gensyms]]) + :refer [arity-builder max-positional-arity unify-gensyms]]) #?(:cljs (:require-macros [quantum.core.reducers From 8fb3e4869e7d07f1a4311c269b34b866cc49e709 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 26 Jun 2018 18:35:56 -0600 Subject: [PATCH 100/810] A little further --- src-dev/quantum/core/defnt.cljc | 6 +++--- src-dev/quantum/core/defnt_equivalences.cljc | 15 ++++++--------- 2 files changed, 9 insertions(+), 12 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index e63b7bb6..4bdf4e9b 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -1096,9 +1096,9 @@ ;; TODO extend to more than just assuming always one arity ;; TODO check whether it even needs to get created based on arglist length etc. -;; TODO `get-relevant-reify`, `get-relevant-reify-overload` +;; TODO `get-relevant-reify-overload` (defns >dynamic-dispatch-fn|form - [{:keys [fn|name _, fnt|overload-groups _, lang _, reify-groups _]} _] + [{:keys [fn|name _, fnt|overload-groups _, gen-gensym fn?, lang _, reify-groups _]} _] (let [fnt|overload-group (first fnt|overload-groups) arglist (ufgen/gen-args 0 (count fnt|overload-group) "x" gen-gensym) i|arg 0 @@ -1158,7 +1158,7 @@ (case lang :clj (->> `[~@(:form direct-dispatch) ~(>dynamic-dispatch-fn|form - (kw-map fnt|overload-groups lang reify-groups))] + (kw-map fn|name fnt|overload-groups gen-gensym lang reify-groups))] (remove nil?)) :cljs (TODO)) overloads|code (->> fnt|overload-groups (c/map+ :unprimitivized) (c/map :code)) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 35ae764c..94588f8b 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -56,9 +56,9 @@ ~'(->> (java.lang.management.ManagementFactory/getRuntimeMXBean) (.getName))))) - #_(defn ~'pid + (defn ~'pid {::t/type (t/fn [:> (? t/string?)])} - ))) + [] (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" 'pid|__0))))) ) @@ -79,7 +79,6 @@ (def ~(tag "[Ljava.lang.Object;" 'identity|uninlined|__0|input-types) (*<> ~'t/any?)) - ;; One `reify` because `t/any?` in CLJ does not have any `t/or`-separability (def ~'identity|uninlined|__0 (reify @@ -141,15 +140,13 @@ ;; ----- expanded code ----- ;; (case (env-lang) - :clj ($ (do ;; Only direct dispatch for primitives or for Object, not for subclasses of - ;; Object + :clj ($ (do ;; Only direct dispatch for primitives or for Object, not for subclasses of Object ;; Return value can be primitive; in this case it's not - ;; The macro in a typed context will find the appropriate dispatch at compile - ;; time + ;; The macro in a typed context will find the appropriate dispatch at compile time ;; [t/string?] - #_(def ~(tag "[Ljava.lang.Object;" 'name|__0|input-types) + (def ~(tag "[Ljava.lang.Object;" 'name|__0|input-types) (*<> t/string?)) (def ~'name|__0 (reify Object>Object @@ -564,7 +561,7 @@ (~(tag "boolean" 'invoke) [~'_48__ ~(tag "double" 'a) ~(tag "double" 'b)] ~'(Numeric/gt a b)))) - #_(defn > + #_(defn > {::t/type (t/fn #?(:clj [t/comparable-primitive? t/comparable-primitive? :> t/boolean?] From 2b4a34aa0556dcca88dca4be48d73582d907191d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 15 Jul 2018 15:56:05 -0600 Subject: [PATCH 101/810] Just committing this --- src-dev/quantum/core/defnt.cljc | 2 +- src-dev/quantum/core/defnt_equivalences.cljc | 141 ++++++++++++------- 2 files changed, 95 insertions(+), 48 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 4bdf4e9b..aecf0f20 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -761,7 +761,7 @@ ;; TODO optimize such that `post-form` doesn't create a new type-validator wholesale every time the ;; function gets run; e.g. extern it -(defn >with-post-form [body post-form] `(let* [~'out ~body] (t/validate ~'out ~post-form))) +(defn >with-post-form [body post-form] `(t/validate ~body ~post-form)) #?(:clj (var/def sort-guide "for use in arity sorting, in increasing conceptual size" diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 94588f8b..2f11617c 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -58,7 +58,7 @@ (defn ~'pid {::t/type (t/fn [:> (? t/string?)])} - [] (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" 'pid|__0))))) + ([] (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" 'pid|__0)))))) ) @@ -101,14 +101,12 @@ double>double (~(tag "double" 'invoke) [~'_8__ ~(tag "double" 'x)] ~'x))) - #_(defn ~'identity|uninlined + (defn ~'identity|uninlined {::t/type (t/fn [t/any?])} - [~'a00__] - (ifs ((Array/get ~'identity|uninlined|__0|input-types 0) ~'a00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" - 'identity|uninlined|__0) ~'a00__) - (unsupported! (quote quantum.core.test.defnt-equivalences/identity|uninlined) - [~'a00__] 0))))) + ([~'x00__] + ;; Checks elided because `t/any?` doesn't require a check + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" + 'identity|uninlined|__0) ~'a00__))))) :cljs ;; Direct dispatch will be simple functions, not `reify`s ($ (do (defn ~'identity|uninlined [~'x] ~'x))))) @@ -155,28 +153,30 @@ ;; [(t/isa? Named)] - #_(def ~(tag "[Ljava.lang.Object;" 'name|__1|input-types) + (def ~(tag "[Ljava.lang.Object;" 'name|__1|input-types) (*<> (t/isa? Named))) (def ~'name|__1 (reify Object>Object (~(tag "java.lang.Object" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] (let* [~(tag "clojure.lang.Named" 'x) ~'x] - (let* [~'out (.getName ~'x)] - (t/validate ~'out ~'(* t/string?))))))) + (t/validate ~'(.getName x) ~'(* t/string?)))))) - #_(defn ~'name + (defn ~'name {::t/type - (t/fn [t/string? :> t/string?] - #?(:clj [(t/isa? Named) :> (* t/string?)] - :cljs [(t/isa? INamed) :> (* t/string?)]))} - [a0##] - (ifs ((Array/get name|__0|input-types 0) a0##) - (.invoke name|__0 a0##) - (unsupported! `>name [a0##] 0))))) - :cljs ($ (do (defn ~'name [~'x] - (ifs (string? x) x + (t/fn [t/string? :> t/string?] + [(t/isa? Named) :> (* t/string?)])} + ([~'x00__] + (ifs ((Array/get ~'name|__0|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" + 'name|__0) ~'x00__) + ((Array/get ~'name|__1|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" + 'name|__1) ~'x00__) + (unsupported! `name [~'x00__] 0)))))) + :cljs ($ (do (defn ~'name [~'x00__] + (ifs (t/string? x) x (satisfies? INamed x) (-name x) - (err! "Not supported for type" {:fn `name :type (type x)})))))) + (unsupported! `name [~'x00__] 0)))))) ) @@ -197,6 +197,8 @@ (case (env-lang) :clj ($ (do ;; [x t/nil?] + (def ~(tag "[Ljava.lang.Object;" 'some?|__0|input-types) + (*<> t/nil?)) (def ~'some?|__0 (reify Object>boolean @@ -204,6 +206,8 @@ ;; [x t/any?] + (def ~(tag "[Ljava.lang.Object;" 'some?|__1|input-types) + (*<> t/any?)) (def ~'some?|__1 (reify Object>boolean @@ -225,11 +229,18 @@ double>boolean (~(tag "boolean" 'invoke) [~'_9__ ~(tag "double" 'x)] true))) - #_(defn ~'some? + (defn ~'some? {::t/type (t/fn [t/nil?] [t/any?])} - ... - ))) + ([~'x00__] + (ifs ((Array/get ~'some?|__0|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" + 'some?|__0) ~'x00__) + ;; TODO eliminate this check because it's not needed (`t/any?`) + ((Array/get ~'some?|__1|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" + 'some?|__1) ~'x00__) + (unsupported! `some? [~'x00__] 0)))))) :cljs ($ (do (defn ~'some? [~'x] (ifs (nil? x) false true))))) @@ -251,32 +262,52 @@ ;; ----- expanded code ----- ;; (case (env-lang) - :clj ($ (do ;;[(t/isa? Reduced)] + :clj ($ (do ;; [x (t/isa? Reduced)] + (def ~(tag "[Ljava.lang.Object;" 'reduced?|__0|input-types) + (*<> (t/isa? Reduced))) (def ~'reduced?|__0 (reify Object>boolean (~(tag "boolean" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] (let* [~(tag "clojure.lang.Reduced" 'x) ~'x] true)))) - ;; [t/any?] + ;; [x t/any?] + (def ~(tag "[Ljava.lang.Object;" 'reduced?|__1|input-types) + (*<> t/any?)) (def ~'reduced?|__1 (reify - Object>boolean (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false) - boolean>boolean (~(tag "boolean" 'invoke) [~'_2__ ~(tag "boolean" 'x)] false) - byte>boolean (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'x)] false) - short>boolean (~(tag "boolean" 'invoke) [~'_4__ ~(tag "short" 'x)] false) - char>boolean (~(tag "boolean" 'invoke) [~'_5__ ~(tag "char" 'x)] false) - int>boolean (~(tag "boolean" 'invoke) [~'_6__ ~(tag "int" 'x)] false) - long>boolean (~(tag "boolean" 'invoke) [~'_7__ ~(tag "long" 'x)] false) - float>boolean (~(tag "boolean" 'invoke) [~'_8__ ~(tag "float" 'x)] false) - double>boolean (~(tag "boolean" 'invoke) [~'_9__ ~(tag "double" 'x)] false))) - - #_(defn ~'reduced? + Object>boolean + (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false) + boolean>boolean + (~(tag "boolean" 'invoke) [~'_2__ ~(tag "boolean" 'x)] false) + byte>boolean + (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'x)] false) + short>boolean + (~(tag "boolean" 'invoke) [~'_4__ ~(tag "short" 'x)] false) + char>boolean + (~(tag "boolean" 'invoke) [~'_5__ ~(tag "char" 'x)] false) + int>boolean + (~(tag "boolean" 'invoke) [~'_6__ ~(tag "int" 'x)] false) + long>boolean + (~(tag "boolean" 'invoke) [~'_7__ ~(tag "long" 'x)] false) + float>boolean + (~(tag "boolean" 'invoke) [~'_8__ ~(tag "float" 'x)] false) + double>boolean + (~(tag "boolean" 'invoke) [~'_9__ ~(tag "double" 'x)] false))) + + (defn ~'reduced? {::t/type (t/fn [(t/isa? Reduced)] [t/any?])} - ... - ))) + ([~'x00__] + (ifs ((Array/get ~'reduced?|__0|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" + 'reduced?|__0) ~'x00__) + ;; TODO eliminate this check because it's not needed (`t/any?`) + ((Array/get ~'reduced?|__1|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" + 'reduced?|__1) ~'x00__) + (unsupported! `reduced? [~'x00__] 0)))))) :cljs ($ (do (defn ~'reduced? [~'x] (ifs (instance? Reduced x) true false))))) @@ -298,20 +329,26 @@ (case (env-lang) :clj ($ (do ;; [x t/boolean?] + (def ~(tag "[Ljava.lang.Object;" '>boolean|__0|input-types) + (*<> t/boolean?)) (def ~'>boolean|__0 (reify boolean>boolean - (~(tag "boolean" 'invoke) [~'_0__ ~(tag "boolean" 'x)] ~'x))) + (~(tag "boolean" 'invoke) [~'_0__ ~(tag "boolean" 'x)] ~'x))) ;; [x t/nil? -> (- t/nil? t/boolean?)] + (def ~(tag "[Ljava.lang.Object;" '>boolean|__1|input-types) + (*<> t/nil?)) (def ~'>boolean|__1 (reify Object>boolean - (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false))) + (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false))) ;; [x t/any? -> (- t/any? t/nil? t/boolean?)] + (def ~(tag "[Ljava.lang.Object;" '>boolean|__1|input-types) + (*<> t/any?)) (def ~'>boolean|__2 (reify Object>boolean @@ -333,12 +370,22 @@ double>boolean (~(tag "boolean" 'invoke) [~'_10__ ~(tag "double" 'x)] true))) - #_(defn ~'>boolean + (defn ~'>boolean {::t/type (t/fn [t/boolean?] [t/nil?] [t/any?])} - ... - ))) + ([~'x00__] + (ifs ((Array/get ~'>boolean|__0|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.boolean>boolean" + '>boolean|__0) ~'x00__) + ((Array/get ~'>boolean|__1|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" + '>boolean|__1) ~'x00__) + ;; TODO eliminate this check because it's not needed (`t/any?`) + ((Array/get ~'>boolean|__2|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" + '>boolean|__2) ~'x00__) + (unsupported! `>boolean [~'x00__] 0)))))) :cljs ($ (do (defn ~'>boolean [~'x] (ifs (boolean? x) x (nil? x) false @@ -365,7 +412,7 @@ (t/fn [(t/- t/primitive? t/boolean?)] [(t/ref (t/isa? Number))])) - ;; [(t/- t/primitive? t/boolean?)] + ;; [x (t/- t/primitive? t/boolean?)] (def ~'>int*|__0 (reify @@ -384,7 +431,7 @@ double>int (~(tag "int" 'invoke) [~'_6__ ~(tag "double" 'x)] ~'(Primitive/uncheckedIntCast x)))) - ;; [(t/ref (t/isa? Number)) + ;; [x (t/ref (t/isa? Number)) ;; -> (t/- (t/ref (t/isa? Number)) (t/- t/primitive? t/boolean?))] (def ~'>int*|__1 From c91c12df91aff5eb6225f6f9054deb521361f034 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 16 Jul 2018 20:33:29 -0600 Subject: [PATCH 102/810] Fix some compilation --- src-dev/quantum/core/defnt.cljc | 5 +++-- src-dev/quantum/core/defnt_equivalences.cljc | 2 ++ src-untyped/quantum/untyped/core/meta/debug.cljc | 7 ++++--- 3 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index aecf0f20..90868a59 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -1102,7 +1102,8 @@ (let [fnt|overload-group (first fnt|overload-groups) arglist (ufgen/gen-args 0 (count fnt|overload-group) "x" gen-gensym) i|arg 0 - arg-sym (get arglist i|arg)] + arg-sym (get arglist i|arg) + get-relevant-reify-overload (constantly nil)] `(defn ~fn|name {::t/type (t/fn ~@(->> fnt|overload-groups (map :arg-types|form)))} ~arglist @@ -1120,7 +1121,7 @@ ~arg-sym) `(~dotted-reify-method-sym ~hinted-reify-sym ~arg-sym)]))) lcat) - (unsupported! (quote ~(qualify fn|name)) [~@arglist] ~i))))) + (unsupported! (quote ~(qualify fn|name)) [~@arglist] ~i|arg))))) (defns fnt|code [kind #{:fn :defn}, lang ::lang, args _] (prl! kind lang args) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 2f11617c..a3c9652f 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -414,6 +414,8 @@ ;; [x (t/- t/primitive? t/boolean?)] + (def ~(tag "[Ljava.lang.Object;" '>int*|__0|input-types) + (*<> (t/- t/primitive? t/boolean?))) (def ~'>int*|__0 (reify byte>int (~(tag "int" 'invoke) [~'_0__ ~(tag "byte" 'x)] diff --git a/src-untyped/quantum/untyped/core/meta/debug.cljc b/src-untyped/quantum/untyped/core/meta/debug.cljc index 3feb1400..c1892b59 100644 --- a/src-untyped/quantum/untyped/core/meta/debug.cljc +++ b/src-untyped/quantum/untyped/core/meta/debug.cljc @@ -34,12 +34,13 @@ (reify java.lang.Thread$UncaughtExceptionHandler (^void uncaughtException [_ ^Thread t ^Throwable e] + ;; TODO (@clojure.core/atom|proto-repl|print-err-fn e) ? (println "Exception in thread" (str t ":")) (trace e))))) #?(:clj (defn print-pretty-exceptions! - ([] (Thread/setDefaultUncaughtExceptionHandler default-exception-handler)) + ([] (->> (Thread/getAllStackTraces) keys (map print-pretty-exceptions!) dorun)) ([^Thread t] (.setUncaughtExceptionHandler t default-exception-handler)))) (def stack-depth @@ -55,8 +56,8 @@ (let [st (identity #?(:clj (-> (Thread/currentThread) .getStackTrace) :cljs (-> (js/Error) .-stack - ; TODO Different browsers have different - ; implementations of stack traces + ;; TODO Different browsers have different + ;; implementations of stack traces (str/split "\n at ")))) #?(:clj ^StackTraceElement elem :cljs elem) From bbebf649e5ccd63539a2b9662bee6fc1292279be Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 16 Jul 2018 21:42:56 -0600 Subject: [PATCH 103/810] Update `repl-options` --- project-base.clj | 42 ++++++++++++++++++++++++------------------ 1 file changed, 24 insertions(+), 18 deletions(-) diff --git a/project-base.clj b/project-base.clj index d63ad74e..165757cf 100644 --- a/project-base.clj +++ b/project-base.clj @@ -400,20 +400,25 @@ :aot '[sparkling.serialization sparkling.destructuring] ;; ===== REPL ===== ;; :repl-options - {:init '(do (require - '[no.disassemble :refer [disassemble]] - 'quantum.untyped.core.error - 'quantum.untyped.core.print - 'quantum.untyped.core.print.prettier - '[quantum.untyped.core.log :refer [prl!]]) - (quantum.untyped.core.print.prettier/extend-pretty-printing!) - (reset! quantum.untyped.core.error/*pr-data-to-str? true) - #_(clojure.main/repl - :print #(binding [*print-meta* true - quantum.untyped.core.print/*collapse-symbols?* true - quantum.untyped.core.print/*print-as-code?* true] - (quantum.untyped.core.print/ppr %)) - :caught #'quantum.untyped.core.print/ppr-error))}}) + {:init + '(do (require + '[no.disassemble :refer [disassemble]] + 'quantum.untyped.core.error + 'quantum.untyped.core.print + 'quantum.untyped.core.print.prettier + '[quantum.untyped.core.log :refer [prl!]]) + (quantum.untyped.core.print.prettier/extend-pretty-printing!) + (reset! quantum.untyped.core.error/*pr-data-to-str? true) + ;; For use with Atom's Proto-REPL + ;; Interned in `clojure.core` in order to not be clobbered by `refresh` + (intern 'clojure.core 'atom|proto-repl|print-fn + (atom #(binding [*print-meta* true + quantum.untyped.core.print/*collapse-symbols?* true + quantum.untyped.core.print/*print-as-code?* true] + (quantum.untyped.core.print/ppr %)))) + (intern 'clojure.core 'atom|proto-repl|print-err-fn + (atom #(quantum.untyped.core.print/ppr-error %))) + #_(clojure.main/repl :print ... :caught ...))}}) (defn >cljsbuild-builds "Note that for Figwheel to work, no character in the build IDs can necessitate an @@ -439,13 +444,13 @@ :quantum-dynamic-source [(:typed quantum-source-paths) (:untyped quantum-source-paths) - (:posh quantum-source-paths)] + #_(:posh quantum-source-paths)] :quantum-dynamic-source-untyped [(:untyped quantum-source-paths) - (:posh quantum-source-paths)] + #_(:posh quantum-source-paths)] :re-frame-trace (cond-> - [(:posh quantum-source-paths) + [#_(:posh quantum-source-paths) (if quantum? "./src-re-frame-trace" (:re-frame-trace quantum-source-paths))] @@ -632,6 +637,7 @@ "-XX:-OmitStackTraceInFastThrow" "-XX:ErrorFile=./JVMErrorDump.log" "-Dquantum.core.log|out-file=./out.log" + "-Dquantum.core.log|print-to-stderror=false" ;; ----- Compilation ----- ;; #_(case system-type "t2.micro" @@ -878,7 +884,7 @@ {:source-paths (vals quantum-source-paths)}) :quantum|dynamic-source|untyped (when-not quantum? - {:source-paths [(:untyped quantum-source-paths) (:posh quantum-source-paths)]}) + {:source-paths [(:untyped quantum-source-paths) #_(:posh quantum-source-paths)]}) ;; ----- Special profiles ----- ;; :auto-instrument {:jvm-opts ["-Dco.paralleluniverse.pulsar.instrument.auto=all"] From 62414697bf3db2385c6b302e68391bd6889945c7 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 17 Jul 2018 01:30:09 -0600 Subject: [PATCH 104/810] `quantum.untyped.core.meta.debug/print-pretty-exceptions!` --- project-base.clj | 2 ++ 1 file changed, 2 insertions(+) diff --git a/project-base.clj b/project-base.clj index 165757cf..f47f2aab 100644 --- a/project-base.clj +++ b/project-base.clj @@ -404,6 +404,7 @@ '(do (require '[no.disassemble :refer [disassemble]] 'quantum.untyped.core.error + 'quantum.untyped.core.meta.debug 'quantum.untyped.core.print 'quantum.untyped.core.print.prettier '[quantum.untyped.core.log :refer [prl!]]) @@ -418,6 +419,7 @@ (quantum.untyped.core.print/ppr %)))) (intern 'clojure.core 'atom|proto-repl|print-err-fn (atom #(quantum.untyped.core.print/ppr-error %))) + (quantum.untyped.core.meta.debug/print-pretty-exceptions!) #_(clojure.main/repl :print ... :caught ...))}}) (defn >cljsbuild-builds From 6de19c6bbce03cd6b2433080b25e3a59f829f83b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 17 Jul 2018 01:30:26 -0600 Subject: [PATCH 105/810] Update specs and add more --- src-dev/quantum/core/defnt.cljc | 127 ++++++++++++-------- src-untyped/quantum/untyped/core/defnt.cljc | 49 ++++---- src-untyped/quantum/untyped/core/specs.cljc | 60 +++++---- 3 files changed, 139 insertions(+), 97 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 90868a59..3cf332e6 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -236,11 +236,13 @@ #?(:clj (defns class->methods [^Class c t/class? > t/map?] (->> (.getMethods c) - (remove+ (fn [^java.lang.reflect.Method x] (java.lang.reflect.Modifier/isPrivate (.getModifiers x)))) - (map+ (fn [^java.lang.reflect.Method x] (Method. (.getName x) (.getReturnType x) (.getParameterTypes x) - (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) - :static - :instance)))) + (remove+ (fn [^java.lang.reflect.Method x] + (java.lang.reflect.Modifier/isPrivate (.getModifiers x)))) + (map+ (fn [^java.lang.reflect.Method x] + (Method. (.getName x) (.getReturnType x) (.getParameterTypes x) + (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) + :static + :instance)))) (c/group-by (fn [^Method x] (.-name x))) ; TODO all of these need to be into !vector and !hash-map (map-vals+ (fn->> (c/group-by (fn [^Method x] (count (.-argtypes x)))) (map-vals+ (fn->> (c/group-by (fn [^Method x] (.-kind x))))) @@ -256,7 +258,8 @@ (defns class->fields [^Class c t/class? > t/map?] (->> (.getFields c) - (remove+ (fn [^java.lang.reflect.Field x] (java.lang.reflect.Modifier/isPrivate (.getModifiers x)))) + (remove+ (fn [^java.lang.reflect.Field x] + (java.lang.reflect.Modifier/isPrivate (.getModifiers x)))) (map+ (fn [^java.lang.reflect.Field x] [(.getName x) (Field. (.getName x) (.getType x) @@ -346,9 +349,10 @@ :type t/nil?}) (let [expr (analyze-non-map-seqable env body [] (fn [accum expr _] - ;; for types, only the last subexpression ever matters, as each is independent from the others + ;; for types, only the last subexpression ever matters, as each is independent :; from the others (assoc expr :form (conj! (:form accum) (:form expr)) - ;; but the env should be the same as whatever it was originally because no new scopes are created + ;; but the env should be the same as whatever it was originally + ;; because no new scopes are created :env (:env accum))))] (ast/do {:env env :form form @@ -379,8 +383,7 @@ :form (list 'let* bindings' body') :type-info type-info'}))) -(defns ?resolve-with-env - [sym t/symbol?, env ::env] +(defns ?resolve-with-env [sym t/symbol?, env ::env] (let [local (c/get env sym)] (if (some? local) (if (ast/unbound? local) @@ -442,22 +445,14 @@ [c t/class?, method t/symbol? > (? t/type?)] (when (identical? c clojure.lang.RT) (case method - (uncheckedBooleanCast booleanCast) - t/boolean? - (uncheckedByteCast byteCast) - t/byte? - (uncheckedCharCast charCast) - t/char? - (uncheckedShortCast shortCast) - t/char? - (uncheckedIntCast intCast) - t/int? - (uncheckedLongCast longCast) - t/long? - (uncheckedFloatCast floatCast) - t/float? - (uncheckedDoubleCast doubleCast) - t/double? + (uncheckedBooleanCast booleanCast) t/boolean? + (uncheckedByteCast byteCast) t/byte? + (uncheckedCharCast charCast) t/char? + (uncheckedShortCast shortCast) t/char? + (uncheckedIntCast intCast) t/int? + (uncheckedLongCast longCast) t/long? + (uncheckedFloatCast floatCast) t/float? + (uncheckedDoubleCast doubleCast) t/double? nil)))) (defns- analyze-seq|dot|method-call @@ -685,7 +680,7 @@ (analyze-seq* env expanded-form) (ast/macro-call {:env env :form form :expanded (analyze-seq* env expanded-form)})))) -(defns- analyze-symbol [env _, form t/symbol?] +(defns- analyze-symbol [env ::env, form t/symbol?] {:post [(prl! %)]} (let [resolved (?resolve-with-env form env)] (if-not resolved @@ -730,7 +725,7 @@ #_(s/def :fnt|overload/arglist-code (t/vec-of arg?)) #_"Must evaluate to an `s/fspec`" -(s/def :fnt|overload/type :quantum.core.specs/code) +(s/def :fnt|overload/type :quantum.core.specs/code) #_(s/def :fnt|overload/body-codelist (t/seq-of :quantum.core.specs/code)) @@ -754,6 +749,8 @@ :reify/arglist-code :reify|overload/body-form])) +(s/def ::lang #{:clj :cljs}) + #_(:clj (defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] (cond (not= k :spec) java.lang.Object; default class @@ -805,8 +802,7 @@ (apply combo/cartesian-product) (c/lmap >vec)))) -(s/def ::lang #{:clj :cljs}) - +;; TODO spec args #?(:clj (defns- >fnt|overload "Is given `arg-classes` and `arg-types`. In order to determine the out-type, performs an analysis @@ -865,8 +861,14 @@ :out-class (out-type>class out-type) :variadic? (boolean varargs)}))) +#_(s/def ::fnt|overload-group + (s/kv {:arg-types|form ... + :unprimitivized ... + :primitivized ...})) + +;; TODO spec #?(:clj ; really, reserve for metalanguage -(defn fnt|overload-data>overload-group +(defns fnt|overload-data>overload-group "Given an `fnt` overload, computes an 'overload group', which is the foundation for potentially multiple direct-dispatch `reify`s. @@ -881,9 +883,12 @@ we decide instead to evaluate types in languages in which the metalanguage (compiler language) is the same as the object language (e.g. Clojure), and symbolically analyze types in the rest (e.g. vanilla ClojureScript), deferring code analyzed as functions to be enforced at runtime." - [{:as in {:keys [args varargs] pre-form :pre [post-type post-form] :post} :arglist - body-codelist|pre-analyze :body} - {:as opts :keys [lang #_::lang symbolic-analysis? #_t/boolean?]}] + [{:as in {:keys [args _, varargs _] + pre-form [:pre _] + [post-type _, post-form _] [:post _]} [:arglist _] + body-codelist|pre-analyze [:body _]} _ + {:as opts :keys [lang ::lang, symbolic-analysis? t/boolean?]} _ + > t/any?] (if symbolic-analysis? (err! "Symbolic analysis not supported yet") (let [_ (when pre-form (TODO "Need to handle pre")) @@ -937,6 +942,7 @@ (>symbol (str (->> args-classes (lmap class>interface-part-name) (str/join "+")) ">" (class>interface-part-name out-class)))) +;; TODO finish specing args (defns fnt-overload>interface [args-classes _, out-class t/class?, gen-gensym fn?] (let [interface-sym (fnt-overload>interface-sym args-classes out-class) hinted-method-sym (ufth/with-type-hint fnt-method-sym @@ -946,6 +952,7 @@ (map ufth/>interface-method-tag args-classes))] `(~'definterface ~interface-sym (~hinted-method-sym ~hinted-args)))) +;; TODO spec args #?(:clj (defns fnt|overload>reify-overload [{:as overload @@ -973,12 +980,12 @@ :method-sym fnt-method-sym :out-class out-class}))) -(defns >fnt|reify|name [fn|name :quantum.core.specs/fn|name, i t/index? > simple-symbol?] +(defns >fnt|reify|name [fn|name ::uss/fn|name, i t/index? > simple-symbol?] (>symbol (str fn|name "|__" i))) #?(:clj (defns fnt|overload-group>reify - [{:keys [fn|name :quantum.core.specs/fn|name, i t/index?, overload-group :fnt/overload-group]} _ + [{:keys [::uss/fn|name ::uss/fn|name, i t/index?, overload-group :fnt/overload-group]} _ gen-gensym fn?] (let [reify-overloads (->> (concat [(:unprimitivized overload-group)] (:primitivized overload-group)) @@ -998,12 +1005,12 @@ :name reify-name :overloads reify-overloads}))) -(defns >input-types-decl|name [fn|name :quantum.core.specs/fn|name, i t/index? > simple-symbol?] +(defns >input-types-decl|name [fn|name ::uss/fn|name, i t/index? > simple-symbol?] (>symbol (str fn|name "|__" i "|input-types"))) #?(:clj (defns fnt|overload-group>input-types-decl - [{:keys [fn|name :quantum.core.specs/fn|name, i t/index?, overload-group :fnt/overload-group]} _] + [{:keys [::uss/fn|name ::uss/fn|name, i t/index?, overload-group :fnt/overload-group]} _] (when (c/contains? (:arg-types|form overload-group)) (let [decl-name (ufth/with-type-hint (>input-types-decl|name fn|name i) "[Ljava.lang.Object;")] {:form `(def ~decl-name (arr/*<> ~(get-in overload-group [:arg-types|form i]))) @@ -1032,6 +1039,7 @@ :remaining (next remaining)))) (get c)))) +;; TODO spec (defn assert-monotonically-increasing-types! "Asserts that each type in an overload of the same arity and arg-position are in monotonically increasing order in terms of `t/compare`." @@ -1055,16 +1063,18 @@ nil overloads))) -(defns unsupported! [name- _ #_t/qualified-symbol?, args t/indexed?, i _ #_index?] +;; TODO spec +(defns unsupported! [name- _ #_t/qualified-symbol?, args t/indexed?, i t/index?] (TODO)) +;; TODO spec (defns gen-register-type "Registers in the map of qualified symbol to input type, to output type Example output: (swap! ... assoc `abcde (fn [args] (case (count args) 1 )))" - [{:keys [fn|name :quantum.core.specs/fn|name, arg-ct->type _, variadic-overload _]} _] + [{:keys [::uss/fn|name ::uss/fn|name, arg-ct->type _, variadic-overload _]} _] (unify-gensyms `(swap! *fn->type assoc '~(qualify fn|name) (xp/>expr @@ -1075,14 +1085,16 @@ (err! "Arg count not enough for variadic overload"))]))))) true)) +;; TODO spec (defns >direct-dispatch - [{:keys [fn|name _, fnt|overload-groups _, gen-gensym fn?, lang _]} _] + [{:keys [::uss/fn|name ::uss/fn|name + fnt|overload-groups _, gen-gensym fn?, lang ::lang]} _] (case lang :clj (let [reify-groups (->> fnt|overload-groups (map-indexed (fn [i {:as fnt|overload-group :keys [arg-types|form]}] - (let [in {:i i :fn|name fn|name :overload-group fnt|overload-group}] + (let [in {:i i ::uss/fn|name fn|name :overload-group fnt|overload-group}] {:fnt|reify (fnt|overload-group>reify in gen-gensym) :input-types-decl (fnt|overload-group>input-types-decl in)})))) form (->> reify-groups @@ -1094,24 +1106,28 @@ {:form form :reify-groups reify-groups}) :cljs (TODO))) +;; TODO spec ;; TODO extend to more than just assuming always one arity ;; TODO check whether it even needs to get created based on arglist length etc. ;; TODO `get-relevant-reify-overload` (defns >dynamic-dispatch-fn|form - [{:keys [fn|name _, fnt|overload-groups _, gen-gensym fn?, lang _, reify-groups _]} _] + [{:keys [::uss/fn|name ::uss/fn|name, fnt|overload-groups _ + gen-gensym fn?, lang ::lang, reify-groups _]} _] (let [fnt|overload-group (first fnt|overload-groups) arglist (ufgen/gen-args 0 (count fnt|overload-group) "x" gen-gensym) i|arg 0 - arg-sym (get arglist i|arg) - get-relevant-reify-overload (constantly nil)] + arg-sym (get arglist i|arg)] `(defn ~fn|name {::t/type (t/fn ~@(->> fnt|overload-groups (map :arg-types|form)))} ~arglist (ifs ~@(->> reify-groups (map-indexed (fn [i|reify {:keys [fnt|reify input-types-decl]}] + (prl! input-types-decl) ;; TODO this part is very rough so far - (let [relevant-reify-overload (get-relevant-reify-overload fnt|reify) + (let [relevant-reify-overload + ;; TODO this is not general enough + (get-in fnt|reify [:overloads 0]) hinted-reify-sym (ufth/with-type-hint (:name fnt|reify) (-> relevant-reify-overload :interface >name >symbol)) @@ -1125,7 +1141,9 @@ (defns fnt|code [kind #{:fn :defn}, lang ::lang, args _] (prl! kind lang args) - (let [{:keys [:quantum.core.specs/fn|name overloads :quantum.core.specs/meta] :as args'} + (let [{:keys [:quantum.core.specs/fn|name + :quantum.core.defnt/overloads + :quantum.core.specs/meta] :as args'} (s/validate args (case kind :defn ::defnt :fn ::fnt)) gen-gensym-base (ufgen/>reproducible-gensym|generator) gen-gensym (fn [x] (symbol (str (gen-gensym-base x) "__"))) @@ -1152,21 +1170,24 @@ (c/lmap :unprimitivized) (c/lfilter :variadic?) first) - register-type (gen-register-type (kw-map fn|name arg-ct->type variadic-overload)) - {:as direct-dispatch :keys [reify-groups]} - (>direct-dispatch (kw-map fn|name fnt|overload-groups gen-gensym lang)) + register-type (gen-register-type + (assoc (kw-map arg-ct->type variadic-overload) + ::uss/fn|name fn|name)) + args (assoc (kw-map fnt|overload-groups gen-gensym lang) + ::uss/fn|name fn|name) + {:as direct-dispatch :keys [reify-groups]} (>direct-dispatch args) + _ (prl! direct-dispatch) fn-codelist (case lang :clj (->> `[~@(:form direct-dispatch) - ~(>dynamic-dispatch-fn|form - (kw-map fn|name fnt|overload-groups gen-gensym lang reify-groups))] + ~(>dynamic-dispatch-fn|form (merge args (kw-map reify-groups)))] (remove nil?)) :cljs (TODO)) overloads|code (->> fnt|overload-groups (c/map+ :unprimitivized) (c/map :code)) _ (prl! overloads) code (case kind :fn (list* 'fn (concat - (if (contains? args' :quantum.core.specs/fn|name) + (if (contains? args' ::uss/fn|name) [fn|name] []) [overloads|code])) diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index 85477fc7..079f3e75 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -12,7 +12,7 @@ :refer [reduce-2]] [quantum.untyped.core.reducers :as ur] [quantum.untyped.core.spec :as us] - [quantum.untyped.core.specs] + [quantum.untyped.core.specs :as uss] [quantum.untyped.core.type.predicates :refer [any? ident? qualified-keyword? seqable? simple-symbol?]]) #?(:cljs @@ -117,25 +117,26 @@ (s/def :quantum.core.defnt/postchecks (s/conformer - (fn [f] - (-> f (update :overloads - #(mapv (fn [overload] - (let [overload' (update overload :body :body)] - (if-let [output-spec (-> f :output-spec :spec)] - (do (us/assert-conform nil? (-> overload' :arglist :post)) - (assoc-in overload' [:arglist :post] output-spec)) - overload'))) %)) - (dissoc :output-spec))))) + (fn [fn-form] + (-> fn-form + (update :quantum.core.defnt/overloads + #(mapv (fn [overload] + (let [overload' (update overload :body :body)] + (if-let [output-spec (-> fn-form :quantum.core.defnt/output-spec :spec)] + (do (us/assert-conform nil? (-> overload' :arglist :post)) + (assoc-in overload' [:arglist :post] output-spec)) + overload'))) %)) + (dissoc :quantum.core.defnt/output-spec))))) (s/def :quantum.core.defnt/fnt (s/and (s/spec (s/cat - :quantum.core.specs/fn|name (s/? :quantum.core.specs/fn|name) - :quantum.core.specs/docstring (s/? :quantum.core.specs/docstring) - :pre-meta (s/? :quantum.core.specs/meta) - :output-spec :quantum.core.defnt/output-spec - :overloads :quantum.core.defnt/overloads)) - :quantum.core.specs/fn|postchecks + :quantum.core.specs/fn|name (s/? :quantum.core.specs/fn|name) + :quantum.core.specs/docstring (s/? :quantum.core.specs/docstring) + :quantum.core.specs/pre-meta :quantum.core.specs/pre-meta + :quantum.core.defnt/output-spec :quantum.core.defnt/output-spec + :quantum.core.defnt/overloads :quantum.core.defnt/overloads)) + (uss/fn-like|postchecks|gen :quantum.core.defnt/overloads) :quantum.core.defnt/postchecks)) (s/def :quantum.core.defnt/fns|code :quantum.core.defnt/fnt) @@ -143,12 +144,12 @@ (s/def :quantum.core.defnt/defnt (s/and (s/spec (s/cat - :quantum.core.specs/fn|name :quantum.core.specs/fn|name - :quantum.core.specs/docstring (s/? :quantum.core.specs/docstring) - :pre-meta (s/? :quantum.core.specs/meta) - :output-spec :quantum.core.defnt/output-spec - :overloads :quantum.core.defnt/overloads)) - :quantum.core.specs/fn|postchecks + :quantum.core.specs/fn|name :quantum.core.specs/fn|name + :quantum.core.specs/docstring (s/? :quantum.core.specs/docstring) + :quantum.core.specs/pre-meta :quantum.core.specs/pre-meta + :quantum.core.defnt/output-spec :quantum.core.defnt/output-spec + :quantum.core.defnt/overloads :quantum.core.defnt/overloads)) + (uss/fn-like|postchecks|gen :quantum.core.defnt/overloads) :quantum.core.defnt/postchecks)) (s/def :quantum.core.defnt/defns|code :quantum.core.defnt/defnt) @@ -329,7 +330,9 @@ (defn fns|code [kind lang args] (assert (= lang #?(:clj :clj :cljs :cljs)) lang) (when (= kind :fn) (println "WARNING: `fn` will ignore spec validation")) - (let [{:keys [:quantum.core.specs/fn|name overloads :quantum.core.specs/meta] :as args'} + (let [{:keys [:quantum.core.specs/fn|name + :quantum.core.defnt/overloads + :quantum.core.specs/meta] :as args'} (us/assert-conform (case kind (:defn :defn-) :quantum.core.defnt/defns|code :fn :quantum.core.defnt/fns|code) args) ret-sym (gensym "ret") arity-kind-sym (gensym "arity-kind") args-sym (gensym "args") diff --git a/src-untyped/quantum/untyped/core/specs.cljc b/src-untyped/quantum/untyped/core/specs.cljc index e2b74b7b..9709f168 100644 --- a/src-untyped/quantum/untyped/core/specs.cljc +++ b/src-untyped/quantum/untyped/core/specs.cljc @@ -85,6 +85,9 @@ ;; defn, defn-, fn +(s/def :quantum.core.specs/pre-meta (s/? :quantum.core.specs/meta)) +(s/def :quantum.core.specs/post-meta (s/? :quantum.core.specs/meta)) + (s/def :quantum.core.specs/fn|arglist (s/and vector? @@ -106,14 +109,15 @@ :body :quantum.core.specs/fn|body)) (s/def :quantum.core.specs/fn|name simple-symbol?) +(s/def ::fn|name :quantum.core.specs/fn|name) (s/def :quantum.core.specs/docstring string?) (s/def :quantum.core.specs/fn|unique-doc #(->> [(:quantum.core.specs/docstring %) (-> % :quantum.core.specs/fn|name meta :doc) - (-> % :pre-meta :doc) - (-> % :post-meta :doc)] + (-> % :quantum.core.specs/pre-meta :doc) + (-> % :quantum.core.specs/post-meta :doc)] (filter val?) count ((fn [x] (<= x 1))))) @@ -121,23 +125,26 @@ (s/def :quantum.core.specs/fn|unique-meta #(empty? (set/intersection (-> % :quantum.core.specs/fn|name meta keys set) - (-> % :pre-meta keys set) - (-> % :post-meta keys set)))) + (-> % :quantum.core.specs/pre-meta keys set) + (-> % :quantum.core.specs/post-meta keys set)))) (s/def :quantum.core.specs/fn|aggregate-meta (s/conformer - (fn [{:keys [:quantum.core.specs/fn|name :quantum.core.specs/docstring pre-meta post-meta] :as m}] + (fn [{:keys [:quantum.core.specs/fn|name :quantum.core.specs/docstring + :quantum.core.specs/pre-meta :quantum.core.specs/post-meta] :as m}] (-> m - (dissoc :quantum.core.specs/docstring :pre-meta :post-meta) + (dissoc :quantum.core.specs/docstring + :quantum.core.specs/pre-meta + :quantum.core.specs/post-meta) (cond-> fn|name (update :quantum.core.specs/fn|name with-meta (-> (merge (meta fn|name) pre-meta post-meta) ; TODO use `merge-unique` instead of `:quantum.core.specs/defn|unique-meta` (cond-> docstring (assoc :doc docstring))))))))) -(s/def :quantum.core.specs/fn|postchecks +(defn fn-like|postchecks|gen [overloads-ident] (s/and (s/conformer (fn [v] - (let [[overloads-k overloads-v] (get v :overloads) + (let [[overloads-k overloads-v] (get v overloads-ident) overloads (-> (case overloads-k :overload-1 {:overloads [overloads-v]} @@ -149,29 +156,40 @@ (case k :body {:body v} :prepost+body v))))))] - (assoc v :post-meta (:post-meta overloads) - :overloads (:overloads overloads))))) + (assoc v :quantum.core.specs/post-meta (:quantum.core.specs/post-meta overloads) + overloads-ident (get overloads :overloads))))) :quantum.core.specs/fn|unique-doc :quantum.core.specs/fn|unique-meta ;; TODO validate metadata like return value etc. :quantum.core.specs/fn|aggregate-meta)) +(s/def :quantum.core.specs/fn|postchecks (fn-like|postchecks|gen :quantum.core.specs/fn|overloads)) + (s/def :quantum.core.specs/fn - (s/and (s/spec - (s/cat :quantum.core.specs/fn|name (s/? :quantum.core.specs/fn|name) - :overloads (s/alt :overload-1 :quantum.core.specs/fn|arglist+body - :overload-n (s/cat :overloads (s/+ (s/spec :quantum.core.specs/fn|arglist+body)))))) - :quantum.core.specs/fn|postchecks)) + (s/and + (s/spec + (s/cat + :quantum.core.specs/fn|name (s/? :quantum.core.specs/fn|name) + :quantum.core.specs/fn|overloads + (s/alt + :overload-1 :quantum.core.specs/fn|arglist+body + :overload-n (s/cat :overloads (s/+ (s/spec :quantum.core.specs/fn|arglist+body)))))) + :quantum.core.specs/fn|postchecks)) (s/def :quantum.core.specs/defn (s/and (s/spec - (s/cat :quantum.core.specs/fn|name :quantum.core.specs/fn|name - :quantum.core.specs/docstring (s/? :quantum.core.specs/docstring) - :pre-meta (s/? :quantum.core.specs/meta) - :overloads (s/alt :overload-1 :quantum.core.specs/fn|arglist+body - :overload-n (s/cat :overloads (s/+ (s/spec :quantum.core.specs/fn|arglist+body)) - :post-meta (s/? :quantum.core.specs/meta))))) + (s/cat + :quantum.core.specs/fn|name :quantum.core.specs/fn|name + :quantum.core.specs/docstring (s/? :quantum.core.specs/docstring) + :quantum.core.specs/pre-meta :quantum.core.specs/pre-meta + :quantum.core.specs/fn|overloads + (s/alt + :overload-1 :quantum.core.specs/fn|arglist+body + :overload-n + (s/cat + :overloads (s/+ (s/spec :quantum.core.specs/fn|arglist+body)) + :quantum.core.specs/post-meta :quantum.core.specs/post-meta)))) :quantum.core.specs/fn|postchecks)) (s/fdef core/defn :args :quantum.core.specs/defn :ret any?) From 07e13e80b99c3a8bf0ff0a0aa84aa507b8c220b1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 17 Jul 2018 01:58:02 -0600 Subject: [PATCH 106/810] Add specs to as many fns as we can --- src-dev/quantum/core/defnt.cljc | 35 +++++++++++++++------ src-untyped/quantum/untyped/core/specs.cljc | 6 ++-- 2 files changed, 29 insertions(+), 12 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 3cf332e6..10b20497 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -78,6 +78,13 @@ #_(:clj (ns-unmap (find-ns 'quantum.core.defnt) 'reformat-string)) #_" + +LEFT OFF LAST TIME (7/17/2018): +- Add specs to as many fns as we can in order to get it back to working state and move forward more + quickly + + + - With `defnt`, protocols and interfaces aren't needed. You can just create `t/fn`s that you can then conform your fns to. - `dotyped`, `defnt`, and `fnt` create typed contexts in which their internal forms are analyzed @@ -729,10 +736,14 @@ #_(s/def :fnt|overload/body-codelist (t/seq-of :quantum.core.specs/code)) -;; Internal +;; Internal specs + +(s/def ::fnt|overload|arg-classes (s/vec-of t/class?)) +(s/def ::fnt|overload|arg-types t/any?) + (s/def ::fnt|overload - (s/kv {:arg-classes (s/vec-of t/class?) - :arg-types t/any? + (s/kv {:arg-classes ::fnt|overload|arg-classes + :arg-types ::fnt|overload|arg-types :arglist-code|fn|hinted t/any? :arglist-code|reify|unhinted t/any? :body-form t/any? @@ -749,6 +760,11 @@ :reify/arglist-code :reify|overload/body-form])) +(s/def ::reify + (s/kv {:form t/any? + :name simple-symbol? + :overloads (s/vec-of ::reify|overload)})) + (s/def ::lang #{:clj :cljs}) #_(:clj @@ -785,7 +801,7 @@ [float] [double]] which includes all primitive subclasses of the type." - [arg-types (s/seq-of t/type?) > (s/seq-of (s/vec-of t/class?))] + [arg-types (s/seq-of t/type?) > (s/seq-of ::fnt|overload|arg-classes)] (->> arg-types (c/lmap (fn [t #_t/type?] (if (-> t meta :ref?) @@ -808,8 +824,9 @@ "Is given `arg-classes` and `arg-types`. In order to determine the out-type, performs an analysis using (in part) these pieces of data, but does not use the possibly-updated `arg-types` as computed in the analysis. As a result, does not yet support type inference." - [{:keys [arg-bindings _, arg-classes _, arg-types _, args _, body-codelist|pre-analyze _, - lang ::lang, post-form _, varargs _, varargs-binding _]} _ + [{:keys [arg-bindings _, arg-classes ::fnt|overload|arg-classes + arg-types ::fnt|overload|arg-types, args _, body-codelist|pre-analyze _, lang ::lang + post-form _, varargs _, varargs-binding _]} _ > ::fnt|overload] (let [env (->> (zipmap arg-bindings arg-types) (c/map' (fn [[arg-binding arg-type]] @@ -887,7 +904,7 @@ pre-form [:pre _] [post-type _, post-form _] [:post _]} [:arglist _] body-codelist|pre-analyze [:body _]} _ - {:as opts :keys [lang ::lang, symbolic-analysis? t/boolean?]} _ + {:as opts :keys [::lang ::lang, symbolic-analysis? t/boolean?]} _ > t/any?] (if symbolic-analysis? (err! "Symbolic analysis not supported yet") @@ -986,7 +1003,7 @@ #?(:clj (defns fnt|overload-group>reify [{:keys [::uss/fn|name ::uss/fn|name, i t/index?, overload-group :fnt/overload-group]} _ - gen-gensym fn?] + gen-gensym fn? > ::reify] (let [reify-overloads (->> (concat [(:unprimitivized overload-group)] (:primitivized overload-group)) (c/map #(fnt|overload>reify-overload % gen-gensym))) @@ -1156,7 +1173,7 @@ (update-meta fn|name dissoc :inline)) fn|name) fnt|overload-groups - (->> overloads (mapv #(fnt|overload-data>overload-group % {:lang lang}))) + (->> overloads (mapv #(fnt|overload-data>overload-group % {::lang lang}))) ;; only one variadic arg allowed _ (s/validate fnt|overload-groups (fn->> (c/lmap :unprimitivized) (c/lfilter :variadic?) count (<- (<= 1)))) diff --git a/src-untyped/quantum/untyped/core/specs.cljc b/src-untyped/quantum/untyped/core/specs.cljc index 9709f168..ce4fb144 100644 --- a/src-untyped/quantum/untyped/core/specs.cljc +++ b/src-untyped/quantum/untyped/core/specs.cljc @@ -85,9 +85,6 @@ ;; defn, defn-, fn -(s/def :quantum.core.specs/pre-meta (s/? :quantum.core.specs/meta)) -(s/def :quantum.core.specs/post-meta (s/? :quantum.core.specs/meta)) - (s/def :quantum.core.specs/fn|arglist (s/and vector? @@ -113,6 +110,9 @@ (s/def :quantum.core.specs/docstring string?) +(s/def :quantum.core.specs/pre-meta (s/? :quantum.core.specs/meta)) +(s/def :quantum.core.specs/post-meta (s/? :quantum.core.specs/meta)) + (s/def :quantum.core.specs/fn|unique-doc #(->> [(:quantum.core.specs/docstring %) (-> % :quantum.core.specs/fn|name meta :doc) From 8e75b848842f90e760316ea8c74e311fb6183a30 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 17 Jul 2018 01:58:29 -0600 Subject: [PATCH 107/810] Add note --- src-dev/quantum/core/defnt.cljc | 1 + 1 file changed, 1 insertion(+) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 10b20497..d260dc31 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -82,6 +82,7 @@ LEFT OFF LAST TIME (7/17/2018): - Add specs to as many fns as we can in order to get it back to working state and move forward more quickly +- Then get dynamic dispatch working (see the TODOs around that) From 4547e5d309731f3968dacedf2882e4e3d41c2998 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 17 Jul 2018 23:24:05 -0600 Subject: [PATCH 108/810] Fixed it a little bit --- src-dev/quantum/core/defnt.cljc | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index d260dc31..358b8863 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -768,6 +768,13 @@ LEFT OFF LAST TIME (7/17/2018): (s/def ::lang #{:clj :cljs}) +(s/def ::input-types-decl (s/kv {:form t/any? :name simple-symbol?})) + +(s/def ::direct-dispatch + (s/kv {:form t/any? + :reify-groups (s/kv {:fnt|reify ::reify + :input-types-decl ::input-types-decl})})) + #_(:clj (defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] (cond (not= k :spec) java.lang.Object; default class @@ -1028,7 +1035,8 @@ LEFT OFF LAST TIME (7/17/2018): #?(:clj (defns fnt|overload-group>input-types-decl - [{:keys [::uss/fn|name ::uss/fn|name, i t/index?, overload-group :fnt/overload-group]} _] + [{:keys [::uss/fn|name ::uss/fn|name, i t/index?, overload-group :fnt/overload-group]} _ + > ::input-types-decl] (when (c/contains? (:arg-types|form overload-group)) (let [decl-name (ufth/with-type-hint (>input-types-decl|name fn|name i) "[Ljava.lang.Object;")] {:form `(def ~decl-name (arr/*<> ~(get-in overload-group [:arg-types|form i]))) @@ -1106,7 +1114,7 @@ LEFT OFF LAST TIME (7/17/2018): ;; TODO spec (defns >direct-dispatch [{:keys [::uss/fn|name ::uss/fn|name - fnt|overload-groups _, gen-gensym fn?, lang ::lang]} _] + fnt|overload-groups _, gen-gensym fn?, lang ::lang]} _ > ::direct-dispatch] (case lang :clj (let [reify-groups (->> fnt|overload-groups @@ -1118,8 +1126,8 @@ LEFT OFF LAST TIME (7/17/2018): form (->> reify-groups (map (fn [{:keys [fnt|reify input-types-decl]}] (cond-> [] - input-types-decl (:form input-types-decl) - true (:form fnt|reify)))) + input-types-decl (conj (:form input-types-decl)) + true (conj (:form fnt|reify))))) lcat)] {:form form :reify-groups reify-groups}) :cljs (TODO))) @@ -1194,7 +1202,7 @@ LEFT OFF LAST TIME (7/17/2018): args (assoc (kw-map fnt|overload-groups gen-gensym lang) ::uss/fn|name fn|name) {:as direct-dispatch :keys [reify-groups]} (>direct-dispatch args) - _ (prl! direct-dispatch) + _ (prl! direct-dispatch) fn-codelist (case lang :clj (->> `[~@(:form direct-dispatch) From 624ed1b8038852f7be64a2e75dd911441d60e084 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 17 Jul 2018 23:59:20 -0600 Subject: [PATCH 109/810] Add more specs; more on dynamic dispatch --- src-dev/quantum/core/defnt.cljc | 102 ++++++++++--------- src-dev/quantum/core/defnt_equivalences.cljc | 2 +- 2 files changed, 57 insertions(+), 47 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 358b8863..2d5c8cb2 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -79,10 +79,8 @@ #_" -LEFT OFF LAST TIME (7/17/2018): -- Add specs to as many fns as we can in order to get it back to working state and move forward more - quickly -- Then get dynamic dispatch working (see the TODOs around that) +LEFT OFF LAST TIME (7/18/2018): +- >dynamic-dispatch-fn|form @@ -770,10 +768,18 @@ LEFT OFF LAST TIME (7/17/2018): (s/def ::input-types-decl (s/kv {:form t/any? :name simple-symbol?})) +(s/def ::direct-dispatch|reify-groups + (s/kv {:fnt|reify ::reify + :input-types-decl ::input-types-decl})) + (s/def ::direct-dispatch - (s/kv {:form t/any? - :reify-groups (s/kv {:fnt|reify ::reify - :input-types-decl ::input-types-decl})})) + (s/kv {:form t/any? + ::direct-dispatch|reify-groups ::direct-dispatch|reify-groups})) + +(s/def ::fnt|overload-group + (s/kv {:arg-types|form (s/vec-of t/any?) + :unprimitivized (s/seq-of ::fnt|overload) + :primitivized (s/seq-of ::fnt|overload)})) #_(:clj (defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] @@ -886,11 +892,6 @@ LEFT OFF LAST TIME (7/17/2018): :out-class (out-type>class out-type) :variadic? (boolean varargs)}))) -#_(s/def ::fnt|overload-group - (s/kv {:arg-types|form ... - :unprimitivized ... - :primitivized ...})) - ;; TODO spec #?(:clj ; really, reserve for metalanguage (defns fnt|overload-data>overload-group @@ -913,7 +914,7 @@ LEFT OFF LAST TIME (7/17/2018): [post-type _, post-form _] [:post _]} [:arglist _] body-codelist|pre-analyze [:body _]} _ {:as opts :keys [::lang ::lang, symbolic-analysis? t/boolean?]} _ - > t/any?] + > ::fnt|overload-group] (if symbolic-analysis? (err! "Symbolic analysis not supported yet") (let [_ (when pre-form (TODO "Need to handle pre")) @@ -1010,7 +1011,7 @@ LEFT OFF LAST TIME (7/17/2018): #?(:clj (defns fnt|overload-group>reify - [{:keys [::uss/fn|name ::uss/fn|name, i t/index?, overload-group :fnt/overload-group]} _ + [{:keys [::uss/fn|name ::uss/fn|name, i t/index?, overload-group ::fnt|overload-group]} _ gen-gensym fn? > ::reify] (let [reify-overloads (->> (concat [(:unprimitivized overload-group)] (:primitivized overload-group)) @@ -1035,7 +1036,7 @@ LEFT OFF LAST TIME (7/17/2018): #?(:clj (defns fnt|overload-group>input-types-decl - [{:keys [::uss/fn|name ::uss/fn|name, i t/index?, overload-group :fnt/overload-group]} _ + [{:keys [::uss/fn|name ::uss/fn|name, i t/index?, overload-group ::fnt|overload-group]} _ > ::input-types-decl] (when (c/contains? (:arg-types|form overload-group)) (let [decl-name (ufth/with-type-hint (>input-types-decl|name fn|name i) "[Ljava.lang.Object;")] @@ -1100,7 +1101,7 @@ LEFT OFF LAST TIME (7/17/2018): Example output: (swap! ... assoc `abcde (fn [args] (case (count args) 1 )))" - [{:keys [::uss/fn|name ::uss/fn|name, arg-ct->type _, variadic-overload _]} _] + [{:keys [::uss/fn|name ::uss/fn|name, arg-ct->type _, variadic-overload ::fnt|overload-group]} _] (unify-gensyms `(swap! *fn->type assoc '~(qualify fn|name) (xp/>expr @@ -1113,8 +1114,9 @@ LEFT OFF LAST TIME (7/17/2018): ;; TODO spec (defns >direct-dispatch - [{:keys [::uss/fn|name ::uss/fn|name - fnt|overload-groups _, gen-gensym fn?, lang ::lang]} _ > ::direct-dispatch] + [{:keys [::uss/fn|name ::uss/fn|name, ::fnt|overload-groups (s/vec-of ::fnt|overload-group) + gen-gensym fn?, lang ::lang]} _ + > ::direct-dispatch] (case lang :clj (let [reify-groups (->> fnt|overload-groups @@ -1129,7 +1131,7 @@ LEFT OFF LAST TIME (7/17/2018): input-types-decl (conj (:form input-types-decl)) true (conj (:form fnt|reify))))) lcat)] - {:form form :reify-groups reify-groups}) + {:form form ::direct-dispatch|reify-groups reify-groups}) :cljs (TODO))) ;; TODO spec @@ -1137,33 +1139,39 @@ LEFT OFF LAST TIME (7/17/2018): ;; TODO check whether it even needs to get created based on arglist length etc. ;; TODO `get-relevant-reify-overload` (defns >dynamic-dispatch-fn|form - [{:keys [::uss/fn|name ::uss/fn|name, fnt|overload-groups _ - gen-gensym fn?, lang ::lang, reify-groups _]} _] + [{:keys [::uss/fn|name ::uss/fn|name + ::fnt|overload-groups (s/vec-of ::fnt|overload-group) + gen-gensym fn? + lang ::lang + ::direct-dispatch|reify-groups ::direct-dispatch|reify-groups]} _] (let [fnt|overload-group (first fnt|overload-groups) - arglist (ufgen/gen-args 0 (count fnt|overload-group) "x" gen-gensym) + arglist (ufgen/gen-args + 0 (-> fnt|overload-group :arg-types|form count) "x" gen-gensym) i|arg 0 arg-sym (get arglist i|arg)] `(defn ~fn|name - {::t/type (t/fn ~@(->> fnt|overload-groups (map :arg-types|form)))} - ~arglist - (ifs ~@(->> reify-groups - (map-indexed - (fn [i|reify {:keys [fnt|reify input-types-decl]}] - (prl! input-types-decl) - ;; TODO this part is very rough so far - (let [relevant-reify-overload - ;; TODO this is not general enough - (get-in fnt|reify [:overloads 0]) - hinted-reify-sym - (ufth/with-type-hint (:name fnt|reify) - (-> relevant-reify-overload :interface >name >symbol)) - dotted-reify-method-sym - (symbol (str "." (:method-sym relevant-reify-overload)))] - [`((quantum.core.Array/get ~(:name input-types-decl) ~i|arg) - ~arg-sym) - `(~dotted-reify-method-sym ~hinted-reify-sym ~arg-sym)]))) - lcat) - (unsupported! (quote ~(qualify fn|name)) [~@arglist] ~i|arg))))) + {::t/type (t/fn ~@(->> fnt|overload-groups + (map (fn [x] (cond-> (:arg-types|form x) + false #_out-spec? identity #_(conj :> out-spec))))))} + (~arglist + (ifs ~@(->> direct-dispatch|reify-groups + (map-indexed + (fn [i|reify {:keys [fnt|reify input-types-decl]}] + (prl! input-types-decl) + ;; TODO this part is very rough so far + (let [relevant-reify-overload + ;; TODO this is not general enough + (get-in fnt|reify [:overloads 0]) + hinted-reify-sym + (ufth/with-type-hint (:name fnt|reify) + (-> relevant-reify-overload :interface >name >symbol)) + dotted-reify-method-sym + (symbol (str "." (:method-sym relevant-reify-overload)))] + [`((quantum.core.Array/get ~(:name input-types-decl) ~i|arg) + ~arg-sym) + `(~dotted-reify-method-sym ~hinted-reify-sym ~arg-sym)]))) + lcat) + (unsupported! (quote ~(qualify fn|name)) [~@arglist] ~i|arg)))))) (defns fnt|code [kind #{:fn :defn}, lang ::lang, args _] (prl! kind lang args) @@ -1199,14 +1207,16 @@ LEFT OFF LAST TIME (7/17/2018): register-type (gen-register-type (assoc (kw-map arg-ct->type variadic-overload) ::uss/fn|name fn|name)) - args (assoc (kw-map fnt|overload-groups gen-gensym lang) - ::uss/fn|name fn|name) - {:as direct-dispatch :keys [reify-groups]} (>direct-dispatch args) + args (assoc (kw-map gen-gensym lang) + ::fnt|overload-groups fnt|overload-groups ::uss/fn|name fn|name) + {:as direct-dispatch :keys [::direct-dispatch|reify-groups]} (>direct-dispatch args) _ (prl! direct-dispatch) fn-codelist (case lang :clj (->> `[~@(:form direct-dispatch) - ~(>dynamic-dispatch-fn|form (merge args (kw-map reify-groups)))] + ~(>dynamic-dispatch-fn|form + (assoc args + ::direct-dispatch|reify-groups direct-dispatch|reify-groups))] (remove nil?)) :cljs (TODO)) overloads|code (->> fnt|overload-groups (c/map+ :unprimitivized) (c/map :code)) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index a3c9652f..c7c3e7a8 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -57,7 +57,7 @@ (.getName))))) (defn ~'pid - {::t/type (t/fn [:> (? t/string?)])} + {::t/type (t/fn [#_:> #_(? t/string?)])} ([] (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" 'pid|__0)))))) ) From 53dc9b78f21187b36bc510c493d0a2e6e49e1a6b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 22 Jul 2018 21:23:43 -0600 Subject: [PATCH 110/810] Cleaner `seq=` --- src-untyped/quantum/untyped/core/core.cljc | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src-untyped/quantum/untyped/core/core.cljc b/src-untyped/quantum/untyped/core/core.cljc index 648211cb..67f84729 100644 --- a/src-untyped/quantum/untyped/core/core.cljc +++ b/src-untyped/quantum/untyped/core/core.cljc @@ -48,14 +48,13 @@ (defn seq= ([a b] (seq= a b =)) ([a b eq-f] - (boolean - (when (or (sequential? b) #?(:clj (instance? java.util.List b) - :cljs (list? b))) + (boolean (loop [a (seq a) b (seq b)] - (when (identical? (nil? a) (nil? b)) - (or (nil? a) - (when (eq-f (first a) (first b)) - (recur (next a) (next b)))))))))) + (let [a-nil? (nil? a)] + (and (identical? a-nil? (nil? b)) + (or a-nil? + (and (eq-f (first a) (first b)) + (recur (next a) (next b)))))))))) (defn code= "Ensures that two pieces of code are equivalent. From 4e2c162358185af64857fa0eb8a7cb1bc5468bb6 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 22 Jul 2018 21:23:52 -0600 Subject: [PATCH 111/810] Clearer `test/code=` --- src-untyped/quantum/untyped/core/test.cljc | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src-untyped/quantum/untyped/core/test.cljc b/src-untyped/quantum/untyped/core/test.cljc index eebbabf5..80876821 100644 --- a/src-untyped/quantum/untyped/core/test.cljc +++ b/src-untyped/quantum/untyped/core/test.cljc @@ -30,7 +30,7 @@ (let [meta0 (-> code0 meta (dissoc :line :column)) meta1 (-> code1 meta (dissoc :line :column))] (or (= meta0 meta1) - (println "FAIL: meta should be match for" meta0 meta1))) + (println "FAIL: meta should be match for" (pr-str meta0) (pr-str meta1)))) (let [similar-class? (cond (seq? code0) (seq? code1) (seq? code1) (seq? code0) @@ -41,14 +41,15 @@ :else ::not-applicable)] (if (= similar-class? ::not-applicable) (or (= code0 code1) - (println "FAIL: should be `(= code0 code1)`" code0 code1)) + (println "FAIL: should be `(= code0 code1)`" (pr-str code0) (pr-str code1))) (and (or similar-class? - (println "FAIL: should be similar class" code0 code1)) + (println "FAIL: should be similar class" (pr-str code0) (pr-str code1))) (or (ucore/seq= (seq code0) (seq code1) code=) - (println "FAIL: `(ucore/seq= code0 code1 code=)`" code0 code1)))))) + (println "FAIL: `(ucore/seq= code0 code1 code=)`" + (pr-str code0) (pr-str code1))))))) (and (not (ucore/metable? code1)) (or (= code0 code1) - (println "FAIL: should be `(= code0 code1)`" code0 code1))))) + (println "FAIL: should be `(= code0 code1)`" (pr-str code0) (pr-str code1)))))) ([code0 code1 & codes] (and (code= code0 code1) (every? #(code= code0 %) codes)))) (defn is-code= [& args] (is (apply code= args))) From ced1ed4849f903fca49ff93d5b4a6b2763b4fd75 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 22 Jul 2018 21:23:59 -0600 Subject: [PATCH 112/810] `t/fn` stub --- src-untyped/quantum/untyped/core/type.cljc | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index fe0233ea..d1d11999 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -14,7 +14,8 @@ seq? seqable? sequential? set? sorted? vector? fn? ifn? meta - ref volatile?]) + ref volatile? + fn]) (:require [clojure.core :as c] [clojure.string :as str] @@ -557,6 +558,10 @@ x (err! "Type-validation failed" {:type t :to-validate x}))) +;; ===== `t/fn` ===== ;; + +(defn fn [& args] (println "TODO `t/fnn`") nil) + ;; ---------------------- ;; ;; ===== Predicates ===== ;; ;; ---------------------- ;; From 5c7dde03c2a3891e88fd1c58463f84c4e36efb81 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 22 Jul 2018 21:24:14 -0600 Subject: [PATCH 113/810] First full test with dynamic dispatch works!! --- src-dev/quantum/core/defnt.cljc | 85 +++++++++++--------- src-dev/quantum/core/defnt_equivalences.cljc | 15 ++-- 2 files changed, 55 insertions(+), 45 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 2d5c8cb2..eceb9a82 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -778,7 +778,9 @@ LEFT OFF LAST TIME (7/18/2018): (s/def ::fnt|overload-group (s/kv {:arg-types|form (s/vec-of t/any?) - :unprimitivized (s/seq-of ::fnt|overload) + :pre-type|form (s/vec-of t/any?) + :post-type|form (s/vec-of t/any?) + :unprimitivized ::fnt|overload :primitivized (s/seq-of ::fnt|overload)})) #_(:clj @@ -786,9 +788,9 @@ LEFT OFF LAST TIME (7/18/2018): (cond (not= k :spec) java.lang.Object; default class (symbol? spec) (pred->class lang spec)))) -;; TODO optimize such that `post-form` doesn't create a new type-validator wholesale every time the -;; function gets run; e.g. extern it -(defn >with-post-form [body post-form] `(t/validate ~body ~post-form)) +;; TODO optimize such that `post-type|form` doesn't create a new type-validator wholesale every +;; time the function gets run; e.g. extern it +(defn >with-post-type|form [body post-type|form] `(t/validate ~body ~post-type|form)) #?(:clj (var/def sort-guide "for use in arity sorting, in increasing conceptual size" @@ -840,7 +842,7 @@ LEFT OFF LAST TIME (7/18/2018): computed in the analysis. As a result, does not yet support type inference." [{:keys [arg-bindings _, arg-classes ::fnt|overload|arg-classes arg-types ::fnt|overload|arg-types, args _, body-codelist|pre-analyze _, lang ::lang - post-form _, varargs _, varargs-binding _]} _ + post-type|form _, pre-type|form _, varargs _, varargs-binding _]} _ > ::fnt|overload] (let [env (->> (zipmap arg-bindings arg-types) (c/map' (fn [[arg-binding arg-type]] @@ -854,13 +856,8 @@ LEFT OFF LAST TIME (7/18/2018): lang (c/count args) varargs))) - post-form|embeddable (if (or (nil? post-form) (= post-form '_)) - `t/any? - post-form) - post-type (cond (nil? post-form) nil - (= post-form '_) t/any? - ;; TODO this becomes an issue when `post-form` references local bindings - :else (eval post-form)) + ;; TODO this becomes an issue when `post-type|form` references local bindings + post-type (eval post-type|form) post-type|runtime? (-> post-type meta :runtime?) out-type (if post-type (if post-type|runtime? @@ -877,7 +874,7 @@ LEFT OFF LAST TIME (7/18/2018): (:type analyzed)) body-form (-> (:form analyzed) - (cond-> post-type|runtime? (>with-post-form post-form|embeddable)) + (cond-> post-type|runtime? (>with-post-type|form post-type|form)) (ufth/cast-bindings|code (->> (c/zipmap-into (map/om) arg-bindings arg-classes) (c/remove-vals' (fn-or nil? (fn= java.lang.Object) t/primitive-class?)))))] @@ -888,7 +885,7 @@ LEFT OFF LAST TIME (7/18/2018): :arglist-code|reify|unhinted (cond-> arg-bindings varargs-binding (conj varargs-binding)) :body-form body-form :positional-args-ct (count args) - :out-types out-type + :out-type out-type :out-class (out-type>class out-type) :variadic? (boolean varargs)}))) @@ -910,14 +907,15 @@ LEFT OFF LAST TIME (7/18/2018): is the same as the object language (e.g. Clojure), and symbolically analyze types in the rest (e.g. vanilla ClojureScript), deferring code analyzed as functions to be enforced at runtime." [{:as in {:keys [args _, varargs _] - pre-form [:pre _] - [post-type _, post-form _] [:post _]} [:arglist _] + pre-type|form [:pre _] + [_ _, post-type|form _] [:post _]} [:arglist _] body-codelist|pre-analyze [:body _]} _ {:as opts :keys [::lang ::lang, symbolic-analysis? t/boolean?]} _ > ::fnt|overload-group] (if symbolic-analysis? (err! "Symbolic analysis not supported yet") - (let [_ (when pre-form (TODO "Need to handle pre")) + (let [_ (when pre-type|form (TODO "Need to handle pre")) + post-type|form (if (= post-type|form '_) `t/any? post-type|form) varargs-binding (when varargs ;; TODO this assertion is purely temporary until destructuring is ;; supported @@ -948,9 +946,11 @@ LEFT OFF LAST TIME (7/18/2018): arg-types|unprimitivized arg-classes)] (>fnt|overload (kw-map arg-bindings arg-classes arg-types args - body-codelist|pre-analyze lang post-form varargs - varargs-binding))))))] + body-codelist|pre-analyze lang post-type|form pre-type|form + varargs varargs-binding))))))] {:arg-types|form arg-types|form + :pre-type|form pre-type|form + :post-type|form post-type|form :unprimitivized unprimitivized :primitivized primitivized})))) @@ -1148,30 +1148,35 @@ LEFT OFF LAST TIME (7/18/2018): arglist (ufgen/gen-args 0 (-> fnt|overload-group :arg-types|form count) "x" gen-gensym) i|arg 0 - arg-sym (get arglist i|arg)] + arg-sym (get arglist i|arg) + >reify-call (fn [{:keys [fnt|reify input-types-decl]}] + (let [;; TODO this is not general enough + relevant-reify-overload (get-in fnt|reify [:overloads 0]) + dotted-reify-method-sym + (symbol (str "." (:method-sym relevant-reify-overload))) + hinted-reify-sym + (ufth/with-type-hint (:name fnt|reify) + (-> relevant-reify-overload :interface >name))] + `(~dotted-reify-method-sym ~hinted-reify-sym ~@arglist)))] `(defn ~fn|name {::t/type (t/fn ~@(->> fnt|overload-groups - (map (fn [x] (cond-> (:arg-types|form x) - false #_out-spec? identity #_(conj :> out-spec))))))} + (map (fn [{:keys [arg-types|form pre-type|form post-type|form]}] + (cond-> (or arg-types|form []) + pre-type|form (conj :| pre-type|form) + post-type|form (conj :> post-type|form))))))} (~arglist - (ifs ~@(->> direct-dispatch|reify-groups - (map-indexed - (fn [i|reify {:keys [fnt|reify input-types-decl]}] - (prl! input-types-decl) - ;; TODO this part is very rough so far - (let [relevant-reify-overload - ;; TODO this is not general enough - (get-in fnt|reify [:overloads 0]) - hinted-reify-sym - (ufth/with-type-hint (:name fnt|reify) - (-> relevant-reify-overload :interface >name >symbol)) - dotted-reify-method-sym - (symbol (str "." (:method-sym relevant-reify-overload)))] - [`((quantum.core.Array/get ~(:name input-types-decl) ~i|arg) - ~arg-sym) - `(~dotted-reify-method-sym ~hinted-reify-sym ~arg-sym)]))) - lcat) - (unsupported! (quote ~(qualify fn|name)) [~@arglist] ~i|arg)))))) + ~(if (empty? arglist) + (-> direct-dispatch|reify-groups first >reify-call) + `(ifs + ~@(->> direct-dispatch|reify-groups + (map-indexed + (fn [i|reify {:as direct-dispatch|reify-group :keys [input-types-decl]}] + (prl! input-types-decl) + ;; TODO this part is very rough so far + [`((quantum.core.Array/get ~(:name input-types-decl) ~i|arg) ~arg-sym) + (>reify-call direct-dispatch|reify-group)])) + lcat) + (unsupported! (quote ~(qualify fn|name)) [~@arglist] ~i|arg))))))) (defns fnt|code [kind #{:fn :defn}, lang ::lang, args _] (prl! kind lang args) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index c7c3e7a8..274dfc9d 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -44,9 +44,10 @@ ;; ----- implementation ----- ;; (macroexpand ' - (defnt pid [> (? t/string?)] - (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) - (.getName)))) +(defnt pid [> (? t/string?)] + (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) + (.getName))) +) ;; ----- expanded code ----- ;; @@ -57,11 +58,15 @@ (.getName))))) (defn ~'pid - {::t/type (t/fn [#_:> #_(? t/string?)])} - ([] (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" 'pid|__0)))))) + {::t/type (t/fn [:> ~'(? t/string?)])} + ([] (.invoke ~(tag "quantum.core.test.defnt_equivalences.>Object" 'pid|__0)))))) ) +(testing "`pid`" + (is (string? (pid))) + (throws (pid 1))) + ;; =====|=====|=====|=====|===== ;; (is-code= From f2a0309b8be3b3d5d05e9ec9b3613a11e9ad3c29 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 22 Jul 2018 23:20:18 -0600 Subject: [PATCH 114/810] Fix `ufgen/>reproducible-gensym|generator`; reduce logging --- src-dev/quantum/core/defnt.cljc | 13 +- src-dev/quantum/core/defnt_equivalences.cljc | 275 ++++++++---------- src-untyped/quantum/untyped/core/error.cljc | 16 +- src-untyped/quantum/untyped/core/form.cljc | 7 +- .../quantum/untyped/core/form/generate.cljc | 18 +- 5 files changed, 147 insertions(+), 182 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index eceb9a82..3f52d73e 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -974,7 +974,7 @@ LEFT OFF LAST TIME (7/18/2018): hinted-method-sym (ufth/with-type-hint fnt-method-sym (ufth/>interface-method-tag out-class)) hinted-args (ufth/hint-arglist-with - (ufgen/gen-args 0 (count args-classes) "x" gen-gensym) + (ufgen/gen-args 0 (count args-classes) "xint" gen-gensym) (map ufth/>interface-method-tag args-classes))] `(~'definterface ~interface-sym (~hinted-method-sym ~hinted-args)))) @@ -994,12 +994,11 @@ LEFT OFF LAST TIME (7/18/2018): (c/get interface-k)) arglist-code (>vec (concat [(gen-gensym '_)] - (doto (->> arglist-code|reify|unhinted - (map-indexed - (fn [i arg] - (ufth/with-type-hint arg (-> arg-classes (doto pr/ppr-meta) - (c/get i) (doto pr/ppr-meta) ufth/>arglist-embeddable-tag))))) - pr/ppr-meta)))] + (->> arglist-code|reify|unhinted + (map-indexed + (fn [i arg] + (ufth/with-type-hint arg + (-> arg-classes (c/get i) ufth/>arglist-embeddable-tag)))))))] {:arglist-code arglist-code :body-form body-form :interface interface diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 274dfc9d..140aa1e8 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -23,7 +23,7 @@ :refer [ifs]] [quantum.untyped.core.spec :as s] [quantum.untyped.core.test :as test - :refer [deftest testing is is= is-code= throws]] + :refer [deftest is is= is-code= testing throws]] [quantum.untyped.core.type :as t :refer [? *]] [quantum.untyped.core.type.reifications :as utr]) @@ -37,153 +37,132 @@ quantum.core.data.Array [quantum.core Numeric Primitive])) -;; =====|=====|=====|=====|===== ;; - -(is-code= - -;; ----- implementation ----- ;; - -(macroexpand ' -(defnt pid [> (? t/string?)] - (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) - (.getName))) -) - -;; ----- expanded code ----- ;; - -($ (do (def ~'pid|__0 - (reify >Object - (~(tag "java.lang.Object" 'invoke) [~'_0__] - ~'(->> (java.lang.management.ManagementFactory/getRuntimeMXBean) - (.getName))))) - - (defn ~'pid - {::t/type (t/fn [:> ~'(? t/string?)])} - ([] (.invoke ~(tag "quantum.core.test.defnt_equivalences.>Object" 'pid|__0)))))) - -) - -(testing "`pid`" - (is (string? (pid))) - (throws (pid 1))) - -;; =====|=====|=====|=====|===== ;; - -(is-code= - -;; ----- implementation ----- ;; - -(macroexpand ' -(defnt identity|uninlined ([x t/any?] x)) -) - -;; ----- expanded code ----- ;; - -(case (env-lang) - :clj ($ (do ;; [x t/any?] - - (def ~(tag "[Ljava.lang.Object;" 'identity|uninlined|__0|input-types) - (*<> ~'t/any?)) - ;; One `reify` because `t/any?` in CLJ does not have any `t/or`-separability - (def ~'identity|uninlined|__0 - (reify - Object>Object - (~(tag "java.lang.Object" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] ~'x) - boolean>boolean - (~(tag "boolean" 'invoke) [~'_1__ ~(tag "boolean" 'x)] ~'x) - byte>byte - (~(tag "byte" 'invoke) [~'_2__ ~(tag "byte" 'x)] ~'x) - short>short - (~(tag "short" 'invoke) [~'_3__ ~(tag "short" 'x)] ~'x) - char>char - (~(tag "char" 'invoke) [~'_4__ ~(tag "char" 'x)] ~'x) - int>int - (~(tag "int" 'invoke) [~'_5__ ~(tag "int" 'x)] ~'x) - long>long - (~(tag "long" 'invoke) [~'_6__ ~(tag "long" 'x)] ~'x) - float>float - (~(tag "float" 'invoke) [~'_7__ ~(tag "float" 'x)] ~'x) - double>double - (~(tag "double" 'invoke) [~'_8__ ~(tag "double" 'x)] ~'x))) - - (defn ~'identity|uninlined - {::t/type (t/fn [t/any?])} - ([~'x00__] - ;; Checks elided because `t/any?` doesn't require a check - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" - 'identity|uninlined|__0) ~'a00__))))) - :cljs ;; Direct dispatch will be simple functions, not `reify`s - ($ (do (defn ~'identity|uninlined [~'x] ~'x))))) - -) - -;; =====|=====|=====|=====|===== ;; - -;; TODO will deal with `inline` later -(defnt ^:inline identity ([x t/any?] x)) - -;; ----- test ----- ;; - -(deftest test|identity - (is= (identity 1 ) 1 ) - (is= (identity "") "")) - -;; =====|=====|=====|=====|===== ;; - -(is-code= - -;; TODO don't ignore `:inline` -(macroexpand ' -(defnt #_:inline name - ([x t/string? > t/string?] x) - #?(:clj ([x (t/isa? Named) > (* t/string?)] (.getName x)) - :cljs ([x (t/isa? INamed) > (* t/string?)] (-name x)))) -) - -;; ----- expanded code ----- ;; - -(case (env-lang) - :clj ($ (do ;; Only direct dispatch for primitives or for Object, not for subclasses of Object - ;; Return value can be primitive; in this case it's not - ;; The macro in a typed context will find the appropriate dispatch at compile time - - ;; [t/string?] - - (def ~(tag "[Ljava.lang.Object;" 'name|__0|input-types) - (*<> t/string?)) - (def ~'name|__0 - (reify Object>Object - (~(tag "java.lang.Object" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "java.lang.String" 'x) ~'x] ~'x)))) - - ;; [(t/isa? Named)] - - (def ~(tag "[Ljava.lang.Object;" 'name|__1|input-types) - (*<> (t/isa? Named))) - (def ~'name|__1 - (reify Object>Object - (~(tag "java.lang.Object" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "clojure.lang.Named" 'x) ~'x] - (t/validate ~'(.getName x) ~'(* t/string?)))))) - - (defn ~'name - {::t/type - (t/fn [t/string? :> t/string?] - [(t/isa? Named) :> (* t/string?)])} - ([~'x00__] - (ifs ((Array/get ~'name|__0|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" - 'name|__0) ~'x00__) - ((Array/get ~'name|__1|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" - 'name|__1) ~'x00__) - (unsupported! `name [~'x00__] 0)))))) - :cljs ($ (do (defn ~'name [~'x00__] - (ifs (t/string? x) x - (satisfies? INamed x) (-name x) - (unsupported! `name [~'x00__] 0)))))) - -) +#?(:clj +(deftest test|pid + (let [actual + (macroexpand ' + (defnt pid|test [> (? t/string?)] + (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) + (.getName)))) + expected + ($ (do (def ~'pid|test|__0 + (reify >Object + (~(tag "java.lang.Object" 'invoke) [~'_0__] + ~'(->> (java.lang.management.ManagementFactory/getRuntimeMXBean) + (.getName))))) + (defn ~'pid|test + {::t/type (t/fn [:> ~'(? t/string?)])} + ([] (.invoke ~(tag "quantum.core.test.defnt_equivalences.>Object" + 'pid|test|__0))))))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do (is (string? (pid|test))) + (throws (pid|test 1)))))))) + +;; TODO test `:inline` + +(deftest test|identity|uninlined + (let [actual + (macroexpand ' + (defnt identity|uninlined ([x t/any?] x))) + expected + (case (env-lang) + :clj + ($ (do ;; [x t/any?] + + (def ~(tag "[Ljava.lang.Object;" 'identity|uninlined|__0|input-types) + (*<> ~'t/any?)) + ;; One `reify` because `t/any?` in CLJ does not have any `t/or`-separability + (def ~'identity|uninlined|__0 + (reify + Object>Object (~(tag "java.lang.Object" 'invoke) + [~'_0__ ~(tag "java.lang.Object" 'x)] ~'x) + boolean>boolean (~(tag "boolean" 'invoke) + [~'_1__ ~(tag "boolean" 'x)] ~'x) + byte>byte (~(tag "byte" 'invoke) + [~'_2__ ~(tag "byte" 'x)] ~'x) + short>short (~(tag "short" 'invoke) + [~'_3__ ~(tag "short" 'x)] ~'x) + char>char (~(tag "char" 'invoke) + [~'_4__ ~(tag "char" 'x)] ~'x) + int>int (~(tag "int" 'invoke) + [~'_5__ ~(tag "int" 'x)] ~'x) + long>long (~(tag "long" 'invoke) + [~'_6__ ~(tag "long" 'x)] ~'x) + float>float (~(tag "float" 'invoke) + [~'_7__ ~(tag "float" 'x)] ~'x) + double>double (~(tag "double" 'invoke) + [~'_8__ ~(tag "double" 'x)] ~'x))) + + (defn ~'identity|uninlined + {::t/type (t/fn ~'[t/any?])} + ([~'x00__] + ;; Checks elided because `t/any?` doesn't require a check + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" + 'identity|uninlined|__0) ~'x00__))))) + :cljs + ;; Direct dispatch will be simple functions, not `reify`s + ($ (do (defn ~'identity|uninlined [~'x] ~'x))))] + (testing "code equivalence" (is-code= actual expected)) + #_(testing "functionality" + (eval actual) + (eval '(do (is= (identity|uninlined 1 ) 1 ) + (is= (identity|uninlined "") "")))))) + +(deftest test|name + (let [actual + (macroexpand ' + (defnt #_:inline name|test + ([x t/string? > t/string?] x) + #?(:clj ([x (t/isa? Named) > (* t/string?)] (.getName x)) + :cljs ([x (t/isa? INamed) > (* t/string?)] (-name x))))) + expected + (case (env-lang) + :clj + ($ (do ;; Only direct dispatch for primitives or for Object, not for subclasses of + ;; Object + ;; Return value can be primitive; in this case it's not + ;; The macro in a typed context will find the appropriate dispatch at compile + ;; time + + ;; [t/string?] + + (def ~(tag "[Ljava.lang.Object;" 'name|__0|input-types) + (*<> t/string?)) + (def ~'name|__0 + (reify Object>Object + (~(tag "java.lang.Object" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] + (let* [~(tag "java.lang.String" 'x) ~'x] ~'x)))) + + ;; [(t/isa? Named)] + + (def ~(tag "[Ljava.lang.Object;" 'name|__1|input-types) + (*<> (t/isa? Named))) + (def ~'name|__1 + (reify Object>Object + (~(tag "java.lang.Object" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] + (let* [~(tag "clojure.lang.Named" 'x) ~'x] + (t/validate ~'(.getName x) ~'(* t/string?)))))) + + (defn ~'name + {::t/type + (t/fn [t/string? :> t/string?] + [(t/isa? Named) :> (* t/string?)])} + ([~'x00__] + (ifs ((Array/get ~'name|__0|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" + 'name|__0) ~'x00__) + ((Array/get ~'name|__1|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" + 'name|__1) ~'x00__) + (unsupported! `name [~'x00__] 0)))))) + :cljs + ($ (do (defn ~'name [~'x00__] + (ifs (t/string? x) x + (satisfies? INamed x) (-name x) + (unsupported! `name [~'x00__] 0))))))] + (testing "code equivalence" (is-code= actual expected)))) ;; =====|=====|=====|=====|===== ;; diff --git a/src-untyped/quantum/untyped/core/error.cljc b/src-untyped/quantum/untyped/core/error.cljc index 8ce2cc2f..d3ec1fa2 100644 --- a/src-untyped/quantum/untyped/core/error.cljc +++ b/src-untyped/quantum/untyped/core/error.cljc @@ -37,21 +37,15 @@ (error? x) (fipp/pprint (>err x)) (and (string? x) (> (count x) *print-length*)) - (println - (str "String is too long to print (" - (str (count x) " elements") - ").") - "`*print-length*` is set at" (str *print-length* ".")) ; TODO fix so ellipsize + (println (str "String is too long to print (" (str (count x) " elements") ").") + ;; TODO fix so ellipsize + "`*print-length*` is set at" (str *print-length* ".")) (contains? @*print-blacklist (type x)) - (println - "Object's class" - (str (type x) "(" ")") - "is blacklisted for printing.") + (println "Object's class" (str "(" (type x) ")") "is blacklisted for printing.") :else (fipp/pprint x)) nil))) - ([x & xs] - (doseq [x' (cons x xs)] (ppr x')))) + ([x & xs] (doseq [x' (cons x xs)] (ppr x')))) (defn ppr-str "Like `pr-str`, but pretty-prints." diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index 90df0312..06486520 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -42,13 +42,10 @@ {:examples '{(let [a 1] (quote+ (for [b 2] (inc ~a)))) '(for [a 1] (inc 1))}} - [form] - `(unquote-replacement (locals) '~form))) + [form] `(unquote-replacement (locals) '~form))) #?(:clj (defmacro $ "Reproducibly, unifiedly syntax quote without messing up the format as a literal syntax quote might do." - [body] - `(binding [ufgen/*reproducible-gensym* (ufgen/>reproducible-gensym|generator true)] - (ufgen/unify-gensyms (syntax-quote ~body) true)))) + [body] `(ufgen/unify-gensyms (syntax-quote ~body) true))) diff --git a/src-untyped/quantum/untyped/core/form/generate.cljc b/src-untyped/quantum/untyped/core/form/generate.cljc index 998733f4..ba63429b 100644 --- a/src-untyped/quantum/untyped/core/form/generate.cljc +++ b/src-untyped/quantum/untyped/core/form/generate.cljc @@ -39,7 +39,8 @@ ([min-n max-n s gen-gensym] (->> (range min-n max-n) (mapv (fn [i] (gen-gensym (str s i))))))) -(defn arity-builder [positionalf variadicf & [min-positional-arity max-positional-arity sym-genf no-gensym?]] +(defn arity-builder + [positionalf variadicf & [min-positional-arity max-positional-arity sym-genf no-gensym?]] (let [mina (or min-positional-arity 0) maxa (or max-positional-arity 18) args (->> (range mina (+ mina maxa)) @@ -81,12 +82,10 @@ [s] (second (re-find gensym-regex (str s)))) -(def ^:dynamic *reproducible-gensym* nil) - -(defn >reproducible-gensym|generator [& memoize?] - (let [*counter (atom -1)] - (cond-> #(symbol (str % (swap! *counter inc))) - memoize? memoize))) +(defn >reproducible-gensym|generator [] + (let [inc-or-0 #(if (nil? %) 0 (inc %)) + str->counter (atom {})] + (fn [s] (symbol (str s (get (swap! str->counter update s inc-or-0) s)))))) (defn unify-gensyms "All gensyms defined using two hash symbols are unified to the same @@ -95,10 +94,7 @@ :contributors ["Alex Gunnarson"]} ([body] (unify-gensyms body false)) ([body reproducible-gensyms?] - (let [gensym* (or *reproducible-gensym* - (memoize (if reproducible-gensyms? - (>reproducible-gensym|generator true) - gensym)))] + (let [gensym* (if reproducible-gensyms? symbol (memoize gensym))] (ucore/postwalk #(if (unified-gensym? %) (symbol (str (gensym* (str (un-gensym %) "__")) From 4f028d2e0745a5794ac840bf26be79464e6929e5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 22 Jul 2018 23:31:47 -0600 Subject: [PATCH 115/810] Miracles do happen; second test passing --- src-dev/quantum/core/defnt.cljc | 22 +++++++++++--------- src-dev/quantum/core/defnt_equivalences.cljc | 1 + 2 files changed, 13 insertions(+), 10 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 3f52d73e..fed87f68 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -1148,15 +1148,15 @@ LEFT OFF LAST TIME (7/18/2018): 0 (-> fnt|overload-group :arg-types|form count) "x" gen-gensym) i|arg 0 arg-sym (get arglist i|arg) - >reify-call (fn [{:keys [fnt|reify input-types-decl]}] - (let [;; TODO this is not general enough - relevant-reify-overload (get-in fnt|reify [:overloads 0]) - dotted-reify-method-sym - (symbol (str "." (:method-sym relevant-reify-overload))) - hinted-reify-sym - (ufth/with-type-hint (:name fnt|reify) - (-> relevant-reify-overload :interface >name))] - `(~dotted-reify-method-sym ~hinted-reify-sym ~@arglist)))] + >reify-call + (fn [{:keys [fnt|reify input-types-decl]}] + (let [;; TODO this is not general enough + relevant-reify-overload (get-in fnt|reify [:overloads 0]) + dotted-reify-method-sym (symbol (str "." (:method-sym relevant-reify-overload))) + hinted-reify-sym + (ufth/with-type-hint (:name fnt|reify) + (-> relevant-reify-overload :interface >name))] + `(~dotted-reify-method-sym ~hinted-reify-sym ~@arglist)))] `(defn ~fn|name {::t/type (t/fn ~@(->> fnt|overload-groups (map (fn [{:keys [arg-types|form pre-type|form post-type|form]}] @@ -1164,7 +1164,9 @@ LEFT OFF LAST TIME (7/18/2018): pre-type|form (conj :| pre-type|form) post-type|form (conj :> post-type|form))))))} (~arglist - ~(if (empty? arglist) + ~(if ;; TODO incrementally check this + (or (empty? arglist) + (->> fnt|overload-group :unprimitivized :arg-types (every? #(t/= % t/any?)))) (-> direct-dispatch|reify-groups first >reify-call) `(ifs ~@(->> direct-dispatch|reify-groups diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 140aa1e8..96eb083d 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -99,6 +99,7 @@ {::t/type (t/fn ~'[t/any?])} ([~'x00__] ;; Checks elided because `t/any?` doesn't require a check + ;; and all args are `t/=` `t/any?` (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" 'identity|uninlined|__0) ~'x00__))))) :cljs From cfd391a077894585236703ee0bdb97b92f5f8a6d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 22 Jul 2018 23:51:38 -0600 Subject: [PATCH 116/810] Another test passes :D --- src-dev/quantum/core/defnt.cljc | 7 +- src-dev/quantum/core/defnt_equivalences.cljc | 102 ++++++++++--------- src-untyped/quantum/untyped/core/test.cljc | 3 +- 3 files changed, 62 insertions(+), 50 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index fed87f68..425ec6ce 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -1038,8 +1038,9 @@ LEFT OFF LAST TIME (7/18/2018): [{:keys [::uss/fn|name ::uss/fn|name, i t/index?, overload-group ::fnt|overload-group]} _ > ::input-types-decl] (when (c/contains? (:arg-types|form overload-group)) - (let [decl-name (ufth/with-type-hint (>input-types-decl|name fn|name i) "[Ljava.lang.Object;")] - {:form `(def ~decl-name (arr/*<> ~(get-in overload-group [:arg-types|form i]))) + (let [decl-name (>input-types-decl|name fn|name i)] + {:form `(def ~(ufth/with-type-hint decl-name "[Ljava.lang.Object;") + (arr/*<> ~@(:arg-types|form overload-group))) :name decl-name})))) (def allowed-shorthand-tag-chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") @@ -1174,7 +1175,7 @@ LEFT OFF LAST TIME (7/18/2018): (fn [i|reify {:as direct-dispatch|reify-group :keys [input-types-decl]}] (prl! input-types-decl) ;; TODO this part is very rough so far - [`((quantum.core.Array/get ~(:name input-types-decl) ~i|arg) ~arg-sym) + [`((quantum.core.data.Array/get ~(:name input-types-decl) ~i|arg) ~arg-sym) (>reify-call direct-dispatch|reify-group)])) lcat) (unsupported! (quote ~(qualify fn|name)) [~@arglist] ~i|arg))))))) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 96eb083d..d059c511 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -106,7 +106,7 @@ ;; Direct dispatch will be simple functions, not `reify`s ($ (do (defn ~'identity|uninlined [~'x] ~'x))))] (testing "code equivalence" (is-code= actual expected)) - #_(testing "functionality" + (testing "functionality" (eval actual) (eval '(do (is= (identity|uninlined 1 ) 1 ) (is= (identity|uninlined "") "")))))) @@ -119,51 +119,61 @@ #?(:clj ([x (t/isa? Named) > (* t/string?)] (.getName x)) :cljs ([x (t/isa? INamed) > (* t/string?)] (-name x))))) expected - (case (env-lang) - :clj - ($ (do ;; Only direct dispatch for primitives or for Object, not for subclasses of - ;; Object - ;; Return value can be primitive; in this case it's not - ;; The macro in a typed context will find the appropriate dispatch at compile - ;; time - - ;; [t/string?] - - (def ~(tag "[Ljava.lang.Object;" 'name|__0|input-types) - (*<> t/string?)) - (def ~'name|__0 - (reify Object>Object - (~(tag "java.lang.Object" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "java.lang.String" 'x) ~'x] ~'x)))) - - ;; [(t/isa? Named)] - - (def ~(tag "[Ljava.lang.Object;" 'name|__1|input-types) - (*<> (t/isa? Named))) - (def ~'name|__1 - (reify Object>Object - (~(tag "java.lang.Object" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "clojure.lang.Named" 'x) ~'x] - (t/validate ~'(.getName x) ~'(* t/string?)))))) - - (defn ~'name - {::t/type - (t/fn [t/string? :> t/string?] - [(t/isa? Named) :> (* t/string?)])} - ([~'x00__] - (ifs ((Array/get ~'name|__0|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" - 'name|__0) ~'x00__) - ((Array/get ~'name|__1|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" - 'name|__1) ~'x00__) - (unsupported! `name [~'x00__] 0)))))) - :cljs - ($ (do (defn ~'name [~'x00__] - (ifs (t/string? x) x - (satisfies? INamed x) (-name x) - (unsupported! `name [~'x00__] 0))))))] - (testing "code equivalence" (is-code= actual expected)))) + (case (env-lang) + :clj + ($ (do ;; Only direct dispatch for primitives or for Object, not for subclasses of + ;; Object + ;; Return value can be primitive; in this case it's not + ;; The macro in a typed context will find the appropriate dispatch at compile + ;; time + + ;; [t/string?] + + (def ~(tag "[Ljava.lang.Object;" 'name|test|__0|input-types) + (*<> ~'t/string?)) + (def ~'name|test|__0 + (reify Object>Object + (~(tag "java.lang.Object" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] + (let* [~(tag "java.lang.String" 'x) ~'x] ~'x)))) + + ;; [(t/isa? Named)] + + (def ~(tag "[Ljava.lang.Object;" 'name|test|__1|input-types) + (*<> ~'(t/isa? Named))) + (def ~'name|test|__1 + (reify Object>Object + (~(tag "java.lang.Object" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] + (let* [~(tag "clojure.lang.Named" 'x) ~'x] + (t/validate ~'(.getName x) ~'(* t/string?)))))) + + (defn ~'name|test + {::t/type + (t/fn ~'[t/string? :> t/string?] + ~'[(t/isa? Named) :> (* t/string?)])} + ([~'x00__] + (ifs ((Array/get ~'name|test|__0|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" + 'name|test|__0) ~'x00__) + ((Array/get ~'name|test|__1|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" + 'name|test|__1) ~'x00__) + (unsupported! `name|test [~'x00__] 0)))))) + :cljs + ($ (do (defn ~'name|test [~'x00__] + (ifs (t/string? x) x + (satisfies? INamed x) (-name x) + (unsupported! `name|test [~'x00__] 0))))))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do (is= (name|test "") "") + (is= (name|test "abc") "abc") + (is= (name|test :abc) "abc") + (is= (name|test 'abc) "abc") + (is= (name|test :abc/def) "def") + (is= (name|test 'abc/def) "def") + (throws (name|test nil)) + (throws (name|test 1))))))) ;; =====|=====|=====|=====|===== ;; diff --git a/src-untyped/quantum/untyped/core/test.cljc b/src-untyped/quantum/untyped/core/test.cljc index 80876821..323ec1ed 100644 --- a/src-untyped/quantum/untyped/core/test.cljc +++ b/src-untyped/quantum/untyped/core/test.cljc @@ -30,7 +30,8 @@ (let [meta0 (-> code0 meta (dissoc :line :column)) meta1 (-> code1 meta (dissoc :line :column))] (or (= meta0 meta1) - (println "FAIL: meta should be match for" (pr-str meta0) (pr-str meta1)))) + (println "FAIL: meta should be match for" (pr-str meta0) (pr-str meta1) + "on code" (pr-str code0) (pr-str code1)))) (let [similar-class? (cond (seq? code0) (seq? code1) (seq? code1) (seq? code0) From 3a614d9713a2c9350af1403f441415685b7d56eb Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 22 Jul 2018 23:56:53 -0600 Subject: [PATCH 117/810] And another test passes! --- src-dev/quantum/core/defnt_equivalences.cljc | 135 ++++++++++--------- 1 file changed, 68 insertions(+), 67 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index d059c511..a54ca5e9 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -121,11 +121,9 @@ expected (case (env-lang) :clj - ($ (do ;; Only direct dispatch for primitives or for Object, not for subclasses of - ;; Object + ($ (do ;; Only direct dispatch for prims or for Object, not for subclasses of Object ;; Return value can be primitive; in this case it's not - ;; The macro in a typed context will find the appropriate dispatch at compile - ;; time + ;; The macro in a typed context will find the right dispatch at compile time ;; [t/string?] @@ -175,72 +173,75 @@ (throws (name|test nil)) (throws (name|test 1))))))) -;; =====|=====|=====|=====|===== ;; - -(is-code= - -;; Perhaps silly in ClojureScript, but avoids boxing in Clojure -(macroexpand ' -(defnt #_:inline some? - ([x t/nil?] false) - ;; Implicitly, `(- t/any? t/nil?)`, so `t/val?` - ([x t/any?] true)) -) - -;; ----- expanded code ----- ;; - -(case (env-lang) - :clj ($ (do ;; [x t/nil?] - - (def ~(tag "[Ljava.lang.Object;" 'some?|__0|input-types) - (*<> t/nil?)) - (def ~'some?|__0 - (reify - Object>boolean - (~(tag "boolean" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] false))) - - ;; [x t/any?] +(deftest test|some? + (let [actual + ;; Perhaps silly in ClojureScript, but avoids boxing in Clojure + (macroexpand ' + (defnt #_:inline some?|test + ([x t/nil?] false) + ;; Implicitly, `(- t/any? t/nil?)`, so `t/val?` + ([x t/any?] true))) + expected + (case (env-lang) + :clj + ($ (do ;; [x t/nil?] - (def ~(tag "[Ljava.lang.Object;" 'some?|__1|input-types) - (*<> t/any?)) - (def ~'some?|__1 - (reify - Object>boolean - (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] true) - boolean>boolean - (~(tag "boolean" 'invoke) [~'_2__ ~(tag "boolean" 'x)] true) - byte>boolean - (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'x)] true) - short>boolean - (~(tag "boolean" 'invoke) [~'_4__ ~(tag "short" 'x)] true) - char>boolean - (~(tag "boolean" 'invoke) [~'_5__ ~(tag "char" 'x)] true) - int>boolean - (~(tag "boolean" 'invoke) [~'_6__ ~(tag "int" 'x)] true) - long>boolean - (~(tag "boolean" 'invoke) [~'_7__ ~(tag "long" 'x)] true) - float>boolean - (~(tag "boolean" 'invoke) [~'_8__ ~(tag "float" 'x)] true) - double>boolean - (~(tag "boolean" 'invoke) [~'_9__ ~(tag "double" 'x)] true))) + (def ~(tag "[Ljava.lang.Object;" 'some?|test|__0|input-types) + (*<> ~'t/nil?)) + (def ~'some?|test|__0 + (reify + Object>boolean + (~(tag "boolean" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] false))) - (defn ~'some? - {::t/type (t/fn [t/nil?] - [t/any?])} - ([~'x00__] - (ifs ((Array/get ~'some?|__0|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" - 'some?|__0) ~'x00__) - ;; TODO eliminate this check because it's not needed (`t/any?`) - ((Array/get ~'some?|__1|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" - 'some?|__1) ~'x00__) - (unsupported! `some? [~'x00__] 0)))))) - :cljs ($ (do (defn ~'some? [~'x] - (ifs (nil? x) false - true))))) + ;; [x t/any?] -) + (def ~(tag "[Ljava.lang.Object;" 'some?|test|__1|input-types) + (*<> ~'t/any?)) + (def ~'some?|test|__1 + (reify + Object>boolean + (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] true) + boolean>boolean + (~(tag "boolean" 'invoke) [~'_2__ ~(tag "boolean" 'x)] true) + byte>boolean + (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'x)] true) + short>boolean + (~(tag "boolean" 'invoke) [~'_4__ ~(tag "short" 'x)] true) + char>boolean + (~(tag "boolean" 'invoke) [~'_5__ ~(tag "char" 'x)] true) + int>boolean + (~(tag "boolean" 'invoke) [~'_6__ ~(tag "int" 'x)] true) + long>boolean + (~(tag "boolean" 'invoke) [~'_7__ ~(tag "long" 'x)] true) + float>boolean + (~(tag "boolean" 'invoke) [~'_8__ ~(tag "float" 'x)] true) + double>boolean + (~(tag "boolean" 'invoke) [~'_9__ ~(tag "double" 'x)] true))) + + (defn ~'some?|test + {::t/type (t/fn ~'[t/nil?] + ~'[t/any?])} + ([~'x00__] + (ifs ((Array/get ~'some?|test|__0|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" + 'some?|test|__0) ~'x00__) + ;; TODO eliminate this check because it's not needed (`t/any?`) + ((Array/get ~'some?|test|__1|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" + 'some?|test|__1) ~'x00__) + (unsupported! `some?|test [~'x00__] 0)))))) + :cljs + ($ (do (defn ~'some?|test [~'x] + (ifs (nil? x) false + true)))))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do (throws (some?)) + (is= (some? 123) true) + (is= (some? true) true) + (is= (some? false) true) + (is= (some? nil) false)))))) ;; =====|=====|=====|=====|===== ;; From 7d413fdc6af1908c3b864c54c598139192f415d2 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 23 Jul 2018 00:01:17 -0600 Subject: [PATCH 118/810] Another passes! So quickly! --- src-dev/quantum/core/defnt_equivalences.cljc | 142 ++++++++++--------- 1 file changed, 74 insertions(+), 68 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index a54ca5e9..e2540ce2 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -237,79 +237,85 @@ (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) - (eval '(do (throws (some?)) - (is= (some? 123) true) - (is= (some? true) true) - (is= (some? false) true) - (is= (some? nil) false)))))) + (eval '(do (throws (some?|test)) + (is= (some?|test 123) true) + (is= (some?|test true) true) + (is= (some?|test false) true) + (is= (some?|test nil) false)))))) -;; =====|=====|=====|=====|===== ;; - -(is-code= - -;; Perhaps silly in ClojureScript, but avoids boxing in Clojure -(macroexpand ' -(defnt #_:inline reduced? - ([x (t/isa? Reduced)] true) - ;; Implicitly, `(- t/any? (t/isa? Reduced))` - ([x t/any? ] false)) -) - -;; ----- expanded code ----- ;; - -(case (env-lang) - :clj ($ (do ;; [x (t/isa? Reduced)] - - (def ~(tag "[Ljava.lang.Object;" 'reduced?|__0|input-types) - (*<> (t/isa? Reduced))) - (def ~'reduced?|__0 - (reify - Object>boolean (~(tag "boolean" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "clojure.lang.Reduced" 'x) ~'x] true)))) - - ;; [x t/any?] +(deftest test|reduced? + (let [actual + ;; Perhaps silly in ClojureScript, but avoids boxing in Clojure + (macroexpand ' + (defnt #_:inline reduced?|test + ([x (t/isa? Reduced)] true) + ;; Implicitly, `(- t/any? (t/isa? Reduced))` + ([x t/any? ] false))) + expected + (case (env-lang) + :clj + ($ (do ;; [x (t/isa? Reduced)] - (def ~(tag "[Ljava.lang.Object;" 'reduced?|__1|input-types) - (*<> t/any?)) - (def ~'reduced?|__1 - (reify - Object>boolean - (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false) - boolean>boolean - (~(tag "boolean" 'invoke) [~'_2__ ~(tag "boolean" 'x)] false) - byte>boolean - (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'x)] false) - short>boolean - (~(tag "boolean" 'invoke) [~'_4__ ~(tag "short" 'x)] false) - char>boolean - (~(tag "boolean" 'invoke) [~'_5__ ~(tag "char" 'x)] false) - int>boolean - (~(tag "boolean" 'invoke) [~'_6__ ~(tag "int" 'x)] false) - long>boolean - (~(tag "boolean" 'invoke) [~'_7__ ~(tag "long" 'x)] false) - float>boolean - (~(tag "boolean" 'invoke) [~'_8__ ~(tag "float" 'x)] false) - double>boolean - (~(tag "boolean" 'invoke) [~'_9__ ~(tag "double" 'x)] false))) + (def ~(tag "[Ljava.lang.Object;" 'reduced?|test|__0|input-types) + (*<> ~'(t/isa? Reduced))) + (def ~'reduced?|test|__0 + (reify + Object>boolean + (~(tag "boolean" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] + (let* [~(tag "clojure.lang.Reduced" 'x) ~'x] true)))) - (defn ~'reduced? - {::t/type (t/fn [(t/isa? Reduced)] - [t/any?])} - ([~'x00__] - (ifs ((Array/get ~'reduced?|__0|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" - 'reduced?|__0) ~'x00__) - ;; TODO eliminate this check because it's not needed (`t/any?`) - ((Array/get ~'reduced?|__1|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" - 'reduced?|__1) ~'x00__) - (unsupported! `reduced? [~'x00__] 0)))))) - :cljs ($ (do (defn ~'reduced? [~'x] - (ifs (instance? Reduced x) true false))))) + ;; [x t/any?] -) + (def ~(tag "[Ljava.lang.Object;" 'reduced?|test|__1|input-types) + (*<> ~'t/any?)) + (def ~'reduced?|test|__1 + (reify + Object>boolean + (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false) + boolean>boolean + (~(tag "boolean" 'invoke) [~'_2__ ~(tag "boolean" 'x)] false) + byte>boolean + (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'x)] false) + short>boolean + (~(tag "boolean" 'invoke) [~'_4__ ~(tag "short" 'x)] false) + char>boolean + (~(tag "boolean" 'invoke) [~'_5__ ~(tag "char" 'x)] false) + int>boolean + (~(tag "boolean" 'invoke) [~'_6__ ~(tag "int" 'x)] false) + long>boolean + (~(tag "boolean" 'invoke) [~'_7__ ~(tag "long" 'x)] false) + float>boolean + (~(tag "boolean" 'invoke) [~'_8__ ~(tag "float" 'x)] false) + double>boolean + (~(tag "boolean" 'invoke) [~'_9__ ~(tag "double" 'x)] false))) -;; =====|=====|=====|=====|===== ;; + (defn ~'reduced?|test + {::t/type (t/fn ~'[(t/isa? Reduced)] + ~'[t/any?])} + ([~'x00__] + (ifs ((Array/get ~'reduced?|test|__0|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" + 'reduced?|test|__0) ~'x00__) + ;; TODO eliminate this check because it's not needed (`t/any?`) + ((Array/get ~'reduced?|test|__1|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" + 'reduced?|test|__1) ~'x00__) + (unsupported! `reduced?|test [~'x00__] 0)))))) + :cljs + ($ (do (defn ~'reduced?|test [~'x] + (ifs (instance? Reduced x) true false)))))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do (throws (reduced?|test)) + (is= (reduced?|test 123) false) + (is= (reduced?|test true) false) + (is= (reduced?|test false) false) + (is= (reduced?|test nil) false) + (is= (reduced?|test (reduced 123)) true) + (is= (reduced?|test (reduced true)) true) + (is= (reduced?|test (reduced false)) true) + (is= (reduced?|test (reduced nil)) true))))))) (is-code= From a986240666202dcb501bbc7e1bc5c7b8ed13d2e3 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 23 Jul 2018 00:04:53 -0600 Subject: [PATCH 119/810] Another test passes! --- src-dev/quantum/core/defnt_equivalences.cljc | 147 ++++++++++--------- 1 file changed, 76 insertions(+), 71 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index e2540ce2..b8760a56 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -317,83 +317,88 @@ (is= (reduced?|test (reduced false)) true) (is= (reduced?|test (reduced nil)) true))))))) -(is-code= - -(macroexpand ' -(defnt #_:inline >boolean - ([x t/boolean?] x) - ([x t/nil?] false) - ([x t/any?] true)) -) - -;; ----- expanded code ----- ;; - -(case (env-lang) - :clj ($ (do ;; [x t/boolean?] +(deftest test|>boolean + (let [actual + (macroexpand ' + (defnt #_:inline >boolean + ([x t/boolean?] x) + ([x t/nil?] false) + ([x t/any?] true))) + expected + (case (env-lang) + :clj + ($ (do ;; [x t/boolean?] - (def ~(tag "[Ljava.lang.Object;" '>boolean|__0|input-types) - (*<> t/boolean?)) - (def ~'>boolean|__0 - (reify - boolean>boolean - (~(tag "boolean" 'invoke) [~'_0__ ~(tag "boolean" 'x)] ~'x))) + (def ~(tag "[Ljava.lang.Object;" '>boolean|__0|input-types) + (*<> ~'t/boolean?)) + (def ~'>boolean|__0 + (reify + boolean>boolean + (~(tag "boolean" 'invoke) [~'_0__ ~(tag "boolean" 'x)] ~'x))) - ;; [x t/nil? -> (- t/nil? t/boolean?)] + ;; [x t/nil? -> (- t/nil? t/boolean?)] - (def ~(tag "[Ljava.lang.Object;" '>boolean|__1|input-types) - (*<> t/nil?)) - (def ~'>boolean|__1 - (reify - Object>boolean - (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false))) + (def ~(tag "[Ljava.lang.Object;" '>boolean|__1|input-types) + (*<> ~'t/nil?)) + (def ~'>boolean|__1 + (reify + Object>boolean + (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false))) - ;; [x t/any? -> (- t/any? t/nil? t/boolean?)] + ;; [x t/any? -> (- t/any? t/nil? t/boolean?)] - (def ~(tag "[Ljava.lang.Object;" '>boolean|__1|input-types) - (*<> t/any?)) - (def ~'>boolean|__2 - (reify - Object>boolean - (~(tag "boolean" 'invoke) [~'_2__ ~(tag "java.lang.Object" 'x)] true) - boolean>boolean - (~(tag "boolean" 'invoke) [~'_3__ ~(tag "boolean" 'x)] true) - byte>boolean - (~(tag "boolean" 'invoke) [~'_4__ ~(tag "byte" 'x)] true) - short>boolean - (~(tag "boolean" 'invoke) [~'_5__ ~(tag "short" 'x)] true) - char>boolean - (~(tag "boolean" 'invoke) [~'_6__ ~(tag "char" 'x)] true) - int>boolean - (~(tag "boolean" 'invoke) [~'_7__ ~(tag "int" 'x)] true) - long>boolean - (~(tag "boolean" 'invoke) [~'_8__ ~(tag "long" 'x)] true) - float>boolean - (~(tag "boolean" 'invoke) [~'_9__ ~(tag "float" 'x)] true) - double>boolean - (~(tag "boolean" 'invoke) [~'_10__ ~(tag "double" 'x)] true))) - - (defn ~'>boolean - {::t/type (t/fn [t/boolean?] - [t/nil?] - [t/any?])} - ([~'x00__] - (ifs ((Array/get ~'>boolean|__0|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.boolean>boolean" - '>boolean|__0) ~'x00__) - ((Array/get ~'>boolean|__1|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" - '>boolean|__1) ~'x00__) - ;; TODO eliminate this check because it's not needed (`t/any?`) - ((Array/get ~'>boolean|__2|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" - '>boolean|__2) ~'x00__) - (unsupported! `>boolean [~'x00__] 0)))))) - :cljs ($ (do (defn ~'>boolean [~'x] - (ifs (boolean? x) x - (nil? x) false - true))))) + (def ~(tag "[Ljava.lang.Object;" '>boolean|__2|input-types) + (*<> ~'t/any?)) + (def ~'>boolean|__2 + (reify + Object>boolean + (~(tag "boolean" 'invoke) [~'_2__ ~(tag "java.lang.Object" 'x)] true) + boolean>boolean + (~(tag "boolean" 'invoke) [~'_3__ ~(tag "boolean" 'x)] true) + byte>boolean + (~(tag "boolean" 'invoke) [~'_4__ ~(tag "byte" 'x)] true) + short>boolean + (~(tag "boolean" 'invoke) [~'_5__ ~(tag "short" 'x)] true) + char>boolean + (~(tag "boolean" 'invoke) [~'_6__ ~(tag "char" 'x)] true) + int>boolean + (~(tag "boolean" 'invoke) [~'_7__ ~(tag "int" 'x)] true) + long>boolean + (~(tag "boolean" 'invoke) [~'_8__ ~(tag "long" 'x)] true) + float>boolean + (~(tag "boolean" 'invoke) [~'_9__ ~(tag "float" 'x)] true) + double>boolean + (~(tag "boolean" 'invoke) [~'_10__ ~(tag "double" 'x)] true))) -) + (defn ~'>boolean + {::t/type (t/fn ~'[t/boolean?] + ~'[t/nil?] + ~'[t/any?])} + ([~'x00__] + (ifs ((Array/get ~'>boolean|__0|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.boolean>boolean" + '>boolean|__0) ~'x00__) + ((Array/get ~'>boolean|__1|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" + '>boolean|__1) ~'x00__) + ;; TODO eliminate this check because it's not needed (`t/any?`) + ((Array/get ~'>boolean|__2|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" + '>boolean|__2) ~'x00__) + (unsupported! `>boolean [~'x00__] 0)))))) + :cljs + ($ (do (defn ~'>boolean [~'x] + (ifs (boolean? x) x + (nil? x) false + true)))))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do (throws (>boolean)) + (is= (>boolean true) true) + (is= (>boolean false) false) + (is= (>boolean nil) false) + (is= (>boolean 123) true)))))) ;; =====|=====|=====|=====|===== ;; From 6b39be8253d75901ae1ca60087f47db4febdc21a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 23 Jul 2018 09:33:20 -0600 Subject: [PATCH 120/810] Got closer but did not yet make this test work --- src-dev/quantum/core/defnt.cljc | 14 +- src-dev/quantum/core/defnt_equivalences.cljc | 497 ++++++++++--------- 2 files changed, 268 insertions(+), 243 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 425ec6ce..dc0c8493 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -79,8 +79,11 @@ #_" -LEFT OFF LAST TIME (7/18/2018): -- >dynamic-dispatch-fn|form +LEFT OFF LAST TIME (7/23/2018): +- In defnt_equivalences: + ;; TODO the dispatch here should realize that `>int*|__0` has multiple + ;; non-primitivized overloads and must dispatch not merely on the whole typedef + ;; but rather on each 'branch' of `(t/- t/primitive? t/boolean?)` @@ -1044,10 +1047,13 @@ LEFT OFF LAST TIME (7/18/2018): :name decl-name})))) (def allowed-shorthand-tag-chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") +(def min-shorthand-tag-length 1) +(def max-shorthand-tag-length 64) ; for now (defn >all-shorthand-tags [] - (->> (for [n (c/unchunk (range 1 (inc 64)))] ; just up to length 64 for now - (apply combo/cartesian-product (repeat n allowed-shorthand-tag-chars))) + (->> (range min-shorthand-tag-length (inc max-shorthand-tag-length)) + c/unchunk + (c/lmap (fn [n] (apply combo/cartesian-product (repeat n allowed-shorthand-tag-chars)))) lcat (c/lmap #(apply str %)) c/unchunk)) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index b8760a56..fcf99cec 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -400,248 +400,267 @@ (is= (>boolean nil) false) (is= (>boolean 123) true)))))) -;; =====|=====|=====|=====|===== ;; - -(is-code= - -;; auto-upcasts to long or double (because 64-bit) unless you tell it otherwise -;; will error if not all return values can be safely converted to the return spec -(macroexpand ' -(defnt #_:inline >int* > t/int? - ([x (t/- t/primitive? t/boolean?)] (Primitive/uncheckedIntCast x)) - ([x (t/ref (t/isa? Number))] (.intValue x))) -) - -;; ----- expanded code ----- ;; - -(case (env-lang) - :clj ($ (do #_(swap! fn->spec assoc #'>int* - (t/fn [(t/- t/primitive? t/boolean?)] - [(t/ref (t/isa? Number))])) - - ;; [x (t/- t/primitive? t/boolean?)] - - (def ~(tag "[Ljava.lang.Object;" '>int*|__0|input-types) - (*<> (t/- t/primitive? t/boolean?))) - (def ~'>int*|__0 - (reify - byte>int (~(tag "int" 'invoke) [~'_0__ ~(tag "byte" 'x)] - ~'(Primitive/uncheckedIntCast x)) - short>int (~(tag "int" 'invoke) [~'_1__ ~(tag "short" 'x)] - ~'(Primitive/uncheckedIntCast x)) - char>int (~(tag "int" 'invoke) [~'_2__ ~(tag "char" 'x)] - ~'(Primitive/uncheckedIntCast x)) - int>int (~(tag "int" 'invoke) [~'_3__ ~(tag "int" 'x)] - ~'(Primitive/uncheckedIntCast x)) - long>int (~(tag "int" 'invoke) [~'_4__ ~(tag "long" 'x)] - ~'(Primitive/uncheckedIntCast x)) - float>int (~(tag "int" 'invoke) [~'_5__ ~(tag "float" 'x)] - ~'(Primitive/uncheckedIntCast x)) - double>int (~(tag "int" 'invoke) [~'_6__ ~(tag "double" 'x)] - ~'(Primitive/uncheckedIntCast x)))) - - ;; [x (t/ref (t/isa? Number)) - ;; -> (t/- (t/ref (t/isa? Number)) (t/- t/primitive? t/boolean?))] - - (def ~'>int*|__1 - (reify - Object>int (~(tag "int" 'invoke) [~'_7__ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(.intValue x)))))))) - -) - -;; =====|=====|=====|=====|===== ;; - -(is-code= - -(macroexpand ' -(defnt #_:inline > - ;; This is admittedly a place where inference might be nice, but luckily there are no - ;; "sparse" combinations - #?(:clj ([a t/comparable-primitive? b t/comparable-primitive? > t/boolean?] - (Numeric/gt a b)) - :cljs ([a t/double? b t/double? > (t/assume t/boolean?)] - (cljs.core/> a b)))) -) +(deftest test|>int* + (let [actual + (macroexpand ' + ;; Auto-upcasts to long or double (because 64-bit) unless you tell it otherwise + ;; Will error if not all return values can be safely converted to the return spec + (defnt #_:inline >int* > t/int? + ([x (t/- t/primitive? t/boolean?)] (Primitive/uncheckedIntCast x)) + ([x (t/ref (t/isa? Number))] (.intValue x)))) + expected + (case (env-lang) + :clj + ($ (do #_(swap! fn->spec assoc #'>int* + (t/fn [(t/- t/primitive? t/boolean?)] + [(t/ref (t/isa? Number))])) -;; ----- expanded code ----- ;; + ;; [x (t/- t/primitive? t/boolean?)] -(case (env-lang) - :clj ($ (do (def ~'>|__0 - (reify - byte+byte>boolean - (~(tag "boolean" 'invoke) [~'_0__ ~(tag "byte" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)) - byte+short>boolean - (~(tag "boolean" 'invoke) [~'_1__ ~(tag "byte" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)) - byte+char>boolean - (~(tag "boolean" 'invoke) [~'_2__ ~(tag "byte" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)) - byte+int>boolean - (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)) - byte+long>boolean - (~(tag "boolean" 'invoke) [~'_4__ ~(tag "byte" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)) - byte+float>boolean - (~(tag "boolean" 'invoke) [~'_5__ ~(tag "byte" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)) - byte+double>boolean - (~(tag "boolean" 'invoke) [~'_6__ ~(tag "byte" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)) - short+byte>boolean - (~(tag "boolean" 'invoke) [~'_7__ ~(tag "short" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)) - short+short>boolean - (~(tag "boolean" 'invoke) [~'_8__ ~(tag "short" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)) - short+char>boolean - (~(tag "boolean" 'invoke) [~'_9__ ~(tag "short" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)) - short+int>boolean - (~(tag "boolean" 'invoke) [~'_10__ ~(tag "short" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)) - short+long>boolean - (~(tag "boolean" 'invoke) [~'_11__ ~(tag "short" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)) - short+float>boolean - (~(tag "boolean" 'invoke) [~'_12__ ~(tag "short" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)) - short+double>boolean - (~(tag "boolean" 'invoke) [~'_13__ ~(tag "short" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)) - char+byte>boolean - (~(tag "boolean" 'invoke) [~'_14__ ~(tag "char" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)) - char+short>boolean - (~(tag "boolean" 'invoke) [~'_15__ ~(tag "char" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)) - char+char>boolean - (~(tag "boolean" 'invoke) [~'_16__ ~(tag "char" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)) - char+int>boolean - (~(tag "boolean" 'invoke) [~'_17__ ~(tag "char" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)) - char+long>boolean - (~(tag "boolean" 'invoke) [~'_18__ ~(tag "char" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)) - char+float>boolean - (~(tag "boolean" 'invoke) [~'_19__ ~(tag "char" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)) - char+double>boolean - (~(tag "boolean" 'invoke) [~'_20__ ~(tag "char" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)) - int+byte>boolean - (~(tag "boolean" 'invoke) [~'_21__ ~(tag "int" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)) - int+short>boolean - (~(tag "boolean" 'invoke) [~'_22__ ~(tag "int" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)) - int+char>boolean - (~(tag "boolean" 'invoke) [~'_23__ ~(tag "int" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)) - int+int>boolean - (~(tag "boolean" 'invoke) [~'_24__ ~(tag "int" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)) - int+long>boolean - (~(tag "boolean" 'invoke) [~'_25__ ~(tag "int" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)) - int+float>boolean - (~(tag "boolean" 'invoke) [~'_26__ ~(tag "int" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)) - int+double>boolean - (~(tag "boolean" 'invoke) [~'_27__ ~(tag "int" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)) - long+byte>boolean - (~(tag "boolean" 'invoke) [~'_28__ ~(tag "long" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)) - long+short>boolean - (~(tag "boolean" 'invoke) [~'_29__ ~(tag "long" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)) - long+char>boolean - (~(tag "boolean" 'invoke) [~'_30__ ~(tag "long" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)) - long+int>boolean - (~(tag "boolean" 'invoke) [~'_31__ ~(tag "long" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)) - long+long>boolean - (~(tag "boolean" 'invoke) [~'_32__ ~(tag "long" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)) - long+float>boolean - (~(tag "boolean" 'invoke) [~'_33__ ~(tag "long" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)) - long+double>boolean - (~(tag "boolean" 'invoke) [~'_34__ ~(tag "long" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)) - float+byte>boolean - (~(tag "boolean" 'invoke) [~'_35__ ~(tag "float" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)) - float+short>boolean - (~(tag "boolean" 'invoke) [~'_36__ ~(tag "float" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)) - float+char>boolean - (~(tag "boolean" 'invoke) [~'_37__ ~(tag "float" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)) - float+int>boolean - (~(tag "boolean" 'invoke) [~'_38__ ~(tag "float" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)) - float+long>boolean - (~(tag "boolean" 'invoke) [~'_39__ ~(tag "float" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)) - float+float>boolean - (~(tag "boolean" 'invoke) [~'_40__ ~(tag "float" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)) - float+double>boolean - (~(tag "boolean" 'invoke) [~'_41__ ~(tag "float" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)) - double+byte>boolean - (~(tag "boolean" 'invoke) [~'_42__ ~(tag "double" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)) - double+short>boolean - (~(tag "boolean" 'invoke) [~'_43__ ~(tag "double" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)) - double+char>boolean - (~(tag "boolean" 'invoke) [~'_44__ ~(tag "double" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)) - double+int>boolean - (~(tag "boolean" 'invoke) [~'_45__ ~(tag "double" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)) - double+long>boolean - (~(tag "boolean" 'invoke) [~'_46__ ~(tag "double" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)) - double+float>boolean - (~(tag "boolean" 'invoke) [~'_47__ ~(tag "double" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)) - double+double>boolean - (~(tag "boolean" 'invoke) [~'_48__ ~(tag "double" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)))) - - #_(defn > - {::t/type - (t/fn #?(:clj [t/comparable-primitive? t/comparable-primitive? - :> t/boolean?] - :cljs [t/double? t/double? - :> (t/assume t/boolean?)]))} - ([a0 a1] - (ifs (t/byte? a0) - (ifs (t/byte? a1) (.invoke ^byte+byte>boolean >|__0 a0 a1) - (t/char? a1) (.invoke ...) - ...) - (t/char? a0) - (ifs (t/byte? a1) (.invoke ^char+byte>boolean >|__0 a0 a1) - ...) - ... - (unsupported! `> [a0 a1] 0)))))) - :cljs `(do (defn > - ([a0 a1] - (ifs (double? a0) - (ifs (double? a1) - (let* [a a0 b a1] (cljs.core/> a b)) - (unsupported! `> [a0 a1] 1)) - (unsupported! `> [a0 a1] 0))))))) + (def ~(tag "[Ljava.lang.Object;" '>int*|__0|input-types) + (*<> ~'(t/- t/primitive? t/boolean?))) + (def ~'>int*|__0 + (reify + byte>int (~(tag "int" 'invoke) [~'_0__ ~(tag "byte" 'x)] + ~'(Primitive/uncheckedIntCast x)) + short>int (~(tag "int" 'invoke) [~'_1__ ~(tag "short" 'x)] + ~'(Primitive/uncheckedIntCast x)) + char>int (~(tag "int" 'invoke) [~'_2__ ~(tag "char" 'x)] + ~'(Primitive/uncheckedIntCast x)) + int>int (~(tag "int" 'invoke) [~'_3__ ~(tag "int" 'x)] + ~'(Primitive/uncheckedIntCast x)) + long>int (~(tag "int" 'invoke) [~'_4__ ~(tag "long" 'x)] + ~'(Primitive/uncheckedIntCast x)) + float>int (~(tag "int" 'invoke) [~'_5__ ~(tag "float" 'x)] + ~'(Primitive/uncheckedIntCast x)) + double>int (~(tag "int" 'invoke) [~'_6__ ~(tag "double" 'x)] + ~'(Primitive/uncheckedIntCast x)))) + + ;; [x (t/ref (t/isa? Number)) + ;; -> (t/- (t/ref (t/isa? Number)) (t/- t/primitive? t/boolean?))] + + (def ~(tag "[Ljava.lang.Object;" '>int*|__1|input-types) + (*<> ~'(t/ref (t/isa? Number)))) + (def ~'>int*|__1 + (reify + Object>int (~(tag "int" 'invoke) [~'_7__ ~(tag "java.lang.Object" 'x)] + (let* [~(tag "java.lang.Number" 'x) ~'x] + ~'(.intValue x))))) + + ;; TODO the dispatch here should realize that `>int*|__0` has multiple + ;; non-primitivized overloads and must dispatch not merely on the whole typedef + ;; but rather on each 'branch' of `(t/- t/primitive? t/boolean?)` + (defn ~'>int* + {::t/type (t/fn ~'[(t/- t/primitive? t/boolean?)] + ~'[(t/ref (t/isa? Number))])} + ([~'x00__] + (ifs ((Array/get ~'>int*|__0|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.boolean>boolean" + '>int*|__0) ~'x00__) + ((Array/get ~'>int*|__1|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" + '>int*|__1) ~'x00__) + (unsupported! `>boolean [~'x00__] 0)))))))]] + (testing "code equivalence" (is-code= actual expected)) + #_(testing "functionality" + (eval actual) + (eval '(do ...))))) -;; =====|=====|=====|=====|===== ;; +(deftest test|> + (let [actual + (macroexpand ' + (defnt #_:inline >|test + ;; This is admittedly a place where inference might be nice, but luckily + ;; there are no "sparse" combinations + #?(:clj ([a t/comparable-primitive? b t/comparable-primitive? > t/boolean?] + (Numeric/gt a b)) + :cljs ([a t/double? b t/double? > (t/assume t/boolean?)] + (cljs.core/> a b))))) + expected + (case (env-lang) + :clj + ($ (do (def ~'>|test|__0 + (reify + byte+byte>boolean + (~(tag "boolean" 'invoke) [~'_0__ ~(tag "byte" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)) + byte+short>boolean + (~(tag "boolean" 'invoke) [~'_1__ ~(tag "byte" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)) + byte+char>boolean + (~(tag "boolean" 'invoke) [~'_2__ ~(tag "byte" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)) + byte+int>boolean + (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)) + byte+long>boolean + (~(tag "boolean" 'invoke) [~'_4__ ~(tag "byte" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)) + byte+float>boolean + (~(tag "boolean" 'invoke) [~'_5__ ~(tag "byte" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)) + byte+double>boolean + (~(tag "boolean" 'invoke) [~'_6__ ~(tag "byte" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)) + short+byte>boolean + (~(tag "boolean" 'invoke) [~'_7__ ~(tag "short" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)) + short+short>boolean + (~(tag "boolean" 'invoke) [~'_8__ ~(tag "short" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)) + short+char>boolean + (~(tag "boolean" 'invoke) [~'_9__ ~(tag "short" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)) + short+int>boolean + (~(tag "boolean" 'invoke) [~'_10__ ~(tag "short" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)) + short+long>boolean + (~(tag "boolean" 'invoke) [~'_11__ ~(tag "short" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)) + short+float>boolean + (~(tag "boolean" 'invoke) [~'_12__ ~(tag "short" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)) + short+double>boolean + (~(tag "boolean" 'invoke) [~'_13__ ~(tag "short" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)) + char+byte>boolean + (~(tag "boolean" 'invoke) [~'_14__ ~(tag "char" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)) + char+short>boolean + (~(tag "boolean" 'invoke) [~'_15__ ~(tag "char" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)) + char+char>boolean + (~(tag "boolean" 'invoke) [~'_16__ ~(tag "char" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)) + char+int>boolean + (~(tag "boolean" 'invoke) [~'_17__ ~(tag "char" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)) + char+long>boolean + (~(tag "boolean" 'invoke) [~'_18__ ~(tag "char" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)) + char+float>boolean + (~(tag "boolean" 'invoke) [~'_19__ ~(tag "char" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)) + char+double>boolean + (~(tag "boolean" 'invoke) [~'_20__ ~(tag "char" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)) + int+byte>boolean + (~(tag "boolean" 'invoke) [~'_21__ ~(tag "int" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)) + int+short>boolean + (~(tag "boolean" 'invoke) [~'_22__ ~(tag "int" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)) + int+char>boolean + (~(tag "boolean" 'invoke) [~'_23__ ~(tag "int" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)) + int+int>boolean + (~(tag "boolean" 'invoke) [~'_24__ ~(tag "int" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)) + int+long>boolean + (~(tag "boolean" 'invoke) [~'_25__ ~(tag "int" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)) + int+float>boolean + (~(tag "boolean" 'invoke) [~'_26__ ~(tag "int" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)) + int+double>boolean + (~(tag "boolean" 'invoke) [~'_27__ ~(tag "int" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)) + long+byte>boolean + (~(tag "boolean" 'invoke) [~'_28__ ~(tag "long" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)) + long+short>boolean + (~(tag "boolean" 'invoke) [~'_29__ ~(tag "long" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)) + long+char>boolean + (~(tag "boolean" 'invoke) [~'_30__ ~(tag "long" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)) + long+int>boolean + (~(tag "boolean" 'invoke) [~'_31__ ~(tag "long" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)) + long+long>boolean + (~(tag "boolean" 'invoke) [~'_32__ ~(tag "long" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)) + long+float>boolean + (~(tag "boolean" 'invoke) [~'_33__ ~(tag "long" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)) + long+double>boolean + (~(tag "boolean" 'invoke) [~'_34__ ~(tag "long" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)) + float+byte>boolean + (~(tag "boolean" 'invoke) [~'_35__ ~(tag "float" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)) + float+short>boolean + (~(tag "boolean" 'invoke) [~'_36__ ~(tag "float" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)) + float+char>boolean + (~(tag "boolean" 'invoke) [~'_37__ ~(tag "float" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)) + float+int>boolean + (~(tag "boolean" 'invoke) [~'_38__ ~(tag "float" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)) + float+long>boolean + (~(tag "boolean" 'invoke) [~'_39__ ~(tag "float" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)) + float+float>boolean + (~(tag "boolean" 'invoke) [~'_40__ ~(tag "float" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)) + float+double>boolean + (~(tag "boolean" 'invoke) [~'_41__ ~(tag "float" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)) + double+byte>boolean + (~(tag "boolean" 'invoke) [~'_42__ ~(tag "double" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)) + double+short>boolean + (~(tag "boolean" 'invoke) [~'_43__ ~(tag "double" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)) + double+char>boolean + (~(tag "boolean" 'invoke) [~'_44__ ~(tag "double" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)) + double+int>boolean + (~(tag "boolean" 'invoke) [~'_45__ ~(tag "double" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)) + double+long>boolean + (~(tag "boolean" 'invoke) [~'_46__ ~(tag "double" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)) + double+float>boolean + (~(tag "boolean" 'invoke) [~'_47__ ~(tag "double" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)) + double+double>boolean + (~(tag "boolean" 'invoke) [~'_48__ ~(tag "double" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)))) + + ;; TODO the dispatch here should realize that `>|test|__0` has multiple + ;; non-primitivized overloads and must dispatch not merely on the whole typedef + ;; but rather on each 'branch' of `[t/comparable-primitive? t/comparable-primitive?]` + (defn >|test + {::t/type + (t/fn #?(:clj [t/comparable-primitive? t/comparable-primitive? + :> t/boolean?] + :cljs [t/double? t/double? + :> (t/assume t/boolean?)]))} + ([a0 a1] + (ifs (t/byte? a0) + (ifs (t/byte? a1) (.invoke ^byte+byte>boolean >|test|__0 a0 a1) + (t/char? a1) (.invoke ...) + ...) + (t/char? a0) + (ifs (t/byte? a1) + (.invoke ^char+byte>boolean >|test|__0 a0 a1) + ...) + ... + (unsupported! `>|tets [a0 a1] 0)))))) + :cljs + ($ (do (defn >|test + ([a0 a1] + (ifs (double? a0) + (ifs (double? a1) + (let* [a a0 b a1] (cljs.core/> a b)) + (unsupported! `>|test [a0 a1] 1)) + (unsupported! `>|test [a0 a1] 0)))))))] + (testing "code equivalence" (is-code= actual expected)) + #_(testing "functionality" + (eval actual) + (eval '(do ...)))) ;; TODO fix: current implementation prefers to consolidate into one `reify` rather than splitting it ;; up as below From 823c2b8c85821a628d57a32186e88ec912621064 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 23 Jul 2018 18:33:07 -0600 Subject: [PATCH 121/810] Add base errors for now --- src-untyped/quantum/untyped/core/error.cljc | 25 +++++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/src-untyped/quantum/untyped/core/error.cljc b/src-untyped/quantum/untyped/core/error.cljc index d3ec1fa2..02007f43 100644 --- a/src-untyped/quantum/untyped/core/error.cljc +++ b/src-untyped/quantum/untyped/core/error.cljc @@ -19,6 +19,31 @@ (ucore/log-this-ns) +;; ===== Types ===== ;; + +;; TODO move this? +;; TODO add to these types based on HTTP response types? +(def ^{:doc "Adapted from `com.cognitect/anomalies`"} types + {:quantum.core.error/unavailable + {:caller-can-retry? true :resolution-strategy "make sure callee healthy"} + :quantum.core.error/interrupted + {:caller-can-retry? true :resolution-strategy "stop interrupting"} + :quantum.core.error/incorrect + {:caller-can-retry? false :resolution-strategy "fix inputs from caller"} + :quantum.core.error/forbidden + {:caller-can-retry? false :resolution-strategy "fix authentication-inputs from caller"} + :quantum.core.error/unsupported + {:caller-can-retry? false + :resolution-strategy "function found, but it does not support what the input requests"} + :quantum.core.error/not-found + {:caller-can-retry? false :resolution-strategy "function not found"} + :quantum.core.error/conflict + {:caller-can-retry? false :resolution-strategy "coordinate with callee"} + :quantum.core.error/fault + {:caller-can-retry? false :resolution-strategy "fix callee bug"} + :quantum.core.error/busy + {:caller-can-retry? true :resolution-strategy "back off and retry"}}) + ;; ===== Config ===== ;; (uvar/defonce *print-blacklist "A set of classes not to print" (atom #{})) From 5ad16271e8032c4f61d96494baff3d9563c7e304 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 23 Jul 2018 18:33:28 -0600 Subject: [PATCH 122/810] Clarification around time formatting --- src/quantum/core/time/core.cljc | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/src/quantum/core/time/core.cljc b/src/quantum/core/time/core.cljc index 5c6cd306..5c9f9b9c 100644 --- a/src/quantum/core/time/core.cljc +++ b/src/quantum/core/time/core.cljc @@ -92,7 +92,8 @@ #?(:clj (def formats ; TODO map->record? - {:rfc DateTimeFormatter/RFC_1123_DATE_TIME ; "EEE, dd MMM yyyy HH:mm:ss zzz" + {:rfc DateTimeFormatter/RFC_1123_DATE_TIME ; e.g. 'Tue, 3 Jun 2008 11:05:30 GMT' + ; e.g. '2011-12-03T10:15:30+01:00' or '2018-07-23T16:58:17.000Z' :iso-offset-date-time DateTimeFormatter/ISO_OFFSET_DATE_TIME :windows "E, dd MMM yyyy HH:mm:ss O" :calendar "EEE MMM dd HH:mm:ss.SSS z yyyy" @@ -415,14 +416,11 @@ ; (between date (now)))) #?(:clj -(defn parse [text formatter] - (LocalDate/parse text (DateTimeFormatter/ofPattern formatter)))) +(defn parse [text formatter] (LocalDate/parse text (DateTimeFormatter/ofPattern formatter)))) -#?(:clj (defn system-timezone [] - (.getID (java.util.TimeZone/getDefault)))) +#?(:clj (defn system-timezone [] (.getID (java.util.TimeZone/getDefault)))) -#?(:clj (def date-format-json - (java.text.SimpleDateFormat. "yyyy-MM-dd'T'HH:mm:ss'Z'"))) +#?(:clj (def date-format-json (java.text.SimpleDateFormat. "yyyy-MM-dd'T'HH:mm:ss'Z'"))) #?(:clj (defnt ^java.util.Calendar ->calendar @@ -709,4 +707,3 @@ ; ===== DAYS OF WEEK ===== ; - From 50a734c85e273cbc3b93938f1f86ad68c3d8a403 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 23 Jul 2018 18:33:46 -0600 Subject: [PATCH 123/810] Add some basic interval map code --- project-base.clj | 3 +- .../quantum/untyped/core/data/map.cljc | 48 ++++++++++++++++++- 2 files changed, 49 insertions(+), 2 deletions(-) diff --git a/project-base.clj b/project-base.clj index f47f2aab..2f73ea3e 100644 --- a/project-base.clj +++ b/project-base.clj @@ -86,7 +86,8 @@ com.esotericsoftware/reflectasm]] [co.paralleluniverse/quasar-core "0.7.6" :exclusions [com.esotericsoftware/reflectasm]] - ; ==== DATA ==== + ; ==== quantum.core.data ==== + [org.dthume/data.interval-treeset "0.1.2" ] [com.carrotsearch/hppc "0.7.1" ] ; High performance primitive collections for Java [it.unimi.dsi/fastutil "7.0.12" ] #_[colt/colt "1.2.0" ] diff --git a/src-untyped/quantum/untyped/core/data/map.cljc b/src-untyped/quantum/untyped/core/data/map.cljc index 05ac0fd5..a74b51f0 100644 --- a/src-untyped/quantum/untyped/core/data/map.cljc +++ b/src-untyped/quantum/untyped/core/data/map.cljc @@ -17,7 +17,7 @@ [quantum.untyped.core.reducers :as ur :refer [reduce-pair]] [quantum.untyped.core.vars - :refer [defalias]]) + :refer [defalias def-]]) (:import #?@(:clj [[java.util HashMap IdentityHashMap LinkedHashMap TreeMap] [it.unimi.dsi.fastutil.ints Int2ReferenceOpenHashMap] @@ -468,6 +468,52 @@ (defalias avl/split-key) (defalias avl/split-at) +;; ===== Interval Tree / Map ===== ;; + +;; TODO this is just a placeholder until we can use `com.dean.clojure-interval-tree` +;; (Adapted from http://clj-me.cgrand.net/2012/03/16/a-poor-mans-interval-tree/) + +(defn- interval< [[a b] [c d]] + (boolean (and b c + (if (= a b) + (neg? (compare b c)) + (<= (compare b c) 0))))) + +(def- interval-map|empty (sorted-map-by interval< [nil nil] #{})) + +(defn- interval-map|split-at [m x] + (if x + (let [[[a b :as k] vs] (find m [x x])] + (if (or (= a x) (= b x)) + m + (-> m (dissoc k) (assoc [a x] vs [x b] vs)))) + m)) + +(defn- interval-map|alter [m from to f & args] + (let [m (-> m (interval-map|split-at from) (interval-map|split-at to)) + kvs (for [[r vs] + (cond + (and from to) (subseq m >= [from from] < [to to]) + from (subseq m >= [from from]) + to (subseq m < [to to]) + :else m)] + [r (apply f vs args)])] + (into m kvs))) + +(defn interval|assoc [m from to v] (interval-map|alter m from to conj v)) +(defn interval|dissoc [m from to v] (interval-map|alter m from to disj v)) +(defn interval|get [m x] (get m [x x])) + +(defn interval-map [] interval-map|empty) + +(-> (interval-map) + (interval|assoc 0 5 :a) + (interval|assoc 1 6 :b) + (interval|assoc 2 7 :c) + (interval|get 2)) + +;; ===== General ===== ;; + ; TODO look at imap/merge ; TODO use |clojure.data.int-map/merge and merge-with|, |update|, |update!| for int maps. From 2b2849f5f6f3f130e901348b4bbd7075d67c776e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 23 Jul 2018 20:58:22 -0600 Subject: [PATCH 124/810] reify -> reify* for faster compilation --- src-dev/quantum/core/defnt.cljc | 19 +- src-dev/quantum/core/defnt_equivalences.cljc | 324 ++++++++++--------- 2 files changed, 177 insertions(+), 166 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index dc0c8493..6fb2ba01 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -80,12 +80,6 @@ #_" LEFT OFF LAST TIME (7/23/2018): -- In defnt_equivalences: - ;; TODO the dispatch here should realize that `>int*|__0` has multiple - ;; non-primitivized overloads and must dispatch not merely on the whole typedef - ;; but rather on each 'branch' of `(t/- t/primitive? t/boolean?)` - - - With `defnt`, protocols and interfaces aren't needed. You can just create `t/fn`s that you can then conform your fns to. @@ -1020,15 +1014,14 @@ LEFT OFF LAST TIME (7/23/2018): (c/map #(fnt|overload>reify-overload % gen-gensym))) reify-name (>fnt|reify|name fn|name i) form `(~'def ~reify-name - (reify + (reify* + ~(->> reify-overloads (mapv #(-> % :interface >name >symbol))) ~@(->> reify-overloads - (c/lmap (fn [{:keys [interface out-class method-sym arglist-code + (c/lmap (fn [{:keys [out-class method-sym arglist-code body-form]} #_::reify|overload] - [(-> interface >name >symbol) - `(~(ufth/with-type-hint method-sym - (ufth/>arglist-embeddable-tag out-class)) - ~arglist-code ~body-form)])) - lcat)))] + `(~(ufth/with-type-hint method-sym + (ufth/>arglist-embeddable-tag out-class)) + ~arglist-code ~body-form))))))] {:form form :name reify-name :overloads reify-overloads}))) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index fcf99cec..746d44eb 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -1,7 +1,6 @@ ;; See https://jsperf.com/js-property-access-comparison — all property accesses (at least of length 1) seem to be equal (ns quantum.core.test.defnt-equivalences - (:refer-clojure :exclude [name identity *]) (:require [clojure.core :as c] [quantum.core.defnt @@ -46,7 +45,7 @@ (.getName)))) expected ($ (do (def ~'pid|test|__0 - (reify >Object + (reify* [>Object] (~(tag "java.lang.Object" 'invoke) [~'_0__] ~'(->> (java.lang.management.ManagementFactory/getRuntimeMXBean) (.getName))))) @@ -75,25 +74,26 @@ (*<> ~'t/any?)) ;; One `reify` because `t/any?` in CLJ does not have any `t/or`-separability (def ~'identity|uninlined|__0 - (reify - Object>Object (~(tag "java.lang.Object" 'invoke) - [~'_0__ ~(tag "java.lang.Object" 'x)] ~'x) - boolean>boolean (~(tag "boolean" 'invoke) - [~'_1__ ~(tag "boolean" 'x)] ~'x) - byte>byte (~(tag "byte" 'invoke) - [~'_2__ ~(tag "byte" 'x)] ~'x) - short>short (~(tag "short" 'invoke) - [~'_3__ ~(tag "short" 'x)] ~'x) - char>char (~(tag "char" 'invoke) - [~'_4__ ~(tag "char" 'x)] ~'x) - int>int (~(tag "int" 'invoke) - [~'_5__ ~(tag "int" 'x)] ~'x) - long>long (~(tag "long" 'invoke) - [~'_6__ ~(tag "long" 'x)] ~'x) - float>float (~(tag "float" 'invoke) - [~'_7__ ~(tag "float" 'x)] ~'x) - double>double (~(tag "double" 'invoke) - [~'_8__ ~(tag "double" 'x)] ~'x))) + (reify* [Object>Object boolean>boolean byte>byte short>short char>char + int>int long>long float>float double>double] + (~(tag "java.lang.Object" 'invoke) + [~'_0__ ~(tag "java.lang.Object" 'x)] ~'x) + (~(tag "boolean" 'invoke) + [~'_1__ ~(tag "boolean" 'x)] ~'x) + (~(tag "byte" 'invoke) + [~'_2__ ~(tag "byte" 'x)] ~'x) + (~(tag "short" 'invoke) + [~'_3__ ~(tag "short" 'x)] ~'x) + (~(tag "char" 'invoke) + [~'_4__ ~(tag "char" 'x)] ~'x) + (~(tag "int" 'invoke) + [~'_5__ ~(tag "int" 'x)] ~'x) + (~(tag "long" 'invoke) + [~'_6__ ~(tag "long" 'x)] ~'x) + (~(tag "float" 'invoke) + [~'_7__ ~(tag "float" 'x)] ~'x) + (~(tag "double" 'invoke) + [~'_8__ ~(tag "double" 'x)] ~'x))) (defn ~'identity|uninlined {::t/type (t/fn ~'[t/any?])} @@ -108,8 +108,8 @@ (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) - (eval '(do (is= (identity|uninlined 1 ) 1 ) - (is= (identity|uninlined "") "")))))) + (eval '(do (is= (identity|uninlined 1) (identity 1)) + (is= (identity|uninlined "") (identity ""))))))) (deftest test|name (let [actual @@ -130,7 +130,7 @@ (def ~(tag "[Ljava.lang.Object;" 'name|test|__0|input-types) (*<> ~'t/string?)) (def ~'name|test|__0 - (reify Object>Object + (reify* [Object>Object] (~(tag "java.lang.Object" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] (let* [~(tag "java.lang.String" 'x) ~'x] ~'x)))) @@ -139,7 +139,7 @@ (def ~(tag "[Ljava.lang.Object;" 'name|test|__1|input-types) (*<> ~'(t/isa? Named))) (def ~'name|test|__1 - (reify Object>Object + (reify* [Object>Object] (~(tag "java.lang.Object" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] (let* [~(tag "clojure.lang.Named" 'x) ~'x] (t/validate ~'(.getName x) ~'(* t/string?)))))) @@ -164,12 +164,12 @@ (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) - (eval '(do (is= (name|test "") "") - (is= (name|test "abc") "abc") - (is= (name|test :abc) "abc") - (is= (name|test 'abc) "abc") - (is= (name|test :abc/def) "def") - (is= (name|test 'abc/def) "def") + (eval '(do (is= (name|test "") (name "")) + (is= (name|test "abc") (name "abc")) + (is= (name|test :abc) (name :abc)) + (is= (name|test 'abc) (name 'abc)) + (is= (name|test :abc/def) (name :abc/def)) + (is= (name|test 'abc/def) (name 'abc/def)) (throws (name|test nil)) (throws (name|test 1))))))) @@ -189,34 +189,25 @@ (def ~(tag "[Ljava.lang.Object;" 'some?|test|__0|input-types) (*<> ~'t/nil?)) (def ~'some?|test|__0 - (reify - Object>boolean - (~(tag "boolean" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] false))) + (reify* [Object>boolean] + (~(tag "boolean" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] false))) ;; [x t/any?] (def ~(tag "[Ljava.lang.Object;" 'some?|test|__1|input-types) (*<> ~'t/any?)) (def ~'some?|test|__1 - (reify - Object>boolean - (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] true) - boolean>boolean - (~(tag "boolean" 'invoke) [~'_2__ ~(tag "boolean" 'x)] true) - byte>boolean - (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'x)] true) - short>boolean - (~(tag "boolean" 'invoke) [~'_4__ ~(tag "short" 'x)] true) - char>boolean - (~(tag "boolean" 'invoke) [~'_5__ ~(tag "char" 'x)] true) - int>boolean - (~(tag "boolean" 'invoke) [~'_6__ ~(tag "int" 'x)] true) - long>boolean - (~(tag "boolean" 'invoke) [~'_7__ ~(tag "long" 'x)] true) - float>boolean - (~(tag "boolean" 'invoke) [~'_8__ ~(tag "float" 'x)] true) - double>boolean - (~(tag "boolean" 'invoke) [~'_9__ ~(tag "double" 'x)] true))) + (reify* [Object>boolean boolean>boolean byte>boolean short>boolean + char>boolean int>boolean long>boolean float>boolean double>boolean] + (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] true) + (~(tag "boolean" 'invoke) [~'_2__ ~(tag "boolean" 'x)] true) + (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'x)] true) + (~(tag "boolean" 'invoke) [~'_4__ ~(tag "short" 'x)] true) + (~(tag "boolean" 'invoke) [~'_5__ ~(tag "char" 'x)] true) + (~(tag "boolean" 'invoke) [~'_6__ ~(tag "int" 'x)] true) + (~(tag "boolean" 'invoke) [~'_7__ ~(tag "long" 'x)] true) + (~(tag "boolean" 'invoke) [~'_8__ ~(tag "float" 'x)] true) + (~(tag "boolean" 'invoke) [~'_9__ ~(tag "double" 'x)] true))) (defn ~'some?|test {::t/type (t/fn ~'[t/nil?] @@ -238,10 +229,10 @@ (testing "functionality" (eval actual) (eval '(do (throws (some?|test)) - (is= (some?|test 123) true) - (is= (some?|test true) true) - (is= (some?|test false) true) - (is= (some?|test nil) false)))))) + (is= (some?|test 123) (some? 123)) + (is= (some?|test true) (some? true)) + (is= (some?|test false) (some? false)) + (is= (some?|test nil) (some? nil))))))) (deftest test|reduced? (let [actual @@ -259,35 +250,26 @@ (def ~(tag "[Ljava.lang.Object;" 'reduced?|test|__0|input-types) (*<> ~'(t/isa? Reduced))) (def ~'reduced?|test|__0 - (reify - Object>boolean - (~(tag "boolean" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "clojure.lang.Reduced" 'x) ~'x] true)))) + (reify* [Object>boolean] + (~(tag "boolean" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] + (let* [~(tag "clojure.lang.Reduced" 'x) ~'x] true)))) ;; [x t/any?] (def ~(tag "[Ljava.lang.Object;" 'reduced?|test|__1|input-types) (*<> ~'t/any?)) (def ~'reduced?|test|__1 - (reify - Object>boolean - (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false) - boolean>boolean - (~(tag "boolean" 'invoke) [~'_2__ ~(tag "boolean" 'x)] false) - byte>boolean - (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'x)] false) - short>boolean - (~(tag "boolean" 'invoke) [~'_4__ ~(tag "short" 'x)] false) - char>boolean - (~(tag "boolean" 'invoke) [~'_5__ ~(tag "char" 'x)] false) - int>boolean - (~(tag "boolean" 'invoke) [~'_6__ ~(tag "int" 'x)] false) - long>boolean - (~(tag "boolean" 'invoke) [~'_7__ ~(tag "long" 'x)] false) - float>boolean - (~(tag "boolean" 'invoke) [~'_8__ ~(tag "float" 'x)] false) - double>boolean - (~(tag "boolean" 'invoke) [~'_9__ ~(tag "double" 'x)] false))) + (reify* [Object>boolean boolean>boolean byte>boolean short>boolean + char>boolean int>boolean long>boolean float>boolean double>boolean] + (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false) + (~(tag "boolean" 'invoke) [~'_2__ ~(tag "boolean" 'x)] false) + (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'x)] false) + (~(tag "boolean" 'invoke) [~'_4__ ~(tag "short" 'x)] false) + (~(tag "boolean" 'invoke) [~'_5__ ~(tag "char" 'x)] false) + (~(tag "boolean" 'invoke) [~'_6__ ~(tag "int" 'x)] false) + (~(tag "boolean" 'invoke) [~'_7__ ~(tag "long" 'x)] false) + (~(tag "boolean" 'invoke) [~'_8__ ~(tag "float" 'x)] false) + (~(tag "boolean" 'invoke) [~'_9__ ~(tag "double" 'x)] false))) (defn ~'reduced?|test {::t/type (t/fn ~'[(t/isa? Reduced)] @@ -308,14 +290,14 @@ (testing "functionality" (eval actual) (eval '(do (throws (reduced?|test)) - (is= (reduced?|test 123) false) - (is= (reduced?|test true) false) - (is= (reduced?|test false) false) - (is= (reduced?|test nil) false) - (is= (reduced?|test (reduced 123)) true) - (is= (reduced?|test (reduced true)) true) - (is= (reduced?|test (reduced false)) true) - (is= (reduced?|test (reduced nil)) true))))))) + (is= (reduced?|test 123) (reduced? 123)) + (is= (reduced?|test true) (reduced? true)) + (is= (reduced?|test false) (reduced? false)) + (is= (reduced?|test nil) (reduced? nil)) + (is= (reduced?|test (reduced 123)) (reduced? (reduced 123))) + (is= (reduced?|test (reduced true)) (reduced? (reduced true))) + (is= (reduced?|test (reduced false)) (reduced? (reduced false))) + (is= (reduced?|test (reduced nil)) (reduced? (reduced nil)))))))) (deftest test|>boolean (let [actual @@ -332,43 +314,33 @@ (def ~(tag "[Ljava.lang.Object;" '>boolean|__0|input-types) (*<> ~'t/boolean?)) (def ~'>boolean|__0 - (reify - boolean>boolean - (~(tag "boolean" 'invoke) [~'_0__ ~(tag "boolean" 'x)] ~'x))) + (reify* [boolean>boolean] + (~(tag "boolean" 'invoke) [~'_0__ ~(tag "boolean" 'x)] ~'x))) ;; [x t/nil? -> (- t/nil? t/boolean?)] (def ~(tag "[Ljava.lang.Object;" '>boolean|__1|input-types) (*<> ~'t/nil?)) (def ~'>boolean|__1 - (reify - Object>boolean - (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false))) + (reify* [Object>boolean] + (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false))) ;; [x t/any? -> (- t/any? t/nil? t/boolean?)] (def ~(tag "[Ljava.lang.Object;" '>boolean|__2|input-types) (*<> ~'t/any?)) (def ~'>boolean|__2 - (reify - Object>boolean - (~(tag "boolean" 'invoke) [~'_2__ ~(tag "java.lang.Object" 'x)] true) - boolean>boolean - (~(tag "boolean" 'invoke) [~'_3__ ~(tag "boolean" 'x)] true) - byte>boolean - (~(tag "boolean" 'invoke) [~'_4__ ~(tag "byte" 'x)] true) - short>boolean - (~(tag "boolean" 'invoke) [~'_5__ ~(tag "short" 'x)] true) - char>boolean - (~(tag "boolean" 'invoke) [~'_6__ ~(tag "char" 'x)] true) - int>boolean - (~(tag "boolean" 'invoke) [~'_7__ ~(tag "int" 'x)] true) - long>boolean - (~(tag "boolean" 'invoke) [~'_8__ ~(tag "long" 'x)] true) - float>boolean - (~(tag "boolean" 'invoke) [~'_9__ ~(tag "float" 'x)] true) - double>boolean - (~(tag "boolean" 'invoke) [~'_10__ ~(tag "double" 'x)] true))) + (reify* [Object>boolean boolean>boolean byte>boolean short>boolean + char>boolean int>boolean long>boolean float>boolean double>boolean] + (~(tag "boolean" 'invoke) [~'_2__ ~(tag "java.lang.Object" 'x)] true) + (~(tag "boolean" 'invoke) [~'_3__ ~(tag "boolean" 'x)] true) + (~(tag "boolean" 'invoke) [~'_4__ ~(tag "byte" 'x)] true) + (~(tag "boolean" 'invoke) [~'_5__ ~(tag "short" 'x)] true) + (~(tag "boolean" 'invoke) [~'_6__ ~(tag "char" 'x)] true) + (~(tag "boolean" 'invoke) [~'_7__ ~(tag "int" 'x)] true) + (~(tag "boolean" 'invoke) [~'_8__ ~(tag "long" 'x)] true) + (~(tag "boolean" 'invoke) [~'_9__ ~(tag "float" 'x)] true) + (~(tag "boolean" 'invoke) [~'_10__ ~(tag "double" 'x)] true))) (defn ~'>boolean {::t/type (t/fn ~'[t/boolean?] @@ -395,10 +367,16 @@ (testing "functionality" (eval actual) (eval '(do (throws (>boolean)) - (is= (>boolean true) true) - (is= (>boolean false) false) - (is= (>boolean nil) false) - (is= (>boolean 123) true)))))) + (is= (>boolean true) (boolean true)) + (is= (>boolean false) (boolean false)) + (is= (>boolean nil) (boolean nil)) + (is= (>boolean 123) (boolean 123))))))) + +;; Let's say you have (t/| t/string? t/number?) in one `fnt` overload. +;; This means that you *can't* have a reify with two Object>Object overloads and expect it to work +;; at all. +;; Therefore, each `fnt` overload necessarily has a one-to-many relationship with `reify`s. +;; Only the primitivized overloads belong grouped together in one `reify`. (deftest test|>int* (let [actual @@ -411,30 +389,56 @@ expected (case (env-lang) :clj - ($ (do #_(swap! fn->spec assoc #'>int* - (t/fn [(t/- t/primitive? t/boolean?)] - [(t/ref (t/isa? Number))])) - - ;; [x (t/- t/primitive? t/boolean?)] - - (def ~(tag "[Ljava.lang.Object;" '>int*|__0|input-types) - (*<> ~'(t/- t/primitive? t/boolean?))) - (def ~'>int*|__0 - (reify - byte>int (~(tag "int" 'invoke) [~'_0__ ~(tag "byte" 'x)] - ~'(Primitive/uncheckedIntCast x)) - short>int (~(tag "int" 'invoke) [~'_1__ ~(tag "short" 'x)] - ~'(Primitive/uncheckedIntCast x)) - char>int (~(tag "int" 'invoke) [~'_2__ ~(tag "char" 'x)] - ~'(Primitive/uncheckedIntCast x)) - int>int (~(tag "int" 'invoke) [~'_3__ ~(tag "int" 'x)] - ~'(Primitive/uncheckedIntCast x)) - long>int (~(tag "int" 'invoke) [~'_4__ ~(tag "long" 'x)] - ~'(Primitive/uncheckedIntCast x)) - float>int (~(tag "int" 'invoke) [~'_5__ ~(tag "float" 'x)] - ~'(Primitive/uncheckedIntCast x)) - double>int (~(tag "int" 'invoke) [~'_6__ ~(tag "double" 'x)] - ~'(Primitive/uncheckedIntCast x)))) + ($ (do ;; [x (t/- t/primitive? t/boolean?)] + + (def ~(tag "[Ljava.lang.Object;" '>int*|__0|__0|input-types) + (*<> ~'(t/isa? java.lang.Byte))) + (def ~'>int*|__0|__0 + (reify* [byte>int] + (~(tag "int" 'invoke) [~'_0__ ~(tag "byte" 'x)] + ~'(Primitive/uncheckedIntCast x)))) + + (def ~(tag "[Ljava.lang.Object;" '>int*|__0|__1|input-types) + (*<> ~'(t/isa? java.lang.Short))) + (def ~'>int*|__0|__1 + (reify* [short>int] + (~(tag "int" 'invoke) [~'_1__ ~(tag "short" 'x)] + ~'(Primitive/uncheckedIntCast x)))) + + (def ~(tag "[Ljava.lang.Object;" '>int*|__0|__2|input-types) + (*<> ~'(t/isa? java.lang.Character))) + (def ~'>int*|__0|__2 + (reify* [char>int] + (~(tag "int" 'invoke) [~'_2__ ~(tag "char" 'x)] + ~'(Primitive/uncheckedIntCast x)))) + + (def ~(tag "[Ljava.lang.Object;" '>int*|__0|__3|input-types) + (*<> ~'(t/isa? java.lang.Integer))) + (def ~'>int*|__0|__3 + (reify* [int>int] + (~(tag "int" 'invoke) [~'_3__ ~(tag "int" 'x)] + ~'(Primitive/uncheckedIntCast x)))) + + (def ~(tag "[Ljava.lang.Object;" '>int*|__0|__4|input-types) + (*<> ~'(t/isa? java.lang.Long))) + (def ~'>int*|__0|__4 + (reify* [long>int] + (~(tag "int" 'invoke) [~'_4__ ~(tag "long" 'x)] + ~'(Primitive/uncheckedIntCast x)))) + + (def ~(tag "[Ljava.lang.Object;" '>int*|__0|__5|input-types) + (*<> ~'(t/isa? java.lang.Float))) + (def ~'>int*|__0|__5 + (reify* [float>int] + (~(tag "int" 'invoke) [~'_5__ ~(tag "float" 'x)] + ~'(Primitive/uncheckedIntCast x)))) + + (def ~(tag "[Ljava.lang.Object;" '>int*|__0|__6|input-types) + (*<> ~'(t/isa? java.lang.Double))) + (def ~'>int*|__0|__6 + (reify* [double>int] + (~(tag "int" 'invoke) [~'_6__ ~(tag "double" 'x)] + ~'(Primitive/uncheckedIntCast x)))) ;; [x (t/ref (t/isa? Number)) ;; -> (t/- (t/ref (t/isa? Number)) (t/- t/primitive? t/boolean?))] @@ -442,25 +446,39 @@ (def ~(tag "[Ljava.lang.Object;" '>int*|__1|input-types) (*<> ~'(t/ref (t/isa? Number)))) (def ~'>int*|__1 - (reify - Object>int (~(tag "int" 'invoke) [~'_7__ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "java.lang.Number" 'x) ~'x] - ~'(.intValue x))))) + (reify* [Object>int] + (~(tag "int" 'invoke) [~'_7__ ~(tag "java.lang.Object" 'x)] + (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(.intValue x))))) - ;; TODO the dispatch here should realize that `>int*|__0` has multiple - ;; non-primitivized overloads and must dispatch not merely on the whole typedef - ;; but rather on each 'branch' of `(t/- t/primitive? t/boolean?)` (defn ~'>int* {::t/type (t/fn ~'[(t/- t/primitive? t/boolean?)] ~'[(t/ref (t/isa? Number))])} ([~'x00__] - (ifs ((Array/get ~'>int*|__0|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.boolean>boolean" - '>int*|__0) ~'x00__) + (ifs ((Array/get ~'>int*|__0|__0|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.byte>int" + '>int*|__0|__0) ~'x00__) + ((Array/get ~'>int*|__0|__1|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.short>int" + '>int*|__0|__1) ~'x00__) + ((Array/get ~'>int*|__0|__2|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.char>int" + '>int*|__0|__2) ~'x00__) + ((Array/get ~'>int*|__0|__3|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.int>int" + '>int*|__0|__3) ~'x00__) + ((Array/get ~'>int*|__0|__4|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.long>int" + '>int*|__0|__4) ~'x00__) + ((Array/get ~'>int*|__0|__5|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.float>int" + '>int*|__0|__5) ~'x00__) + ((Array/get ~'>int*|__0|__6|input-types 0) ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.double>int" + '>int*|__0|__6) ~'x00__) ((Array/get ~'>int*|__1|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>int" '>int*|__1) ~'x00__) - (unsupported! `>boolean [~'x00__] 0)))))))]] + (unsupported! `>int* [~'x00__] 0)))))))]] (testing "code equivalence" (is-code= actual expected)) #_(testing "functionality" (eval actual) From 1a4d10d4681e542868c9523c546011db9046a024 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 23 Jul 2018 21:07:31 -0600 Subject: [PATCH 125/810] Maybe a little faster this way --- src-dev/quantum/core/defnt.cljc | 16 ++++++++-------- src-dev/quantum/core/defnt_equivalences.cljc | 2 +- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 6fb2ba01..cb79450c 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -1014,14 +1014,14 @@ LEFT OFF LAST TIME (7/23/2018): (c/map #(fnt|overload>reify-overload % gen-gensym))) reify-name (>fnt|reify|name fn|name i) form `(~'def ~reify-name - (reify* - ~(->> reify-overloads (mapv #(-> % :interface >name >symbol))) - ~@(->> reify-overloads - (c/lmap (fn [{:keys [out-class method-sym arglist-code - body-form]} #_::reify|overload] - `(~(ufth/with-type-hint method-sym - (ufth/>arglist-embeddable-tag out-class)) - ~arglist-code ~body-form))))))] + ~(list* `reify* + (->> reify-overloads (mapv #(-> % :interface >name >symbol))) + (->> reify-overloads + (c/lmap (fn [{:keys [out-class method-sym arglist-code + body-form]} #_::reify|overload] + `(~(ufth/with-type-hint method-sym + (ufth/>arglist-embeddable-tag out-class)) + ~arglist-code ~body-form))))))] {:form form :name reify-name :overloads reify-overloads}))) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 746d44eb..87c18ede 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -478,7 +478,7 @@ ((Array/get ~'>int*|__1|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>int" '>int*|__1) ~'x00__) - (unsupported! `>int* [~'x00__] 0)))))))]] + (unsupported! `>int* [~'x00__] 0)))))))] (testing "code equivalence" (is-code= actual expected)) #_(testing "functionality" (eval actual) From 74096f8c1e809f3ee0eec4dbf35af210e3c78ba3 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 23 Jul 2018 23:44:19 -0600 Subject: [PATCH 126/810] One step closer to complete dispatching --- src-dev/quantum/core/defnt.cljc | 378 ++++++++++--------- src-dev/quantum/core/defnt_equivalences.cljc | 5 +- test/quantum/test/core/defnt.cljc | 23 +- 3 files changed, 213 insertions(+), 193 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index cb79450c..ff75413b 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -4,63 +4,64 @@ bit-and ==]) (:require - [clojure.core :as core] - [clojure.string :as str] - [quantum.core.type.core :as tcore] - [quantum.core.type.defs :as tdef] - [quantum.untyped.core.analyze.ast :as ast] - [quantum.untyped.core.analyze.expr :as xp] - [quantum.untyped.core.analyze.rewrite :as ana-rw] - [quantum.untyped.core.collections :as c + [clojure.core :as core] + [clojure.string :as str] + [quantum.core.type.core :as tcore] + [quantum.core.type.defs :as tdef] + [quantum.untyped.core.analyze.ast :as ast] + [quantum.untyped.core.analyze.expr :as xp] + [quantum.untyped.core.analyze.rewrite :as ana-rw] + [quantum.untyped.core.collections :as c :refer [dissoc-if dissoc* lcat subview >vec >set lmap map+ map-vals+ mapcat+ filter+ remove+ partition-all+]] - [quantum.untyped.core.collections.logic :as ucl + [quantum.untyped.core.collections.logic :as ucl :refer [seq-and seq-or]] - [quantum.untyped.core.collections.tree :as tree + [quantum.untyped.core.collections.tree :as tree :refer [prewalk postwalk walk]] - [quantum.untyped.core.compare :as comp + [quantum.untyped.core.compare :as comp :refer [==]] - [quantum.untyped.core.convert :as conv + [quantum.untyped.core.convert :as conv :refer [>symbol >name]] [quantum.untyped.core.core :refer [istr]] [quantum.untyped.core.data :refer [kw-map]] - [quantum.untyped.core.data.array :as arr] - [quantum.untyped.core.data.map :as map] - [quantum.untyped.core.data.set :as set] + [quantum.untyped.core.data.array :as arr] + [quantum.untyped.core.data.map :as map] + [quantum.untyped.core.data.set :as set] [quantum.untyped.core.defnt :refer [defns defns- fns]] - [quantum.untyped.core.error :as err + [quantum.untyped.core.error :as err :refer [TODO err!]] [quantum.untyped.core.fn :refer [aritoid fn1 fnl fn', fn-> fn->> <-, rcomp firsta seconda]] - [quantum.untyped.core.form :as uform] - [quantum.untyped.core.form.evaluate :as ufeval] - [quantum.untyped.core.form.generate :as ufgen + [quantum.untyped.core.form :as uform] + [quantum.untyped.core.form.evaluate :as ufeval] + [quantum.untyped.core.form.generate :as ufgen :refer [unify-gensyms]] - [quantum.untyped.core.form.type-hint :as ufth] - [quantum.untyped.core.log :as log + [quantum.untyped.core.form.type-hint :as ufth] + [quantum.untyped.core.log :as log :refer [ppr! ppr prl! prlm!]] - [quantum.untyped.core.logic :as l + [quantum.untyped.core.logic :as l :refer [fn= fn-and fn-or fn-not ifs if-not-let]] - [quantum.untyped.core.loops :as loops + [quantum.untyped.core.loops :as loops :refer [reduce-2]] [quantum.untyped.core.numeric.combinatorics :as combo] - [quantum.untyped.core.print :as pr] - [quantum.untyped.core.qualify :as qual :refer [qualify]] - [quantum.untyped.core.reducers :as r + [quantum.untyped.core.print :as pr] + [quantum.untyped.core.qualify :as qual + :refer [qualify]] + [quantum.untyped.core.reducers :as r :refer [join reducei educe]] - [quantum.untyped.core.refs :as ref + [quantum.untyped.core.refs :as ref :refer [?deref]] - [quantum.untyped.core.spec :as s] - [quantum.untyped.core.specs :as uss] - [quantum.untyped.core.type :as t + [quantum.untyped.core.spec :as s] + [quantum.untyped.core.specs :as uss] + [quantum.untyped.core.type :as t :refer [?]] - [quantum.untyped.core.type.predicates :as utpred] - [quantum.untyped.core.type.reifications :as utr] - [quantum.untyped.core.vars :as var + [quantum.untyped.core.type.predicates :as utpred] + [quantum.untyped.core.type.reifications :as utr] + [quantum.untyped.core.vars :as var :refer [update-meta]] #_[quantum.format.clojure.core ; TODO temporary :refer [reformat-string]]) @@ -725,27 +726,23 @@ LEFT OFF LAST TIME (7/23/2018): ;; ===== (DE)FNT ===== ;; -#_(s/def :fnt|overload/arglist-code (t/vec-of arg?)) - - #_"Must evaluate to an `s/fspec`" -(s/def :fnt|overload/type :quantum.core.specs/code) - -#_(s/def :fnt|overload/body-codelist (t/seq-of :quantum.core.specs/code)) - ;; Internal specs -(s/def ::fnt|overload|arg-classes (s/vec-of t/class?)) -(s/def ::fnt|overload|arg-types t/any?) +(s/def ::expanded-overload|arg-classes (s/vec-of t/class?)) +(s/def ::expanded-overload|arg-types (s/seq-of t/any?)) -(s/def ::fnt|overload - (s/kv {:arg-classes ::fnt|overload|arg-classes - :arg-types ::fnt|overload|arg-types +;; This is the overload after the input specs are split by their respective `t/or` constituents, +;; and after primitivization, but before readiness for incorporation into a `reify`. +;; One of these corresponds to one reify overload. +(s/def ::expanded-overload + (s/kv {:arg-classes ::expanded-overload|arg-classes + :arg-types ::expanded-overload|arg-types :arglist-code|fn|hinted t/any? :arglist-code|reify|unhinted t/any? :body-form t/any? - :positional-args-ct t/nneg-int? - :out-type t/type? :out-class (? t/class?) + :out-type t/type? + :positional-args-ct t/nneg-int? ;; When present, varargs are considered to be of class Object :variadic? t/boolean?})) @@ -766,19 +763,24 @@ LEFT OFF LAST TIME (7/23/2018): (s/def ::input-types-decl (s/kv {:form t/any? :name simple-symbol?})) (s/def ::direct-dispatch|reify-groups - (s/kv {:fnt|reify ::reify + (s/kv {:reify ::reify :input-types-decl ::input-types-decl})) (s/def ::direct-dispatch (s/kv {:form t/any? ::direct-dispatch|reify-groups ::direct-dispatch|reify-groups})) -(s/def ::fnt|overload-group - (s/kv {:arg-types|form (s/vec-of t/any?) - :pre-type|form (s/vec-of t/any?) - :post-type|form (s/vec-of t/any?) - :unprimitivized ::fnt|overload - :primitivized (s/seq-of ::fnt|overload)})) +(s/def ::expanded-overload-group|arg-types|form (s/vec-of t/any?)) +(s/def ::expanded-overload-group|pre-type|form (s/vec-of t/any?)) +(s/def ::expanded-overload-group|post-type|form (s/vec-of t/any?)) + +(s/def ::expanded-overload-group + (s/kv {:arg-types|pre-split|form ::expanded-overload-group|arg-types|form + :arg-types|form ::expanded-overload-group|arg-types|form + :pre-type|form ::expanded-overload-group|pre-type|form + :post-type|form ::expanded-overload-group|post-type|form + :unprimitivized ::expanded-overload + :primitivized (s/seq-of ::expanded-overload)})) #_(:clj (defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] @@ -814,7 +816,7 @@ LEFT OFF LAST TIME (7/23/2018): [float] [double]] which includes all primitive subclasses of the type." - [arg-types (s/seq-of t/type?) > (s/seq-of ::fnt|overload|arg-classes)] + [arg-types (s/seq-of t/type?) > (s/seq-of ::expanded-overload|arg-classes)] (->> arg-types (c/lmap (fn [t #_t/type?] (if (-> t meta :ref?) @@ -833,14 +835,14 @@ LEFT OFF LAST TIME (7/23/2018): ;; TODO spec args #?(:clj -(defns- >fnt|overload +(defns- >expanded-overload "Is given `arg-classes` and `arg-types`. In order to determine the out-type, performs an analysis using (in part) these pieces of data, but does not use the possibly-updated `arg-types` as computed in the analysis. As a result, does not yet support type inference." - [{:keys [arg-bindings _, arg-classes ::fnt|overload|arg-classes - arg-types ::fnt|overload|arg-types, args _, body-codelist|pre-analyze _, lang ::lang + [{:keys [arg-bindings _, arg-classes ::expanded-overload|arg-classes + arg-types ::expanded-overload|arg-types, body-codelist|pre-analyze _, lang ::lang post-type|form _, pre-type|form _, varargs _, varargs-binding _]} _ - > ::fnt|overload] + > ::expanded-overload] (let [env (->> (zipmap arg-bindings arg-types) (c/map' (fn [[arg-binding arg-type]] [arg-binding (ast/unbound nil arg-binding arg-type)]))) @@ -851,7 +853,7 @@ LEFT OFF LAST TIME (7/23/2018): (ufth/>fn-arglist-tag (c/get arg-classes|simplest i) lang - (c/count args) + (c/count arg-bindings) varargs))) ;; TODO this becomes an issue when `post-type|form` references local bindings post-type (eval post-type|form) @@ -881,16 +883,49 @@ LEFT OFF LAST TIME (7/23/2018): varargs-binding (conj '& varargs-binding)) ; TODO use `` :arglist-code|reify|unhinted (cond-> arg-bindings varargs-binding (conj varargs-binding)) :body-form body-form - :positional-args-ct (count args) + :positional-args-ct (count arg-bindings) :out-type out-type :out-class (out-type>class out-type) :variadic? (boolean varargs)}))) +(defns >expanded-overload-group + [{:as in + :keys [arg-types ::expanded-overload|arg-types|form + arg-types|pre-split|form ::expanded-overload-group|arg-types|form + pre-type|form ::expanded-overload-group|pre-type|form + post-type|form ::expanded-overload-group|post-type|form]} _ + > ::expanded-overload-group] + (let [arg-types|form (->> arg-types (mapv fipp.ednize/edn)) + ;; `unprimitivized` is first because of class sorting + [unprimitivized & primitivized :as overloads] + (->> arg-types + arg-types>arg-classes-seq|primitivized + (mapv (fn [arg-classes #_::expanded-overload|arg-classes] + (let [arg-types|satisfying-primitivization + (c/mergev-with + (fn [_ s #_t/type? c #_t/class?] + (cond-> s (t/primitive-class? c) (t/and c))) + arg-types arg-classes)] + (>expanded-overload + (assoc in :arg-classes arg-classes + :arg-types arg-types|satisfying-primitivization))))))] + (kw-map arg-types|pre-split|form arg-types|form pre-type|form post-type|form + unprimitivized primitivized))) + +(defns arg-types>split + [arg-types ::expanded-overload|arg-types > (s/seq-of ::expanded-overload|arg-types)] + (->> arg-types + (map (fn [t] (if (utr/or-type? t) ; splittable + (utr/or-type>args t) + [t]))) + (apply combo/cartesian-product) + (c/map vec))) + ;; TODO spec #?(:clj ; really, reserve for metalanguage -(defns fnt|overload-data>overload-group - "Given an `fnt` overload, computes an 'overload group', which is the foundation for potentially - multiple direct-dispatch `reify`s. +(defns fnt|overload-data>expanded-overload-groups + "Given an `fnt` overload, computes a seq of 'expanded-overload groups'. Each expanded-overload + group is the foundation for one `reify`. Rather than rigging together something in which either: 1) the Clojure compiler will try to cross its fingers and evaluate code meant to be evaluated in @@ -908,10 +943,11 @@ LEFT OFF LAST TIME (7/23/2018): [_ _, post-type|form _] [:post _]} [:arglist _] body-codelist|pre-analyze [:body _]} _ {:as opts :keys [::lang ::lang, symbolic-analysis? t/boolean?]} _ - > ::fnt|overload-group] + > (s/seq-of ::expanded-overload-group)] (if symbolic-analysis? (err! "Symbolic analysis not supported yet") (let [_ (when pre-type|form (TODO "Need to handle pre")) + _ (when varargs (TODO "Need to handle varargs")) post-type|form (if (= post-type|form '_) `t/any? post-type|form) varargs-binding (when varargs ;; TODO this assertion is purely temporary until destructuring is @@ -924,32 +960,18 @@ LEFT OFF LAST TIME (7/23/2018): ;; supported (assert kind :sym) binding-))) - arg-types|form + arg-types|pre-split|form (->> args (mapv (fn [{[kind #_#{:any :spec}, t #_t/form?] :spec}] (case kind :any `t/any? :spec t)))) - arg-types|unprimitivized (->> arg-types|form (mapv (fn-> eval t/>type))) - arg-classes-seq (arg-types>arg-classes-seq|primitivized arg-types|unprimitivized) - ;; `unprimitivized` is first because of class sorting - ;; TODO `unprimitivized` might actually not be just the first one here due to - ;; `or`-splitting - [unprimitivized & primitivized :as overloads] - (->> arg-classes-seq - (mapv (fn [arg-classes] - (let [arg-types - (c/mergev-with - (fn [_ s #_t/type? c #_t/class?] - (cond-> s (t/primitive-class? c) (t/and c))) - arg-types|unprimitivized arg-classes)] - (>fnt|overload - (kw-map arg-bindings arg-classes arg-types args - body-codelist|pre-analyze lang post-type|form pre-type|form - varargs varargs-binding))))))] - {:arg-types|form arg-types|form - :pre-type|form pre-type|form - :post-type|form post-type|form - :unprimitivized unprimitivized - :primitivized primitivized})))) + arg-types|pre-split (->> arg-types|pre-split|form (mapv (fn-> eval t/>type))) + arg-types|split (arg-types>split arg-types|pre-split)] + (->> arg-types|split + (mapv (fn [arg-types] + (>expanded-overload-group + (kw-map arg-bindings arg-types body-codelist|pre-analyze lang + arg-types|pre-split|form pre-type|form post-type|form + varargs varargs-binding))))))))) (def fnt-method-sym 'invoke) @@ -977,10 +999,10 @@ LEFT OFF LAST TIME (7/23/2018): ;; TODO spec args #?(:clj -(defns fnt|overload>reify-overload +(defns expanded-overload>reify-overload [{:as overload :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, out-class t/class?]} - :fnt/overload + ::expanded-overload gen-gensym fn? > (s/seq-of ::reify|overload)] (let [interface-k {:out out-class :in arg-classes} @@ -1002,17 +1024,21 @@ LEFT OFF LAST TIME (7/23/2018): :method-sym fnt-method-sym :out-class out-class}))) -(defns >fnt|reify|name [fn|name ::uss/fn|name, i t/index? > simple-symbol?] - (>symbol (str fn|name "|__" i))) +(defns >reify|name + [{:keys [::uss/fn|name ::uss/fn|name, i|fnt-overload t/index? + i|expanded-overload-group t/index?]} _ > simple-symbol?] + (>symbol (str fn|name "|__" i|fnt-overload "|__" i|expanded-overload-group))) #?(:clj -(defns fnt|overload-group>reify - [{:keys [::uss/fn|name ::uss/fn|name, i t/index?, overload-group ::fnt|overload-group]} _ +(defns expanded-overload-group>reify + [{:as in + :keys [::uss/fn|name ::uss/fn|name, i|fnt-overload t/index?, i|expanded-overload-group t/index? + expanded-overload-group ::expanded-overload-group]} _ gen-gensym fn? > ::reify] - (let [reify-overloads (->> (concat [(:unprimitivized overload-group)] - (:primitivized overload-group)) - (c/map #(fnt|overload>reify-overload % gen-gensym))) - reify-name (>fnt|reify|name fn|name i) + (let [reify-overloads (->> (concat [(:unprimitivized expanded-overload-group)] + (:primitivized expanded-overload-group)) + (c/map #(expanded-overload>reify-overload % gen-gensym))) + reify-name (>reify|name in) form `(~'def ~reify-name ~(list* `reify* (->> reify-overloads (mapv #(-> % :interface >name >symbol))) @@ -1026,18 +1052,21 @@ LEFT OFF LAST TIME (7/23/2018): :name reify-name :overloads reify-overloads}))) -(defns >input-types-decl|name [fn|name ::uss/fn|name, i t/index? > simple-symbol?] - (>symbol (str fn|name "|__" i "|input-types"))) +(defns >input-types-decl|name + [fn|name ::uss/fn|name, i|fnt-overload t/index?, i|expanded-overload-group t/index? + > simple-symbol?] + (>symbol (str fn|name "|__" i|fnt-overload "|__" i|expanded-overload-group "|input-types"))) #?(:clj -(defns fnt|overload-group>input-types-decl - [{:keys [::uss/fn|name ::uss/fn|name, i t/index?, overload-group ::fnt|overload-group]} _ +(defns expanded-overload-group>input-types-decl + [{:keys [::uss/fn|name ::uss/fn|name, i t/index? + expanded-overload-group ::expanded-overload-group]} _ > ::input-types-decl] - (when (c/contains? (:arg-types|form overload-group)) - (let [decl-name (>input-types-decl|name fn|name i)] - {:form `(def ~(ufth/with-type-hint decl-name "[Ljava.lang.Object;") - (arr/*<> ~@(:arg-types|form overload-group))) - :name decl-name})))) + (when (c/contains? (:arg-types|form expanded-overload-group)) + (let [decl-name (>input-types-decl|name fn|name i)] + {:form `(def ~(ufth/with-type-hint decl-name "[Ljava.lang.Object;") + (arr/*<> ~@(:arg-types|form expanded-overload-group))) + :name decl-name})))) (def allowed-shorthand-tag-chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") (def min-shorthand-tag-length 1) @@ -1093,44 +1122,39 @@ LEFT OFF LAST TIME (7/23/2018): (defns unsupported! [name- _ #_t/qualified-symbol?, args t/indexed?, i t/index?] (TODO)) -;; TODO spec -(defns gen-register-type - "Registers in the map of qualified symbol to input type, to output type - - Example output: - (swap! ... assoc `abcde - (fn [args] (case (count args) 1 )))" - [{:keys [::uss/fn|name ::uss/fn|name, arg-ct->type _, variadic-overload ::fnt|overload-group]} _] - (unify-gensyms - `(swap! *fn->type assoc '~(qualify fn|name) - (xp/>expr - (fn [args##] (case (count args##) ~@arg-ct->type - ~@(when variadic-overload - [`(if (>= (count args##) (:positional-args-ct variadic-overload)) - (:out-type variadic-overload) - (err! "Arg count not enough for variadic overload"))]))))) - true)) - ;; TODO spec (defns >direct-dispatch - [{:keys [::uss/fn|name ::uss/fn|name, ::fnt|overload-groups (s/vec-of ::fnt|overload-group) - gen-gensym fn?, lang ::lang]} _ + [{:keys [::uss/fn|name ::uss/fn|name + expanded-overload-groups-by-fnt-overload (s/vec-of (s/vec-of ::expanded-overload-group)) + gen-gensym fn? + lang ::lang]} _ > ::direct-dispatch] (case lang - :clj (let [reify-groups - (->> fnt|overload-groups - (map-indexed - (fn [i {:as fnt|overload-group :keys [arg-types|form]}] - (let [in {:i i ::uss/fn|name fn|name :overload-group fnt|overload-group}] - {:fnt|reify (fnt|overload-group>reify in gen-gensym) - :input-types-decl (fnt|overload-group>input-types-decl in)})))) - form (->> reify-groups - (map (fn [{:keys [fnt|reify input-types-decl]}] - (cond-> [] - input-types-decl (conj (:form input-types-decl)) - true (conj (:form fnt|reify))))) - lcat)] - {:form form ::direct-dispatch|reify-groups reify-groups}) + :clj + (let [reify-groups + (->> expanded-overload-groups-by-fnt-overload + (map-indexed + (fn [i|fnt-overload expanded-overload-groups] + (->> expanded-overload-groups + (map-indexed + (fn [i|expanded-overload-group + {:as expanded-overload-group :keys [arg-types|form]}] + (let [in (assoc (kw-map i|fnt-overload + i|expanded-overload-group + expanded-overload-group) + ::uss/fn|name fn|name)] + {:reify + (expanded-overload-group>reify in gen-gensym) + :input-types-decl + (expanded-overload-group>input-types-decl in)})))))) + c/lcat) + form (->> reify-groups + (map (fn [{:keys [input-types-decl] reify- :reify}] + (cond-> [] + input-types-decl (conj (:form input-types-decl)) + true (conj (:form reify-))))) + lcat)] + {:form form ::direct-dispatch|reify-groups reify-groups}) :cljs (TODO))) ;; TODO spec @@ -1138,35 +1162,38 @@ LEFT OFF LAST TIME (7/23/2018): ;; TODO check whether it even needs to get created based on arglist length etc. ;; TODO `get-relevant-reify-overload` (defns >dynamic-dispatch-fn|form - [{:keys [::uss/fn|name ::uss/fn|name - ::fnt|overload-groups (s/vec-of ::fnt|overload-group) - gen-gensym fn? - lang ::lang - ::direct-dispatch|reify-groups ::direct-dispatch|reify-groups]} _] - (let [fnt|overload-group (first fnt|overload-groups) - arglist (ufgen/gen-args - 0 (-> fnt|overload-group :arg-types|form count) "x" gen-gensym) - i|arg 0 - arg-sym (get arglist i|arg) + [{:keys [::uss/fn|name ::uss/fn|name + expanded-overload-groups-by-fnt-overload (s/vec-of (s/vec-of ::expanded-overload-group)) + gen-gensym fn? + lang ::lang + ::direct-dispatch|reify-groups ::direct-dispatch|reify-groups]} _] + (let [;; TODO not right + expanded-overload-group (-> expanded-overload-groups-by-fnt-overload first first) + arglist (ufgen/gen-args 0 (-> expanded-overload-group :arg-types|form count) "x" gen-gensym) + i|arg 0 + arg-sym (get arglist i|arg) >reify-call - (fn [{:keys [fnt|reify input-types-decl]}] + (fn [{reify- :reify}] (let [;; TODO this is not general enough - relevant-reify-overload (get-in fnt|reify [:overloads 0]) + relevant-reify-overload (get-in reify- [:overloads 0]) dotted-reify-method-sym (symbol (str "." (:method-sym relevant-reify-overload))) hinted-reify-sym - (ufth/with-type-hint (:name fnt|reify) + (ufth/with-type-hint (:name reify-) (-> relevant-reify-overload :interface >name))] `(~dotted-reify-method-sym ~hinted-reify-sym ~@arglist)))] `(defn ~fn|name - {::t/type (t/fn ~@(->> fnt|overload-groups - (map (fn [{:keys [arg-types|form pre-type|form post-type|form]}] - (cond-> (or arg-types|form []) + {::t/type (t/fn ~@(->> expanded-overload-groups-by-fnt-overload + (map first) ; because what it needs is identical across groups + (map (fn [{:keys [arg-types|pre-split|form + pre-type|form post-type|form]}] + (cond-> (or arg-types|pre-split|form []) pre-type|form (conj :| pre-type|form) post-type|form (conj :> post-type|form))))))} (~arglist ~(if ;; TODO incrementally check this (or (empty? arglist) - (->> fnt|overload-group :unprimitivized :arg-types (every? #(t/= % t/any?)))) + (->> expanded-overload-group :unprimitivized :arg-types + (every? #(t/= % t/any?)))) (-> direct-dispatch|reify-groups first >reify-call) `(ifs ~@(->> direct-dispatch|reify-groups @@ -1195,26 +1222,10 @@ LEFT OFF LAST TIME (7/23/2018): (do (log/pr :warn "requested `:inline`; ignoring until feature is implemented") (update-meta fn|name dissoc :inline)) fn|name) - fnt|overload-groups - (->> overloads (mapv #(fnt|overload-data>overload-group % {::lang lang}))) - ;; only one variadic arg allowed - _ (s/validate fnt|overload-groups - (fn->> (c/lmap :unprimitivized) (c/lfilter :variadic?) count (<- (<= 1)))) - arg-ct->type (->> fnt|overload-groups - (c/map+ :unprimitivized) - (remove+ :variadic?) - (c/group-by :positional-args-ct) - (map-vals+ :out-type) - join lcat) - variadic-overload (->> fnt|overload-groups - (c/lmap :unprimitivized) - (c/lfilter :variadic?) - first) - register-type (gen-register-type - (assoc (kw-map arg-ct->type variadic-overload) - ::uss/fn|name fn|name)) - args (assoc (kw-map gen-gensym lang) - ::fnt|overload-groups fnt|overload-groups ::uss/fn|name fn|name) + expanded-overload-groups-by-fnt-overload + (->> overloads (mapv #(fnt|overload-data>expanded-overload-groups % {::lang lang}))) + args (assoc (kw-map expanded-overload-groups-by-fnt-overload gen-gensym lang) + ::uss/fn|name fn|name) {:as direct-dispatch :keys [::direct-dispatch|reify-groups]} (>direct-dispatch args) _ (prl! direct-dispatch) fn-codelist @@ -1225,16 +1236,9 @@ LEFT OFF LAST TIME (7/23/2018): ::direct-dispatch|reify-groups direct-dispatch|reify-groups))] (remove nil?)) :cljs (TODO)) - overloads|code (->> fnt|overload-groups (c/map+ :unprimitivized) (c/map :code)) - _ (prl! overloads) code (case kind - :fn (list* 'fn (concat - (if (contains? args' ::uss/fn|name) - [fn|name] - []) - [overloads|code])) - :defn `(~'do #_~register-type ; elide for now - ~@fn-codelist))] + :fn (TODO) + :defn `(~'do ~@fn-codelist))] code)) #?(:clj (defmacro fnt [& args] (fnt|code :fn (ufeval/env-lang) args))) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 87c18ede..2da485ca 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -1,6 +1,7 @@ ;; See https://jsperf.com/js-property-access-comparison — all property accesses (at least of length 1) seem to be equal (ns quantum.core.test.defnt-equivalences + (:refer-clojure :exclude [*]) (:require [clojure.core :as c] [quantum.core.defnt @@ -44,7 +45,7 @@ (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) (.getName)))) expected - ($ (do (def ~'pid|test|__0 + ($ (do (def ~'pid|test|__0|__0 (reify* [>Object] (~(tag "java.lang.Object" 'invoke) [~'_0__] ~'(->> (java.lang.management.ManagementFactory/getRuntimeMXBean) @@ -52,7 +53,7 @@ (defn ~'pid|test {::t/type (t/fn [:> ~'(? t/string?)])} ([] (.invoke ~(tag "quantum.core.test.defnt_equivalences.>Object" - 'pid|test|__0))))))] + 'pid|test|__0|__0))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) diff --git a/test/quantum/test/core/defnt.cljc b/test/quantum/test/core/defnt.cljc index a3423a2b..13567164 100644 --- a/test/quantum/test/core/defnt.cljc +++ b/test/quantum/test/core/defnt.cljc @@ -29,6 +29,25 @@ [clojure.lang Keyword Symbol] [quantum.core Numeric]))) +(deftest test|arg-types>split + (is= (this/arg-types>split + [(t/or t/byte? t/double? t/string?) + (t/or t/map? t/byte?)]) + [[(t/isa? Byte) (t/isa? clojure.lang.ITransientMap)] + [(t/isa? Byte) (t/isa? clojure.lang.IPersistentMap)] + [(t/isa? Byte) (t/isa? java.util.Map)] + [(t/isa? Byte) (t/isa? Byte)] + [(t/isa? Double) (t/isa? clojure.lang.ITransientMap)] + [(t/isa? Double) (t/isa? clojure.lang.IPersistentMap)] + [(t/isa? Double) (t/isa? java.util.Map)] + [(t/isa? Double) (t/isa? Byte)] + [(t/isa? String) (t/isa? clojure.lang.ITransientMap)] + [(t/isa? String) (t/isa? clojure.lang.IPersistentMap)] + [(t/isa? String) (t/isa? java.util.Map)] + [(t/isa? String) (t/isa? Byte)]])) + +;; ============== OLD TESTS ============== ;; + ;; # args | ret | ? arg specs (delimited by `,`) ;; abstract > concrete > concrete #?(:clj (def t0> java.io.OutputStream)) @@ -721,7 +740,3 @@ [[a number? b number? :as b] ^:gen? (s/nonconforming (s/cat :a double? :b double?))]) (defspec-test test|gen|seq|1 `gen|seq|1) - - - - From 96016d9c811d8320af5759ba8f85e58fd2c9ca0a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 00:22:39 -0600 Subject: [PATCH 127/810] `>form`; lots closer with more test cases passing! --- src-dev/quantum/core/defnt.cljc | 25 ++++++---- src-dev/quantum/core/defnt_equivalences.cljc | 22 ++++----- src-untyped/quantum/untyped/core/form.cljc | 7 +++ .../untyped/core/type/reifications.cljc | 48 +++++++++++-------- 4 files changed, 63 insertions(+), 39 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index ff75413b..d6430211 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -36,7 +36,8 @@ [quantum.untyped.core.fn :refer [aritoid fn1 fnl fn', fn-> fn->> <-, rcomp firsta seconda]] - [quantum.untyped.core.form :as uform] + [quantum.untyped.core.form :as uform + :refer [>form]] [quantum.untyped.core.form.evaluate :as ufeval] [quantum.untyped.core.form.generate :as ufgen :refer [unify-gensyms]] @@ -80,7 +81,12 @@ #_" -LEFT OFF LAST TIME (7/23/2018): +LEFT OFF LAST TIME (7/24/2018): +- ;; TODO probably failing because class vs. symbol +- This is because of the `>form` not quite returning the right thing for `t/isa?` stuff in reifications +- After that, keep going making sure the test cases pass, especially the >int* cases + + - With `defnt`, protocols and interfaces aren't needed. You can just create `t/fn`s that you can then conform your fns to. @@ -895,7 +901,7 @@ LEFT OFF LAST TIME (7/23/2018): pre-type|form ::expanded-overload-group|pre-type|form post-type|form ::expanded-overload-group|post-type|form]} _ > ::expanded-overload-group] - (let [arg-types|form (->> arg-types (mapv fipp.ednize/edn)) + (let [arg-types|form (mapv >form arg-types) ;; `unprimitivized` is first because of class sorting [unprimitivized & primitivized :as overloads] (->> arg-types @@ -1027,7 +1033,7 @@ LEFT OFF LAST TIME (7/23/2018): (defns >reify|name [{:keys [::uss/fn|name ::uss/fn|name, i|fnt-overload t/index? i|expanded-overload-group t/index?]} _ > simple-symbol?] - (>symbol (str fn|name "|__" i|fnt-overload "|__" i|expanded-overload-group))) + (>symbol (str fn|name "|__" i|fnt-overload "|" i|expanded-overload-group))) #?(:clj (defns expanded-overload-group>reify @@ -1053,17 +1059,18 @@ LEFT OFF LAST TIME (7/23/2018): :overloads reify-overloads}))) (defns >input-types-decl|name - [fn|name ::uss/fn|name, i|fnt-overload t/index?, i|expanded-overload-group t/index? - > simple-symbol?] - (>symbol (str fn|name "|__" i|fnt-overload "|__" i|expanded-overload-group "|input-types"))) + [{:keys [::uss/fn|name ::uss/fn|name, i|fnt-overload t/index? + i|expanded-overload-group t/index?]} _ > simple-symbol?] + (>symbol (str fn|name "|__" i|fnt-overload "|" i|expanded-overload-group "|input-types"))) #?(:clj (defns expanded-overload-group>input-types-decl - [{:keys [::uss/fn|name ::uss/fn|name, i t/index? + [{:as in + :keys [::uss/fn|name ::uss/fn|name, i|fnt-overload t/index?, i|expanded-overload-group t/index? expanded-overload-group ::expanded-overload-group]} _ > ::input-types-decl] (when (c/contains? (:arg-types|form expanded-overload-group)) - (let [decl-name (>input-types-decl|name fn|name i)] + (let [decl-name (>input-types-decl|name in)] {:form `(def ~(ufth/with-type-hint decl-name "[Ljava.lang.Object;") (arr/*<> ~@(:arg-types|form expanded-overload-group))) :name decl-name})))) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 2da485ca..14108e27 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -45,7 +45,7 @@ (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) (.getName)))) expected - ($ (do (def ~'pid|test|__0|__0 + ($ (do (def ~'pid|test|__0|0 (reify* [>Object] (~(tag "java.lang.Object" 'invoke) [~'_0__] ~'(->> (java.lang.management.ManagementFactory/getRuntimeMXBean) @@ -53,7 +53,7 @@ (defn ~'pid|test {::t/type (t/fn [:> ~'(? t/string?)])} ([] (.invoke ~(tag "quantum.core.test.defnt_equivalences.>Object" - 'pid|test|__0|__0))))))] + 'pid|test|__0|0))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) @@ -71,10 +71,10 @@ :clj ($ (do ;; [x t/any?] - (def ~(tag "[Ljava.lang.Object;" 'identity|uninlined|__0|input-types) - (*<> ~'t/any?)) + (def ~(tag "[Ljava.lang.Object;" 'identity|uninlined|__0|0|input-types) + (*<> t/any?)) ;; One `reify` because `t/any?` in CLJ does not have any `t/or`-separability - (def ~'identity|uninlined|__0 + (def ~'identity|uninlined|__0|0 (reify* [Object>Object boolean>boolean byte>byte short>short char>char int>int long>long float>float double>double] (~(tag "java.lang.Object" 'invoke) @@ -102,7 +102,7 @@ ;; Checks elided because `t/any?` doesn't require a check ;; and all args are `t/=` `t/any?` (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" - 'identity|uninlined|__0) ~'x00__))))) + 'identity|uninlined|__0|0) ~'x00__))))) :cljs ;; Direct dispatch will be simple functions, not `reify`s ($ (do (defn ~'identity|uninlined [~'x] ~'x))))] @@ -128,8 +128,8 @@ ;; [t/string?] - (def ~(tag "[Ljava.lang.Object;" 'name|test|__0|input-types) - (*<> ~'t/string?)) + (def ~(tag "[Ljava.lang.Object;" 'name|test|__0|0|input-types) + (*<> (t/isa? java.lang.String))) ;; TODO probably failing because class vs. symbol (def ~'name|test|__0 (reify* [Object>Object] (~(tag "java.lang.Object" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] @@ -137,7 +137,7 @@ ;; [(t/isa? Named)] - (def ~(tag "[Ljava.lang.Object;" 'name|test|__1|input-types) + (def ~(tag "[Ljava.lang.Object;" 'name|test|__1|0|input-types) (*<> ~'(t/isa? Named))) (def ~'name|test|__1 (reify* [Object>Object] @@ -150,10 +150,10 @@ (t/fn ~'[t/string? :> t/string?] ~'[(t/isa? Named) :> (* t/string?)])} ([~'x00__] - (ifs ((Array/get ~'name|test|__0|input-types 0) ~'x00__) + (ifs ((Array/get ~'name|test|__0|0|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" 'name|test|__0) ~'x00__) - ((Array/get ~'name|test|__1|input-types 0) ~'x00__) + ((Array/get ~'name|test|__1|0|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" 'name|test|__1) ~'x00__) (unsupported! `name|test [~'x00__] 0)))))) diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index 06486520..b458006e 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -8,6 +8,13 @@ (ucore/log-this-ns) +(defprotocol PGenForm + (>form [this] "Returns the form associated with the object. + If evaluated, the form should evaluate to something exactly equivalent to the + value of the object (even stronger than a `=` guarantee — all properties up to + but not including identity). + Effectively the inverse of `eval`.")) + (defn core-symbol [env sym] (symbol (str (case-env* env :cljs "cljs" "clojure") ".core") (name sym))) ;; TODO move this code generation code to a different namespace diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 376a1721..6b9d666b 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -11,6 +11,8 @@ [quantum.untyped.core.data.hash :as uhash] [quantum.untyped.core.defnt :refer [defns]] + [quantum.untyped.core.form :as uform + :refer [>form]] [quantum.untyped.core.form.generate.deftype :as udt]) #?(:clj (:import [quantum.untyped.core.analyze.expr Expression]))) @@ -34,6 +36,7 @@ ?Hash {hash ([this] (hash UniversalSetType))} ?Object {hash-code ([this] (uhash/code UniversalSetType)) equals ([this that] (or (== this that) (instance? UniversalSetType that)))} + uform/PGenForm {>form ([this] 'quantum.untyped.core.type/any?)} fedn/IOverride nil fedn/IEdn {-edn ([this] 'quantum.untyped.core.type/U)}}) @@ -50,8 +53,9 @@ ?Hash {hash ([this] (hash EmptySetType))} ?Object {hash-code ([this] (uhash/code EmptySetType)) equals ([this that] (or (== this that) (instance? EmptySetType that)))} + uform/PGenForm {>form ([this] 'quantum.untyped.core.type/none?)} fedn/IOverride nil - fedn/IEdn {-edn ([this] 'quantum.untyped.core.type/∅)}}) + fedn/IEdn {-edn ([this] 'quantum.untyped.core.type/∅)}}) (def empty-set (EmptySetType.)) @@ -69,8 +73,9 @@ (or (== this that) (and (instance? NotType that) (= t (.-t ^NotType that)))))} + uform/PGenForm {>form ([this] (list 'quantum.untyped.core.type/not t))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (list 'quantum.untyped.core.type/not t))}}) + fedn/IEdn {-edn ([this] (>form this))}}) (defns not-type? [x _ > boolean?] (instance? NotType x)) @@ -96,8 +101,9 @@ (or (== this that) (and (instance? OrType that) (= args (.-args ^OrType that)))))} + uform/PGenForm {>form ([this] (list* 'quantum.untyped.core.type/or args))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (list* 'quantum.untyped.core.type/or args))}}) + fedn/IEdn {-edn ([this] (>form this))}}) (defns or-type? [x _ > boolean?] (instance? OrType x)) @@ -111,8 +117,6 @@ args #_(t/and t/indexed? (t/seq t/type?)) *logical-complement] {PType nil - fedn/IOverride nil - fedn/IEdn {-edn ([this] (list* 'quantum.untyped.core.type/and args))} ?Fn {invoke ([_ x] (reduce (fn [_ t] (or (t x) (reduced false))) true ; vacuously args))} @@ -121,7 +125,10 @@ equals ([this that] (or (== this that) (and (instance? AndType that) - (= args (.-args ^AndType that)))))}}) + (= args (.-args ^AndType that)))))} + uform/PGenForm {>form ([this] (list* 'quantum.untyped.core.type/and args))} + fedn/IOverride nil + fedn/IEdn {-edn ([this] (>form this))}}) (defns and-type? [x _ > boolean?] (instance? AndType x)) @@ -140,8 +147,6 @@ p #_t/protocol? name #_(t/? t/symbol?)] {PType nil - fedn/IOverride nil - fedn/IEdn {-edn ([this] (or name (list 'quantum.untyped.core.type/isa?|protocol (:on p))))} ?Fn {invoke ([_ x] (satisfies? p x))} ?Meta {meta ([this] meta) with-meta ([this meta'] (ProtocolType. hash hash-code meta' p name))} @@ -150,7 +155,10 @@ equals ([this that #_any?] (or (== this that) (and (instance? ProtocolType that) - (= p (.-p ^ProtocolType that)))))}}) + (= p (.-p ^ProtocolType that)))))} + uform/PGenForm {>form ([this] (list 'quantum.untyped.core.type/isa?|protocol (:on p)))} + fedn/IOverride nil + fedn/IEdn {-edn ([this] (or name (>form this)))}}) (defns protocol-type? [x _] (instance? ProtocolType x)) @@ -165,8 +173,6 @@ ^Class c #_t/class? name #_(t/? t/symbol?)] {PType nil - fedn/IOverride nil - fedn/IEdn {-edn ([this] (or name (list 'quantum.untyped.core.type/isa? c)))} ?Fn {invoke ([_ x] (instance? c x))} ?Meta {meta ([this] meta) with-meta ([this meta'] (ClassType. hash hash-code meta' c name))} @@ -175,7 +181,10 @@ equals ([this that #_any?] (or (== this that) (and (instance? ClassType that) - (= c (.-c ^ClassType that)))))}}) + (= c (.-c ^ClassType that)))))} + uform/PGenForm {>form ([this] (list 'quantum.untyped.core.type/isa? c))} + fedn/IOverride nil + fedn/IEdn {-edn ([this] (or name (>form this)))}}) (defns class-type? [x _] (instance? ClassType x)) @@ -188,15 +197,16 @@ ^int ^:unsynchronized-mutable hash-code v #_any?] {PType nil - fedn/IOverride nil - fedn/IEdn {-edn ([this] (list 'quantum.untyped.core.type/value v))} - ?Fn {invoke ([_ x] (= x v))} + ?Fn {invoke ([_ x] (= x v))} ?Hash {hash ([this] (uhash/caching-set-ordered! hash ValueType v))} ?Object {hash-code ([this] (uhash/caching-set-code! hash-code ValueType v)) - equals ([this that #_any?] - (or (== this that) - (and (instance? ValueType that) - (= v (.-v ^ValueType that)))))}}) + equals ([this that #_any?] + (or (== this that) + (and (instance? ValueType that) + (= v (.-v ^ValueType that)))))} + uform/PGenForm {>form ([this] (list 'quantum.untyped.core.type/value v))} + fedn/IOverride nil + fedn/IEdn {-edn ([this] (>form this))}}) (defns value-type? [x _] (instance? ValueType x)) From 4ae7cf781afabbb33fe7f21e86d6afb462b7f3c8 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 09:13:53 -0600 Subject: [PATCH 128/810] Another test passes! --- src-dev/quantum/core/defnt_equivalences.cljc | 10 +++++----- src-untyped/quantum/untyped/core/convert.cljc | 3 ++- src-untyped/quantum/untyped/core/error.cljc | 2 +- src-untyped/quantum/untyped/core/form.cljc | 4 ++++ .../quantum/untyped/core/type/reifications.cljc | 13 +++++++------ 5 files changed, 19 insertions(+), 13 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 14108e27..720b16f7 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -130,7 +130,7 @@ (def ~(tag "[Ljava.lang.Object;" 'name|test|__0|0|input-types) (*<> (t/isa? java.lang.String))) ;; TODO probably failing because class vs. symbol - (def ~'name|test|__0 + (def ~'name|test|__0|0 (reify* [Object>Object] (~(tag "java.lang.Object" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] (let* [~(tag "java.lang.String" 'x) ~'x] ~'x)))) @@ -138,8 +138,8 @@ ;; [(t/isa? Named)] (def ~(tag "[Ljava.lang.Object;" 'name|test|__1|0|input-types) - (*<> ~'(t/isa? Named))) - (def ~'name|test|__1 + (*<> (t/isa? Named))) + (def ~'name|test|__1|0 (reify* [Object>Object] (~(tag "java.lang.Object" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] (let* [~(tag "clojure.lang.Named" 'x) ~'x] @@ -152,10 +152,10 @@ ([~'x00__] (ifs ((Array/get ~'name|test|__0|0|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" - 'name|test|__0) ~'x00__) + 'name|test|__0|0) ~'x00__) ((Array/get ~'name|test|__1|0|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" - 'name|test|__1) ~'x00__) + 'name|test|__1|0) ~'x00__) (unsupported! `name|test [~'x00__] 0)))))) :cljs ($ (do (defn ~'name|test [~'x00__] diff --git a/src-untyped/quantum/untyped/core/convert.cljc b/src-untyped/quantum/untyped/core/convert.cljc index 39eaa41a..f3e10741 100644 --- a/src-untyped/quantum/untyped/core/convert.cljc +++ b/src-untyped/quantum/untyped/core/convert.cljc @@ -80,7 +80,8 @@ (string? x) (symbol x) (or (keyword? x) #?(:clj (var? x))) (symbol (>?namespace x) (>name x)) -#?@(:clj [(namespace? x) (ns-name x)]) +#?@(:clj [(class? x) (-> x >name symbol) + (namespace? x) (ns-name x)]) (fn? x) #?(:clj (or (when-let [ns- (-> x meta :ns)] (symbol (>name ns-) (-> x meta :name >name))) (-> x class .getName clojure.lang.Compiler/demunge recur)) diff --git a/src-untyped/quantum/untyped/core/error.cljc b/src-untyped/quantum/untyped/core/error.cljc index 02007f43..a7e95bfe 100644 --- a/src-untyped/quantum/untyped/core/error.cljc +++ b/src-untyped/quantum/untyped/core/error.cljc @@ -22,7 +22,7 @@ ;; ===== Types ===== ;; ;; TODO move this? -;; TODO add to these types based on HTTP response types? +;; TODO add to these types based on HTTP response types, Java(Script) built-in errors, etc.? (def ^{:doc "Adapted from `com.cognitect/anomalies`"} types {:quantum.core.error/unavailable {:caller-can-retry? true :resolution-strategy "make sure callee healthy"} diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index b458006e..d39c0606 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -15,6 +15,10 @@ but not including identity). Effectively the inverse of `eval`.")) +(extend-protocol PGenForm + nil (>form [this] nil) + #?@(:clj [Class (>form [this] (-> this #_uconv/>symbol .getName symbol))])) + (defn core-symbol [env sym] (symbol (str (case-env* env :cljs "cljs" "clojure") ".core") (name sym))) ;; TODO move this code generation code to a different namespace diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 6b9d666b..70baa20b 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -73,7 +73,7 @@ (or (== this that) (and (instance? NotType that) (= t (.-t ^NotType that)))))} - uform/PGenForm {>form ([this] (list 'quantum.untyped.core.type/not t))} + uform/PGenForm {>form ([this] (list 'quantum.untyped.core.type/not (>form t)))} fedn/IOverride nil fedn/IEdn {-edn ([this] (>form this))}}) @@ -101,7 +101,7 @@ (or (== this that) (and (instance? OrType that) (= args (.-args ^OrType that)))))} - uform/PGenForm {>form ([this] (list* 'quantum.untyped.core.type/or args))} + uform/PGenForm {>form ([this] (list* 'quantum.untyped.core.type/or (map >form args)))} fedn/IOverride nil fedn/IEdn {-edn ([this] (>form this))}}) @@ -126,7 +126,7 @@ (or (== this that) (and (instance? AndType that) (= args (.-args ^AndType that)))))} - uform/PGenForm {>form ([this] (list* 'quantum.untyped.core.type/and args))} + uform/PGenForm {>form ([this] (list* 'quantum.untyped.core.type/and (map >form args)))} fedn/IOverride nil fedn/IEdn {-edn ([this] (>form this))}}) @@ -156,7 +156,8 @@ (or (== this that) (and (instance? ProtocolType that) (= p (.-p ^ProtocolType that)))))} - uform/PGenForm {>form ([this] (list 'quantum.untyped.core.type/isa?|protocol (:on p)))} + uform/PGenForm {>form ([this] (list 'quantum.untyped.core.type/isa?|protocol + (-> p :on >form)))} fedn/IOverride nil fedn/IEdn {-edn ([this] (or name (>form this)))}}) @@ -182,7 +183,7 @@ (or (== this that) (and (instance? ClassType that) (= c (.-c ^ClassType that)))))} - uform/PGenForm {>form ([this] (list 'quantum.untyped.core.type/isa? c))} + uform/PGenForm {>form ([this] (list 'quantum.untyped.core.type/isa? (>form c)))} fedn/IOverride nil fedn/IEdn {-edn ([this] (or name (>form this)))}}) @@ -204,7 +205,7 @@ (or (== this that) (and (instance? ValueType that) (= v (.-v ^ValueType that)))))} - uform/PGenForm {>form ([this] (list 'quantum.untyped.core.type/value v))} + uform/PGenForm {>form ([this] (list 'quantum.untyped.core.type/value (>form v)))} fedn/IOverride nil fedn/IEdn {-edn ([this] (>form this))}}) From 0c5ade6d1e1a29cb606f04a716124c89c1a42c54 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 09:16:41 -0600 Subject: [PATCH 129/810] Another one passes! --- src-dev/quantum/core/defnt_equivalences.cljc | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 720b16f7..4e10851d 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -187,17 +187,17 @@ :clj ($ (do ;; [x t/nil?] - (def ~(tag "[Ljava.lang.Object;" 'some?|test|__0|input-types) - (*<> ~'t/nil?)) - (def ~'some?|test|__0 + (def ~(tag "[Ljava.lang.Object;" 'some?|test|__0|0|input-types) + (*<> t/nil?)) + (def ~'some?|test|__0|0 (reify* [Object>boolean] (~(tag "boolean" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] false))) ;; [x t/any?] - (def ~(tag "[Ljava.lang.Object;" 'some?|test|__1|input-types) - (*<> ~'t/any?)) - (def ~'some?|test|__1 + (def ~(tag "[Ljava.lang.Object;" 'some?|test|__1|0|input-types) + (*<> t/any?)) + (def ~'some?|test|__1|0 (reify* [Object>boolean boolean>boolean byte>boolean short>boolean char>boolean int>boolean long>boolean float>boolean double>boolean] (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] true) @@ -214,13 +214,13 @@ {::t/type (t/fn ~'[t/nil?] ~'[t/any?])} ([~'x00__] - (ifs ((Array/get ~'some?|test|__0|input-types 0) ~'x00__) + (ifs ((Array/get ~'some?|test|__0|0|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" - 'some?|test|__0) ~'x00__) + 'some?|test|__0|0) ~'x00__) ;; TODO eliminate this check because it's not needed (`t/any?`) - ((Array/get ~'some?|test|__1|input-types 0) ~'x00__) + ((Array/get ~'some?|test|__1|0|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" - 'some?|test|__1) ~'x00__) + 'some?|test|__1|0) ~'x00__) (unsupported! `some?|test [~'x00__] 0)))))) :cljs ($ (do (defn ~'some?|test [~'x] From 944410e25da3bd4d8702f060487a71f89bcffbe3 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 09:17:13 -0600 Subject: [PATCH 130/810] And another! --- src-dev/quantum/core/defnt_equivalences.cljc | 22 ++++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 4e10851d..b818fb16 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -188,7 +188,7 @@ ($ (do ;; [x t/nil?] (def ~(tag "[Ljava.lang.Object;" 'some?|test|__0|0|input-types) - (*<> t/nil?)) + (*<> (t/value nil))) (def ~'some?|test|__0|0 (reify* [Object>boolean] (~(tag "boolean" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] false))) @@ -248,18 +248,18 @@ :clj ($ (do ;; [x (t/isa? Reduced)] - (def ~(tag "[Ljava.lang.Object;" 'reduced?|test|__0|input-types) - (*<> ~'(t/isa? Reduced))) - (def ~'reduced?|test|__0 + (def ~(tag "[Ljava.lang.Object;" 'reduced?|test|__0|0|input-types) + (*<> (t/isa? Reduced))) + (def ~'reduced?|test|__0|0 (reify* [Object>boolean] (~(tag "boolean" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] (let* [~(tag "clojure.lang.Reduced" 'x) ~'x] true)))) ;; [x t/any?] - (def ~(tag "[Ljava.lang.Object;" 'reduced?|test|__1|input-types) - (*<> ~'t/any?)) - (def ~'reduced?|test|__1 + (def ~(tag "[Ljava.lang.Object;" 'reduced?|test|__1|0|input-types) + (*<> t/any?)) + (def ~'reduced?|test|__1|0 (reify* [Object>boolean boolean>boolean byte>boolean short>boolean char>boolean int>boolean long>boolean float>boolean double>boolean] (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false) @@ -276,13 +276,13 @@ {::t/type (t/fn ~'[(t/isa? Reduced)] ~'[t/any?])} ([~'x00__] - (ifs ((Array/get ~'reduced?|test|__0|input-types 0) ~'x00__) + (ifs ((Array/get ~'reduced?|test|__0|0|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" - 'reduced?|test|__0) ~'x00__) + 'reduced?|test|__0|0) ~'x00__) ;; TODO eliminate this check because it's not needed (`t/any?`) - ((Array/get ~'reduced?|test|__1|input-types 0) ~'x00__) + ((Array/get ~'reduced?|test|__1|0|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" - 'reduced?|test|__1) ~'x00__) + 'reduced?|test|__1|0) ~'x00__) (unsupported! `reduced?|test [~'x00__] 0)))))) :cljs ($ (do (defn ~'reduced?|test [~'x] From a0373282ee5ccded73fb8662b3310612df3cd356 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 09:18:33 -0600 Subject: [PATCH 131/810] And another! --- src-dev/quantum/core/defnt_equivalences.cljc | 30 ++++++++++---------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index b818fb16..1c200313 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -312,25 +312,25 @@ :clj ($ (do ;; [x t/boolean?] - (def ~(tag "[Ljava.lang.Object;" '>boolean|__0|input-types) - (*<> ~'t/boolean?)) - (def ~'>boolean|__0 + (def ~(tag "[Ljava.lang.Object;" '>boolean|__0|0|input-types) + (*<> (t/isa? Boolean))) + (def ~'>boolean|__0|0 (reify* [boolean>boolean] (~(tag "boolean" 'invoke) [~'_0__ ~(tag "boolean" 'x)] ~'x))) ;; [x t/nil? -> (- t/nil? t/boolean?)] - (def ~(tag "[Ljava.lang.Object;" '>boolean|__1|input-types) - (*<> ~'t/nil?)) - (def ~'>boolean|__1 + (def ~(tag "[Ljava.lang.Object;" '>boolean|__1|0|input-types) + (*<> (t/value nil))) + (def ~'>boolean|__1|0 (reify* [Object>boolean] (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false))) ;; [x t/any? -> (- t/any? t/nil? t/boolean?)] - (def ~(tag "[Ljava.lang.Object;" '>boolean|__2|input-types) - (*<> ~'t/any?)) - (def ~'>boolean|__2 + (def ~(tag "[Ljava.lang.Object;" '>boolean|__2|0|input-types) + (*<> t/any?)) + (def ~'>boolean|__2|0 (reify* [Object>boolean boolean>boolean byte>boolean short>boolean char>boolean int>boolean long>boolean float>boolean double>boolean] (~(tag "boolean" 'invoke) [~'_2__ ~(tag "java.lang.Object" 'x)] true) @@ -348,16 +348,16 @@ ~'[t/nil?] ~'[t/any?])} ([~'x00__] - (ifs ((Array/get ~'>boolean|__0|input-types 0) ~'x00__) + (ifs ((Array/get ~'>boolean|__0|0|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.boolean>boolean" - '>boolean|__0) ~'x00__) - ((Array/get ~'>boolean|__1|input-types 0) ~'x00__) + '>boolean|__0|0) ~'x00__) + ((Array/get ~'>boolean|__1|0|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" - '>boolean|__1) ~'x00__) + '>boolean|__1|0) ~'x00__) ;; TODO eliminate this check because it's not needed (`t/any?`) - ((Array/get ~'>boolean|__2|input-types 0) ~'x00__) + ((Array/get ~'>boolean|__2|0|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" - '>boolean|__2) ~'x00__) + '>boolean|__2|0) ~'x00__) (unsupported! `>boolean [~'x00__] 0)))))) :cljs ($ (do (defn ~'>boolean [~'x] From d4a64d5a515e10c3b35d77be5f286ae1fc5df23d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 10:58:35 -0600 Subject: [PATCH 132/810] Oh my gosh, code is equivalent for `>int*`! --- src-dev/quantum/core/defnt_equivalences.cljc | 84 +++++++++---------- src-untyped/quantum/untyped/core/type.cljc | 2 +- .../untyped/core/type/reifications.cljc | 9 +- 3 files changed, 49 insertions(+), 46 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 1c200313..8f2223a0 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -392,51 +392,51 @@ :clj ($ (do ;; [x (t/- t/primitive? t/boolean?)] - (def ~(tag "[Ljava.lang.Object;" '>int*|__0|__0|input-types) - (*<> ~'(t/isa? java.lang.Byte))) - (def ~'>int*|__0|__0 + (def ~(tag "[Ljava.lang.Object;" '>int*|__0|0|input-types) + (*<> (t/isa? java.lang.Byte))) + (def ~'>int*|__0|0 (reify* [byte>int] (~(tag "int" 'invoke) [~'_0__ ~(tag "byte" 'x)] ~'(Primitive/uncheckedIntCast x)))) - (def ~(tag "[Ljava.lang.Object;" '>int*|__0|__1|input-types) - (*<> ~'(t/isa? java.lang.Short))) - (def ~'>int*|__0|__1 + (def ~(tag "[Ljava.lang.Object;" '>int*|__0|1|input-types) + (*<> (t/isa? java.lang.Short))) + (def ~'>int*|__0|1 (reify* [short>int] (~(tag "int" 'invoke) [~'_1__ ~(tag "short" 'x)] ~'(Primitive/uncheckedIntCast x)))) - (def ~(tag "[Ljava.lang.Object;" '>int*|__0|__2|input-types) - (*<> ~'(t/isa? java.lang.Character))) - (def ~'>int*|__0|__2 + (def ~(tag "[Ljava.lang.Object;" '>int*|__0|2|input-types) + (*<> (t/isa? java.lang.Character))) + (def ~'>int*|__0|2 (reify* [char>int] (~(tag "int" 'invoke) [~'_2__ ~(tag "char" 'x)] ~'(Primitive/uncheckedIntCast x)))) - (def ~(tag "[Ljava.lang.Object;" '>int*|__0|__3|input-types) - (*<> ~'(t/isa? java.lang.Integer))) - (def ~'>int*|__0|__3 + (def ~(tag "[Ljava.lang.Object;" '>int*|__0|3|input-types) + (*<> (t/isa? java.lang.Integer))) + (def ~'>int*|__0|3 (reify* [int>int] (~(tag "int" 'invoke) [~'_3__ ~(tag "int" 'x)] ~'(Primitive/uncheckedIntCast x)))) - (def ~(tag "[Ljava.lang.Object;" '>int*|__0|__4|input-types) - (*<> ~'(t/isa? java.lang.Long))) - (def ~'>int*|__0|__4 + (def ~(tag "[Ljava.lang.Object;" '>int*|__0|4|input-types) + (*<> (t/isa? java.lang.Long))) + (def ~'>int*|__0|4 (reify* [long>int] (~(tag "int" 'invoke) [~'_4__ ~(tag "long" 'x)] ~'(Primitive/uncheckedIntCast x)))) - (def ~(tag "[Ljava.lang.Object;" '>int*|__0|__5|input-types) - (*<> ~'(t/isa? java.lang.Float))) - (def ~'>int*|__0|__5 + (def ~(tag "[Ljava.lang.Object;" '>int*|__0|5|input-types) + (*<> (t/isa? java.lang.Float))) + (def ~'>int*|__0|5 (reify* [float>int] (~(tag "int" 'invoke) [~'_5__ ~(tag "float" 'x)] ~'(Primitive/uncheckedIntCast x)))) - (def ~(tag "[Ljava.lang.Object;" '>int*|__0|__6|input-types) - (*<> ~'(t/isa? java.lang.Double))) - (def ~'>int*|__0|__6 + (def ~(tag "[Ljava.lang.Object;" '>int*|__0|6|input-types) + (*<> (t/isa? java.lang.Double))) + (def ~'>int*|__0|6 (reify* [double>int] (~(tag "int" 'invoke) [~'_6__ ~(tag "double" 'x)] ~'(Primitive/uncheckedIntCast x)))) @@ -444,41 +444,41 @@ ;; [x (t/ref (t/isa? Number)) ;; -> (t/- (t/ref (t/isa? Number)) (t/- t/primitive? t/boolean?))] - (def ~(tag "[Ljava.lang.Object;" '>int*|__1|input-types) - (*<> ~'(t/ref (t/isa? Number)))) - (def ~'>int*|__1 + (def ~(tag "[Ljava.lang.Object;" '>int*|__1|0|input-types) + (*<> ~(with-meta `(t/isa? Number) {:ref? true}))) + (def ~'>int*|__1|0 (reify* [Object>int] (~(tag "int" 'invoke) [~'_7__ ~(tag "java.lang.Object" 'x)] (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(.intValue x))))) (defn ~'>int* - {::t/type (t/fn ~'[(t/- t/primitive? t/boolean?)] - ~'[(t/ref (t/isa? Number))])} + {::t/type (t/fn ~'[(t/- t/primitive? t/boolean?) :> t/int?] + ~'[(t/ref (t/isa? Number)) :> t/int?])} ([~'x00__] - (ifs ((Array/get ~'>int*|__0|__0|input-types 0) ~'x00__) + (ifs ((Array/get ~'>int*|__0|0|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.byte>int" - '>int*|__0|__0) ~'x00__) - ((Array/get ~'>int*|__0|__1|input-types 0) ~'x00__) + '>int*|__0|0) ~'x00__) + ((Array/get ~'>int*|__0|1|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.short>int" - '>int*|__0|__1) ~'x00__) - ((Array/get ~'>int*|__0|__2|input-types 0) ~'x00__) + '>int*|__0|1) ~'x00__) + ((Array/get ~'>int*|__0|2|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.char>int" - '>int*|__0|__2) ~'x00__) - ((Array/get ~'>int*|__0|__3|input-types 0) ~'x00__) + '>int*|__0|2) ~'x00__) + ((Array/get ~'>int*|__0|3|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.int>int" - '>int*|__0|__3) ~'x00__) - ((Array/get ~'>int*|__0|__4|input-types 0) ~'x00__) + '>int*|__0|3) ~'x00__) + ((Array/get ~'>int*|__0|4|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.long>int" - '>int*|__0|__4) ~'x00__) - ((Array/get ~'>int*|__0|__5|input-types 0) ~'x00__) + '>int*|__0|4) ~'x00__) + ((Array/get ~'>int*|__0|5|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.float>int" - '>int*|__0|__5) ~'x00__) - ((Array/get ~'>int*|__0|__6|input-types 0) ~'x00__) + '>int*|__0|5) ~'x00__) + ((Array/get ~'>int*|__0|6|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.double>int" - '>int*|__0|__6) ~'x00__) - ((Array/get ~'>int*|__1|input-types 0) ~'x00__) + '>int*|__0|6) ~'x00__) + ((Array/get ~'>int*|__1|0|input-types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>int" - '>int*|__1) ~'x00__) + '>int*|__1|0) ~'x00__) (unsupported! `>int* [~'x00__] 0)))))))] (testing "code equivalence" (is-code= actual expected)) #_(testing "functionality" diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index d1d11999..a7e8a9f9 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -644,7 +644,7 @@ (-def double? (isa? #?(:clj Double :cljs js/Number))) (-def ?double? (? double?)) - (-def primitive? (or boolean? #?@(:clj [byte? char? short? int? long? float?]) double?)) + (-def primitive? (or boolean? #?@(:clj [byte? short? char? int? long? float?]) double?)) #?(:clj (-def comparable-primitive? (- primitive? boolean?))) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 70baa20b..eb89dbd4 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -156,8 +156,10 @@ (or (== this that) (and (instance? ProtocolType that) (= p (.-p ^ProtocolType that)))))} - uform/PGenForm {>form ([this] (list 'quantum.untyped.core.type/isa?|protocol - (-> p :on >form)))} + uform/PGenForm {>form ([this] (with-meta + (list 'quantum.untyped.core.type/isa?|protocol + (-> p :on >form)) + meta))} fedn/IOverride nil fedn/IEdn {-edn ([this] (or name (>form this)))}}) @@ -183,7 +185,8 @@ (or (== this that) (and (instance? ClassType that) (= c (.-c ^ClassType that)))))} - uform/PGenForm {>form ([this] (list 'quantum.untyped.core.type/isa? (>form c)))} + uform/PGenForm {>form ([this] + (with-meta (list 'quantum.untyped.core.type/isa? (>form c)) meta))} fedn/IOverride nil fedn/IEdn {-edn ([this] (or name (>form this)))}}) From 55c2d56ba9885f26f70f9f072c5e4d73a5d33d80 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 11:03:59 -0600 Subject: [PATCH 133/810] And the tests pass too :D --- src-dev/quantum/core/defnt_equivalences.cljc | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 8f2223a0..b9b3679a 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -481,9 +481,18 @@ '>int*|__1|0) ~'x00__) (unsupported! `>int* [~'x00__] 0)))))))] (testing "code equivalence" (is-code= actual expected)) - #_(testing "functionality" + (testing "functionality" (eval actual) - (eval '(do ...))))) + (eval '(do (throws (>int*)) + (throws (>int* nil)) + (throws (>int* "")) + (is (identical? (>int* 1) (clojure.lang.RT/uncheckedIntCast 1))) + (is (identical? (>int* 1.0) (clojure.lang.RT/uncheckedIntCast 1.0))) + (is (identical? (>int* 1.1) (clojure.lang.RT/uncheckedIntCast 1.1))) + (is (identical? (>int* -1) (clojure.lang.RT/uncheckedIntCast -1))) + (is (identical? (>int* -1.0) (clojure.lang.RT/uncheckedIntCast -1.0))) + (is (identical? (>int* -1.1) (clojure.lang.RT/uncheckedIntCast -1.1))) + (is (identical? (>int* (byte 1)) (clojure.lang.RT/uncheckedIntCast (byte 1))))))))) (deftest test|> (let [actual From e9544d43bac38408eaf8a3535c70dbd2f7718224 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 11:34:37 -0600 Subject: [PATCH 134/810] Getting there --- src-dev/quantum/core/defnt_equivalences.cljc | 107 +++++++++++++------ src-untyped/quantum/untyped/core/test.cljc | 20 ++-- 2 files changed, 84 insertions(+), 43 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index b9b3679a..4f0b47c2 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -507,38 +507,80 @@ expected (case (env-lang) :clj - ($ (do (def ~'>|test|__0 + ($ (do ;; [a t/comparable-primitive? b t/comparable-primitive? > t/boolean?] + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|0|input-types) + (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Byte))) + (def ~'>|test|__0|0 + (reify* [byte+byte>boolean] + (~(tag "boolean" 'invoke) [~'_0__ ~(tag "byte" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|1|input-types) + (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Short))) + (def ~'>|test|__0|1 + (reify* [byte+short>boolean] + (~(tag "boolean" 'invoke) [~'_1__ ~(tag "byte" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|2|input-types) + (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Character))) + (def ~'>|test|__0|2 + (reify* [byte+char>boolean] + (~(tag "boolean" 'invoke) [~'_2__ ~(tag "byte" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|3|input-types) + (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Integer))) + (def ~'>|test|__0|3 + (reify* [byte+int>boolean] + (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|4|input-types) + (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Long))) + (def ~'>|test|__0|4 + (reify* [byte+long>boolean] + (~(tag "boolean" 'invoke) [~'_4__ ~(tag "byte" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|5|input-types) + (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Float))) + (def ~'>|test|__0|5 + (reify* [byte+float>boolean] + (~(tag "boolean" 'invoke) [~'_5__ ~(tag "byte" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|6|input-types) + (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Double))) + (def ~'>|test|__0|6 + (reify* [byte+double>boolean] + (~(tag "boolean" 'invoke) [~'_6__ ~(tag "byte" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|7|input-types) + (*<> (t/isa? java.lang.Short) (t/isa? java.lang.Byte))) + (def ~'>|test|__0|7 + (reify* [short+byte>boolean] + (~(tag "boolean" 'invoke) [~'_7__ ~(tag "short" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|8|input-types) + (*<> (t/isa? java.lang.Short) (t/isa? java.lang.Short))) + (def ~'>|test|__0|8 + (reify* [short+short>boolean] + (~(tag "boolean" 'invoke) [~'_8__ ~(tag "short" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|9|input-types) + (*<> (t/isa? java.lang.Short) (t/isa? java.lang.Character))) + (def ~'>|test|__0|9 + (reify* [short+char>boolean] + (~(tag "boolean" 'invoke) [~'_9__ ~(tag "short" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)))) + + (def ~'>|test|__0|0 (reify - byte+byte>boolean - (~(tag "boolean" 'invoke) [~'_0__ ~(tag "byte" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)) - byte+short>boolean - (~(tag "boolean" 'invoke) [~'_1__ ~(tag "byte" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)) - byte+char>boolean - (~(tag "boolean" 'invoke) [~'_2__ ~(tag "byte" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)) - byte+int>boolean - (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)) - byte+long>boolean - (~(tag "boolean" 'invoke) [~'_4__ ~(tag "byte" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)) - byte+float>boolean - (~(tag "boolean" 'invoke) [~'_5__ ~(tag "byte" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)) - byte+double>boolean - (~(tag "boolean" 'invoke) [~'_6__ ~(tag "byte" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)) - short+byte>boolean - (~(tag "boolean" 'invoke) [~'_7__ ~(tag "short" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)) - short+short>boolean - (~(tag "boolean" 'invoke) [~'_8__ ~(tag "short" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)) - short+char>boolean - (~(tag "boolean" 'invoke) [~'_9__ ~(tag "short" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)) short+int>boolean (~(tag "boolean" 'invoke) [~'_10__ ~(tag "short" 'a) ~(tag "int" 'b)] ~'(Numeric/gt a b)) @@ -657,9 +699,6 @@ (~(tag "boolean" 'invoke) [~'_48__ ~(tag "double" 'a) ~(tag "double" 'b)] ~'(Numeric/gt a b)))) - ;; TODO the dispatch here should realize that `>|test|__0` has multiple - ;; non-primitivized overloads and must dispatch not merely on the whole typedef - ;; but rather on each 'branch' of `[t/comparable-primitive? t/comparable-primitive?]` (defn >|test {::t/type (t/fn #?(:clj [t/comparable-primitive? t/comparable-primitive? diff --git a/src-untyped/quantum/untyped/core/test.cljc b/src-untyped/quantum/untyped/core/test.cljc index 323ec1ed..c93cdb4a 100644 --- a/src-untyped/quantum/untyped/core/test.cljc +++ b/src-untyped/quantum/untyped/core/test.cljc @@ -5,7 +5,9 @@ [clojure.string :as str] [clojure.test :as test] [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.error :as err] + [quantum.untyped.core.error :as uerr] + [quantum.untyped.core.log + :refer [pr!]] [quantum.untyped.core.print :refer [ppr-meta]] [quantum.untyped.core.vars @@ -30,8 +32,8 @@ (let [meta0 (-> code0 meta (dissoc :line :column)) meta1 (-> code1 meta (dissoc :line :column))] (or (= meta0 meta1) - (println "FAIL: meta should be match for" (pr-str meta0) (pr-str meta1) - "on code" (pr-str code0) (pr-str code1)))) + (pr! "FAIL: meta should be match for" (pr-str meta0) (pr-str meta1) + "on code" (pr-str code0) (pr-str code1)))) (let [similar-class? (cond (seq? code0) (seq? code1) (seq? code1) (seq? code0) @@ -42,12 +44,12 @@ :else ::not-applicable)] (if (= similar-class? ::not-applicable) (or (= code0 code1) - (println "FAIL: should be `(= code0 code1)`" (pr-str code0) (pr-str code1))) + (pr! "FAIL: should be `(= code0 code1)`" (pr-str code0) (pr-str code1))) (and (or similar-class? - (println "FAIL: should be similar class" (pr-str code0) (pr-str code1))) + (pr! "FAIL: should be similar class" (pr-str code0) (pr-str code1))) (or (ucore/seq= (seq code0) (seq code1) code=) - (println "FAIL: `(ucore/seq= code0 code1 code=)`" - (pr-str code0) (pr-str code1))))))) + (pr! "FAIL: `(ucore/seq= code0 code1 code=)`" + (pr-str code0) (pr-str code1))))))) (and (not (ucore/metable? code1)) (or (= code0 code1) (println "FAIL: should be `(= code0 code1)`" (pr-str code0) (pr-str code1)))))) @@ -58,11 +60,11 @@ #?(:clj (defmacro is= [& args] `(is (= ~@args)))) #?(:clj (defmacro throws - ([x] `(do (is (~'thrown? ~(err/env>generic-error &env) ~x)) true)) + ([x] `(do (is (~'thrown? ~(uerr/env>generic-error &env) ~x)) true)) ([expr err-pred] `(try ~expr (is (throws '~err-pred)) - (catch ~(err/env>generic-error &env) e# (is (~err-pred e#))))))) + (catch ~(uerr/env>generic-error &env) e# (is (~err-pred e#))))))) ; Makes test failures and errors print prettily ; TODO CLJS From 898867fba6bc7ff96fd000e6954c7757f06e5572 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 12:06:20 -0600 Subject: [PATCH 135/810] A little further --- src-dev/quantum/core/defnt_equivalences.cljc | 110 +++++++++++++------ 1 file changed, 77 insertions(+), 33 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 4f0b47c2..006e33d2 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -579,41 +579,85 @@ (~(tag "boolean" 'invoke) [~'_9__ ~(tag "short" 'a) ~(tag "char" 'b)] ~'(Numeric/gt a b)))) + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|10|input-types) + (*<> (t/isa? java.lang.Short) (t/isa? java.lang.Integer))) + (def ~'>|test|__0|10 + (reify* [short+int>boolean] + (~(tag "boolean" 'invoke) [~'_10__ ~(tag "short" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|11|input-types) + (*<> (t/isa? java.lang.Short) (t/isa? java.lang.Long))) + (def ~'>|test|__0|11 + (reify* [short+long>boolean] + (~(tag "boolean" 'invoke) [~'_11__ ~(tag "short" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|12|input-types) + (*<> (t/isa? java.lang.Short) (t/isa? java.lang.Float))) + (def ~'>|test|__0|12 + (reify* [short+float>boolean] + (~(tag "boolean" 'invoke) [~'_12__ ~(tag "short" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|13|input-types) + (*<> (t/isa? java.lang.Short) (t/isa? java.lang.Double))) + (def ~'>|test|__0|13 + (reify* [short+double>boolean] + (~(tag "boolean" 'invoke) [~'_13__ ~(tag "short" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|14|input-types) + (*<> (t/isa? java.lang.Character) (t/isa? java.lang.Byte))) + (def ~'>|test|__0|14 + (reify* [char+byte>boolean] + (~(tag "boolean" 'invoke) [~'_14__ ~(tag "char" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|15|input-types) + (*<> (t/isa? java.lang.Character) (t/isa? java.lang.Short))) + (def ~'>|test|__0|15 + (reify* [char+short>boolean] + (~(tag "boolean" 'invoke) [~'_15__ ~(tag "char" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|16|input-types) + (*<> (t/isa? java.lang.Character) (t/isa? java.lang.Character))) + (def ~'>|test|__0|16 + (reify* [char+char>boolean] + (~(tag "boolean" 'invoke) [~'_16__ ~(tag "char" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|17|input-types) + (*<> (t/isa? java.lang.Character) (t/isa? java.lang.Integer))) + (def ~'>|test|__0|17 + (reify* [char+int>boolean] + (~(tag "boolean" 'invoke) [~'_17__ ~(tag "char" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|18|input-types) + (*<> (t/isa? java.lang.Character) (t/isa? java.lang.Long))) + (def ~'>|test|__0|18 + (reify* [char+long>boolean] + (~(tag "boolean" 'invoke) [~'_18__ ~(tag "char" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|19|input-types) + (*<> (t/isa? java.lang.Character) (t/isa? java.lang.Float))) + (def ~'>|test|__0|19 + (reify* [char+float>boolean] + (~(tag "boolean" 'invoke) [~'_19__ ~(tag "char" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|20|input-types) + (*<> (t/isa? java.lang.Character) (t/isa? java.lang.Double))) + (def ~'>|test|__0|20 + (reify* [char+double>boolean] + (~(tag "boolean" 'invoke) [~'_20__ ~(tag "char" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)))) + (def ~'>|test|__0|0 (reify - short+int>boolean - (~(tag "boolean" 'invoke) [~'_10__ ~(tag "short" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)) - short+long>boolean - (~(tag "boolean" 'invoke) [~'_11__ ~(tag "short" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)) - short+float>boolean - (~(tag "boolean" 'invoke) [~'_12__ ~(tag "short" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)) - short+double>boolean - (~(tag "boolean" 'invoke) [~'_13__ ~(tag "short" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)) - char+byte>boolean - (~(tag "boolean" 'invoke) [~'_14__ ~(tag "char" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)) - char+short>boolean - (~(tag "boolean" 'invoke) [~'_15__ ~(tag "char" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)) - char+char>boolean - (~(tag "boolean" 'invoke) [~'_16__ ~(tag "char" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)) - char+int>boolean - (~(tag "boolean" 'invoke) [~'_17__ ~(tag "char" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)) - char+long>boolean - (~(tag "boolean" 'invoke) [~'_18__ ~(tag "char" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)) - char+float>boolean - (~(tag "boolean" 'invoke) [~'_19__ ~(tag "char" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)) - char+double>boolean - (~(tag "boolean" 'invoke) [~'_20__ ~(tag "char" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)) int+byte>boolean (~(tag "boolean" 'invoke) [~'_21__ ~(tag "int" 'a) ~(tag "byte" 'b)] ~'(Numeric/gt a b)) From b45e6a7d0dc3b6c40d5869df17150cb5e2909e70 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 12:08:51 -0600 Subject: [PATCH 136/810] And more --- src-dev/quantum/core/defnt_equivalences.cljc | 70 ++++++++++++++------ 1 file changed, 49 insertions(+), 21 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 006e33d2..6caa22f5 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -656,29 +656,57 @@ (~(tag "boolean" 'invoke) [~'_20__ ~(tag "char" 'a) ~(tag "double" 'b)] ~'(Numeric/gt a b)))) + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|21|input-types) + (*<> (t/isa? java.lang.Integer) (t/isa? java.lang.Byte))) + (def ~'>|test|__0|21 + (reify* [int+byte>boolean] + (~(tag "boolean" 'invoke) [~'_21__ ~(tag "int" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|22|input-types) + (*<> (t/isa? java.lang.Integer) (t/isa? java.lang.Short))) + (def ~'>|test|__0|22 + (reify* [int+short>boolean] + (~(tag "boolean" 'invoke) [~'_22__ ~(tag "int" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|23|input-types) + (*<> (t/isa? java.lang.Integer) (t/isa? java.lang.Character))) + (def ~'>|test|__0|23 + (reify* [int+char>boolean] + (~(tag "boolean" 'invoke) [~'_23__ ~(tag "int" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|24|input-types) + (*<> (t/isa? java.lang.Integer) (t/isa? java.lang.Integer))) + (def ~'>|test|__0|24 + (reify* [int+int>boolean] + (~(tag "boolean" 'invoke) [~'_24__ ~(tag "int" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|25|input-types) + (*<> (t/isa? java.lang.Integer) (t/isa? java.lang.Long))) + (def ~'>|test|__0|25 + (reify* [int+long>boolean] + (~(tag "boolean" 'invoke) [~'_25__ ~(tag "int" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|26|input-types) + (*<> (t/isa? java.lang.Integer) (t/isa? java.lang.Float))) + (def ~'>|test|__0|26 + (reify* [int+float>boolean] + (~(tag "boolean" 'invoke) [~'_26__ ~(tag "int" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|27|input-types) + (*<> (t/isa? java.lang.Integer) (t/isa? java.lang.Double))) + (def ~'>|test|__0|27 + (reify* [int+double>boolean] + (~(tag "boolean" 'invoke) [~'_27__ ~(tag "int" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)))) + (def ~'>|test|__0|0 (reify - int+byte>boolean - (~(tag "boolean" 'invoke) [~'_21__ ~(tag "int" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)) - int+short>boolean - (~(tag "boolean" 'invoke) [~'_22__ ~(tag "int" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)) - int+char>boolean - (~(tag "boolean" 'invoke) [~'_23__ ~(tag "int" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)) - int+int>boolean - (~(tag "boolean" 'invoke) [~'_24__ ~(tag "int" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)) - int+long>boolean - (~(tag "boolean" 'invoke) [~'_25__ ~(tag "int" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)) - int+float>boolean - (~(tag "boolean" 'invoke) [~'_26__ ~(tag "int" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)) - int+double>boolean - (~(tag "boolean" 'invoke) [~'_27__ ~(tag "int" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)) long+byte>boolean (~(tag "boolean" 'invoke) [~'_28__ ~(tag "long" 'a) ~(tag "byte" 'b)] ~'(Numeric/gt a b)) From 7322960094b8add43bbc2cee36b2b5ea3ab10b9c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 12:10:47 -0600 Subject: [PATCH 137/810] And more --- src-dev/quantum/core/defnt_equivalences.cljc | 70 ++++++++++++++------ 1 file changed, 49 insertions(+), 21 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 6caa22f5..b3a1fbab 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -705,29 +705,57 @@ (~(tag "boolean" 'invoke) [~'_27__ ~(tag "int" 'a) ~(tag "double" 'b)] ~'(Numeric/gt a b)))) + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|28|input-types) + (*<> (t/isa? java.lang.Long) (t/isa? java.lang.Byte))) + (def ~'>|test|__0|28 + (reify* [long+byte>boolean] + (~(tag "boolean" 'invoke) [~'_28__ ~(tag "long" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|29|input-types) + (*<> (t/isa? java.lang.Long) (t/isa? java.lang.Short))) + (def ~'>|test|__0|29 + (reify* [long+short>boolean] + (~(tag "boolean" 'invoke) [~'_29__ ~(tag "long" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|30|input-types) + (*<> (t/isa? java.lang.Long) (t/isa? java.lang.Character))) + (def ~'>|test|__0|30 + (reify* [long+char>boolean] + (~(tag "boolean" 'invoke) [~'_30__ ~(tag "long" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|31|input-types) + (*<> (t/isa? java.lang.Long) (t/isa? java.lang.Integer))) + (def ~'>|test|__0|31 + (reify* [long+int>boolean] + (~(tag "boolean" 'invoke) [~'_31__ ~(tag "long" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|32|input-types) + (*<> (t/isa? java.lang.Long) (t/isa? java.lang.Long))) + (def ~'>|test|__0|32 + (reify* [long+long>boolean] + (~(tag "boolean" 'invoke) [~'_32__ ~(tag "long" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|33|input-types) + (*<> (t/isa? java.lang.Long) (t/isa? java.lang.Float))) + (def ~'>|test|__0|33 + (reify* [long+float>boolean] + (~(tag "boolean" 'invoke) [~'_33__ ~(tag "long" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|34|input-types) + (*<> (t/isa? java.lang.Long) (t/isa? java.lang.Double))) + (def ~'>|test|__0|34 + (reify* [long+double>boolean] + (~(tag "boolean" 'invoke) [~'_34__ ~(tag "long" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)))) + (def ~'>|test|__0|0 (reify - long+byte>boolean - (~(tag "boolean" 'invoke) [~'_28__ ~(tag "long" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)) - long+short>boolean - (~(tag "boolean" 'invoke) [~'_29__ ~(tag "long" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)) - long+char>boolean - (~(tag "boolean" 'invoke) [~'_30__ ~(tag "long" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)) - long+int>boolean - (~(tag "boolean" 'invoke) [~'_31__ ~(tag "long" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)) - long+long>boolean - (~(tag "boolean" 'invoke) [~'_32__ ~(tag "long" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)) - long+float>boolean - (~(tag "boolean" 'invoke) [~'_33__ ~(tag "long" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)) - long+double>boolean - (~(tag "boolean" 'invoke) [~'_34__ ~(tag "long" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)) float+byte>boolean (~(tag "boolean" 'invoke) [~'_35__ ~(tag "float" 'a) ~(tag "byte" 'b)] ~'(Numeric/gt a b)) From bfdb5e2792ebdef315fa150a20eb53d591b861e1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 12:12:46 -0600 Subject: [PATCH 138/810] More --- src-dev/quantum/core/defnt_equivalences.cljc | 70 ++++++++++++++------ 1 file changed, 49 insertions(+), 21 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index b3a1fbab..582b3398 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -754,29 +754,57 @@ (~(tag "boolean" 'invoke) [~'_34__ ~(tag "long" 'a) ~(tag "double" 'b)] ~'(Numeric/gt a b)))) + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|35|input-types) + (*<> (t/isa? java.lang.Float) (t/isa? java.lang.Byte))) + (def ~'>|test|__0|35 + (reify* [float+byte>boolean] + (~(tag "boolean" 'invoke) [~'_35__ ~(tag "float" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|36|input-types) + (*<> (t/isa? java.lang.Float) (t/isa? java.lang.Short))) + (def ~'>|test|__0|36 + (reify* [float+short>boolean] + (~(tag "boolean" 'invoke) [~'_36__ ~(tag "float" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|37|input-types) + (*<> (t/isa? java.lang.Float) (t/isa? java.lang.Character))) + (def ~'>|test|__0|37 + (reify* [float+char>boolean] + (~(tag "boolean" 'invoke) [~'_37__ ~(tag "float" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|38|input-types) + (*<> (t/isa? java.lang.Float) (t/isa? java.lang.Integer))) + (def ~'>|test|__0|38 + (reify* [float+int>boolean] + (~(tag "boolean" 'invoke) [~'_38__ ~(tag "float" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|39|input-types) + (*<> (t/isa? java.lang.Float) (t/isa? java.lang.Long))) + (def ~'>|test|__0|39 + (reify* [float+long>boolean] + (~(tag "boolean" 'invoke) [~'_39__ ~(tag "float" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|40|input-types) + (*<> (t/isa? java.lang.Float) (t/isa? java.lang.Float))) + (def ~'>|test|__0|40 + (reify* [float+float>boolean] + (~(tag "boolean" 'invoke) [~'_40__ ~(tag "float" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|41|input-types) + (*<> (t/isa? java.lang.Float) (t/isa? java.lang.Double))) + (def ~'>|test|__0|41 + (reify* [float+double>boolean] + (~(tag "boolean" 'invoke) [~'_41__ ~(tag "float" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)))) + (def ~'>|test|__0|0 (reify - float+byte>boolean - (~(tag "boolean" 'invoke) [~'_35__ ~(tag "float" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)) - float+short>boolean - (~(tag "boolean" 'invoke) [~'_36__ ~(tag "float" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)) - float+char>boolean - (~(tag "boolean" 'invoke) [~'_37__ ~(tag "float" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)) - float+int>boolean - (~(tag "boolean" 'invoke) [~'_38__ ~(tag "float" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)) - float+long>boolean - (~(tag "boolean" 'invoke) [~'_39__ ~(tag "float" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)) - float+float>boolean - (~(tag "boolean" 'invoke) [~'_40__ ~(tag "float" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)) - float+double>boolean - (~(tag "boolean" 'invoke) [~'_41__ ~(tag "float" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)) double+byte>boolean (~(tag "boolean" 'invoke) [~'_42__ ~(tag "double" 'a) ~(tag "byte" 'b)] ~'(Numeric/gt a b)) From da1a9cf44393bd1933339481c05681c680d87dc3 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 12:14:51 -0600 Subject: [PATCH 139/810] Finished `reify` portion --- src-dev/quantum/core/defnt_equivalences.cljc | 71 +++++++++++++------- 1 file changed, 48 insertions(+), 23 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 582b3398..d0f27a84 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -803,29 +803,54 @@ (~(tag "boolean" 'invoke) [~'_41__ ~(tag "float" 'a) ~(tag "double" 'b)] ~'(Numeric/gt a b)))) - (def ~'>|test|__0|0 - (reify - double+byte>boolean - (~(tag "boolean" 'invoke) [~'_42__ ~(tag "double" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)) - double+short>boolean - (~(tag "boolean" 'invoke) [~'_43__ ~(tag "double" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)) - double+char>boolean - (~(tag "boolean" 'invoke) [~'_44__ ~(tag "double" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)) - double+int>boolean - (~(tag "boolean" 'invoke) [~'_45__ ~(tag "double" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)) - double+long>boolean - (~(tag "boolean" 'invoke) [~'_46__ ~(tag "double" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)) - double+float>boolean - (~(tag "boolean" 'invoke) [~'_47__ ~(tag "double" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)) - double+double>boolean - (~(tag "boolean" 'invoke) [~'_48__ ~(tag "double" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)))) + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|42|input-types) + (*<> (t/isa? java.lang.Double) (t/isa? java.lang.Byte))) + (def ~'>|test|__0|42 + (reify* [double+byte>boolean] + (~(tag "boolean" 'invoke) [~'_42__ ~(tag "double" 'a) ~(tag "byte" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|43|input-types) + (*<> (t/isa? java.lang.Double) (t/isa? java.lang.Short))) + (def ~'>|test|__0|43 + (reify* [double+short>boolean] + (~(tag "boolean" 'invoke) [~'_43__ ~(tag "double" 'a) ~(tag "short" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|44|input-types) + (*<> (t/isa? java.lang.Double) (t/isa? java.lang.Character))) + (def ~'>|test|__0|44 + (reify* [double+char>boolean] + (~(tag "boolean" 'invoke) [~'_44__ ~(tag "double" 'a) ~(tag "char" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|45|input-types) + (*<> (t/isa? java.lang.Double) (t/isa? java.lang.Integer))) + (def ~'>|test|__0|45 + (reify* [double+int>boolean] + (~(tag "boolean" 'invoke) [~'_45__ ~(tag "double" 'a) ~(tag "int" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|46|input-types) + (*<> (t/isa? java.lang.Double) (t/isa? java.lang.Long))) + (def ~'>|test|__0|46 + (reify* [double+long>boolean] + (~(tag "boolean" 'invoke) [~'_46__ ~(tag "double" 'a) ~(tag "long" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|47|input-types) + (*<> (t/isa? java.lang.Double) (t/isa? java.lang.Float))) + (def ~'>|test|__0|47 + (reify* [double+float>boolean] + (~(tag "boolean" 'invoke) [~'_47__ ~(tag "double" 'a) ~(tag "float" 'b)] + ~'(Numeric/gt a b)))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|48|input-types) + (*<> (t/isa? java.lang.Double) (t/isa? java.lang.Double))) + (def ~'>|test|__0|48 + (reify* [double+double>boolean] + (~(tag "boolean" 'invoke) [~'_48__ ~(tag "double" 'a) ~(tag "double" 'b)] + ~'(Numeric/gt a b)))) (defn >|test {::t/type From eae510236b0007a1f924fb2f90b80eb1f95fc34d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 12:59:22 -0600 Subject: [PATCH 140/810] Flesh out test a little more --- src-dev/quantum/core/defnt_equivalences.cljc | 129 ++++++++++++------- 1 file changed, 80 insertions(+), 49 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index d0f27a84..6eef02cf 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -52,7 +52,7 @@ (.getName))))) (defn ~'pid|test {::t/type (t/fn [:> ~'(? t/string?)])} - ([] (.invoke ~(tag "quantum.core.test.defnt_equivalences.>Object" + ([] (.invoke ~(tag (str `>Object) 'pid|test|__0|0))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" @@ -101,7 +101,7 @@ ([~'x00__] ;; Checks elided because `t/any?` doesn't require a check ;; and all args are `t/=` `t/any?` - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" + (.invoke ~(tag (str `Object>Object) 'identity|uninlined|__0|0) ~'x00__))))) :cljs ;; Direct dispatch will be simple functions, not `reify`s @@ -151,10 +151,10 @@ ~'[(t/isa? Named) :> (* t/string?)])} ([~'x00__] (ifs ((Array/get ~'name|test|__0|0|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" + (.invoke ~(tag (str `Object>Object) 'name|test|__0|0) ~'x00__) ((Array/get ~'name|test|__1|0|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" + (.invoke ~(tag (str `Object>Object) 'name|test|__1|0) ~'x00__) (unsupported! `name|test [~'x00__] 0)))))) :cljs @@ -215,12 +215,10 @@ ~'[t/any?])} ([~'x00__] (ifs ((Array/get ~'some?|test|__0|0|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" - 'some?|test|__0|0) ~'x00__) + (.invoke ~(tag (str `Object>boolean) 'some?|test|__0|0) ~'x00__) ;; TODO eliminate this check because it's not needed (`t/any?`) ((Array/get ~'some?|test|__1|0|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" - 'some?|test|__1|0) ~'x00__) + (.invoke ~(tag (str `Object>boolean) 'some?|test|__1|0) ~'x00__) (unsupported! `some?|test [~'x00__] 0)))))) :cljs ($ (do (defn ~'some?|test [~'x] @@ -277,12 +275,10 @@ ~'[t/any?])} ([~'x00__] (ifs ((Array/get ~'reduced?|test|__0|0|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" - 'reduced?|test|__0|0) ~'x00__) + (.invoke ~(tag (str `Object>boolean) 'reduced?|test|__0|0) ~'x00__) ;; TODO eliminate this check because it's not needed (`t/any?`) ((Array/get ~'reduced?|test|__1|0|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" - 'reduced?|test|__1|0) ~'x00__) + (.invoke ~(tag (str `Object>boolean) 'reduced?|test|__1|0) ~'x00__) (unsupported! `reduced?|test [~'x00__] 0)))))) :cljs ($ (do (defn ~'reduced?|test [~'x] @@ -352,12 +348,10 @@ (.invoke ~(tag "quantum.core.test.defnt_equivalences.boolean>boolean" '>boolean|__0|0) ~'x00__) ((Array/get ~'>boolean|__1|0|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" - '>boolean|__1|0) ~'x00__) + (.invoke ~(tag (str `Object>boolean) '>boolean|__1|0) ~'x00__) ;; TODO eliminate this check because it's not needed (`t/any?`) ((Array/get ~'>boolean|__2|0|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>boolean" - '>boolean|__2|0) ~'x00__) + (.invoke ~(tag (str `Object>boolean) '>boolean|__2|0) ~'x00__) (unsupported! `>boolean [~'x00__] 0)))))) :cljs ($ (do (defn ~'>boolean [~'x] @@ -456,29 +450,21 @@ ~'[(t/ref (t/isa? Number)) :> t/int?])} ([~'x00__] (ifs ((Array/get ~'>int*|__0|0|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.byte>int" - '>int*|__0|0) ~'x00__) + (.invoke ~(tag (str `byte>int) '>int*|__0|0) ~'x00__) ((Array/get ~'>int*|__0|1|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.short>int" - '>int*|__0|1) ~'x00__) + (.invoke ~(tag (str `short>int) '>int*|__0|1) ~'x00__) ((Array/get ~'>int*|__0|2|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.char>int" - '>int*|__0|2) ~'x00__) + (.invoke ~(tag (str `char>int) '>int*|__0|2) ~'x00__) ((Array/get ~'>int*|__0|3|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.int>int" - '>int*|__0|3) ~'x00__) + (.invoke ~(tag (str `int>int) '>int*|__0|3) ~'x00__) ((Array/get ~'>int*|__0|4|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.long>int" - '>int*|__0|4) ~'x00__) + (.invoke ~(tag (str `long>int) '>int*|__0|4) ~'x00__) ((Array/get ~'>int*|__0|5|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.float>int" - '>int*|__0|5) ~'x00__) + (.invoke ~(tag (str `float>int) '>int*|__0|5) ~'x00__) ((Array/get ~'>int*|__0|6|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.double>int" - '>int*|__0|6) ~'x00__) + (.invoke ~(tag (str `double>int) '>int*|__0|6) ~'x00__) ((Array/get ~'>int*|__1|0|input-types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>int" - '>int*|__1|0) ~'x00__) + (.invoke ~(tag (str `Object>int) '>int*|__1|0) ~'x00__) (unsupported! `>int* [~'x00__] 0)))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" @@ -509,6 +495,24 @@ :clj ($ (do ;; [a t/comparable-primitive? b t/comparable-primitive? > t/boolean?] + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|input0|types) + (*<> (t/isa? java.lang.Byte) + (t/isa? java.lang.Short) + (t/isa? java.lang.Character) + (t/isa? java.lang.Integer) + (t/isa? java.lang.Long) + (t/isa? java.lang.Float) + (t/isa? java.lang.Double))) + + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|input1|types) + (*<> (t/isa? java.lang.Byte) + (t/isa? java.lang.Short) + (t/isa? java.lang.Character) + (t/isa? java.lang.Integer) + (t/isa? java.lang.Long) + (t/isa? java.lang.Float) + (t/isa? java.lang.Double))) + (def ~(tag "[Ljava.lang.Object;" '>|test|__0|0|input-types) (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Byte))) (def ~'>|test|__0|0 @@ -852,25 +856,52 @@ (~(tag "boolean" 'invoke) [~'_48__ ~(tag "double" 'a) ~(tag "double" 'b)] ~'(Numeric/gt a b)))) - (defn >|test + (defn ~'>|test {::t/type - (t/fn #?(:clj [t/comparable-primitive? t/comparable-primitive? - :> t/boolean?] - :cljs [t/double? t/double? - :> (t/assume t/boolean?)]))} - ([a0 a1] - (ifs (t/byte? a0) - (ifs (t/byte? a1) (.invoke ^byte+byte>boolean >|test|__0 a0 a1) - (t/char? a1) (.invoke ...) - ...) - (t/char? a0) - (ifs (t/byte? a1) - (.invoke ^char+byte>boolean >|test|__0 a0 a1) - ...) - ... - (unsupported! `>|tets [a0 a1] 0)))))) + (t/fn #?(:clj ~'[t/comparable-primitive? t/comparable-primitive? + :> t/boolean?] + :cljs ~'[t/double? t/double? + :> (t/assume t/boolean?)]))} + ([~'x00__ ~'x10__] + (ifs + ((Array/get ~'>|test|__0|input0|types 0) ~'x00__) + (ifs + ((Array/get ~'>|test|__0|input1|types 0) ~'x00__) + (.invoke ~(tag (str `byte+byte>boolean) '>|test|__0|0) ~'x00__) + ((Array/get ~'>|test|__0|input1|types 1) ~'x00__) + (.invoke ~(tag (str `byte+short>boolean) '>|test|__0|1) ~'x00__) + ((Array/get ~'>|test|__0|input1|types 2) ~'x00__) + (.invoke ~(tag (str `byte+char>boolean) '>|test|__0|2) ~'x00__) + ((Array/get ~'>|test|__0|input1|types 3) ~'x00__) + (.invoke ~(tag (str `byte+int>boolean) '>|test|__0|3) ~'x00__) + ((Array/get ~'>|test|__0|input1|types 4) ~'x00__) + (.invoke ~(tag (str `byte+long>boolean) '>|test|__0|4) ~'x00__) + ((Array/get ~'>|test|__0|input1|types 5) ~'x00__) + (.invoke ~(tag (str `byte+float>boolean) '>|test|__0|5) ~'x00__) + ((Array/get ~'>|test|__0|input1|types 6) ~'x00__) + (.invoke ~(tag (str `byte+double>boolean) '>|test|__0|6) ~'x00__) + (unsupported! `>|test [~'x00__ ~'x10__] 1)) + ((Array/get ~'>|test|__0|input0|types 0) ~'x00__) + (ifs + ((Array/get ~'>|test|__0|input1|types 0) ~'x00__) + (.invoke ~(tag (str `short+byte>boolean) '>|test|__0|7) ~'x00__) + ((Array/get ~'>|test|__0|input1|types 1) ~'x00__) + (.invoke ~(tag (str `short+short>boolean) '>|test|__0|8) ~'x00__) + ((Array/get ~'>|test|__0|input1|types 2) ~'x00__) + (.invoke ~(tag (str `short+char>boolean) '>|test|__0|9) ~'x00__) + ((Array/get ~'>|test|__0|input1|types 3) ~'x00__) + (.invoke ~(tag (str `short+int>boolean) '>|test|__0|10) ~'x00__) + ((Array/get ~'>|test|__0|input1|types 4) ~'x00__) + (.invoke ~(tag (str `short+long>boolean) '>|test|__0|11) ~'x00__) + ((Array/get ~'>|test|__0|input1|types 5) ~'x00__) + (.invoke ~(tag (str `short+float>boolean) '>|test|__0|12) ~'x00__) + ((Array/get ~'>|test|__0|input1|types 6) ~'x00__) + (.invoke ~(tag (str `short+double>boolean) '>|test|__0|13) ~'x00__) + (unsupported! `>|test [~'x00__ ~'x10__] 1)) + ... + (unsupported! `>|test [~'x00__ ~'x10__] 0)))))) :cljs - ($ (do (defn >|test + ($ (do (defn ~'>|test ([a0 a1] (ifs (double? a0) (ifs (double? a1) From 5ab58b3b484711523c69a49d4e9ae1fbc2af5d80 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 12:59:34 -0600 Subject: [PATCH 141/810] Fix --- src-dev/quantum/core/defnt_equivalences.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 6eef02cf..947ead35 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -881,7 +881,7 @@ ((Array/get ~'>|test|__0|input1|types 6) ~'x00__) (.invoke ~(tag (str `byte+double>boolean) '>|test|__0|6) ~'x00__) (unsupported! `>|test [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|test|__0|input0|types 0) ~'x00__) + ((Array/get ~'>|test|__0|input0|types 1) ~'x00__) (ifs ((Array/get ~'>|test|__0|input1|types 0) ~'x00__) (.invoke ~(tag (str `short+byte>boolean) '>|test|__0|7) ~'x00__) From 394069f7c26cd7d7eee5a08f5a6475a8e66742f1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 13:18:15 -0600 Subject: [PATCH 142/810] Move to a different dispatch with less code --- src-dev/quantum/core/defnt_equivalences.cljc | 236 +++---------------- 1 file changed, 39 insertions(+), 197 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 947ead35..0872b63e 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -71,7 +71,7 @@ :clj ($ (do ;; [x t/any?] - (def ~(tag "[Ljava.lang.Object;" 'identity|uninlined|__0|0|input-types) + (def ~(tag "[Ljava.lang.Object;" 'identity|uninlined|__0|input0|types) (*<> t/any?)) ;; One `reify` because `t/any?` in CLJ does not have any `t/or`-separability (def ~'identity|uninlined|__0|0 @@ -128,8 +128,8 @@ ;; [t/string?] - (def ~(tag "[Ljava.lang.Object;" 'name|test|__0|0|input-types) - (*<> (t/isa? java.lang.String))) ;; TODO probably failing because class vs. symbol + (def ~(tag "[Ljava.lang.Object;" 'name|test|__0|input0|types) + (*<> (t/isa? java.lang.String))) (def ~'name|test|__0|0 (reify* [Object>Object] (~(tag "java.lang.Object" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] @@ -137,7 +137,7 @@ ;; [(t/isa? Named)] - (def ~(tag "[Ljava.lang.Object;" 'name|test|__1|0|input-types) + (def ~(tag "[Ljava.lang.Object;" 'name|test|__1|input0|types) (*<> (t/isa? Named))) (def ~'name|test|__1|0 (reify* [Object>Object] @@ -150,10 +150,10 @@ (t/fn ~'[t/string? :> t/string?] ~'[(t/isa? Named) :> (* t/string?)])} ([~'x00__] - (ifs ((Array/get ~'name|test|__0|0|input-types 0) ~'x00__) + (ifs ((Array/get ~'name|test|__0|input0|types 0) ~'x00__) (.invoke ~(tag (str `Object>Object) 'name|test|__0|0) ~'x00__) - ((Array/get ~'name|test|__1|0|input-types 0) ~'x00__) + ((Array/get ~'name|test|__1|input0|types 0) ~'x00__) (.invoke ~(tag (str `Object>Object) 'name|test|__1|0) ~'x00__) (unsupported! `name|test [~'x00__] 0)))))) @@ -187,7 +187,7 @@ :clj ($ (do ;; [x t/nil?] - (def ~(tag "[Ljava.lang.Object;" 'some?|test|__0|0|input-types) + (def ~(tag "[Ljava.lang.Object;" 'some?|test|__0|input0|types) (*<> (t/value nil))) (def ~'some?|test|__0|0 (reify* [Object>boolean] @@ -195,7 +195,7 @@ ;; [x t/any?] - (def ~(tag "[Ljava.lang.Object;" 'some?|test|__1|0|input-types) + (def ~(tag "[Ljava.lang.Object;" 'some?|test|__1|input0|types) (*<> t/any?)) (def ~'some?|test|__1|0 (reify* [Object>boolean boolean>boolean byte>boolean short>boolean @@ -214,10 +214,10 @@ {::t/type (t/fn ~'[t/nil?] ~'[t/any?])} ([~'x00__] - (ifs ((Array/get ~'some?|test|__0|0|input-types 0) ~'x00__) + (ifs ((Array/get ~'some?|test|__0|input0|types 0) ~'x00__) (.invoke ~(tag (str `Object>boolean) 'some?|test|__0|0) ~'x00__) ;; TODO eliminate this check because it's not needed (`t/any?`) - ((Array/get ~'some?|test|__1|0|input-types 0) ~'x00__) + ((Array/get ~'some?|test|__1|input0|types 0) ~'x00__) (.invoke ~(tag (str `Object>boolean) 'some?|test|__1|0) ~'x00__) (unsupported! `some?|test [~'x00__] 0)))))) :cljs @@ -246,7 +246,7 @@ :clj ($ (do ;; [x (t/isa? Reduced)] - (def ~(tag "[Ljava.lang.Object;" 'reduced?|test|__0|0|input-types) + (def ~(tag "[Ljava.lang.Object;" 'reduced?|test|__0|input0|types) (*<> (t/isa? Reduced))) (def ~'reduced?|test|__0|0 (reify* [Object>boolean] @@ -255,7 +255,7 @@ ;; [x t/any?] - (def ~(tag "[Ljava.lang.Object;" 'reduced?|test|__1|0|input-types) + (def ~(tag "[Ljava.lang.Object;" 'reduced?|test|__1|input0|types) (*<> t/any?)) (def ~'reduced?|test|__1|0 (reify* [Object>boolean boolean>boolean byte>boolean short>boolean @@ -274,10 +274,10 @@ {::t/type (t/fn ~'[(t/isa? Reduced)] ~'[t/any?])} ([~'x00__] - (ifs ((Array/get ~'reduced?|test|__0|0|input-types 0) ~'x00__) + (ifs ((Array/get ~'reduced?|test|__0|input0|types 0) ~'x00__) (.invoke ~(tag (str `Object>boolean) 'reduced?|test|__0|0) ~'x00__) ;; TODO eliminate this check because it's not needed (`t/any?`) - ((Array/get ~'reduced?|test|__1|0|input-types 0) ~'x00__) + ((Array/get ~'reduced?|test|__1|input0|types 0) ~'x00__) (.invoke ~(tag (str `Object>boolean) 'reduced?|test|__1|0) ~'x00__) (unsupported! `reduced?|test [~'x00__] 0)))))) :cljs @@ -308,7 +308,7 @@ :clj ($ (do ;; [x t/boolean?] - (def ~(tag "[Ljava.lang.Object;" '>boolean|__0|0|input-types) + (def ~(tag "[Ljava.lang.Object;" '>boolean|__0|input0|types) (*<> (t/isa? Boolean))) (def ~'>boolean|__0|0 (reify* [boolean>boolean] @@ -316,7 +316,7 @@ ;; [x t/nil? -> (- t/nil? t/boolean?)] - (def ~(tag "[Ljava.lang.Object;" '>boolean|__1|0|input-types) + (def ~(tag "[Ljava.lang.Object;" '>boolean|__1|input0|types) (*<> (t/value nil))) (def ~'>boolean|__1|0 (reify* [Object>boolean] @@ -324,7 +324,7 @@ ;; [x t/any? -> (- t/any? t/nil? t/boolean?)] - (def ~(tag "[Ljava.lang.Object;" '>boolean|__2|0|input-types) + (def ~(tag "[Ljava.lang.Object;" '>boolean|__2|input0|types) (*<> t/any?)) (def ~'>boolean|__2|0 (reify* [Object>boolean boolean>boolean byte>boolean short>boolean @@ -344,13 +344,13 @@ ~'[t/nil?] ~'[t/any?])} ([~'x00__] - (ifs ((Array/get ~'>boolean|__0|0|input-types 0) ~'x00__) + (ifs ((Array/get ~'>boolean|__0|input0|types 0) ~'x00__) (.invoke ~(tag "quantum.core.test.defnt_equivalences.boolean>boolean" '>boolean|__0|0) ~'x00__) - ((Array/get ~'>boolean|__1|0|input-types 0) ~'x00__) + ((Array/get ~'>boolean|__1|input0|types 0) ~'x00__) (.invoke ~(tag (str `Object>boolean) '>boolean|__1|0) ~'x00__) ;; TODO eliminate this check because it's not needed (`t/any?`) - ((Array/get ~'>boolean|__2|0|input-types 0) ~'x00__) + ((Array/get ~'>boolean|__2|input0|types 0) ~'x00__) (.invoke ~(tag (str `Object>boolean) '>boolean|__2|0) ~'x00__) (unsupported! `>boolean [~'x00__] 0)))))) :cljs @@ -386,50 +386,39 @@ :clj ($ (do ;; [x (t/- t/primitive? t/boolean?)] - (def ~(tag "[Ljava.lang.Object;" '>int*|__0|0|input-types) - (*<> (t/isa? java.lang.Byte))) + ;; These are non-primitivized + (def ~(tag "[Ljava.lang.Object;" '>int*|__0|input0|types) + (*<> (t/isa? java.lang.Byte) + (t/isa? java.lang.Short) + (t/isa? java.lang.Character) + (t/isa? java.lang.Integer) + (t/isa? java.lang.Long) + (t/isa? java.lang.Float) + (t/isa? java.lang.Double))) (def ~'>int*|__0|0 (reify* [byte>int] (~(tag "int" 'invoke) [~'_0__ ~(tag "byte" 'x)] ~'(Primitive/uncheckedIntCast x)))) - - (def ~(tag "[Ljava.lang.Object;" '>int*|__0|1|input-types) - (*<> (t/isa? java.lang.Short))) (def ~'>int*|__0|1 (reify* [short>int] (~(tag "int" 'invoke) [~'_1__ ~(tag "short" 'x)] ~'(Primitive/uncheckedIntCast x)))) - - (def ~(tag "[Ljava.lang.Object;" '>int*|__0|2|input-types) - (*<> (t/isa? java.lang.Character))) (def ~'>int*|__0|2 (reify* [char>int] (~(tag "int" 'invoke) [~'_2__ ~(tag "char" 'x)] ~'(Primitive/uncheckedIntCast x)))) - - (def ~(tag "[Ljava.lang.Object;" '>int*|__0|3|input-types) - (*<> (t/isa? java.lang.Integer))) (def ~'>int*|__0|3 (reify* [int>int] (~(tag "int" 'invoke) [~'_3__ ~(tag "int" 'x)] ~'(Primitive/uncheckedIntCast x)))) - - (def ~(tag "[Ljava.lang.Object;" '>int*|__0|4|input-types) - (*<> (t/isa? java.lang.Long))) (def ~'>int*|__0|4 (reify* [long>int] (~(tag "int" 'invoke) [~'_4__ ~(tag "long" 'x)] ~'(Primitive/uncheckedIntCast x)))) - - (def ~(tag "[Ljava.lang.Object;" '>int*|__0|5|input-types) - (*<> (t/isa? java.lang.Float))) (def ~'>int*|__0|5 (reify* [float>int] (~(tag "int" 'invoke) [~'_5__ ~(tag "float" 'x)] ~'(Primitive/uncheckedIntCast x)))) - - (def ~(tag "[Ljava.lang.Object;" '>int*|__0|6|input-types) - (*<> (t/isa? java.lang.Double))) (def ~'>int*|__0|6 (reify* [double>int] (~(tag "int" 'invoke) [~'_6__ ~(tag "double" 'x)] @@ -438,7 +427,7 @@ ;; [x (t/ref (t/isa? Number)) ;; -> (t/- (t/ref (t/isa? Number)) (t/- t/primitive? t/boolean?))] - (def ~(tag "[Ljava.lang.Object;" '>int*|__1|0|input-types) + (def ~(tag "[Ljava.lang.Object;" '>int*|__1|input0|types) (*<> ~(with-meta `(t/isa? Number) {:ref? true}))) (def ~'>int*|__1|0 (reify* [Object>int] @@ -449,21 +438,21 @@ {::t/type (t/fn ~'[(t/- t/primitive? t/boolean?) :> t/int?] ~'[(t/ref (t/isa? Number)) :> t/int?])} ([~'x00__] - (ifs ((Array/get ~'>int*|__0|0|input-types 0) ~'x00__) + (ifs ((Array/get ~'>int*|__0|input0|types 0) ~'x00__) (.invoke ~(tag (str `byte>int) '>int*|__0|0) ~'x00__) - ((Array/get ~'>int*|__0|1|input-types 0) ~'x00__) + ((Array/get ~'>int*|__0|input0|types 1) ~'x00__) (.invoke ~(tag (str `short>int) '>int*|__0|1) ~'x00__) - ((Array/get ~'>int*|__0|2|input-types 0) ~'x00__) + ((Array/get ~'>int*|__0|input0|types 2) ~'x00__) (.invoke ~(tag (str `char>int) '>int*|__0|2) ~'x00__) - ((Array/get ~'>int*|__0|3|input-types 0) ~'x00__) + ((Array/get ~'>int*|__0|input0|types 3) ~'x00__) (.invoke ~(tag (str `int>int) '>int*|__0|3) ~'x00__) - ((Array/get ~'>int*|__0|4|input-types 0) ~'x00__) + ((Array/get ~'>int*|__0|input0|types 4) ~'x00__) (.invoke ~(tag (str `long>int) '>int*|__0|4) ~'x00__) - ((Array/get ~'>int*|__0|5|input-types 0) ~'x00__) + ((Array/get ~'>int*|__0|input0|types 5) ~'x00__) (.invoke ~(tag (str `float>int) '>int*|__0|5) ~'x00__) - ((Array/get ~'>int*|__0|6|input-types 0) ~'x00__) + ((Array/get ~'>int*|__0|input0|types 6) ~'x00__) (.invoke ~(tag (str `double>int) '>int*|__0|6) ~'x00__) - ((Array/get ~'>int*|__1|0|input-types 0) ~'x00__) + ((Array/get ~'>int*|__1|input0|types 0) ~'x00__) (.invoke ~(tag (str `Object>int) '>int*|__1|0) ~'x00__) (unsupported! `>int* [~'x00__] 0)))))))] (testing "code equivalence" (is-code= actual expected)) @@ -495,6 +484,7 @@ :clj ($ (do ;; [a t/comparable-primitive? b t/comparable-primitive? > t/boolean?] + ;; These are non-primitivized (def ~(tag "[Ljava.lang.Object;" '>|test|__0|input0|types) (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Short) @@ -503,7 +493,6 @@ (t/isa? java.lang.Long) (t/isa? java.lang.Float) (t/isa? java.lang.Double))) - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|input1|types) (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Short) @@ -512,345 +501,198 @@ (t/isa? java.lang.Long) (t/isa? java.lang.Float) (t/isa? java.lang.Double))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|0|input-types) - (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Byte))) (def ~'>|test|__0|0 (reify* [byte+byte>boolean] (~(tag "boolean" 'invoke) [~'_0__ ~(tag "byte" 'a) ~(tag "byte" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|1|input-types) - (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Short))) (def ~'>|test|__0|1 (reify* [byte+short>boolean] (~(tag "boolean" 'invoke) [~'_1__ ~(tag "byte" 'a) ~(tag "short" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|2|input-types) - (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Character))) (def ~'>|test|__0|2 (reify* [byte+char>boolean] (~(tag "boolean" 'invoke) [~'_2__ ~(tag "byte" 'a) ~(tag "char" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|3|input-types) - (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Integer))) (def ~'>|test|__0|3 (reify* [byte+int>boolean] (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'a) ~(tag "int" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|4|input-types) - (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Long))) (def ~'>|test|__0|4 (reify* [byte+long>boolean] (~(tag "boolean" 'invoke) [~'_4__ ~(tag "byte" 'a) ~(tag "long" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|5|input-types) - (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Float))) (def ~'>|test|__0|5 (reify* [byte+float>boolean] (~(tag "boolean" 'invoke) [~'_5__ ~(tag "byte" 'a) ~(tag "float" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|6|input-types) - (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Double))) (def ~'>|test|__0|6 (reify* [byte+double>boolean] (~(tag "boolean" 'invoke) [~'_6__ ~(tag "byte" 'a) ~(tag "double" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|7|input-types) - (*<> (t/isa? java.lang.Short) (t/isa? java.lang.Byte))) (def ~'>|test|__0|7 (reify* [short+byte>boolean] (~(tag "boolean" 'invoke) [~'_7__ ~(tag "short" 'a) ~(tag "byte" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|8|input-types) - (*<> (t/isa? java.lang.Short) (t/isa? java.lang.Short))) (def ~'>|test|__0|8 (reify* [short+short>boolean] (~(tag "boolean" 'invoke) [~'_8__ ~(tag "short" 'a) ~(tag "short" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|9|input-types) - (*<> (t/isa? java.lang.Short) (t/isa? java.lang.Character))) (def ~'>|test|__0|9 (reify* [short+char>boolean] (~(tag "boolean" 'invoke) [~'_9__ ~(tag "short" 'a) ~(tag "char" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|10|input-types) - (*<> (t/isa? java.lang.Short) (t/isa? java.lang.Integer))) (def ~'>|test|__0|10 (reify* [short+int>boolean] (~(tag "boolean" 'invoke) [~'_10__ ~(tag "short" 'a) ~(tag "int" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|11|input-types) - (*<> (t/isa? java.lang.Short) (t/isa? java.lang.Long))) (def ~'>|test|__0|11 (reify* [short+long>boolean] (~(tag "boolean" 'invoke) [~'_11__ ~(tag "short" 'a) ~(tag "long" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|12|input-types) - (*<> (t/isa? java.lang.Short) (t/isa? java.lang.Float))) (def ~'>|test|__0|12 (reify* [short+float>boolean] (~(tag "boolean" 'invoke) [~'_12__ ~(tag "short" 'a) ~(tag "float" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|13|input-types) - (*<> (t/isa? java.lang.Short) (t/isa? java.lang.Double))) (def ~'>|test|__0|13 (reify* [short+double>boolean] (~(tag "boolean" 'invoke) [~'_13__ ~(tag "short" 'a) ~(tag "double" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|14|input-types) - (*<> (t/isa? java.lang.Character) (t/isa? java.lang.Byte))) (def ~'>|test|__0|14 (reify* [char+byte>boolean] (~(tag "boolean" 'invoke) [~'_14__ ~(tag "char" 'a) ~(tag "byte" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|15|input-types) - (*<> (t/isa? java.lang.Character) (t/isa? java.lang.Short))) (def ~'>|test|__0|15 (reify* [char+short>boolean] (~(tag "boolean" 'invoke) [~'_15__ ~(tag "char" 'a) ~(tag "short" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|16|input-types) - (*<> (t/isa? java.lang.Character) (t/isa? java.lang.Character))) (def ~'>|test|__0|16 (reify* [char+char>boolean] (~(tag "boolean" 'invoke) [~'_16__ ~(tag "char" 'a) ~(tag "char" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|17|input-types) - (*<> (t/isa? java.lang.Character) (t/isa? java.lang.Integer))) (def ~'>|test|__0|17 (reify* [char+int>boolean] (~(tag "boolean" 'invoke) [~'_17__ ~(tag "char" 'a) ~(tag "int" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|18|input-types) - (*<> (t/isa? java.lang.Character) (t/isa? java.lang.Long))) (def ~'>|test|__0|18 (reify* [char+long>boolean] (~(tag "boolean" 'invoke) [~'_18__ ~(tag "char" 'a) ~(tag "long" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|19|input-types) - (*<> (t/isa? java.lang.Character) (t/isa? java.lang.Float))) (def ~'>|test|__0|19 (reify* [char+float>boolean] (~(tag "boolean" 'invoke) [~'_19__ ~(tag "char" 'a) ~(tag "float" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|20|input-types) - (*<> (t/isa? java.lang.Character) (t/isa? java.lang.Double))) (def ~'>|test|__0|20 (reify* [char+double>boolean] (~(tag "boolean" 'invoke) [~'_20__ ~(tag "char" 'a) ~(tag "double" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|21|input-types) - (*<> (t/isa? java.lang.Integer) (t/isa? java.lang.Byte))) (def ~'>|test|__0|21 (reify* [int+byte>boolean] (~(tag "boolean" 'invoke) [~'_21__ ~(tag "int" 'a) ~(tag "byte" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|22|input-types) - (*<> (t/isa? java.lang.Integer) (t/isa? java.lang.Short))) (def ~'>|test|__0|22 (reify* [int+short>boolean] (~(tag "boolean" 'invoke) [~'_22__ ~(tag "int" 'a) ~(tag "short" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|23|input-types) - (*<> (t/isa? java.lang.Integer) (t/isa? java.lang.Character))) (def ~'>|test|__0|23 (reify* [int+char>boolean] (~(tag "boolean" 'invoke) [~'_23__ ~(tag "int" 'a) ~(tag "char" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|24|input-types) - (*<> (t/isa? java.lang.Integer) (t/isa? java.lang.Integer))) (def ~'>|test|__0|24 (reify* [int+int>boolean] (~(tag "boolean" 'invoke) [~'_24__ ~(tag "int" 'a) ~(tag "int" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|25|input-types) - (*<> (t/isa? java.lang.Integer) (t/isa? java.lang.Long))) (def ~'>|test|__0|25 (reify* [int+long>boolean] (~(tag "boolean" 'invoke) [~'_25__ ~(tag "int" 'a) ~(tag "long" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|26|input-types) - (*<> (t/isa? java.lang.Integer) (t/isa? java.lang.Float))) (def ~'>|test|__0|26 (reify* [int+float>boolean] (~(tag "boolean" 'invoke) [~'_26__ ~(tag "int" 'a) ~(tag "float" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|27|input-types) - (*<> (t/isa? java.lang.Integer) (t/isa? java.lang.Double))) (def ~'>|test|__0|27 (reify* [int+double>boolean] (~(tag "boolean" 'invoke) [~'_27__ ~(tag "int" 'a) ~(tag "double" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|28|input-types) - (*<> (t/isa? java.lang.Long) (t/isa? java.lang.Byte))) (def ~'>|test|__0|28 (reify* [long+byte>boolean] (~(tag "boolean" 'invoke) [~'_28__ ~(tag "long" 'a) ~(tag "byte" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|29|input-types) - (*<> (t/isa? java.lang.Long) (t/isa? java.lang.Short))) (def ~'>|test|__0|29 (reify* [long+short>boolean] (~(tag "boolean" 'invoke) [~'_29__ ~(tag "long" 'a) ~(tag "short" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|30|input-types) - (*<> (t/isa? java.lang.Long) (t/isa? java.lang.Character))) (def ~'>|test|__0|30 (reify* [long+char>boolean] (~(tag "boolean" 'invoke) [~'_30__ ~(tag "long" 'a) ~(tag "char" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|31|input-types) - (*<> (t/isa? java.lang.Long) (t/isa? java.lang.Integer))) (def ~'>|test|__0|31 (reify* [long+int>boolean] (~(tag "boolean" 'invoke) [~'_31__ ~(tag "long" 'a) ~(tag "int" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|32|input-types) - (*<> (t/isa? java.lang.Long) (t/isa? java.lang.Long))) (def ~'>|test|__0|32 (reify* [long+long>boolean] (~(tag "boolean" 'invoke) [~'_32__ ~(tag "long" 'a) ~(tag "long" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|33|input-types) - (*<> (t/isa? java.lang.Long) (t/isa? java.lang.Float))) (def ~'>|test|__0|33 (reify* [long+float>boolean] (~(tag "boolean" 'invoke) [~'_33__ ~(tag "long" 'a) ~(tag "float" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|34|input-types) - (*<> (t/isa? java.lang.Long) (t/isa? java.lang.Double))) (def ~'>|test|__0|34 (reify* [long+double>boolean] (~(tag "boolean" 'invoke) [~'_34__ ~(tag "long" 'a) ~(tag "double" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|35|input-types) - (*<> (t/isa? java.lang.Float) (t/isa? java.lang.Byte))) (def ~'>|test|__0|35 (reify* [float+byte>boolean] (~(tag "boolean" 'invoke) [~'_35__ ~(tag "float" 'a) ~(tag "byte" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|36|input-types) - (*<> (t/isa? java.lang.Float) (t/isa? java.lang.Short))) (def ~'>|test|__0|36 (reify* [float+short>boolean] (~(tag "boolean" 'invoke) [~'_36__ ~(tag "float" 'a) ~(tag "short" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|37|input-types) - (*<> (t/isa? java.lang.Float) (t/isa? java.lang.Character))) (def ~'>|test|__0|37 (reify* [float+char>boolean] (~(tag "boolean" 'invoke) [~'_37__ ~(tag "float" 'a) ~(tag "char" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|38|input-types) - (*<> (t/isa? java.lang.Float) (t/isa? java.lang.Integer))) (def ~'>|test|__0|38 (reify* [float+int>boolean] (~(tag "boolean" 'invoke) [~'_38__ ~(tag "float" 'a) ~(tag "int" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|39|input-types) - (*<> (t/isa? java.lang.Float) (t/isa? java.lang.Long))) (def ~'>|test|__0|39 (reify* [float+long>boolean] (~(tag "boolean" 'invoke) [~'_39__ ~(tag "float" 'a) ~(tag "long" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|40|input-types) - (*<> (t/isa? java.lang.Float) (t/isa? java.lang.Float))) (def ~'>|test|__0|40 (reify* [float+float>boolean] (~(tag "boolean" 'invoke) [~'_40__ ~(tag "float" 'a) ~(tag "float" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|41|input-types) - (*<> (t/isa? java.lang.Float) (t/isa? java.lang.Double))) (def ~'>|test|__0|41 (reify* [float+double>boolean] (~(tag "boolean" 'invoke) [~'_41__ ~(tag "float" 'a) ~(tag "double" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|42|input-types) - (*<> (t/isa? java.lang.Double) (t/isa? java.lang.Byte))) (def ~'>|test|__0|42 (reify* [double+byte>boolean] (~(tag "boolean" 'invoke) [~'_42__ ~(tag "double" 'a) ~(tag "byte" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|43|input-types) - (*<> (t/isa? java.lang.Double) (t/isa? java.lang.Short))) (def ~'>|test|__0|43 (reify* [double+short>boolean] (~(tag "boolean" 'invoke) [~'_43__ ~(tag "double" 'a) ~(tag "short" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|44|input-types) - (*<> (t/isa? java.lang.Double) (t/isa? java.lang.Character))) (def ~'>|test|__0|44 (reify* [double+char>boolean] (~(tag "boolean" 'invoke) [~'_44__ ~(tag "double" 'a) ~(tag "char" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|45|input-types) - (*<> (t/isa? java.lang.Double) (t/isa? java.lang.Integer))) (def ~'>|test|__0|45 (reify* [double+int>boolean] (~(tag "boolean" 'invoke) [~'_45__ ~(tag "double" 'a) ~(tag "int" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|46|input-types) - (*<> (t/isa? java.lang.Double) (t/isa? java.lang.Long))) (def ~'>|test|__0|46 (reify* [double+long>boolean] (~(tag "boolean" 'invoke) [~'_46__ ~(tag "double" 'a) ~(tag "long" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|47|input-types) - (*<> (t/isa? java.lang.Double) (t/isa? java.lang.Float))) (def ~'>|test|__0|47 (reify* [double+float>boolean] (~(tag "boolean" 'invoke) [~'_47__ ~(tag "double" 'a) ~(tag "float" 'b)] ~'(Numeric/gt a b)))) - - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|48|input-types) - (*<> (t/isa? java.lang.Double) (t/isa? java.lang.Double))) (def ~'>|test|__0|48 (reify* [double+double>boolean] (~(tag "boolean" 'invoke) [~'_48__ ~(tag "double" 'a) ~(tag "double" 'b)] From 29af0ddd3d63200aa94487995565789a8d2a256b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 16:04:01 -0600 Subject: [PATCH 143/810] Add `coll/reverse` --- src-untyped/quantum/untyped/core/collections.cljc | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index 5a584147..85913871 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -1,7 +1,7 @@ (ns quantum.untyped.core.collections (:refer-clojure :exclude [#?(:cljs array?) assoc-in cat contains? count distinct distinct? first get group-by filter - flatten last map map-indexed mapcat partition-all pmap remove zipmap]) + flatten last map map-indexed mapcat partition-all pmap remove reverse zipmap]) (:require [clojure.core :as core] [fast-zip.core :as zip] @@ -34,6 +34,8 @@ (educe first|rf xs) (core/first xs))) +(defn reverse [xs] (if (reversible? xs) (rseq xs) (core/reverse xs))) + ;; ===== SOCIATIVE ===== ;; (defn get From d3f2d723bf988027f7a22e50d5e1dba08b9739cf Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 16:04:19 -0600 Subject: [PATCH 144/810] Add symbol `>form` support --- src-untyped/quantum/untyped/core/form.cljc | 5 +++-- src-untyped/quantum/untyped/core/type/reifications.cljc | 3 +-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index d39c0606..bd844fc5 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -16,8 +16,9 @@ Effectively the inverse of `eval`.")) (extend-protocol PGenForm - nil (>form [this] nil) - #?@(:clj [Class (>form [this] (-> this #_uconv/>symbol .getName symbol))])) + nil (>form [x] nil) + clojure.lang.Symbol (>form [x] (list 'quote x)) + #?@(:clj [Class (>form [x] (-> x #_uconv/>symbol .getName symbol))])) (defn core-symbol [env sym] (symbol (str (case-env* env :cljs "cljs" "clojure") ".core") (name sym))) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index eb89dbd4..100b998c 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -157,8 +157,7 @@ (and (instance? ProtocolType that) (= p (.-p ^ProtocolType that)))))} uform/PGenForm {>form ([this] (with-meta - (list 'quantum.untyped.core.type/isa?|protocol - (-> p :on >form)) + (list 'quantum.untyped.core.type/isa?|protocol (:on p)) meta))} fedn/IOverride nil fedn/IEdn {-edn ([this] (or name (>form this)))}}) From 82281c61e1912b2032a21d6354cbac9ec641f20d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 17:43:30 -0600 Subject: [PATCH 145/810] This is basically it! --- src-dev/quantum/core/defnt.cljc | 324 ++++++++++--------- src-dev/quantum/core/defnt_equivalences.cljc | 3 + 2 files changed, 173 insertions(+), 154 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index d6430211..29e45e7d 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -67,7 +67,8 @@ #_[quantum.format.clojure.core ; TODO temporary :refer [reformat-string]]) (:import - [quantum.core Numeric])) + [quantum.core Numeric] + [quantum.core.data Array])) ;; TODO move #_(defn ppr-code [code] @@ -172,11 +173,6 @@ LEFT OFF LAST TIME (7/24/2018): with that label and replace the typedef in the typedef-set - Else a new label will be given to the `reify`; the typedef will be added to the typedef-set - - [ ] One reify per type-that-cannot-be-split - - Only `t/or`s can be split for now - - [ ] `(= (hash (t/or t/long? t/float?)) (hash (t/or t/long? t/float?)))` - - Currently this isn't the case; we'd like to have it so, so we can more efficiently look - up what overloads we've generated so far [ ] Types yielding generative specs [—] Types using the clojure.spec interface - Not yet; wait for it to come out of alpha @@ -405,7 +401,7 @@ LEFT OFF LAST TIME (7/24/2018): (defns methods->type "Creates a type given ->`methods`." - [methods (s/seq-of method?) > t/type?] + [methods (s/seq-of t/any? #_method?) > t/type?] ;; TODO room for plenty of optimization here (let [methods|by-ct (->> methods (c/group-by (fn-> :argtypes count)) @@ -519,7 +515,7 @@ LEFT OFF LAST TIME (7/24/2018): (defns classes>class "Ensure that given a set of classes, that set consists of at most a class C and nil. If so, returns C. Otherwise, throws." - [cs (s/set-of t/class?) > t/class?] + [cs (s/set-of (? t/class?)) > t/class?] (let [cs' (disj cs nil)] (if (-> cs' count (= 1)) (first cs') @@ -735,7 +731,7 @@ LEFT OFF LAST TIME (7/24/2018): ;; Internal specs (s/def ::expanded-overload|arg-classes (s/vec-of t/class?)) -(s/def ::expanded-overload|arg-types (s/seq-of t/any?)) +(s/def ::expanded-overload|arg-types (s/seq-of t/type?)) ;; This is the overload after the input specs are split by their respective `t/or` constituents, ;; and after primitivization, but before readiness for incorporation into a `reify`. @@ -760,33 +756,46 @@ LEFT OFF LAST TIME (7/24/2018): :reify|overload/body-form])) (s/def ::reify - (s/kv {:form t/any? - :name simple-symbol? - :overloads (s/vec-of ::reify|overload)})) + (s/kv {:form t/any? + :name simple-symbol? + :non-primitivized-overload ::reify|overload + :overloads (s/vec-of ::reify|overload)})) (s/def ::lang #{:clj :cljs}) -(s/def ::input-types-decl (s/kv {:form t/any? :name simple-symbol?})) +(s/def ::input-types-decl + (s/kv {:form t/any? + :name simple-symbol? + :arg-type|split (s/vec-of t/type?)})) -(s/def ::direct-dispatch|reify-groups - (s/kv {:reify ::reify - :input-types-decl ::input-types-decl})) +(s/def ::direct-dispatch-data + (s/kv {:i-arg->input-types-decl (s/vec-of ::input-types-decl) + :reify-seq (s/vec-of ::reify)})) + +(s/def ::i-overload->direct-dispatch-data (s/vec-of ::direct-dispatch-data)) (s/def ::direct-dispatch - (s/kv {:form t/any? - ::direct-dispatch|reify-groups ::direct-dispatch|reify-groups})) + (s/kv {:form t/any? + :i-overload->direct-dispatch-data ::i-overload->direct-dispatch-data})) (s/def ::expanded-overload-group|arg-types|form (s/vec-of t/any?)) -(s/def ::expanded-overload-group|pre-type|form (s/vec-of t/any?)) -(s/def ::expanded-overload-group|post-type|form (s/vec-of t/any?)) (s/def ::expanded-overload-group - (s/kv {:arg-types|pre-split|form ::expanded-overload-group|arg-types|form - :arg-types|form ::expanded-overload-group|arg-types|form - :pre-type|form ::expanded-overload-group|pre-type|form - :post-type|form ::expanded-overload-group|post-type|form - :unprimitivized ::expanded-overload - :primitivized (s/seq-of ::expanded-overload)})) + (s/kv {:arg-types|form ::expanded-overload-group|arg-types|form + :non-primitivized ::expanded-overload + :primitivized (s/nilable (s/seq-of ::expanded-overload))})) + +(s/def ::expanded-overload-groups|arg-types|split (s/vec-of (s/vec-of t/type?))) +(s/def ::expanded-overload-groups|pre-type|form t/any?) +(s/def ::expanded-overload-groups|post-type|form t/any?) + +(s/def ::expanded-overload-groups + (s/kv {:arg-types|pre-split|form ::expanded-overload-group|arg-types|form + :pre-type|form ::expanded-overload-groups|pre-type|form + :post-type|form ::expanded-overload-groups|post-type|form + :arg-types|split ::expanded-overload-groups|arg-types|split + :arg-types|recombined (s/vec-of (s/vec-of t/type?)) + :expanded-overload-group-seq (s/seq-of ::expanded-overload-group)})) #_(:clj (defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] @@ -798,7 +807,7 @@ LEFT OFF LAST TIME (7/24/2018): (defn >with-post-type|form [body post-type|form] `(t/validate ~body ~post-type|form)) #?(:clj -(var/def sort-guide "for use in arity sorting, in increasing conceptual size" +(var/def sort-guide "for use in arity sorting, in increasing conceptual (and bit) size" {Object 0 tdef/boolean 1 tdef/byte 2 @@ -846,8 +855,9 @@ LEFT OFF LAST TIME (7/24/2018): using (in part) these pieces of data, but does not use the possibly-updated `arg-types` as computed in the analysis. As a result, does not yet support type inference." [{:keys [arg-bindings _, arg-classes ::expanded-overload|arg-classes + post-type|form _ arg-types ::expanded-overload|arg-types, body-codelist|pre-analyze _, lang ::lang - post-type|form _, pre-type|form _, varargs _, varargs-binding _]} _ + varargs _, varargs-binding _]} _ > ::expanded-overload] (let [env (->> (zipmap arg-bindings arg-types) (c/map' (fn [[arg-binding arg-type]] @@ -895,15 +905,11 @@ LEFT OFF LAST TIME (7/24/2018): :variadic? (boolean varargs)}))) (defns >expanded-overload-group - [{:as in - :keys [arg-types ::expanded-overload|arg-types|form - arg-types|pre-split|form ::expanded-overload-group|arg-types|form - pre-type|form ::expanded-overload-group|pre-type|form - post-type|form ::expanded-overload-group|post-type|form]} _ + [{:as in :keys [arg-types ::expanded-overload-group|arg-types|form]} _ > ::expanded-overload-group] (let [arg-types|form (mapv >form arg-types) - ;; `unprimitivized` is first because of class sorting - [unprimitivized & primitivized :as overloads] + ;; `non-primitivized` is first because of class sorting + [non-primitivized & primitivized :as overloads] (->> arg-types arg-types>arg-classes-seq|primitivized (mapv (fn [arg-classes #_::expanded-overload|arg-classes] @@ -915,17 +921,7 @@ LEFT OFF LAST TIME (7/24/2018): (>expanded-overload (assoc in :arg-classes arg-classes :arg-types arg-types|satisfying-primitivization))))))] - (kw-map arg-types|pre-split|form arg-types|form pre-type|form post-type|form - unprimitivized primitivized))) - -(defns arg-types>split - [arg-types ::expanded-overload|arg-types > (s/seq-of ::expanded-overload|arg-types)] - (->> arg-types - (map (fn [t] (if (utr/or-type? t) ; splittable - (utr/or-type>args t) - [t]))) - (apply combo/cartesian-product) - (c/map vec))) + (kw-map arg-types|form non-primitivized primitivized))) ;; TODO spec #?(:clj ; really, reserve for metalanguage @@ -949,7 +945,7 @@ LEFT OFF LAST TIME (7/24/2018): [_ _, post-type|form _] [:post _]} [:arglist _] body-codelist|pre-analyze [:body _]} _ {:as opts :keys [::lang ::lang, symbolic-analysis? t/boolean?]} _ - > (s/seq-of ::expanded-overload-group)] + > ::expanded-overload-groups] (if symbolic-analysis? (err! "Symbolic analysis not supported yet") (let [_ (when pre-type|form (TODO "Need to handle pre")) @@ -971,13 +967,23 @@ LEFT OFF LAST TIME (7/24/2018): (mapv (fn [{[kind #_#{:any :spec}, t #_t/form?] :spec}] (case kind :any `t/any? :spec t)))) arg-types|pre-split (->> arg-types|pre-split|form (mapv (fn-> eval t/>type))) - arg-types|split (arg-types>split arg-types|pre-split)] - (->> arg-types|split - (mapv (fn [arg-types] - (>expanded-overload-group - (kw-map arg-bindings arg-types body-codelist|pre-analyze lang - arg-types|pre-split|form pre-type|form post-type|form - varargs varargs-binding))))))))) + arg-types|split + ;; NOTE Only `t/or`s are splittable for now + (->> arg-types|pre-split + (c/map (fn [t] (if (utr/or-type? t) (utr/or-type>args t) [t])))) + arg-types|recombined (->> arg-types|split + (apply combo/cartesian-product) + (c/map vec)) + expanded-overload-group-seq + (->> arg-types|recombined + (mapv (fn [arg-types] + (>expanded-overload-group + (kw-map arg-bindings arg-types body-codelist|pre-analyze lang + arg-types|pre-split|form pre-type|form post-type|form + varargs varargs-binding)))))] + (kw-map arg-types|pre-split|form pre-type|form post-type|form + arg-types|split arg-types|recombined + expanded-overload-group-seq))))) (def fnt-method-sym 'invoke) @@ -1041,8 +1047,8 @@ LEFT OFF LAST TIME (7/24/2018): :keys [::uss/fn|name ::uss/fn|name, i|fnt-overload t/index?, i|expanded-overload-group t/index? expanded-overload-group ::expanded-overload-group]} _ gen-gensym fn? > ::reify] - (let [reify-overloads (->> (concat [(:unprimitivized expanded-overload-group)] - (:primitivized expanded-overload-group)) + (let [reify-overloads (->> (concat [(:non-primitivized expanded-overload-group)] + (:primitivized expanded-overload-group)) (c/map #(expanded-overload>reify-overload % gen-gensym))) reify-name (>reify|name in) form `(~'def ~reify-name @@ -1054,26 +1060,30 @@ LEFT OFF LAST TIME (7/24/2018): `(~(ufth/with-type-hint method-sym (ufth/>arglist-embeddable-tag out-class)) ~arglist-code ~body-form))))))] - {:form form - :name reify-name - :overloads reify-overloads}))) - -(defns >input-types-decl|name - [{:keys [::uss/fn|name ::uss/fn|name, i|fnt-overload t/index? - i|expanded-overload-group t/index?]} _ > simple-symbol?] - (>symbol (str fn|name "|__" i|fnt-overload "|" i|expanded-overload-group "|input-types"))) - -#?(:clj -(defns expanded-overload-group>input-types-decl + {:form form + :name reify-name + :non-primitivized-overload (first reify-overloads) + :overloads reify-overloads}))) + +(defns >input-type-decl|name + [fn|name ::uss/fn|name, i|fnt-overload t/index?, i|arg t/index? > simple-symbol?] + (>symbol (str fn|name "|__" i|fnt-overload "|input" i|arg "|types"))) + +(defns >i-arg->input-types-decl + "The evaluated `form` of each input-types-decl is an array of non-primitivized types that the + dynamic dispatch uses to dispatch off input types." [{:as in - :keys [::uss/fn|name ::uss/fn|name, i|fnt-overload t/index?, i|expanded-overload-group t/index? - expanded-overload-group ::expanded-overload-group]} _ - > ::input-types-decl] - (when (c/contains? (:arg-types|form expanded-overload-group)) - (let [decl-name (>input-types-decl|name in)] - {:form `(def ~(ufth/with-type-hint decl-name "[Ljava.lang.Object;") - (arr/*<> ~@(:arg-types|form expanded-overload-group))) - :name decl-name})))) + :keys [arg-types|split ::expanded-overload-groups|arg-types|split + ::uss/fn|name ::uss/fn|name + i|fnt-overload t/index?]} _ + > (s/vec-of ::input-types-decl)] + (->> arg-types|split + (c/map-indexed + (fn [i|arg arg-type|split] + (let [decl-name (>input-type-decl|name fn|name i|fnt-overload i|arg) + form (list 'def (ufth/with-type-hint decl-name "[Ljava.lang.Object;") + (list* `arr/*<> (map >form arg-type|split)))] + (assoc (kw-map form arg-type|split) :name decl-name)))))) (def allowed-shorthand-tag-chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") (def min-shorthand-tag-length 1) @@ -1129,118 +1139,124 @@ LEFT OFF LAST TIME (7/24/2018): (defns unsupported! [name- _ #_t/qualified-symbol?, args t/indexed?, i t/index?] (TODO)) -;; TODO spec (defns >direct-dispatch [{:keys [::uss/fn|name ::uss/fn|name - expanded-overload-groups-by-fnt-overload (s/vec-of (s/vec-of ::expanded-overload-group)) + expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups) gen-gensym fn? lang ::lang]} _ > ::direct-dispatch] (case lang :clj - (let [reify-groups + (let [i-overload->direct-dispatch-data (->> expanded-overload-groups-by-fnt-overload - (map-indexed - (fn [i|fnt-overload expanded-overload-groups] - (->> expanded-overload-groups - (map-indexed - (fn [i|expanded-overload-group - {:as expanded-overload-group :keys [arg-types|form]}] - (let [in (assoc (kw-map i|fnt-overload - i|expanded-overload-group - expanded-overload-group) - ::uss/fn|name fn|name)] - {:reify - (expanded-overload-group>reify in gen-gensym) - :input-types-decl - (expanded-overload-group>input-types-decl in)})))))) - c/lcat) - form (->> reify-groups - (map (fn [{:keys [input-types-decl] reify- :reify}] - (cond-> [] - input-types-decl (conj (:form input-types-decl)) - true (conj (:form reify-))))) - lcat)] - {:form form ::direct-dispatch|reify-groups reify-groups}) + (c/map-indexed + (fn [i|fnt-overload {:keys [arg-types|split expanded-overload-group-seq]}] + {:i-arg->input-types-decl + (>i-arg->input-types-decl (kw-map arg-types|split fn|name i|fnt-overload)) + :reify-seq + (->> expanded-overload-group-seq + (c/map-indexed + (fn [i|expanded-overload-group + {:as expanded-overload-group :keys [arg-types|form]}] + (let [in (assoc (kw-map i|fnt-overload + i|expanded-overload-group + expanded-overload-group) + ::uss/fn|name fn|name)] + (expanded-overload-group>reify in gen-gensym)))))}))) + form (->> i-overload->direct-dispatch-data + (c/map (fn [{:keys [i-arg->input-types-decl reify-seq]}] + (concat (c/lmap :form i-arg->input-types-decl) + (c/lmap :form reify-seq)))) + c/lcat)] + (kw-map form i-overload->direct-dispatch-data)) :cljs (TODO))) -;; TODO spec -;; TODO extend to more than just assuming always one arity -;; TODO check whether it even needs to get created based on arglist length etc. -;; TODO `get-relevant-reify-overload` +(defns >dynamic-dispatch-fn|type-decl + [expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups)] + (list* `t/fn (->> expanded-overload-groups-by-fnt-overload + (map (fn [{:keys [arg-types|pre-split|form + pre-type|form post-type|form]}] + (cond-> (or arg-types|pre-split|form []) + pre-type|form (conj :| pre-type|form) + post-type|form (conj :> post-type|form))))))) + +(defns >dynamic-dispatch|reify-call [reify- ::reify, arglist (s/vec-of simple-symbol?)] + (let [dotted-reify-method-sym + (symbol (str "." (-> reify- :non-primitivized-overload :method-sym))) + hinted-reify-sym + (ufth/with-type-hint (:name reify-) + (-> reify- :non-primitivized-overload :interface >name))] + `(~dotted-reify-method-sym ~hinted-reify-sym ~@arglist))) + +(defns >dynamic-dispatch|body-for-arity + ([fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?) + direct-dispatch-data-for-arity (s/seq-of ::direct-dispatch-data)] + (if (empty? arglist) + (>dynamic-dispatch|reify-call (-> direct-dispatch-data-for-arity :reify-seq first) arglist) + (let [i|arg 0] + `(ifs ~@(->> direct-dispatch-data-for-arity + (c/lmap + (fn [{:keys [reify-seq i-arg->input-types-decl]}] + (>dynamic-dispatch|body-for-arity fn|name arglist reify-seq + i-arg->input-types-decl i|arg 0))) + c/lcat)) + (unsupported! (quote ~(qualify fn|name)) [~@arglist] ~i|arg)))) + ([fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?), reify-seq (s/vec-of ::reify) + input-types-decl-group' (s/seq-of ::input-types-decl), i|arg t/index?, i|arg-type t/index?] + (let [{:as input-types-decl :keys [arg-type|split]} (first input-types-decl-group') + input-types-decl-group'' (rest input-types-decl-group')] + (if (empty? input-types-decl-group'') + (let [i|reify i|arg-type] + (>dynamic-dispatch|reify-call (get reify-seq i|reify) arglist)) + (->> arg-type|split + (c/lmap-indexed + (fn [i|arg-type' _] + [`((Array/get ~(:name input-types-decl) ~i|arg-type') ~@arglist) + `(ifs ~@(>dynamic-dispatch|body-for-arity fn|name arglist reify-seq + input-types-decl-group'' (inc i|arg) i|arg-type') + (unsupported! (quote ~(qualify fn|name)) [~@arglist] ~i|arg))])) + c/lcat))))) + (defns >dynamic-dispatch-fn|form [{:keys [::uss/fn|name ::uss/fn|name - expanded-overload-groups-by-fnt-overload (s/vec-of (s/vec-of ::expanded-overload-group)) + expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups) gen-gensym fn? lang ::lang - ::direct-dispatch|reify-groups ::direct-dispatch|reify-groups]} _] - (let [;; TODO not right - expanded-overload-group (-> expanded-overload-groups-by-fnt-overload first first) - arglist (ufgen/gen-args 0 (-> expanded-overload-group :arg-types|form count) "x" gen-gensym) - i|arg 0 - arg-sym (get arglist i|arg) - >reify-call - (fn [{reify- :reify}] - (let [;; TODO this is not general enough - relevant-reify-overload (get-in reify- [:overloads 0]) - dotted-reify-method-sym (symbol (str "." (:method-sym relevant-reify-overload))) - hinted-reify-sym - (ufth/with-type-hint (:name reify-) - (-> relevant-reify-overload :interface >name))] - `(~dotted-reify-method-sym ~hinted-reify-sym ~@arglist)))] - `(defn ~fn|name - {::t/type (t/fn ~@(->> expanded-overload-groups-by-fnt-overload - (map first) ; because what it needs is identical across groups - (map (fn [{:keys [arg-types|pre-split|form - pre-type|form post-type|form]}] - (cond-> (or arg-types|pre-split|form []) - pre-type|form (conj :| pre-type|form) - post-type|form (conj :> post-type|form))))))} - (~arglist - ~(if ;; TODO incrementally check this - (or (empty? arglist) - (->> expanded-overload-group :unprimitivized :arg-types - (every? #(t/= % t/any?)))) - (-> direct-dispatch|reify-groups first >reify-call) - `(ifs - ~@(->> direct-dispatch|reify-groups - (map-indexed - (fn [i|reify {:as direct-dispatch|reify-group :keys [input-types-decl]}] - (prl! input-types-decl) - ;; TODO this part is very rough so far - [`((quantum.core.data.Array/get ~(:name input-types-decl) ~i|arg) ~arg-sym) - (>reify-call direct-dispatch|reify-group)])) - lcat) - (unsupported! (quote ~(qualify fn|name)) [~@arglist] ~i|arg))))))) + i-overload->direct-dispatch-data ::i-overload->direct-dispatch-data]} _] + `(defn ~fn|name + {::t/type ~(>dynamic-dispatch-fn|type-decl expanded-overload-groups-by-fnt-overload)} + ~@(->> i-overload->direct-dispatch-data + (group-by (fn-> :i-arg->input-types-decl count)) + (map (fn [[arg-ct direct-dispatch-data-for-arity]] + (let [arglist (ufgen/gen-args 0 arg-ct "x" gen-gensym) + body (>dynamic-dispatch|body-for-arity + fn|name arglist direct-dispatch-data-for-arity)] + (list arglist body))))))) (defns fnt|code [kind #{:fn :defn}, lang ::lang, args _] - (prl! kind lang args) (let [{:keys [:quantum.core.specs/fn|name :quantum.core.defnt/overloads :quantum.core.specs/meta] :as args'} (s/validate args (case kind :defn ::defnt :fn ::fnt)) + symbolic-analysis? false ; TODO parameterize this gen-gensym-base (ufgen/>reproducible-gensym|generator) gen-gensym (fn [x] (symbol (str (gen-gensym-base x) "__"))) - _ (prl! args') - inline? - (s/validate (-> fn|name core/meta :inline) (t/? t/boolean?)) - _ (prl! inline?) + inline? (s/validate (-> fn|name core/meta :inline) (t/? t/boolean?)) fn|name (if inline? (do (log/pr :warn "requested `:inline`; ignoring until feature is implemented") (update-meta fn|name dissoc :inline)) fn|name) expanded-overload-groups-by-fnt-overload - (->> overloads (mapv #(fnt|overload-data>expanded-overload-groups % {::lang lang}))) + (->> overloads (mapv #(fnt|overload-data>expanded-overload-groups % + {::lang lang :symbolic-analysis? symbolic-analysis?}))) args (assoc (kw-map expanded-overload-groups-by-fnt-overload gen-gensym lang) ::uss/fn|name fn|name) - {:as direct-dispatch :keys [::direct-dispatch|reify-groups]} (>direct-dispatch args) - _ (prl! direct-dispatch) + {:as direct-dispatch :keys [i-overload->direct-dispatch-data]} (>direct-dispatch args) fn-codelist (case lang :clj (->> `[~@(:form direct-dispatch) ~(>dynamic-dispatch-fn|form - (assoc args - ::direct-dispatch|reify-groups direct-dispatch|reify-groups))] + (merge args (kw-map i-overload->direct-dispatch-data)))] (remove nil?)) :cljs (TODO)) code (case kind diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 0872b63e..6318d03c 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -37,6 +37,9 @@ quantum.core.data.Array [quantum.core Numeric Primitive])) +;; Just in case +(clojure.spec.test.alpha/instrument) + #?(:clj (deftest test|pid (let [actual From 28ef1b318cb4e2f52d768c73f04835cc76321aa4 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 17:55:24 -0600 Subject: [PATCH 146/810] First test passes with new code :D --- src-dev/quantum/core/defnt.cljc | 5 +++-- src-untyped/quantum/untyped/core/type.cljc | 2 +- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 29e45e7d..11546880 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -1074,7 +1074,7 @@ LEFT OFF LAST TIME (7/24/2018): dynamic dispatch uses to dispatch off input types." [{:as in :keys [arg-types|split ::expanded-overload-groups|arg-types|split - ::uss/fn|name ::uss/fn|name + fn|name ::uss/fn|name i|fnt-overload t/index?]} _ > (s/vec-of ::input-types-decl)] (->> arg-types|split @@ -1192,7 +1192,8 @@ LEFT OFF LAST TIME (7/24/2018): ([fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?) direct-dispatch-data-for-arity (s/seq-of ::direct-dispatch-data)] (if (empty? arglist) - (>dynamic-dispatch|reify-call (-> direct-dispatch-data-for-arity :reify-seq first) arglist) + (>dynamic-dispatch|reify-call + (-> direct-dispatch-data-for-arity first :reify-seq first) arglist) (let [i|arg 0] `(ifs ~@(->> direct-dispatch-data-for-arity (c/lmap diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index a7e8a9f9..f69c4e7f 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -1819,6 +1819,6 @@ (-def integral? (or primitive? number?)) ;; TODO make into a type - (def nneg-int? #(and (integer? %) (c/>= % 0))) + (def nneg-int? #(c/and (integer? %) (c/>= % 0))) ;; TODO make into a type (def index? nneg-int?) From 86791cefc8d16706044a8bd947829d5b6ada45e7 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 18:07:26 -0600 Subject: [PATCH 147/810] Another test passes :D --- src-dev/quantum/core/defnt.cljc | 30 ++++++++++++++++++------------ 1 file changed, 18 insertions(+), 12 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 11546880..426b341f 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -1188,34 +1188,40 @@ LEFT OFF LAST TIME (7/24/2018): (-> reify- :non-primitivized-overload :interface >name))] `(~dotted-reify-method-sym ~hinted-reify-sym ~@arglist))) +(defns >dynamic-dispatch|conditional + [fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?), i|arg t/index?, body _] + (if (-> body count (= 1)) + (first body) + `(ifs ~@body (unsupported! (quote ~(qualify fn|name)) [~@arglist] ~i|arg)))) + (defns >dynamic-dispatch|body-for-arity ([fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?) direct-dispatch-data-for-arity (s/seq-of ::direct-dispatch-data)] (if (empty? arglist) (>dynamic-dispatch|reify-call (-> direct-dispatch-data-for-arity first :reify-seq first) arglist) - (let [i|arg 0] - `(ifs ~@(->> direct-dispatch-data-for-arity - (c/lmap - (fn [{:keys [reify-seq i-arg->input-types-decl]}] - (>dynamic-dispatch|body-for-arity fn|name arglist reify-seq - i-arg->input-types-decl i|arg 0))) - c/lcat)) - (unsupported! (quote ~(qualify fn|name)) [~@arglist] ~i|arg)))) + (let [i|arg 0 + branches (->> direct-dispatch-data-for-arity + (c/lmap + (fn [{:keys [reify-seq i-arg->input-types-decl]}] + (>dynamic-dispatch|body-for-arity fn|name arglist reify-seq + i-arg->input-types-decl i|arg 0))) + c/lcat)] + (>dynamic-dispatch|conditional fn|name arglist i|arg branches)))) ([fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?), reify-seq (s/vec-of ::reify) input-types-decl-group' (s/seq-of ::input-types-decl), i|arg t/index?, i|arg-type t/index?] (let [{:as input-types-decl :keys [arg-type|split]} (first input-types-decl-group') input-types-decl-group'' (rest input-types-decl-group')] (if (empty? input-types-decl-group'') (let [i|reify i|arg-type] - (>dynamic-dispatch|reify-call (get reify-seq i|reify) arglist)) + [(>dynamic-dispatch|reify-call (get reify-seq i|reify) arglist)]) (->> arg-type|split (c/lmap-indexed (fn [i|arg-type' _] [`((Array/get ~(:name input-types-decl) ~i|arg-type') ~@arglist) - `(ifs ~@(>dynamic-dispatch|body-for-arity fn|name arglist reify-seq - input-types-decl-group'' (inc i|arg) i|arg-type') - (unsupported! (quote ~(qualify fn|name)) [~@arglist] ~i|arg))])) + (let [next-branch (>dynamic-dispatch|body-for-arity fn|name arglist reify-seq + input-types-decl-group'' (inc i|arg) i|arg-type')] + (>dynamic-dispatch|conditional fn|name arglist i|arg next-branch))])) c/lcat))))) (defns >dynamic-dispatch-fn|form From ff6141637518764d730b1fadf79db87e190c51b0 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 18:15:34 -0600 Subject: [PATCH 148/810] And another test passes :D --- src-dev/quantum/core/defnt.cljc | 18 +++++++++--------- src-dev/quantum/core/defnt_equivalences.cljc | 8 +++++--- 2 files changed, 14 insertions(+), 12 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 426b341f..43feabec 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -1212,17 +1212,17 @@ LEFT OFF LAST TIME (7/24/2018): input-types-decl-group' (s/seq-of ::input-types-decl), i|arg t/index?, i|arg-type t/index?] (let [{:as input-types-decl :keys [arg-type|split]} (first input-types-decl-group') input-types-decl-group'' (rest input-types-decl-group')] - (if (empty? input-types-decl-group'') - (let [i|reify i|arg-type] - [(>dynamic-dispatch|reify-call (get reify-seq i|reify) arglist)]) - (->> arg-type|split - (c/lmap-indexed - (fn [i|arg-type' _] - [`((Array/get ~(:name input-types-decl) ~i|arg-type') ~@arglist) + (->> arg-type|split + (c/lmap-indexed + (fn [i|arg-type' _] + [`((Array/get ~(:name input-types-decl) ~i|arg-type') ~@arglist) + (if (empty? input-types-decl-group'') + (let [i|reify i|arg-type] + (>dynamic-dispatch|reify-call (get reify-seq i|reify) arglist)) (let [next-branch (>dynamic-dispatch|body-for-arity fn|name arglist reify-seq input-types-decl-group'' (inc i|arg) i|arg-type')] - (>dynamic-dispatch|conditional fn|name arglist i|arg next-branch))])) - c/lcat))))) + (>dynamic-dispatch|conditional fn|name arglist i|arg next-branch)))])) + c/lcat)))) (defns >dynamic-dispatch-fn|form [{:keys [::uss/fn|name ::uss/fn|name diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 6318d03c..bc0e011b 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -102,10 +102,12 @@ (defn ~'identity|uninlined {::t/type (t/fn ~'[t/any?])} ([~'x00__] - ;; Checks elided because `t/any?` doesn't require a check + ;; TODO elide check because `t/any?` doesn't require a check ;; and all args are `t/=` `t/any?` - (.invoke ~(tag (str `Object>Object) - 'identity|uninlined|__0|0) ~'x00__))))) + (ifs ((Array/get ~'identity|uninlined|__0|input0|types 0) ~'x00__) + (.invoke ~(tag (str `Object>Object) + 'identity|uninlined|__0|0) ~'x00__) + (unsupported! `name|test [~'x00__] 0)))))) :cljs ;; Direct dispatch will be simple functions, not `reify`s ($ (do (defn ~'identity|uninlined [~'x] ~'x))))] From 6d720a6d4c372b5e3b7bb3ba8b2325213e4b1029 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 19:10:34 -0600 Subject: [PATCH 149/810] It passes!! :D --- src-dev/quantum/core/defnt.cljc | 20 +- src-dev/quantum/core/defnt_equivalences.cljc | 181 ++++++++++++++----- 2 files changed, 144 insertions(+), 57 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 43feabec..9ae1cffb 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -35,7 +35,7 @@ :refer [TODO err!]] [quantum.untyped.core.fn :refer [aritoid fn1 fnl fn', fn-> fn->> <-, rcomp - firsta seconda]] + firsta seconda with-do]] [quantum.untyped.core.form :as uform :refer [>form]] [quantum.untyped.core.form.evaluate :as ufeval] @@ -1205,23 +1205,25 @@ LEFT OFF LAST TIME (7/24/2018): (c/lmap (fn [{:keys [reify-seq i-arg->input-types-decl]}] (>dynamic-dispatch|body-for-arity fn|name arglist reify-seq - i-arg->input-types-decl i|arg 0))) + i-arg->input-types-decl (atom 0) i|arg))) c/lcat)] (>dynamic-dispatch|conditional fn|name arglist i|arg branches)))) ([fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?), reify-seq (s/vec-of ::reify) - input-types-decl-group' (s/seq-of ::input-types-decl), i|arg t/index?, i|arg-type t/index?] + input-types-decl-group' (s/seq-of ::input-types-decl), *i|reify _, i|arg t/index?] (let [{:as input-types-decl :keys [arg-type|split]} (first input-types-decl-group') input-types-decl-group'' (rest input-types-decl-group')] (->> arg-type|split (c/lmap-indexed (fn [i|arg-type' _] - [`((Array/get ~(:name input-types-decl) ~i|arg-type') ~@arglist) + [`((Array/get ~(:name input-types-decl) ~i|arg-type') ~(get arglist i|arg)) (if (empty? input-types-decl-group'') - (let [i|reify i|arg-type] - (>dynamic-dispatch|reify-call (get reify-seq i|reify) arglist)) - (let [next-branch (>dynamic-dispatch|body-for-arity fn|name arglist reify-seq - input-types-decl-group'' (inc i|arg) i|arg-type')] - (>dynamic-dispatch|conditional fn|name arglist i|arg next-branch)))])) + (with-do (>dynamic-dispatch|reify-call (get reify-seq @*i|reify) arglist) + ;; TODO take out this ugly bit + (swap! *i|reify inc)) + (let [i|arg' (inc i|arg) + next-branch (>dynamic-dispatch|body-for-arity fn|name arglist reify-seq + input-types-decl-group'' *i|reify i|arg')] + (>dynamic-dispatch|conditional fn|name arglist i|arg' next-branch)))])) c/lcat)))) (defns >dynamic-dispatch-fn|form diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index bc0e011b..c6538fa9 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -703,50 +703,135 @@ (~(tag "boolean" 'invoke) [~'_48__ ~(tag "double" 'a) ~(tag "double" 'b)] ~'(Numeric/gt a b)))) - (defn ~'>|test - {::t/type - (t/fn #?(:clj ~'[t/comparable-primitive? t/comparable-primitive? - :> t/boolean?] - :cljs ~'[t/double? t/double? - :> (t/assume t/boolean?)]))} - ([~'x00__ ~'x10__] - (ifs - ((Array/get ~'>|test|__0|input0|types 0) ~'x00__) - (ifs - ((Array/get ~'>|test|__0|input1|types 0) ~'x00__) - (.invoke ~(tag (str `byte+byte>boolean) '>|test|__0|0) ~'x00__) - ((Array/get ~'>|test|__0|input1|types 1) ~'x00__) - (.invoke ~(tag (str `byte+short>boolean) '>|test|__0|1) ~'x00__) - ((Array/get ~'>|test|__0|input1|types 2) ~'x00__) - (.invoke ~(tag (str `byte+char>boolean) '>|test|__0|2) ~'x00__) - ((Array/get ~'>|test|__0|input1|types 3) ~'x00__) - (.invoke ~(tag (str `byte+int>boolean) '>|test|__0|3) ~'x00__) - ((Array/get ~'>|test|__0|input1|types 4) ~'x00__) - (.invoke ~(tag (str `byte+long>boolean) '>|test|__0|4) ~'x00__) - ((Array/get ~'>|test|__0|input1|types 5) ~'x00__) - (.invoke ~(tag (str `byte+float>boolean) '>|test|__0|5) ~'x00__) - ((Array/get ~'>|test|__0|input1|types 6) ~'x00__) - (.invoke ~(tag (str `byte+double>boolean) '>|test|__0|6) ~'x00__) - (unsupported! `>|test [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|test|__0|input0|types 1) ~'x00__) - (ifs - ((Array/get ~'>|test|__0|input1|types 0) ~'x00__) - (.invoke ~(tag (str `short+byte>boolean) '>|test|__0|7) ~'x00__) - ((Array/get ~'>|test|__0|input1|types 1) ~'x00__) - (.invoke ~(tag (str `short+short>boolean) '>|test|__0|8) ~'x00__) - ((Array/get ~'>|test|__0|input1|types 2) ~'x00__) - (.invoke ~(tag (str `short+char>boolean) '>|test|__0|9) ~'x00__) - ((Array/get ~'>|test|__0|input1|types 3) ~'x00__) - (.invoke ~(tag (str `short+int>boolean) '>|test|__0|10) ~'x00__) - ((Array/get ~'>|test|__0|input1|types 4) ~'x00__) - (.invoke ~(tag (str `short+long>boolean) '>|test|__0|11) ~'x00__) - ((Array/get ~'>|test|__0|input1|types 5) ~'x00__) - (.invoke ~(tag (str `short+float>boolean) '>|test|__0|12) ~'x00__) - ((Array/get ~'>|test|__0|input1|types 6) ~'x00__) - (.invoke ~(tag (str `short+double>boolean) '>|test|__0|13) ~'x00__) - (unsupported! `>|test [~'x00__ ~'x10__] 1)) - ... - (unsupported! `>|test [~'x00__ ~'x10__] 0)))))) + ;; Unindented for greater vertical brevity + (defn ~'>|test + {::t/type + (t/fn #?(:clj ~'[t/comparable-primitive? t/comparable-primitive? + :> t/boolean?] + :cljs ~'[t/double? t/double? + :> (t/assume t/boolean?)]))} + ([~'x00__ ~'x10__] + (ifs + ((Array/get ~'>|test|__0|input0|types 0) ~'x00__) + (ifs + ((Array/get ~'>|test|__0|input1|types 0) ~'x10__) + (.invoke ~(tag (str `byte+byte>boolean) '>|test|__0|0) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 1) ~'x10__) + (.invoke ~(tag (str `byte+short>boolean) '>|test|__0|1) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 2) ~'x10__) + (.invoke ~(tag (str `byte+char>boolean) '>|test|__0|2) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 3) ~'x10__) + (.invoke ~(tag (str `byte+int>boolean) '>|test|__0|3) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 4) ~'x10__) + (.invoke ~(tag (str `byte+long>boolean) '>|test|__0|4) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 5) ~'x10__) + (.invoke ~(tag (str `byte+float>boolean) '>|test|__0|5) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 6) ~'x10__) + (.invoke ~(tag (str `byte+double>boolean) '>|test|__0|6) ~'x00__ ~'x10__) + (unsupported! `>|test [~'x00__ ~'x10__] 1)) + ((Array/get ~'>|test|__0|input0|types 1) ~'x00__) + (ifs + ((Array/get ~'>|test|__0|input1|types 0) ~'x10__) + (.invoke ~(tag (str `short+byte>boolean) '>|test|__0|7) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 1) ~'x10__) + (.invoke ~(tag (str `short+short>boolean) '>|test|__0|8) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 2) ~'x10__) + (.invoke ~(tag (str `short+char>boolean) '>|test|__0|9) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 3) ~'x10__) + (.invoke ~(tag (str `short+int>boolean) '>|test|__0|10) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 4) ~'x10__) + (.invoke ~(tag (str `short+long>boolean) '>|test|__0|11) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 5) ~'x10__) + (.invoke ~(tag (str `short+float>boolean) '>|test|__0|12) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 6) ~'x10__) + (.invoke ~(tag (str `short+double>boolean) '>|test|__0|13) ~'x00__ ~'x10__) + (unsupported! `>|test [~'x00__ ~'x10__] 1)) + ((Array/get ~'>|test|__0|input0|types 2) ~'x00__) + (ifs + ((Array/get ~'>|test|__0|input1|types 0) ~'x10__) + (.invoke ~(tag (str `char+byte>boolean) '>|test|__0|14) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 1) ~'x10__) + (.invoke ~(tag (str `char+short>boolean) '>|test|__0|15) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 2) ~'x10__) + (.invoke ~(tag (str `char+char>boolean) '>|test|__0|16) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 3) ~'x10__) + (.invoke ~(tag (str `char+int>boolean) '>|test|__0|17) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 4) ~'x10__) + (.invoke ~(tag (str `char+long>boolean) '>|test|__0|18) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 5) ~'x10__) + (.invoke ~(tag (str `char+float>boolean) '>|test|__0|19) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 6) ~'x10__) + (.invoke ~(tag (str `char+double>boolean) '>|test|__0|20) ~'x00__ ~'x10__) + (unsupported! `>|test [~'x00__ ~'x10__] 1)) + ((Array/get ~'>|test|__0|input0|types 3) ~'x00__) + (ifs + ((Array/get ~'>|test|__0|input1|types 0) ~'x10__) + (.invoke ~(tag (str `int+byte>boolean) '>|test|__0|21) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 1) ~'x10__) + (.invoke ~(tag (str `int+short>boolean) '>|test|__0|22) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 2) ~'x10__) + (.invoke ~(tag (str `int+char>boolean) '>|test|__0|23) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 3) ~'x10__) + (.invoke ~(tag (str `int+int>boolean) '>|test|__0|24) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 4) ~'x10__) + (.invoke ~(tag (str `int+long>boolean) '>|test|__0|25) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 5) ~'x10__) + (.invoke ~(tag (str `int+float>boolean) '>|test|__0|26) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 6) ~'x10__) + (.invoke ~(tag (str `int+double>boolean) '>|test|__0|27) ~'x00__ ~'x10__) + (unsupported! `>|test [~'x00__ ~'x10__] 1)) + ((Array/get ~'>|test|__0|input0|types 4) ~'x00__) + (ifs + ((Array/get ~'>|test|__0|input1|types 0) ~'x10__) + (.invoke ~(tag (str `long+byte>boolean) '>|test|__0|28) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 1) ~'x10__) + (.invoke ~(tag (str `long+short>boolean) '>|test|__0|29) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 2) ~'x10__) + (.invoke ~(tag (str `long+char>boolean) '>|test|__0|30) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 3) ~'x10__) + (.invoke ~(tag (str `long+int>boolean) '>|test|__0|31) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 4) ~'x10__) + (.invoke ~(tag (str `long+long>boolean) '>|test|__0|32) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 5) ~'x10__) + (.invoke ~(tag (str `long+float>boolean) '>|test|__0|33) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 6) ~'x10__) + (.invoke ~(tag (str `long+double>boolean) '>|test|__0|34) ~'x00__ ~'x10__) + (unsupported! `>|test [~'x00__ ~'x10__] 1)) + ((Array/get ~'>|test|__0|input0|types 5) ~'x00__) + (ifs + ((Array/get ~'>|test|__0|input1|types 0) ~'x10__) + (.invoke ~(tag (str `float+byte>boolean) '>|test|__0|35) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 1) ~'x10__) + (.invoke ~(tag (str `float+short>boolean) '>|test|__0|36) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 2) ~'x10__) + (.invoke ~(tag (str `float+char>boolean) '>|test|__0|37) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 3) ~'x10__) + (.invoke ~(tag (str `float+int>boolean) '>|test|__0|38) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 4) ~'x10__) + (.invoke ~(tag (str `float+long>boolean) '>|test|__0|39) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 5) ~'x10__) + (.invoke ~(tag (str `float+float>boolean) '>|test|__0|40) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 6) ~'x10__) + (.invoke ~(tag (str `float+double>boolean) '>|test|__0|41) ~'x00__ ~'x10__) + (unsupported! `>|test [~'x00__ ~'x10__] 1)) + ((Array/get ~'>|test|__0|input0|types 6) ~'x00__) + (ifs + ((Array/get ~'>|test|__0|input1|types 0) ~'x10__) + (.invoke ~(tag (str `double+byte>boolean) '>|test|__0|42) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 1) ~'x10__) + (.invoke ~(tag (str `double+short>boolean) '>|test|__0|43) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 2) ~'x10__) + (.invoke ~(tag (str `double+char>boolean) '>|test|__0|44) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 3) ~'x10__) + (.invoke ~(tag (str `double+int>boolean) '>|test|__0|45) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 4) ~'x10__) + (.invoke ~(tag (str `double+long>boolean) '>|test|__0|46) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 5) ~'x10__) + (.invoke ~(tag (str `double+float>boolean) '>|test|__0|47) ~'x00__ ~'x10__) + ((Array/get ~'>|test|__0|input1|types 6) ~'x10__) + (.invoke ~(tag (str `double+double>boolean) '>|test|__0|48) ~'x00__ ~'x10__) + (unsupported! `>|test [~'x00__ ~'x10__] 1)) + (unsupported! `>|test [~'x00__ ~'x10__] 0)))))) :cljs ($ (do (defn ~'>|test ([a0 a1] @@ -756,12 +841,12 @@ (unsupported! `>|test [a0 a1] 1)) (unsupported! `>|test [a0 a1] 0)))))))] (testing "code equivalence" (is-code= actual expected)) - #_(testing "functionality" + (testing "functionality" (eval actual) - (eval '(do ...)))) + (eval '(do (is= (>|test 0 1) (> 0 1)) + (is= (>|test 1 0) (> 1 0)) + (is= (>|test 1.0 0) (> 1.0 0)))))) -;; TODO fix: current implementation prefers to consolidate into one `reify` rather than splitting it -;; up as below (is-code= (macroexpand ' From ed7e0203b52c97dbaef5275958f8dbff0ba06d99 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 21:47:41 -0600 Subject: [PATCH 150/810] A few comments and reorganizations --- src-dev/quantum/core/defnt.cljc | 53 ++++++++++++-------- src-dev/quantum/core/defnt_equivalences.cljc | 12 +++-- src-untyped/quantum/untyped/core/type.cljc | 35 ++++++------- 3 files changed, 55 insertions(+), 45 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 9ae1cffb..52c1a03c 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -563,7 +563,8 @@ LEFT OFF LAST TIME (7/24/2018): [env ::env, form _, [pred-form _, true-form _, false-form _ :as body] _] {:post [(prl! %)]} (if (-> body count (not= 3)) - (err! "`if` accepts exactly 3 arguments: one predicate test and two branches; received" {:body body}) + (err! "`if` accepts exactly 3 arguments: one predicate test and two branches; received" + {:body body}) (let [pred-expr (analyze* env pred-form) true-expr (delay (analyze* env true-form)) false-expr (delay (analyze* env false-form)) @@ -575,16 +576,19 @@ LEFT OFF LAST TIME (7/24/2018): :pred-expr pred-expr :true-expr @true-expr :false-expr @false-expr - :type (apply t/or (->> [(:type @true-expr) (:type @false-expr)] (remove nil?)))}))] + :type (apply t/or (->> [(:type @true-expr) (:type @false-expr)] + (remove nil?)))}))] (case (truthy-expr? pred-expr) true (do (ppr :warn "Predicate in `if` expression is always true" {:pred pred-form}) - (-> @true-expr (assoc :env env) - (cond-> (not *conditional-branch-pruning?*) - (assoc :form (list 'if pred-form (:form @true-expr) false-form))))) + (-> @true-expr + (assoc :env env) + (cond-> (not *conditional-branch-pruning?*) + (assoc :form (list 'if pred-form (:form @true-expr) false-form))))) false (do (ppr :warn "Predicate in `if` expression is always false" {:pred pred-form}) - (-> @false-expr (assoc :env env) - (cond-> (not *conditional-branch-pruning?*) - (assoc :form (list 'if pred-form true-form (:form @false-expr)))))) + (-> @false-expr + (assoc :env env) + (cond-> (not *conditional-branch-pruning?*) + (assoc :form (list 'if pred-form true-form (:form @false-expr)))))) nil @whole-expr)))) (defns- analyze-seq|quote [env ::env, form _, body _] @@ -643,34 +647,42 @@ LEFT OFF LAST TIME (7/24/2018): (1 2) (err! "It is not known whether expression be called" {:expr caller|expr}) 3 (err! "Expression cannot be called" {:expr caller|expr}) (-1 0) (let [assert-valid-args-ct - (ifs (or (t/<= caller|type t/keyword?) (t/<= caller|type t/+map|built-in?)) + (ifs (or (t/<= caller|type t/keyword?) + (t/<= caller|type t/+map|built-in?)) (when-not (or (= args-ct 1) (= args-ct 2)) - (err! (str "Keywords and `clojure.core` persistent maps must be provided " - "with exactly one or two args when calling them") + (err! (str "Keywords and `clojure.core` persistent maps must be " + "provided with exactly one or two args when calling " + "them") {:args-ct args-ct :caller caller|expr})) - (or (t/<= caller|type t/+vector|built-in?) (t/<= caller|type t/+set|built-in?)) + (or (t/<= caller|type t/+vector|built-in?) + (t/<= caller|type t/+set|built-in?)) (when-not (= args-ct 1) - (err! (str "`clojure.core` persistent vectors and `clojure.core` persistent " - "sets must be provided with exactly one arg when calling them") + (err! (str "`clojure.core` persistent vectors and `clojure.core` " + "persistent sets must be provided with exactly one arg " + "when calling them") {:args-ct args-ct :caller caller|expr})) (t/<= caller|type t/fnt?) (TODO "Don't know how to handle typed fns yet" {:caller caller|expr}) ;; For non-typed fns, unknown; we will have to risk runtime exception - ;; because we can't necessarily rely on metadata to tell us the whole truth + ;; because we can't necessarily rely on metadata to tell us the + ;; whole truth (t/<= caller|type t/fn?) nil - ;; If it's ifn but not fn, we might have missed something in this dispatch so for now we throw - (err! "Don't know how how to handle non-fn ifn" {:caller caller|expr})) + ;; If it's ifn but not fn, we might have missed something in this + ;; dispatch so for now we throw + (err! "Don't know how how to handle non-fn ifn" + {:caller caller|expr})) {:keys [args] t :type} (->> body (c/map+ #(analyze* env %)) (reduce (fn [{:keys [args]} arg|analyzed] (conj args))))] - ;; TODO incrementally check by analyzing each arg in `reduce` and pruning branches of what the - ;; type could be, and throwing if it's found something that's an impossible combination + ;; TODO incrementally check by analyzing each arg in `reduce` and pruning + ;; branches of what the type could be, and throwing if it's found something + ;; that's an impossible combination (ast/call-expr {:env env :form form @@ -697,8 +709,7 @@ LEFT OFF LAST TIME (7/24/2018): (or (t/literal? resolved) (t/class? resolved)) (t/value resolved) (var? resolved) - (or (-> resolved meta :type) - (t/value @resolved)) + (or (-> resolved meta ::t/type) (t/value @resolved)) (utpred/unbound? resolved) ;; Because the var could be anything and cannot have metadata (type or otherwise) t/any? diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index c6538fa9..4408a6d6 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -5,7 +5,7 @@ (:require [clojure.core :as c] [quantum.core.defnt - :refer [analyze defnt fnt|code *fn->type unsupported!]] + :refer [analyze defnt fnt fnt|code *fn->type unsupported!]] [quantum.untyped.core.analyze.expr :as xp] [quantum.untyped.core.collections.diff :as diff :refer [diff]] @@ -847,6 +847,7 @@ (is= (>|test 1 0) (> 1 0)) (is= (>|test 1.0 0) (> 1.0 0)))))) +;; TODO finish test (is-code= (macroexpand ' @@ -925,13 +926,16 @@ > t/long? ([x (t/- t/primitive? t/boolean? t/float? t/double?)] (>long* x)) ([x (t/and (t/or t/double? t/float?) - (fnt [x (t/or double? float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] + ;; TODO add this back in + #_(fnt [x (t/or t/double? t/float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] (>long* x)) ([x (t/and (t/isa? clojure.lang.BigInt) - (fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] + ;; TODO add this back in + #_(fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] (.lpart x)) ([x (t/and (t/isa? java.math.BigInteger) - (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] + ;; TODO add this back in + #_(fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] (.longValue x)) ([x t/ratio?] (>long (.bigIntegerValue x))) ([x (t/value true)] 1) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index f69c4e7f..8c335cc3 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -174,6 +174,7 @@ If `t0` < `t1`, `∅` If `t0` <> `t1`, `t0` If `t0` > | >< `t1`, `t0` with all elements of `t1` removed" + ([t0 utr/type? > utr/type?] t0) ([t0 utr/type?, t1 utr/type? > utr/type?] (let [c (compare t0 t1)] (case c @@ -436,11 +437,11 @@ ;; TODO do this #_(do -(udt/deftype FnSpec +(udt/deftype FnType [name #_(t/? t/symbol?) dispatch ... meta] - {PSpec nil + {PType nil ;; Outputs whether the args match any input spec ?Fn {invoke ([this args] (if-let [arity-specs (get lookup (count args))] @@ -449,32 +450,30 @@ ?Meta {meta ([this] meta) with-meta ([this meta'] (FnSpec. name lookup spec meta'))} fipp.ednize/IOverride nil - fipp.ednize/IEdn {-edn ([this] (list `fn name lookup))}}) + fipp.ednize/IEdn {-edn ([this] (list `fn name lookup))}})) -(defns fn-spec? [x _ > c/boolean?] (instance? FnSpec x)) +(udt/deftype FnType + [arg] + {PType nil + fipp.ednize/IOverride nil + fipp.ednize/IEdn {-edn ([this] (list `fn arg))}}) -(defns fn|args>out-spec - "Returns nil if args do not match any input spec" - [^FnSpec spec fn-spec?, args _] - (when-let [spec-or-arity-specs (get (.-lookup spec) (count args))] - (if (spec? spec-or-arity-specs) - spec-or-arity-specs - (->> spec-or-arity-specs (uc/filter+ #((first %) args)) uc/first second)))) +(defns fn-type? [x _ > c/boolean?] (instance? FnType x)) (defns fn - [name- (s/nilable c/symbol?) + [& args _] + (FnType. args) + #_[name- (s/nilable c/symbol?) lookup _ #_(t/map-of t/integer? (t/or (spec spec? "output-spec") (t/vec-of (t/tuple (t/vec-of (spec spec? "input-spec")) (spec spec? "output-spec")))))] - (let [spec (->> lookup vals + #_(let [spec (->> lookup vals (uc/map+ (c/fn [spec-or-arity-specs] (if (spec? spec-or-arity-specs) spec-or-arity-specs (->> spec-or-arity-specs (map (TODO)))))))] - (FnSpec. name- lookup spec nil))) - -) + (FnType. name- lookup spec nil))) (defn unkeyed "Creates an unkeyed collection type, in which the collection may @@ -558,10 +557,6 @@ x (err! "Type-validation failed" {:type t :to-validate x}))) -;; ===== `t/fn` ===== ;; - -(defn fn [& args] (println "TODO `t/fnn`") nil) - ;; ---------------------- ;; ;; ===== Predicates ===== ;; ;; ---------------------- ;; From ae3efb76cc3886d518b6841bc6ec1d10ec2c7859 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 24 Jul 2018 22:01:15 -0600 Subject: [PATCH 151/810] Add some notes --- src-dev/quantum/core/defnt.cljc | 7 ++++--- src-dev/quantum/core/defnt_equivalences.cljc | 1 - src-untyped/quantum/untyped/core/type.cljc | 2 +- src-untyped/quantum/untyped/core/type/compare.cljc | 9 ++++----- 4 files changed, 9 insertions(+), 10 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 52c1a03c..59ec5f8e 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -83,9 +83,10 @@ #_" LEFT OFF LAST TIME (7/24/2018): -- ;; TODO probably failing because class vs. symbol -- This is because of the `>form` not quite returning the right thing for `t/isa?` stuff in reifications -- After that, keep going making sure the test cases pass, especially the >int* cases +- expressions (`quantum.untyped.core.analyze.expr`) +- `t/fn` +- `(defnt >long ...)` : enable to refer to `>long*` and have that analyzed +- finish `>long` example diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 4408a6d6..aa442a70 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -917,7 +917,6 @@ ;; =====|=====|=====|=====|===== ;; -;; TODO requires `>long*` being defined for it to work (is-code= (macroexpand ' diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 8c335cc3..3aaa9ee4 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -1655,7 +1655,7 @@ (-def ifn? (isa? #?(:clj clojure.lang.IFn :cljs cljs.core/IFn))) - (-def fnt? (and fn? (>expr (fn-> c/meta :type)))) + (-def fnt? (and fn? (>expr (fn-> c/meta ::type)))) (-def multimethod? (isa? #?(:clj clojure.lang.MultiFn :cljs cljs.core/IMultiFn))) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index 20d516f5..954d78a7 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -334,7 +334,7 @@ NotType #'compare|not+not OrType #'compare|not+or AndType #'compare|not+and - Expression #'fn<> + Expression #'fn<> ; TODO not entirely true ProtocolType #'compare|not+protocol ClassType #'compare|not+class ValueType #'compare|not+value} @@ -344,7 +344,7 @@ NotType (inverted #'compare|not+or) OrType #'compare|or+or AndType #'compare|or+and - Expression #'fn<> + Expression #'fn<> ; TODO not entirely true ProtocolType #'compare|todo ClassType (inverted #'compare|class+or) ValueType (inverted #'compare|value+or)} @@ -354,7 +354,7 @@ NotType #'compare|todo OrType (inverted #'compare|or+and) AndType #'compare|and+and - Expression #'fn<> + Expression #'fn<> ; TODO not entirely true ProtocolType #'compare|todo ClassType (inverted #'compare|class+and) ValueType (inverted #'compare|value+and)} @@ -385,7 +385,7 @@ NotType (inverted #'compare|not+class) OrType #'compare|class+or AndType #'compare|class+and - Expression #'fn<> + Expression #'fn<> ; TODO not entirely true ProtocolType #'compare|todo ClassType #'compare|class+class ValueType #'compare|class+value} @@ -461,4 +461,3 @@ "Computes whether the respective extensions of types ->`t0` and ->`t1` are disjoint." ([t1 type?] #(<> % t1)) ([t0 type? t1 type? > boolean?] (c/= (compare t0 t1) <>ident))) - From abc22744a3a11bc4851e0aec6f57064f665b2862 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 25 Jul 2018 11:55:52 -0600 Subject: [PATCH 152/810] Finish a test --- src-dev/quantum/core/defnt_equivalences.cljc | 155 ++++++++++--------- 1 file changed, 82 insertions(+), 73 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index aa442a70..91345991 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -168,7 +168,7 @@ (satisfies? INamed x) (-name x) (unsupported! `name|test [~'x00__] 0))))))] (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" + #_(testing "functionality" (eval actual) (eval '(do (is= (name|test "") (name "")) (is= (name|test "abc") (name "abc")) @@ -230,7 +230,7 @@ (ifs (nil? x) false true)))))] (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" + #_(testing "functionality" (eval actual) (eval '(do (throws (some?|test)) (is= (some?|test 123) (some? 123)) @@ -289,7 +289,7 @@ ($ (do (defn ~'reduced?|test [~'x] (ifs (instance? Reduced x) true false)))))] (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" + #_(testing "functionality" (eval actual) (eval '(do (throws (reduced?|test)) (is= (reduced?|test 123) (reduced? 123)) @@ -364,7 +364,7 @@ (nil? x) false true)))))] (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" + #_(testing "functionality" (eval actual) (eval '(do (throws (>boolean)) (is= (>boolean true) (boolean true)) @@ -461,7 +461,7 @@ (.invoke ~(tag (str `Object>int) '>int*|__1|0) ~'x00__) (unsupported! `>int* [~'x00__] 0)))))))] (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" + #_(testing "functionality" (eval actual) (eval '(do (throws (>int*)) (throws (>int* nil)) @@ -841,79 +841,88 @@ (unsupported! `>|test [a0 a1] 1)) (unsupported! `>|test [a0 a1] 0)))))))] (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" + #_(testing "functionality" (eval actual) (eval '(do (is= (>|test 0 1) (> 0 1)) (is= (>|test 1 0) (> 1 0)) (is= (>|test 1.0 0) (> 1.0 0)))))) -;; TODO finish test -(is-code= - -(macroexpand ' -(defnt #_:inline >long* - {:source "clojure.lang.RT.uncheckedLongCast"} - > t/long? - ([x (t/- t/primitive? t/boolean?)] (Primitive/uncheckedLongCast x)) - ([x (t/ref (t/isa? Number))] (.longValue x)))) - -;; ----- expanded code ----- ;; - -(case (env-lang) - :clj ($ (do ;; [x (t/- t/primitive? t/boolean?)] - - #_(def ~'>long*|__0|input-types (*<> t/byte?)) - (def ~'>long*|__0 - (reify byte>long (~(tag "long" 'invoke) [~'_0__ ~(tag "byte" 'x)] - ~'(Primitive/uncheckedLongCast x)))) - - #_(def ~'>long*|__1|input-types (*<> t/char?)) - (def ~'>long*|__1 - (reify char>long (~(tag "long" 'invoke) [~'_1__ ~(tag "char" 'x)] - ~'(Primitive/uncheckedLongCast x)))) - - #_(def ~'>long*|__2|input-types (*<> t/short?)) - (def ~'>long*|__2 - (reify short>long (~(tag "long" 'invoke) [~'_2__ ~(tag "short" 'x)] - ~'(Primitive/uncheckedLongCast x)))) - - #_(def ~'>long*|__3|input-types (*<> t/int?)) - (def ~'>long*|__3 - (reify int>long (~(tag "long" 'invoke) [~'_3__ ~(tag "int" 'x)] - ~'(Primitive/uncheckedLongCast x)))) - - #_(def ~'>long*|__4|input-types (*<> t/long?)) - (def ~'>long*|__4 - (reify long>long (~(tag "long" 'invoke) [~'_4__ ~(tag "long" 'x)] - ~'(Primitive/uncheckedLongCast x)))) - - #_(def ~'>long*|__5|input-types (*<> t/float?)) - (def ~'>long*|__5 - (reify float>long (~(tag "long" 'invoke) [~'_5__ ~(tag "float" 'x)] - ~'(Primitive/uncheckedLongCast x)))) - - #_(def ~'>long*|__6|input-types (*<> t/double?)) - (def ~'>long*|__6 - (reify double>long (~(tag "long" 'invoke) [~'_6__ ~(tag "double" 'x)] - ~'(Primitive/uncheckedLongCast x)))) - - ;; [x (t/ref (t/isa? Number))] - - #_(def ~'>long*|__7|input-types (*<> (t/isa? Number))) - (def ~'>long*|__7 - (reify Object>long (~(tag "long" 'invoke) [~'_7__ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(.longValue x))))) - - #_(defn >long* - {::t/type (t/fn [(t/- t/primitive? t/boolean?)] - [(t/ref (t/isa? Number))])} - [a0##] (ifs ((Array/get >long*|__0|input-types 0) a0##) - (.invoke >long*|__0 a0##) - ...)) - - ))) - -) +(deftest test|>long* + (let [actual + (macroexpand ' + (defnt #_:inline >long* + {:source "clojure.lang.RT.uncheckedLongCast"} + > t/long? + ([x (t/- t/primitive? t/boolean?)] (Primitive/uncheckedLongCast x)) + ([x (t/ref (t/isa? Number))] (.longValue x)))) + expected + (case (env-lang) + :clj ($ (do ;; [x (t/- t/primitive? t/boolean?)] + + (def ~(tag "[Ljava.lang.Object;" '>long*|__0|input0|types) + (*<> (t/isa? java.lang.Byte) + (t/isa? java.lang.Short) + (t/isa? java.lang.Character) + (t/isa? java.lang.Integer) + (t/isa? java.lang.Long) + (t/isa? java.lang.Float) + (t/isa? java.lang.Double))) + (def ~'>long*|__0|0 + (reify* [byte>long] (~(tag "long" 'invoke) [~'_0__ ~(tag "byte" 'x)] + ~'(Primitive/uncheckedLongCast x)))) + (def ~'>long*|__0|1 + (reify* [char>long] (~(tag "long" 'invoke) [~'_1__ ~(tag "char" 'x)] + ~'(Primitive/uncheckedLongCast x)))) + (def ~'>long*|__0|2 + (reify* [short>long] (~(tag "long" 'invoke) [~'_2__ ~(tag "short" 'x)] + ~'(Primitive/uncheckedLongCast x)))) + (def ~'>long*|__0|3 + (reify* [int>long] (~(tag "long" 'invoke) [~'_3__ ~(tag "int" 'x)] + ~'(Primitive/uncheckedLongCast x)))) + (def ~'>long*|__0|4 + (reify* [long>long] (~(tag "long" 'invoke) [~'_4__ ~(tag "long" 'x)] + ~'(Primitive/uncheckedLongCast x)))) + (def ~'>long*|__0|5 + (reify* [float>long] (~(tag "long" 'invoke) [~'_5__ ~(tag "float" 'x)] + ~'(Primitive/uncheckedLongCast x)))) + (def ~'>long*|__0|6 + (reify* [double>long] (~(tag "long" 'invoke) [~'_6__ ~(tag "double" 'x)] + ~'(Primitive/uncheckedLongCast x)))) + + ;; [x (t/ref (t/isa? Number))] + + (def ~(tag "[Ljava.lang.Object;" '>long*|__1|input0|types) + (*<> ~(with-meta `(t/isa? Number) {:ref? true}))) + (def ~'>long*|__1|0 + (reify* [Object>long] (~(tag "long" 'invoke) [~'_7__ ~(tag "java.lang.Object" 'x)] + (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(.longValue x))))) + + (defn ~'>long* + {::t/type (t/fn ~'[(t/- t/primitive? t/boolean?) :> t/long?] + ~'[(t/ref (t/isa? Number)) :> t/long?])} + ([~'x00__] + (ifs + ((Array/get ~'>long*|__0|input0|types 0) x00__) + (.invoke >long*|__0|0 x00__) + ((Array/get ~'>long*|__0|input0|types 1) x00__) + (.invoke >long*|__0|1 x00__) + ((Array/get ~'>long*|__0|input0|types 2) x00__) + (.invoke >long*|__0|2 x00__) + ((Array/get ~'>long*|__0|input0|types 3) x00__) + (.invoke >long*|__0|3 x00__) + ((Array/get ~'>long*|__0|input0|types 4) x00__) + (.invoke >long*|__0|4 x00__) + ((Array/get ~'>long*|__0|input0|types 5) x00__) + (.invoke >long*|__0|5 x00__) + ((Array/get ~'>long*|__0|input0|types 6) x00__) + (.invoke >long*|__0|6 x00__) + ((Array/get ~'>long*|__1|input0|types 0) x00__) + (.invoke >long*|__1|0 x00__) + (unsupported! `>long* [~'x00__] 0)))))))] + (testing "code equivalence" (is-code= actual expected)) + #_(testing "functionality" + (eval actual) + (eval '(do ))))) ;; =====|=====|=====|=====|===== ;; From 951b8f52574e21fad6c3c2c1eaa4569512d84e6b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 25 Jul 2018 12:02:08 -0600 Subject: [PATCH 153/810] Temporary fix to `t/fn` to make `eval` work for `defnt`s --- src-dev/quantum/core/defnt_equivalences.cljc | 28 +++++++++++++------- src-untyped/quantum/untyped/core/type.cljc | 4 +-- 2 files changed, 21 insertions(+), 11 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 91345991..3b1476ef 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -54,7 +54,7 @@ ~'(->> (java.lang.management.ManagementFactory/getRuntimeMXBean) (.getName))))) (defn ~'pid|test - {::t/type (t/fn [:> ~'(? t/string?)])} + {::t/type (t/fn ~'[:> (? t/string?)])} ([] (.invoke ~(tag (str `>Object) 'pid|test|__0|0))))))] (testing "code equivalence" (is-code= actual expected)) @@ -168,7 +168,7 @@ (satisfies? INamed x) (-name x) (unsupported! `name|test [~'x00__] 0))))))] (testing "code equivalence" (is-code= actual expected)) - #_(testing "functionality" + (testing "functionality" (eval actual) (eval '(do (is= (name|test "") (name "")) (is= (name|test "abc") (name "abc")) @@ -230,7 +230,7 @@ (ifs (nil? x) false true)))))] (testing "code equivalence" (is-code= actual expected)) - #_(testing "functionality" + (testing "functionality" (eval actual) (eval '(do (throws (some?|test)) (is= (some?|test 123) (some? 123)) @@ -289,7 +289,7 @@ ($ (do (defn ~'reduced?|test [~'x] (ifs (instance? Reduced x) true false)))))] (testing "code equivalence" (is-code= actual expected)) - #_(testing "functionality" + (testing "functionality" (eval actual) (eval '(do (throws (reduced?|test)) (is= (reduced?|test 123) (reduced? 123)) @@ -364,7 +364,7 @@ (nil? x) false true)))))] (testing "code equivalence" (is-code= actual expected)) - #_(testing "functionality" + (testing "functionality" (eval actual) (eval '(do (throws (>boolean)) (is= (>boolean true) (boolean true)) @@ -461,7 +461,7 @@ (.invoke ~(tag (str `Object>int) '>int*|__1|0) ~'x00__) (unsupported! `>int* [~'x00__] 0)))))))] (testing "code equivalence" (is-code= actual expected)) - #_(testing "functionality" + (testing "functionality" (eval actual) (eval '(do (throws (>int*)) (throws (>int* nil)) @@ -841,7 +841,7 @@ (unsupported! `>|test [a0 a1] 1)) (unsupported! `>|test [a0 a1] 0)))))))] (testing "code equivalence" (is-code= actual expected)) - #_(testing "functionality" + (testing "functionality" (eval actual) (eval '(do (is= (>|test 0 1) (> 0 1)) (is= (>|test 1 0) (> 1 0)) @@ -920,9 +920,19 @@ (.invoke >long*|__1|0 x00__) (unsupported! `>long* [~'x00__] 0)))))))] (testing "code equivalence" (is-code= actual expected)) - #_(testing "functionality" + (testing "functionality" (eval actual) - (eval '(do ))))) + (eval + '(do (throws (>long*)) + (throws (>long* nil)) + (throws (>long* "")) + (is (identical? (>long* 1) (clojure.lang.RT/uncheckedLongCast 1))) + (is (identical? (>long* 1.0) (clojure.lang.RT/uncheckedLongCast 1.0))) + (is (identical? (>long* 1.1) (clojure.lang.RT/uncheckedLongCast 1.1))) + (is (identical? (>long* -1) (clojure.lang.RT/uncheckedLongCast -1))) + (is (identical? (>long* -1.0) (clojure.lang.RT/uncheckedLongCast -1.0))) + (is (identical? (>long* -1.1) (clojure.lang.RT/uncheckedLongCast -1.1))) + (is (identical? (>long* (byte 1)) (clojure.lang.RT/uncheckedLongCast (byte 1))))))))) ;; =====|=====|=====|=====|===== ;; diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 3aaa9ee4..4cc94dce 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -461,8 +461,8 @@ (defns fn-type? [x _ > c/boolean?] (instance? FnType x)) (defns fn - [& args _] - (FnType. args) + [arg _ & args _] ; TODO fix — & args should have been sufficient but `defnt` has a bug that way + (FnType. (cons arg args)) #_[name- (s/nilable c/symbol?) lookup _ #_(t/map-of t/integer? (t/or (spec spec? "output-spec") From 23f0d4f2b9f0e2fc928353601f55dd83ad0db368 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 25 Jul 2018 12:04:32 -0600 Subject: [PATCH 154/810] Spacing; introduce `defnt-reference-test` --- src-dev/quantum/core/defnt_equivalences.cljc | 46 ++++++++++++-------- 1 file changed, 28 insertions(+), 18 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 3b1476ef..6101f6ff 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -868,34 +868,42 @@ (t/isa? java.lang.Float) (t/isa? java.lang.Double))) (def ~'>long*|__0|0 - (reify* [byte>long] (~(tag "long" 'invoke) [~'_0__ ~(tag "byte" 'x)] - ~'(Primitive/uncheckedLongCast x)))) + (reify* [byte>long] + (~(tag "long" 'invoke) [~'_0__ ~(tag "byte" 'x)] + ~'(Primitive/uncheckedLongCast x)))) (def ~'>long*|__0|1 - (reify* [char>long] (~(tag "long" 'invoke) [~'_1__ ~(tag "char" 'x)] - ~'(Primitive/uncheckedLongCast x)))) + (reify* [char>long] + (~(tag "long" 'invoke) [~'_1__ ~(tag "char" 'x)] + ~'(Primitive/uncheckedLongCast x)))) (def ~'>long*|__0|2 - (reify* [short>long] (~(tag "long" 'invoke) [~'_2__ ~(tag "short" 'x)] - ~'(Primitive/uncheckedLongCast x)))) + (reify* [short>long] + (~(tag "long" 'invoke) [~'_2__ ~(tag "short" 'x)] + ~'(Primitive/uncheckedLongCast x)))) (def ~'>long*|__0|3 - (reify* [int>long] (~(tag "long" 'invoke) [~'_3__ ~(tag "int" 'x)] - ~'(Primitive/uncheckedLongCast x)))) + (reify* [int>long] + (~(tag "long" 'invoke) [~'_3__ ~(tag "int" 'x)] + ~'(Primitive/uncheckedLongCast x)))) (def ~'>long*|__0|4 - (reify* [long>long] (~(tag "long" 'invoke) [~'_4__ ~(tag "long" 'x)] - ~'(Primitive/uncheckedLongCast x)))) + (reify* [long>long] + (~(tag "long" 'invoke) [~'_4__ ~(tag "long" 'x)] + ~'(Primitive/uncheckedLongCast x)))) (def ~'>long*|__0|5 - (reify* [float>long] (~(tag "long" 'invoke) [~'_5__ ~(tag "float" 'x)] - ~'(Primitive/uncheckedLongCast x)))) + (reify* [float>long] + (~(tag "long" 'invoke) [~'_5__ ~(tag "float" 'x)] + ~'(Primitive/uncheckedLongCast x)))) (def ~'>long*|__0|6 - (reify* [double>long] (~(tag "long" 'invoke) [~'_6__ ~(tag "double" 'x)] - ~'(Primitive/uncheckedLongCast x)))) + (reify* [double>long] + (~(tag "long" 'invoke) [~'_6__ ~(tag "double" 'x)] + ~'(Primitive/uncheckedLongCast x)))) ;; [x (t/ref (t/isa? Number))] (def ~(tag "[Ljava.lang.Object;" '>long*|__1|input0|types) (*<> ~(with-meta `(t/isa? Number) {:ref? true}))) (def ~'>long*|__1|0 - (reify* [Object>long] (~(tag "long" 'invoke) [~'_7__ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(.longValue x))))) + (reify* [Object>long] + (~(tag "long" 'invoke) [~'_7__ ~(tag "java.lang.Object" 'x)] + (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(.longValue x))))) (defn ~'>long* {::t/type (t/fn ~'[(t/- t/primitive? t/boolean?) :> t/long?] @@ -920,7 +928,7 @@ (.invoke >long*|__1|0 x00__) (unsupported! `>long* [~'x00__] 0)))))))] (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" + (testing "functionality" (eval actual) (eval '(do (throws (>long*)) @@ -934,7 +942,9 @@ (is (identical? (>long* -1.1) (clojure.lang.RT/uncheckedLongCast -1.1))) (is (identical? (>long* (byte 1)) (clojure.lang.RT/uncheckedLongCast (byte 1))))))))) -;; =====|=====|=====|=====|===== ;; + +(defnt defnt-reference-test + ([] (>long* 1))) (is-code= From 61291b5cf4fba622f5bbf32d24003a916f938340 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 25 Jul 2018 12:25:49 -0600 Subject: [PATCH 155/810] Typed overhaul of quantum.core.core --- src/quantum/core/core.cljc | 38 ++++++++++++++++++++++++-------------- 1 file changed, 24 insertions(+), 14 deletions(-) diff --git a/src/quantum/core/core.cljc b/src/quantum/core/core.cljc index c34fee84..d90d31fe 100644 --- a/src/quantum/core/core.cljc +++ b/src/quantum/core/core.cljc @@ -5,37 +5,48 @@ #?(:clj [clojure.core.specs.alpha :as ss]) [cuerdas.core :as str+] #?(:clj [environ.core :as env]) + ;; TODO TYPED move to quantum.core.type + [quantum.core.defnt + :refer [defnt]] #_[quantum.core.type :as t - :refer [defnt defmacrot defprotocolt]] + :refer [defnt defmacrot defprotocolt deft]] [quantum.untyped.core.core :as u] + ;; TODO TYPED move to quantum.core.type + [quantum.untyped.core.type :as t + :refer [?]] [quantum.untyped.core.vars :refer [defalias defaliases]])) ;; ===== Environment ===== ;; -(defaliases u lang #?(:clj pid)) +(deft lang t/keyword? "The language this code is compiled under" u/lang) + +#?(:clj +(defnt pid [> (? t/string?)] + (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) + (.getName)))) ;; ===== Compilation ===== ;; +;; TODO TYPED (defalias u/externs?) ;; ===== quantum.core.system ===== ;; +;; TODO TYPED +;; TODO move (defalias u/*registered-components) ;; ===== Miscellaneous ===== ;; -(defaliases u >sentinel >object) - -;; TODO typed -;; TODO excise -(def unchecked-inc-long - #?(:clj (fn [^long x] (unchecked-inc x)) - :cljs inc)) +;; TODO move +(defnt >sentinel [> t/object?] #?(:clj (Object.) :cljs #js {})) +(defalias >object >sentinel) ;; ===== Mutability/Effects ===== ;; -;; TODO excise when typed +;; TODO TYPED +;; TODO move? (defprotocol IValue (get [this]) (set [this newv])) @@ -44,15 +55,14 @@ (get [this _]) (set [this _, newv _])) -;; TODO excise when typed +;; TODO TYPED +;; TODO move? #?(:clj (defmacro with "Evaluates @expr, then @body, then returns @expr. For (side) effects." [expr & body] - `(let [expr# ~expr] - ~@body - expr#))) + `(let [expr# ~expr] ~@body expr#))) #_(:clj (defmacrot with From ea04cb0a05f37b597b7ad35836af87bd2da630ed Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 25 Jul 2018 12:48:37 -0600 Subject: [PATCH 156/810] Fix number of args for `analyze-seq|let*` --- src-dev/quantum/core/defnt.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 59ec5f8e..1f1cf342 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -380,7 +380,7 @@ LEFT OFF LAST TIME (7/24/2018): (->expr-info {:env env :form (transient [])})) (persistent!-and-add-file-context bindings))) -(defns analyze-seq|let* [env ::env, [bindings _ & body _] _] +(defns analyze-seq|let* [env ::env, form _, [bindings _ & body _] _] (TODO "`let*` analysis") #_(let [{env' :env bindings' :form} (analyze-seq|let*|bindings env bindings) From f77e436485e57773ea97fba955a255130e94ae95 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 25 Jul 2018 12:49:12 -0600 Subject: [PATCH 157/810] Add to typed map ns --- .../quantum/untyped/core/data/map.cljc | 4 +- src-untyped/quantum/untyped/core/type.cljc | 1 + src/quantum/core/data/map.cljc | 93 ++++++++++++++++++- 3 files changed, 94 insertions(+), 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/map.cljc b/src-untyped/quantum/untyped/core/data/map.cljc index a74b51f0..913ff887 100644 --- a/src-untyped/quantum/untyped/core/data/map.cljc +++ b/src-untyped/quantum/untyped/core/data/map.cljc @@ -29,6 +29,7 @@ ;; TO EXPLORE ;; - Optimizing Hash-Array Mapped Tries for Fast and Lean Immutable JVM Collections +;; - Actual usable implementation: https://github.com/usethesource/capsule ;; - http://michael.steindorfer.name/publications/oopsla15.pdf ;; - Overall significantly faster on what they've chosen to measure. ;; - Alex Miller: "We have seen it and will probably investigate some of these ideas after 1.8." @@ -36,8 +37,6 @@ ;; ===== Map entries ===== ;; -; `(apply hash-map pairs)` <~> `lodash/fromPairs` - (defn map-entry "A performant replacement for creating 2-tuples (vectors), e.g., as return values in a |kv-reduce| function. @@ -60,6 +59,7 @@ #?(:clj (clojure.lang.MapEntry. k v) :cljs (cljs.core.MapEntry. k v nil))) +;; TODO excise? (defn map-entry-seq [args] (loop [[k v :as args-n] args accum []] diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 4cc94dce..a132377b 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -716,6 +716,7 @@ (-def tuple? ;; clojure.lang.Tuple was discontinued; we won't support it for now (isa? quantum.untyped.core.data.tuple.Tuple)) #?(:clj (-def map-entry? (isa? java.util.Map$Entry))) + (-def +map-entry? (isa? #?(:clj clojure.lang.MapEntry :cljs cljs.core.MapEntry))) ;; ===== Sequences ===== ;; Sequential (generally not efficient Lookup / RandomAccess) diff --git a/src/quantum/core/data/map.cljc b/src/quantum/core/data/map.cljc index da827f40..0908d3fc 100644 --- a/src/quantum/core/data/map.cljc +++ b/src/quantum/core/data/map.cljc @@ -5,17 +5,106 @@ (:refer-clojure :exclude [split-at, merge, sorted-map sorted-map-by, array-map, hash-map]) (:require + [quantum.core.defnt + :refer [defnt]] [quantum.untyped.core.data.map :as u] + [quantum.untyped.core.type :as t] [quantum.untyped.core.vars - :refer [defaliases]])) + :refer [defaliases]]) + (:import +#?@(:clj [[java.util HashMap IdentityHashMap LinkedHashMap TreeMap] + [it.unimi.dsi.fastutil.ints Int2ReferenceOpenHashMap] + [it.unimi.dsi.fastutil.longs Long2LongOpenHashMap + Long2ReferenceOpenHashMap] + [it.unimi.dsi.fastutil.doubles Double2ReferenceOpenHashMap] + [it.unimi.dsi.fastutil.objects Reference2LongOpenHashMap]] + :cljs [[goog.structs AvlTree LinkedMap]]))) +;; ===== Map entries ===== ;; + +(defnt >map-entry + "A performant replacement for creating 2-tuples (vectors), e.g., as return values + in a |kv-reduce| function. + + Now overshadowed by ztellman's unrolled vectors in 1.8.0. + + Time to create 100000000 2-tuples: + new tuple-vector 55.816415 ms + map-entry 37.542442 ms + + However, insertion into maps is faster with map-entry: + + (def vs [[1 2] [3 4]]) + (def ms [(map-entry 1 2) (map-entry 3 4)]) + (def m0 {}) + 508.122831 ms (dotimes [n 1000000] (into m0 vs)) + 310.335998 ms (dotimes [n 1000000] (into m0 ms))" + {:attribution "alexandergunnarson"} + [k _, v _ > t/+map-entry?] + #?(:clj (clojure.lang.MapEntry. k v) + :cljs (cljs.core.MapEntry. k v nil))) + +;; ===== Unordered identity-semantic maps ===== ;; + +;; TODO generate this via macro? +(defnt >!identity-map + "Creates a single-threaded, mutable identity map. + On the JVM, this is a `java.util.IdentityHashMap`. + On JS, this is a `js/Map` (ECMAScript 6 Map)." + ([> t/!identity-map?] #?(:clj (IdentityHashMap.) :cljs (js/Map.))) + ([k0 _, v0 _] + (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) + (#?(:clj .put :cljs .set) k0 v0))) + #_([k0 _, v0 _, k1 _, v1 _] + (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) + (#?(:clj .put :cljs .set) k0 v0) + (#?(:clj .put :cljs .set) k1 v1))) + #_([k0 _, v0 _, k1 _, v1 _, k2 _, v2 _] + (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) + (#?(:clj .put :cljs .set) k0 v0) + (#?(:clj .put :cljs .set) k1 v1) + (#?(:clj .put :cljs .set) k2 v2))) + #_([k0 _, v0 _, k1 _, v1 _, k2 _, v2 _, k3 _, v3 _] + (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) + (#?(:clj .put :cljs .set) k0 v0) + (#?(:clj .put :cljs .set) k1 v1) + (#?(:clj .put :cljs .set) k2 v2) + (#?(:clj .put :cljs .set) k3 v3))) + #_([k0 _, v0 _, k1 _, v1 _, k2 _, v2 _, k3 _, v3 _, k4 _, v4 _] + (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) + (#?(:clj .put :cljs .set) k0 v0) + (#?(:clj .put :cljs .set) k1 v1) + (#?(:clj .put :cljs .set) k2 v2) + (#?(:clj .put :cljs .set) k3 v3) + (#?(:clj .put :cljs .set) k4 v4))) + #_([k0 _, v0 _, k1 _, v1 _, k2 _, v2 _, k3 _, v3 _, k4 _, v4 _, k5 _, v5 _] + (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) + (#?(:clj .put :cljs .set) k0 v0) + (#?(:clj .put :cljs .set) k1 v1) + (#?(:clj .put :cljs .set) k2 v2) + (#?(:clj .put :cljs .set) k3 v3) + (#?(:clj .put :cljs .set) k4 v4) + (#?(:clj .put :cljs .set) k5 v5))) + #_([k0 _, v0 _, k1 _, v1 _, k2 _, v2 _, k3 _, v3 _, k4 _, v4 _, k5 _, v5 _ k6, _ v6, _ & kvs _] + (reduce-pair + (fn [#?(:clj ^IdentityHashMap m :cljs m) k v] (doto m (#?(:clj .put :cljs .set) k v))) + (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) + (#?(:clj .put :cljs .set) k0 v0) + (#?(:clj .put :cljs .set) k1 v1) + (#?(:clj .put :cljs .set) k2 v2) + (#?(:clj .put :cljs .set) k3 v3) + (#?(:clj .put :cljs .set) k4 v4) + (#?(:clj .put :cljs .set) k5 v5) + (#?(:clj .put :cljs .set) k6 v6)) + kvs))) + +; `(apply hash-map pairs)` <~> `lodash/fromPairs` (defaliases u #?@(:clj [int-map hash-map|long->ref]) array-map hash-map ordered-map om #?(:clj !ordered-map) #?(:clj kw-omap) sorted-map sorted-map-by sorted-map-by-val sorted-rank-map sorted-rank-map-by nearest rank-of subrange split-key split-at - map-entry map-entry-seq #?(:clj hash-map?) merge #?(:clj pmerge) !hash-map From 56fc83bfad6467f697725b4eb5940afa9ec159fa Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 25 Jul 2018 13:31:42 -0600 Subject: [PATCH 158/810] Fix subtle bug in ` analyze-seq|do` --- src-dev/quantum/core/defnt.cljc | 24 +++++++++++++++++------- 1 file changed, 17 insertions(+), 7 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 1f1cf342..ca6e81f3 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -326,7 +326,6 @@ LEFT OFF LAST TIME (7/24/2018): overall expression; the second is the deduced type of the current subexpression."}} [env ::env, form _, empty-form _, rf _] - (prl! env form empty-form) (->> form (reducei (fn [accum form' i] (rf accum (analyze* (:env accum) form') i)) {:env env :form (transient empty-form)}) @@ -343,12 +342,12 @@ LEFT OFF LAST TIME (7/24/2018): ast-ret-v (analyze* env' form'v)] (->expr-info {:env env' :form (assoc! forms (:form ast-ret-k) (:form ast-ret-v)) - :type-info nil}))) ; TODO fix; we want the types of the keys and vals to be deduced + ;; TODO fix; we want the types of the keys and vals to be deduced + :type-info nil}))) (->expr-info {:env env :form (transient {})})) (persistent!-and-add-file-context form))) (defns- analyze-seq|do [env ::env, form _, body _] - (prl! env body) (if (empty? body) (ast/do {:env env :form form @@ -356,15 +355,16 @@ LEFT OFF LAST TIME (7/24/2018): :type t/nil?}) (let [expr (analyze-non-map-seqable env body [] (fn [accum expr _] - ;; for types, only the last subexpression ever matters, as each is independent :; from the others (assoc expr :form (conj! (:form accum) (:form expr)) - ;; but the env should be the same as whatever it was originally + ;; The env should be the same as whatever it was originally ;; because no new scopes are created :env (:env accum))))] (ast/do {:env env :form form :body (>vec body) - :type (:type expr)})))) + ;; To types, only the last subexpression ever matters, as each is independent + ;; from the others + :type (-> expr :form c/last :type)})))) (defns analyze-seq|let*|bindings [env ::env, bindings _] (TODO "`let*|bindings` analysis") @@ -381,7 +381,17 @@ LEFT OFF LAST TIME (7/24/2018): (persistent!-and-add-file-context bindings))) (defns analyze-seq|let* [env ::env, form _, [bindings _ & body _] _] - (TODO "`let*` analysis") + {:pre [(prl! env bindings body)]} + (let [env' (analyze-seq|let*|bindings env ) + expr (analyze-seq|do env' (list* 'do form) body)] + (prl! expr) + (TODO "`let*` analysis") + #_(ast/let* {:env env + :form form + :bindings (bindings>env bindings) + :body (>vec body) + :type (:type expr)})) + #_(let [{env' :env bindings' :form} (analyze-seq|let*|bindings env bindings) {env'' :env body' :form type-info' :type-info} From 02ed5739a0828dd7841efcaa933fdd9c5a0b9764 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 25 Jul 2018 13:47:47 -0600 Subject: [PATCH 159/810] Improved `analyze-seq|do` --- src-dev/quantum/core/defnt.cljc | 19 +++++++++++-------- .../quantum/untyped/core/analyze/ast.cljc | 1 + src-untyped/quantum/untyped/core/form.cljc | 1 + 3 files changed, 13 insertions(+), 8 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index ca6e81f3..89751800 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -328,8 +328,9 @@ LEFT OFF LAST TIME (7/24/2018): [env ::env, form _, empty-form _, rf _] (->> form (reducei (fn [accum form' i] (rf accum (analyze* (:env accum) form') i)) - {:env env :form (transient empty-form)}) - (persistent!-and-add-file-context form))) + {:env env :form (transient empty-form) :body (transient [])}) + (persistent!-and-add-file-context form) + (<- (update :body persistent!)))) (defns- analyze-map {:todo #{"If the map is bound to a variable, preserve type info for it such that lookups @@ -355,16 +356,18 @@ LEFT OFF LAST TIME (7/24/2018): :type t/nil?}) (let [expr (analyze-non-map-seqable env body [] (fn [accum expr _] - (assoc expr :form (conj! (:form accum) (:form expr)) - ;; The env should be the same as whatever it was originally + (assoc expr ;; The env should be the same as whatever it was originally ;; because no new scopes are created - :env (:env accum))))] + :env (:env accum) + :form (conj! (:form accum) (:form expr)) + :body (conj! (:body accum) expr))))] (ast/do {:env env - :form form - :body (>vec body) + :form (list* 'do (:form expr)) + :unexpanded-form form + :body (:body expr) ;; To types, only the last subexpression ever matters, as each is independent ;; from the others - :type (-> expr :form c/last :type)})))) + :type (-> expr :body c/last :type)})))) (defns analyze-seq|let*|bindings [env ::env, bindings _] (TODO "`let*|bindings` analysis") diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 6ea801ac..ae0024e6 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -92,6 +92,7 @@ (defrecord Do [env #_::env form #_::t/form + unexpanded-form #_::t/form body #_(t/and t/sequential? t/indexed? (t/every? ::node)) type #_t/type?] INode diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index bd844fc5..34d47e3b 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -17,6 +17,7 @@ (extend-protocol PGenForm nil (>form [x] nil) + java.lang.Long (>form [x] x) clojure.lang.Symbol (>form [x] (list 'quote x)) #?@(:clj [Class (>form [x] (-> x #_uconv/>symbol .getName symbol))])) From b323d166d1f5c1445e4bce4c2d57d16e4d63e03a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 25 Jul 2018 14:37:47 -0600 Subject: [PATCH 160/810] Repair `analyze-seq|do` and `analyze-seq` a little --- src-dev/quantum/core/defnt.cljc | 96 ++++++++++--------- .../quantum/untyped/core/analyze/ast.cljc | 2 +- src-untyped/quantum/untyped/core/type.cljc | 88 +++++++++++------ .../quantum/untyped/core/type/compare.cljc | 22 ++--- 4 files changed, 123 insertions(+), 85 deletions(-) diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc index 89751800..87b39487 100644 --- a/src-dev/quantum/core/defnt.cljc +++ b/src-dev/quantum/core/defnt.cljc @@ -350,10 +350,11 @@ LEFT OFF LAST TIME (7/24/2018): (defns- analyze-seq|do [env ::env, form _, body _] (if (empty? body) - (ast/do {:env env - :form form - :body (>vec body) - :type t/nil?}) + (ast/do {:env env + :unexpanded-form form + :form form + :body (>vec body) + :type t/nil?}) (let [expr (analyze-non-map-seqable env body [] (fn [accum expr _] (assoc expr ;; The env should be the same as whatever it was originally @@ -361,13 +362,13 @@ LEFT OFF LAST TIME (7/24/2018): :env (:env accum) :form (conj! (:form accum) (:form expr)) :body (conj! (:body accum) expr))))] - (ast/do {:env env - :form (list* 'do (:form expr)) + (ast/do {:env env :unexpanded-form form - :body (:body expr) + :form (list* 'do (:form expr)) + :body (:body expr) ;; To types, only the last subexpression ever matters, as each is independent ;; from the others - :type (-> expr :body c/last :type)})))) + :type (-> expr :body c/last :type)})))) (defns analyze-seq|let*|bindings [env ::env, bindings _] (TODO "`let*|bindings` analysis") @@ -660,53 +661,62 @@ LEFT OFF LAST TIME (7/24/2018): (case (t/compare caller|type t/callable?) (1 2) (err! "It is not known whether expression be called" {:expr caller|expr}) 3 (err! "Expression cannot be called" {:expr caller|expr}) - (-1 0) (let [assert-valid-args-ct - (ifs (or (t/<= caller|type t/keyword?) - (t/<= caller|type t/+map|built-in?)) - (when-not (or (= args-ct 1) (= args-ct 2)) - (err! (str "Keywords and `clojure.core` persistent maps must be " - "provided with exactly one or two args when calling " - "them") - {:args-ct args-ct :caller caller|expr})) - - (or (t/<= caller|type t/+vector|built-in?) - (t/<= caller|type t/+set|built-in?)) - (when-not (= args-ct 1) + (-1 0) (let [caller-kind + (ifs (t/<= caller|type t/keyword?) :keyword + (t/<= caller|type t/+map|built-in?) :map + (t/<= caller|type t/+vector|built-in?) :vector + (t/<= caller|type t/+set|built-in?) :set + (t/<= caller|type t/fnt?) :fnt + (t/<= caller|type t/fn?) :fn + ;; If it's callable but not fn, we might have missed something in + ;; this dispatch so for now we throw + (err! "Don't know how how to handle non-fn callable" + {:caller caller|expr})) + assert-valid-args-ct + (case caller-kind + (:keyword :map) + (when-not (or (= args-ct 1) (= args-ct 2)) + (err! (str "Keywords and `clojure.core` persistent maps must be " + "provided with exactly one or two args when calling " + "them") + {:args-ct args-ct :caller caller|expr})) + + (:vector :set) + (when-not (= args-ct 1) (err! (str "`clojure.core` persistent vectors and `clojure.core` " "persistent sets must be provided with exactly one arg " "when calling them") {:args-ct args-ct :caller caller|expr})) - (t/<= caller|type t/fnt?) - (TODO "Don't know how to handle typed fns yet" {:caller caller|expr}) - ;; For non-typed fns, unknown; we will have to risk runtime exception - ;; because we can't necessarily rely on metadata to tell us the - ;; whole truth - (t/<= caller|type t/fn?) - nil - ;; If it's ifn but not fn, we might have missed something in this - ;; dispatch so for now we throw - (err! "Don't know how how to handle non-fn ifn" - {:caller caller|expr})) - {:keys [args] t :type} - (->> body - (c/map+ #(analyze* env %)) - (reduce (fn [{:keys [args]} arg|analyzed] - (conj args))))] - - ;; TODO incrementally check by analyzing each arg in `reduce` and pruning - ;; branches of what the type could be, and throwing if it's found something - ;; that's an impossible combination + :fnt + (TODO "Don't know how to handle typed fns yet" {:caller caller|expr}) + ;; For non-typed fns, unknown; we will have to risk runtime exception + ;; because we can't necessarily rely on metadata to tell us the + ;; whole truth + :fn nil) + ;; TODO incrementally check by analyzing each arg in `reduce` and pruning + ;; branches of what the type could be, and throwing if it's found something + ;; that's an impossible combination + arg-exprs (->> body + (c/map+ #(analyze* env %)) + (reduce (fn [args arg|analyzed] + (conj args arg|analyzed)) + [])) + out-type + (case caller-kind + ;; We could do a little smarter analysis here but we'll keep it simple + ;; for now + (:keyword :map :vector :set :fn) t/any? + :fnt (TODO "Use `::t/type` metadata to make this decision"))] (ast/call-expr {:env env :form form :caller caller|expr - :args args - :type t})))))) + :args arg-exprs + :type out-type})))))) (defns- analyze-seq [env ::env, form _] {:post [(prl! %)]} - (prl! form) (let [expanded-form (ufeval/macroexpand form)] (if (== form expanded-form) (analyze-seq* env expanded-form) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index ae0024e6..476eafcc 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -100,7 +100,7 @@ fipp.ednize/IEdn (-edn [this] (list `do (into (array-map) this)))) -(defn do [m] (map->Let* m)) +(defn do [m] (map->Do* m)) (defrecord MacroCall [env #_::env diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index a132377b..d943c2a6 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -1291,35 +1291,62 @@ (-def !sorted-map|boolean->double? none?) (-def !sorted-map|boolean->ref? none?) - (-def !sorted-map|byte->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2BooleanSortedMap) :cljs none?)) - (-def !sorted-map|byte->byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ByteSortedMap) :cljs none?)) - (-def !sorted-map|byte->char? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2CharSortedMap) :cljs none?)) - (-def !sorted-map|byte->short? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ShortSortedMap) :cljs none?)) - (-def !sorted-map|byte->int? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2IntSortedMap) :cljs none?)) - (-def !sorted-map|byte->long? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2LongSortedMap) :cljs none?)) - (-def !sorted-map|byte->float? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2FloatSortedMap) :cljs none?)) - (-def !sorted-map|byte->double? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2DoubleSortedMap) :cljs none?)) - (-def !sorted-map|byte->ref? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ReferenceSortedMap) :cljs none?)) - - (-def !sorted-map|char->ref? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ReferenceSortedMap) :cljs none?)) - (-def !sorted-map|char->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2BooleanSortedMap) :cljs none?)) - (-def !sorted-map|char->byte? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ByteSortedMap) :cljs none?)) - (-def !sorted-map|char->char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2CharSortedMap) :cljs none?)) - (-def !sorted-map|char->short? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ShortSortedMap) :cljs none?)) - (-def !sorted-map|char->int? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2IntSortedMap) :cljs none?)) - (-def !sorted-map|char->long? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2LongSortedMap) :cljs none?)) - (-def !sorted-map|char->float? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2FloatSortedMap) :cljs none?)) - (-def !sorted-map|char->double? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2DoubleSortedMap) :cljs none?)) - - (-def !sorted-map|short->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2BooleanSortedMap) :cljs none?)) - (-def !sorted-map|short->byte? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ByteSortedMap) :cljs none?)) - (-def !sorted-map|short->char? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2CharSortedMap) :cljs none?)) - (-def !sorted-map|short->short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ShortSortedMap) :cljs none?)) - (-def !sorted-map|short->int? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2IntSortedMap) :cljs none?)) - (-def !sorted-map|short->long? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2LongSortedMap) :cljs none?)) - (-def !sorted-map|short->float? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2FloatSortedMap) :cljs none?)) - (-def !sorted-map|short->double? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2DoubleSortedMap) :cljs none?)) - (-def !sorted-map|short->ref? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ReferenceSortedMap) :cljs none?)) + (-def !sorted-map|byte->boolean? + #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2BooleanSortedMap) :cljs none?)) + (-def !sorted-map|byte->byte? + #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ByteSortedMap) :cljs none?)) + (-def !sorted-map|byte->char? + #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2CharSortedMap) :cljs none?)) + (-def !sorted-map|byte->short? + #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ShortSortedMap) :cljs none?)) + (-def !sorted-map|byte->int? + #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2IntSortedMap) :cljs none?)) + (-def !sorted-map|byte->long? + #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2LongSortedMap) :cljs none?)) + (-def !sorted-map|byte->float? + #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2FloatSortedMap) :cljs none?)) + (-def !sorted-map|byte->double? + #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2DoubleSortedMap) :cljs none?)) + (-def !sorted-map|byte->ref? + #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ReferenceSortedMap) :cljs none?)) + + (-def !sorted-map|char->ref? + #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ReferenceSortedMap) :cljs none?)) + (-def !sorted-map|char->boolean? + #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2BooleanSortedMap) :cljs none?)) + (-def !sorted-map|char->byte? + #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ByteSortedMap) :cljs none?)) + (-def !sorted-map|char->char? + #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2CharSortedMap) :cljs none?)) + (-def !sorted-map|char->short? + #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ShortSortedMap) :cljs none?)) + (-def !sorted-map|char->int? + #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2IntSortedMap) :cljs none?)) + (-def !sorted-map|char->long? + #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2LongSortedMap) :cljs none?)) + (-def !sorted-map|char->float? + #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2FloatSortedMap) :cljs none?)) + (-def !sorted-map|char->double? + #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2DoubleSortedMap) :cljs none?)) + + (-def !sorted-map|short->boolean? + #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2BooleanSortedMap) :cljs none?)) + (-def !sorted-map|short->byte? + #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ByteSortedMap) :cljs none?)) + (-def !sorted-map|short->char? + #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2CharSortedMap) :cljs none?)) + (-def !sorted-map|short->short? + #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ShortSortedMap) :cljs none?)) + (-def !sorted-map|short->int? + #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2IntSortedMap) :cljs none?)) + (-def !sorted-map|short->long? + #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2LongSortedMap) :cljs none?)) + (-def !sorted-map|short->float? + #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2FloatSortedMap) :cljs none?)) + (-def !sorted-map|short->double? + #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2DoubleSortedMap) :cljs none?)) + (-def !sorted-map|short->ref? + #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ReferenceSortedMap) :cljs none?)) (-def !sorted-map|int->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2BooleanSortedMap) :cljs none?)) (-def !sorted-map|int->byte? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2ByteSortedMap) :cljs none?)) @@ -1662,7 +1689,8 @@ ;; I.e., can you call/invoke it by being in functor position (first element of an unquoted list) ;; within a typed context? - ;; TODO should we allow java.lang.Runnable, java.util.concurrent.Callable to be `callable?`? + ;; TODO should we allow java.lang.Runnable, java.util.concurrent.Callable, and other + ;; functional interfaces to be `callable?`? (-def callable? (or ifn? fnt?)) ;; ===== References ===== ;; diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index 954d78a7..459a25df 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -223,7 +223,7 @@ (defns- compare|expr+expr [t0 _, t1 _ > comparison?] (if (c/= t0 t1) =ident <>ident)) -(def- compare|expr+value fn<>) +(def- compare|expr+value fn><) ; TODO not entirely true ;; ----- ProtocolType ----- ;; @@ -334,7 +334,7 @@ NotType #'compare|not+not OrType #'compare|not+or AndType #'compare|not+and - Expression #'fn<> ; TODO not entirely true + Expression #'fn>< ; TODO not entirely true ProtocolType #'compare|not+protocol ClassType #'compare|not+class ValueType #'compare|not+value} @@ -344,7 +344,7 @@ NotType (inverted #'compare|not+or) OrType #'compare|or+or AndType #'compare|or+and - Expression #'fn<> ; TODO not entirely true + Expression #'fn>< ; TODO not entirely true ProtocolType #'compare|todo ClassType (inverted #'compare|class+or) ValueType (inverted #'compare|value+or)} @@ -354,7 +354,7 @@ NotType #'compare|todo OrType (inverted #'compare|or+and) AndType #'compare|and+and - Expression #'fn<> ; TODO not entirely true + Expression #'fn>< ; TODO not entirely true ProtocolType #'compare|todo ClassType (inverted #'compare|class+and) ValueType (inverted #'compare|value+and)} @@ -362,12 +362,12 @@ Expression {UniversalSetType (inverted #'compare|universal+expr) EmptySetType (inverted #'compare|empty+expr) - NotType #'compare|todo - OrType #'compare|todo - AndType #'compare|todo + NotType #'fn>< ; TODO not entirely true + OrType #'fn>< ; TODO not entirely true + AndType #'fn>< ; TODO not entirely true Expression #'compare|expr+expr - ProtocolType #'compare|todo - ClassType #'fn<> ; TODO not entirely true + ProtocolType #'fn>< ; TODO not entirely true + ClassType #'fn>< ; TODO not entirely true ValueType #'compare|expr+value} ProtocolType {UniversalSetType (inverted #'compare|universal+protocol) @@ -375,7 +375,7 @@ NotType (inverted #'compare|not+protocol) OrType #'compare|todo AndType #'compare|todo - Expression #'fn<> + Expression #'fn>< ; TODO not entirely true ProtocolType #'compare|protocol+protocol ClassType #'compare|todo ValueType (inverted #'compare|value+protocol)} @@ -385,7 +385,7 @@ NotType (inverted #'compare|not+class) OrType #'compare|class+or AndType #'compare|class+and - Expression #'fn<> ; TODO not entirely true + Expression #'fn>< ; TODO not entirely true ProtocolType #'compare|todo ClassType #'compare|class+class ValueType #'compare|class+value} From effdd4b32b5825f91a24d031c19feaff0686e3d2 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 25 Jul 2018 14:37:58 -0600 Subject: [PATCH 161/810] Now fns are `>form`able --- src-untyped/quantum/untyped/core/form.cljc | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index 34d47e3b..bd7bb84b 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -18,7 +18,19 @@ (extend-protocol PGenForm nil (>form [x] nil) java.lang.Long (>form [x] x) - clojure.lang.Symbol (>form [x] (list 'quote x)) + #?(:clj clojure.lang.Symbol + :cljs cljs.core.Symbol) (>form [x] (list 'quote x)) + + #?@(:clj [clojure.lang.Fn (>form [x] + ;; TODO can probably use uconv to good effect here + (or (when-let [ns- (-> x meta :ns)] + (symbol (ns-name ns-) (-> x meta :name name))) + (let [demunged (-> x class .getName + clojure.lang.Compiler/demunge)] + (if-let [anonymous-fn? (not= (.indexOf demunged "/") + (.lastIndexOf demunged "/"))] + (tagged-literal 'fn (symbol demunged)) + (symbol demunged)))))]) #?@(:clj [Class (>form [x] (-> x #_uconv/>symbol .getName symbol))])) (defn core-symbol [env sym] (symbol (str (case-env* env :cljs "cljs" "clojure") ".core") (name sym))) From 12e0173c663f1287eeb5517aefef73576e3dfd03 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 25 Jul 2018 15:15:18 -0600 Subject: [PATCH 162/810] Split up analysis from defnt and reorganize --- resources-dev/defnt.cljc | 103 ++ src-dev/quantum/core/defnt.cljc | 1312 ----------------- src-dev/quantum/core/defnt_equivalences.cljc | 17 +- src-untyped/quantum/untyped/core/analyze.cljc | 564 +++++++ .../quantum/untyped/core/analyze/ast.cljc | 2 +- src-untyped/quantum/untyped/core/type.cljc | 4 +- .../quantum/untyped/core/type/defnt.cljc | 648 ++++++++ 7 files changed, 1322 insertions(+), 1328 deletions(-) create mode 100644 resources-dev/defnt.cljc delete mode 100644 src-dev/quantum/core/defnt.cljc create mode 100644 src-untyped/quantum/untyped/core/analyze.cljc create mode 100644 src-untyped/quantum/untyped/core/type/defnt.cljc diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc new file mode 100644 index 00000000..946f50cc --- /dev/null +++ b/resources-dev/defnt.cljc @@ -0,0 +1,103 @@ +#_" + +LEFT OFF LAST TIME (7/24/2018): +- expressions (`quantum.untyped.core.analyze.expr`) +- `t/fn` +- `(defnt >long ...)` : enable to refer to `>long*` and have that analyzed +- finish `>long` example + + + +- With `defnt`, protocols and interfaces aren't needed. You can just create `t/fn`s that you can + then conform your fns to. +- `dotyped`, `defnt`, and `fnt` create typed contexts in which their internal forms are analyzed + and overloads are resolved. +- `defnt` is intended to catch many runtime errors at compile time, but cannot catch all of them; + types will very often have to be validated at runtime. + +[ ] Compile-Time (Direct) Dispatch + - Any argument, if it requires a non-nilable primitive-like value, will be marked as a + primitive. + - If nilable, there will be one overload for nil and one for primitive. + - When a `fnt` with type overloads is referenced outside of a typed context, then the overload + resolution will be done via Runtime Dispatch. + - TODO Should we take into account 'actual' types (not just 'declared' types) when performing + dispatch / overload resolution? + - Let's take the example of `(defnt abcde [] (f (rand/int-between -10 -2)))`. + - Let's say `rand/int-between`'s output is labeled `t/int?`. However, we know based on + further static analysis of its implementation that the output is not only `t/int?` but + also `t/neg?`, or perhaps even further, `(< -10 % -2)`. + - In this case, should we take advantage of this knowledge? + - Let's say we do. Then `(.invoke reify|we-know-specifics (rand/int-between -10 -2))`. + Yay for efficiency! But let's then say we then change the implementation even if we + don't change the 'interface'/typedefs. Now `rand/int-between` returns `(<= -10 % -2)` — + that is, it's now numerically *inclusive* (for instance, maybe the implementation's + previous behavior of generating numbers numerically *exclusive*ly was mistaken). + `reify|we-know-specifics` would then still be invoked but incorrectly (and unsafely) so. + - To be fair, we'll tend to change output specs/typedefs all the time as we do + development. Do we need to keep track of every call site it affects and recompile + accordingly? Perhaps. It seems like overkill though. It should be configurable in any + case. + - I think that because of this last point, we can and should rely on implementational + specifics wherever available to boost performance (Maybe this should be configurable so + it doesn't slow down development? The more we change the implementation, the more it has + to recompile, ostensibly). We can take advantage of the output specs, certainly, if for + nothing else than to ensure that our implementation (as characterized by its 'actual' + output type) matches what we expect (as characterized by its 'expected'/'declared' + output type). + - One option (Option A) is to turn off compile-time overload resolution during + development. This would mean it might get very slow during that time. But if it's in + the same `defnt` (ignoring `extend-defnt!` for a minute) — like a recursive call — you + could always leave on compile-time resolution for that. + - Option B — probably better (though we'd still like to have all this configurable) — + is to have each function know its dependencies (this would actually have the bonus + property of enabling `clojure.tools.namespace.repl/refresh`-style function-level + smart auto-recompilation which is nice). So let's go back to the previous example. + `abcde` could keep track of (or the `defnt` ns could keep track of it, but you get the + point) the fact that it depends on `rand/int-between` and `f`. It has a compile-time- + resolvable call site that depends only on the output type of `rand/int-between` so if + `rand/int-between`'s computed/actual output type (when given the inputs in question) + ever changes, `abcde` needs to be recompiled and `abcde`'s output type recomputed. If, + on the other hand, `f`'s output type (given the input) ever changes, `abcde` need not be + recompiled, but rather, only its output type need be recomputed. + - I think this reactive approach (do we need a library for that? probably not?) should + solve our problems and let us code in a very flexible way. It'll just (currently) be a + way that depends on a compiler in which the metalanguage and object language are + identical. +[ ] Runtime (Dynamic) Dispatch + [—] Protocol generation + - For now we won't do it because we can very often find the correct overload at compile + time. We will resort to using the `fn`. + - It will be left as an optimization. + [ ] `fn` generation + - Performs a worst-case linear check of the typedefs, `cond`-style. +[ ] Interface generation + - Even if the `defnt` is redefined, you won't have interface problems. +[ ] `reify` generation + - Which `reify`s get generated is mainly up to the inputs but partially up to the fn body — + If any typed fns are called in the fn body then this can change what gets generated. + - TODO explain this more + - Each of the `reify`s will keep their label (`__2__0` or whatever) as long as the original + typedef of the `reify` is `t/=` to the new typedef of that reify + - If a redefined `defnt` doesn't have that type overload then the previous reify is uninterned + and thus made unavailable + - That way, according to the dynamicity tests in `quantum.test.core.defnt`, we can redefine + implementations at will as long as the specs don't change + - To make this process faster we maintain a set of typedefs so at least cheap c/= checks can + be performed + - If c/= succeeds, great; the `reify` corresponding to the label (and reify-type) will be + replaced; the typedef-set will remain unchanged + - Else it must find a corresponding typedef by t/= + - Then if it is found by t/= it will replace the `reify` and the typedef corresponding + with that label and replace the typedef in the typedef-set + - Else a new label will be given to the `reify`; the typedef will be added to the + typedef-set +[ ] Types yielding generative specs +[—] Types using the clojure.spec interface + - Not yet; wait for it to come out of alpha +[—] Support for compilers in which the metalanguage differs from the object language (i.e. 'normal' + non-CLJS-in-CLJS CLJS) + - This will have to be approached later. We'll figure it out; maybe just not yet. +[—] `extend-defnt!` + - Not yet; probably complicated and we don't need it right now +" diff --git a/src-dev/quantum/core/defnt.cljc b/src-dev/quantum/core/defnt.cljc deleted file mode 100644 index 87b39487..00000000 --- a/src-dev/quantum/core/defnt.cljc +++ /dev/null @@ -1,1312 +0,0 @@ -(ns quantum.core.defnt - (:refer-clojure :exclude - [+ #_zero? odd? even? - bit-and - ==]) - (:require - [clojure.core :as core] - [clojure.string :as str] - [quantum.core.type.core :as tcore] - [quantum.core.type.defs :as tdef] - [quantum.untyped.core.analyze.ast :as ast] - [quantum.untyped.core.analyze.expr :as xp] - [quantum.untyped.core.analyze.rewrite :as ana-rw] - [quantum.untyped.core.collections :as c - :refer [dissoc-if dissoc* lcat subview >vec >set - lmap map+ map-vals+ mapcat+ filter+ remove+ partition-all+]] - [quantum.untyped.core.collections.logic :as ucl - :refer [seq-and seq-or]] - [quantum.untyped.core.collections.tree :as tree - :refer [prewalk postwalk walk]] - [quantum.untyped.core.compare :as comp - :refer [==]] - [quantum.untyped.core.convert :as conv - :refer [>symbol >name]] - [quantum.untyped.core.core - :refer [istr]] - [quantum.untyped.core.data - :refer [kw-map]] - [quantum.untyped.core.data.array :as arr] - [quantum.untyped.core.data.map :as map] - [quantum.untyped.core.data.set :as set] - [quantum.untyped.core.defnt - :refer [defns defns- fns]] - [quantum.untyped.core.error :as err - :refer [TODO err!]] - [quantum.untyped.core.fn - :refer [aritoid fn1 fnl fn', fn-> fn->> <-, rcomp - firsta seconda with-do]] - [quantum.untyped.core.form :as uform - :refer [>form]] - [quantum.untyped.core.form.evaluate :as ufeval] - [quantum.untyped.core.form.generate :as ufgen - :refer [unify-gensyms]] - [quantum.untyped.core.form.type-hint :as ufth] - [quantum.untyped.core.log :as log - :refer [ppr! ppr prl! prlm!]] - [quantum.untyped.core.logic :as l - :refer [fn= fn-and fn-or fn-not ifs if-not-let]] - [quantum.untyped.core.loops :as loops - :refer [reduce-2]] - [quantum.untyped.core.numeric.combinatorics :as combo] - [quantum.untyped.core.print :as pr] - [quantum.untyped.core.qualify :as qual - :refer [qualify]] - [quantum.untyped.core.reducers :as r - :refer [join reducei educe]] - [quantum.untyped.core.refs :as ref - :refer [?deref]] - [quantum.untyped.core.spec :as s] - [quantum.untyped.core.specs :as uss] - [quantum.untyped.core.type :as t - :refer [?]] - [quantum.untyped.core.type.predicates :as utpred] - [quantum.untyped.core.type.reifications :as utr] - [quantum.untyped.core.vars :as var - :refer [update-meta]] - #_[quantum.format.clojure.core ; TODO temporary - :refer [reformat-string]]) - (:import - [quantum.core Numeric] - [quantum.core.data Array])) - -;; TODO move -#_(defn ppr-code [code] - (let [default-indentations '{do [[:inner 2 2]] - if [[:inner 2 2]]}] - (-> code pr/ppr-meta with-out-str - (reformat-string {:indents default-indentations}) - println))) - -#_(:clj (ns-unmap (find-ns 'quantum.core.defnt) 'reformat-string)) - -#_" - -LEFT OFF LAST TIME (7/24/2018): -- expressions (`quantum.untyped.core.analyze.expr`) -- `t/fn` -- `(defnt >long ...)` : enable to refer to `>long*` and have that analyzed -- finish `>long` example - - - -- With `defnt`, protocols and interfaces aren't needed. You can just create `t/fn`s that you can - then conform your fns to. -- `dotyped`, `defnt`, and `fnt` create typed contexts in which their internal forms are analyzed - and overloads are resolved. -- `defnt` is intended to catch many runtime errors at compile time, but cannot catch all of them; - types will very often have to be validated at runtime. - -[ ] Compile-Time (Direct) Dispatch - - Any argument, if it requires a non-nilable primitive-like value, will be marked as a - primitive. - - If nilable, there will be one overload for nil and one for primitive. - - When a `fnt` with type overloads is referenced outside of a typed context, then the overload - resolution will be done via Runtime Dispatch. - - TODO Should we take into account 'actual' types (not just 'declared' types) when performing - dispatch / overload resolution? - - Let's take the example of `(defnt abcde [] (f (rand/int-between -10 -2)))`. - - Let's say `rand/int-between`'s output is labeled `t/int?`. However, we know based on - further static analysis of its implementation that the output is not only `t/int?` but - also `t/neg?`, or perhaps even further, `(< -10 % -2)`. - - In this case, should we take advantage of this knowledge? - - Let's say we do. Then `(.invoke reify|we-know-specifics (rand/int-between -10 -2))`. - Yay for efficiency! But let's then say we then change the implementation even if we - don't change the 'interface'/typedefs. Now `rand/int-between` returns `(<= -10 % -2)` — - that is, it's now numerically *inclusive* (for instance, maybe the implementation's - previous behavior of generating numbers numerically *exclusive*ly was mistaken). - `reify|we-know-specifics` would then still be invoked but incorrectly (and unsafely) so. - - To be fair, we'll tend to change output specs/typedefs all the time as we do - development. Do we need to keep track of every call site it affects and recompile - accordingly? Perhaps. It seems like overkill though. It should be configurable in any - case. - - I think that because of this last point, we can and should rely on implementational - specifics wherever available to boost performance (Maybe this should be configurable so - it doesn't slow down development? The more we change the implementation, the more it has - to recompile, ostensibly). We can take advantage of the output specs, certainly, if for - nothing else than to ensure that our implementation (as characterized by its 'actual' - output type) matches what we expect (as characterized by its 'expected'/'declared' - output type). - - One option (Option A) is to turn off compile-time overload resolution during - development. This would mean it might get very slow during that time. But if it's in - the same `defnt` (ignoring `extend-defnt!` for a minute) — like a recursive call — you - could always leave on compile-time resolution for that. - - Option B — probably better (though we'd still like to have all this configurable) — - is to have each function know its dependencies (this would actually have the bonus - property of enabling `clojure.tools.namespace.repl/refresh`-style function-level - smart auto-recompilation which is nice). So let's go back to the previous example. - `abcde` could keep track of (or the `defnt` ns could keep track of it, but you get the - point) the fact that it depends on `rand/int-between` and `f`. It has a compile-time- - resolvable call site that depends only on the output type of `rand/int-between` so if - `rand/int-between`'s computed/actual output type (when given the inputs in question) - ever changes, `abcde` needs to be recompiled and `abcde`'s output type recomputed. If, - on the other hand, `f`'s output type (given the input) ever changes, `abcde` need not be - recompiled, but rather, only its output type need be recomputed. - - I think this reactive approach (do we need a library for that? probably not?) should - solve our problems and let us code in a very flexible way. It'll just (currently) be a - way that depends on a compiler in which the metalanguage and object language are - identical. -[ ] Runtime (Dynamic) Dispatch - [—] Protocol generation - - For now we won't do it because we can very often find the correct overload at compile - time. We will resort to using the `fn`. - - It will be left as an optimization. - [ ] `fn` generation - - Performs a worst-case linear check of the typedefs, `cond`-style. -[ ] Interface generation - - Even if the `defnt` is redefined, you won't have interface problems. -[ ] `reify` generation - - Which `reify`s get generated is mainly up to the inputs but partially up to the fn body — - If any typed fns are called in the fn body then this can change what gets generated. - - TODO explain this more - - Each of the `reify`s will keep their label (`__2__0` or whatever) as long as the original - typedef of the `reify` is `t/=` to the new typedef of that reify - - If a redefined `defnt` doesn't have that type overload then the previous reify is uninterned - and thus made unavailable - - That way, according to the dynamicity tests in `quantum.test.core.defnt`, we can redefine - implementations at will as long as the specs don't change - - To make this process faster we maintain a set of typedefs so at least cheap c/= checks can - be performed - - If c/= succeeds, great; the `reify` corresponding to the label (and reify-type) will be - replaced; the typedef-set will remain unchanged - - Else it must find a corresponding typedef by t/= - - Then if it is found by t/= it will replace the `reify` and the typedef corresponding - with that label and replace the typedef in the typedef-set - - Else a new label will be given to the `reify`; the typedef will be added to the - typedef-set -[ ] Types yielding generative specs -[—] Types using the clojure.spec interface - - Not yet; wait for it to come out of alpha -[—] Support for compilers in which the metalanguage differs from the object language (i.e. 'normal' - non-CLJS-in-CLJS CLJS) - - This will have to be approached later. We'll figure it out; maybe just not yet. -[—] `extend-defnt!` - - Not yet; probably complicated and we don't need it right now -" - -#?(:clj -(defns class>simplest-class - "This ensures that special overloads are not created for non-primitive subclasses - of java.lang.Object (e.g. String, etc.)." - [c (? t/class?) > (? t/class?)] - (if (t/primitive-class? c) - c - (or (tcore/boxed->unboxed c) java.lang.Object)))) - -#?(:clj -(defns class>most-primitive-class [c (? t/class?), nilable? t/boolean? > (? t/class?)] - (if nilable? c (or (tcore/boxed->unboxed c) c)))) - -#?(:clj -(defns type>most-primitive-classes [t t/type? > (s/set-of (? t/class?))] - (let [cs (t/type>classes t) nilable? (contains? cs nil)] - (->> cs - (c/map+ #(class>most-primitive-class % nilable?)) - (join #{}))))) - -#?(:clj -(defns type>most-primitive-class [t t/type? > (? t/class?)] - (let [cs (type>most-primitive-classes t)] - (if (-> cs count (not= 1)) - (err! "Not exactly 1 class found" (kw-map t cs)) - (first cs))))) - -#?(:clj -(defns out-type>class [t t/type? > (? t/class?)] - (let [cs (t/type>classes t) cs' (disj cs nil)] - (if (-> cs' count (not= 1)) - ;; NOTE: we don't need to vary the output class if there are multiple output possibilities - ;; or just nil - java.lang.Object - (-> (class>most-primitive-class (first cs') (contains? cs nil)) - class>simplest-class))))) - -; ----- TYPED PART ----- ; - -;; NOTE: All this code can be defnt-ized after; this is just for bootstrapping purposes so performance isn't extremely important in most of these functions. - -(defonce *fn->type (atom {})) - -(defonce defnt-cache (atom {})) ; TODO For now — but maybe lock-free concurrent hash map to come - -(defonce *interfaces (atom {})) - -; ----- REFLECTION ----- ; - -#?(:clj -(defrecord Method [^String name ^Class rtype ^"[Ljava.lang.Class;" argtypes ^clojure.lang.Keyword kind] - fipp.ednize/IOverride - fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "M") (into (array-map) this))))) - -#?(:clj (defns method? [x _] (instance? Method x))) - -#?(:clj -(defns class->methods [^Class c t/class? > t/map?] - (->> (.getMethods c) - (remove+ (fn [^java.lang.reflect.Method x] - (java.lang.reflect.Modifier/isPrivate (.getModifiers x)))) - (map+ (fn [^java.lang.reflect.Method x] - (Method. (.getName x) (.getReturnType x) (.getParameterTypes x) - (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) - :static - :instance)))) - (c/group-by (fn [^Method x] (.-name x))) ; TODO all of these need to be into !vector and !hash-map - (map-vals+ (fn->> (c/group-by (fn [^Method x] (count (.-argtypes x)))) - (map-vals+ (fn->> (c/group-by (fn [^Method x] (.-kind x))))) - (join {}))) - (join {})))) - -(defonce class->methods|with-cache - (memoize (fn [c] (class->methods c)))) - -(defrecord Field [^String name ^Class class ^clojure.lang.Keyword kind] - fipp.ednize/IOverride - fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "F") (into (array-map) this)))) - -(defns class->fields [^Class c t/class? > t/map?] - (->> (.getFields c) - (remove+ (fn [^java.lang.reflect.Field x] - (java.lang.reflect.Modifier/isPrivate (.getModifiers x)))) - (map+ (fn [^java.lang.reflect.Field x] - [(.getName x) - (Field. (.getName x) (.getType x) - (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) - :static - :instance))])) - (join {}))) ; TODO !hash-map - -(def class->fields|with-cache - (memoize (fn [c] (class->fields c)))) - -(def ^:dynamic *conditional-branch-pruning?* true) - -(defonce *analyze-i (atom 0)) - -(defn add-file-context [to from] - (let [from-meta (meta from)] - (update-meta to assoc :line (:line from-meta) :column (:column from-meta)))) - -(defn persistent!-and-add-file-context [form ast-ret] - (update ast-ret :form (fn-> persistent! (add-file-context form)))) - -(def special-symbols '#{do let* deftype* fn* def . if quote new throw}) ; TODO make more complete - -;; TODO move -(deftype WatchableMutable - [^:unsynchronized-mutable v ^:unsynchronized-mutable ^clojure.lang.IFn watch] - clojure.lang.IDeref (deref [this] v) - clojure.lang.IRef (addWatch [this _ f] (set! watch f ) this) - (removeWatch [this _] (set! watch nil) this) - clojure.lang.IAtom (reset [this newv] (set! v newv) v) - (swap [this f] - (let [oldv v] - (set! v (f v)) - (when (some? watch) (watch nil this oldv v)) - v)) - Object (equals [this that] - (and (instance? WatchableMutable that) - (= v (.-v ^WatchableMutable that)))) - fipp.ednize/IOverride - fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "!@") v))) - -;; TODO move -(defn !ref - ([v] (->WatchableMutable v nil)) - ([v watch] (->WatchableMutable v watch))) - -(s/def ::env (s/map-of t/symbol? t/any?)) - -(declare analyze*) - -(defns- analyze-non-map-seqable - "Analyzes a non-map seqable." - {:params-doc - '{merge-types-fn "2-arity fn that merges two types (or sets of types). - The first argument is the current deduced type of the - overall expression; the second is the deduced type of - the current subexpression."}} - [env ::env, form _, empty-form _, rf _] - (->> form - (reducei (fn [accum form' i] (rf accum (analyze* (:env accum) form') i)) - {:env env :form (transient empty-form) :body (transient [])}) - (persistent!-and-add-file-context form) - (<- (update :body persistent!)))) - -(defns- analyze-map - {:todo #{"If the map is bound to a variable, preserve type info for it such that lookups - can start out with a guarantee of a certain type."}} - [env ::env, form _] - (TODO "analyze-map") - #_(->> form - (reduce-kv (fn [{env' :env forms :form} form'k form'v] - (let [ast-ret-k (analyze* env' form'k) - ast-ret-v (analyze* env' form'v)] - (->expr-info {:env env' - :form (assoc! forms (:form ast-ret-k) (:form ast-ret-v)) - ;; TODO fix; we want the types of the keys and vals to be deduced - :type-info nil}))) - (->expr-info {:env env :form (transient {})})) - (persistent!-and-add-file-context form))) - -(defns- analyze-seq|do [env ::env, form _, body _] - (if (empty? body) - (ast/do {:env env - :unexpanded-form form - :form form - :body (>vec body) - :type t/nil?}) - (let [expr (analyze-non-map-seqable env body [] - (fn [accum expr _] - (assoc expr ;; The env should be the same as whatever it was originally - ;; because no new scopes are created - :env (:env accum) - :form (conj! (:form accum) (:form expr)) - :body (conj! (:body accum) expr))))] - (ast/do {:env env - :unexpanded-form form - :form (list* 'do (:form expr)) - :body (:body expr) - ;; To types, only the last subexpression ever matters, as each is independent - ;; from the others - :type (-> expr :body c/last :type)})))) - -(defns analyze-seq|let*|bindings [env ::env, bindings _] - (TODO "`let*|bindings` analysis") - #_(->> bindings - (partition-all+ 2) - (reduce (fn [{env' :env forms :form} [sym form]] - (let [expr-ret (analyze* env' form)] - (->expr-info - {:env (assoc env' sym (->type-info {:reifieds (:reifieds expr-ret) ; TODO should use type info or exprinfo? - :abstracts (:abstracts expr-ret) - :fn-types (:fn-types expr-ret)})) - :form (conj! (conj! forms sym) (:form expr-ret))}))) - (->expr-info {:env env :form (transient [])})) - (persistent!-and-add-file-context bindings))) - -(defns analyze-seq|let* [env ::env, form _, [bindings _ & body _] _] - {:pre [(prl! env bindings body)]} - (let [env' (analyze-seq|let*|bindings env ) - expr (analyze-seq|do env' (list* 'do form) body)] - (prl! expr) - (TODO "`let*` analysis") - #_(ast/let* {:env env - :form form - :bindings (bindings>env bindings) - :body (>vec body) - :type (:type expr)})) - - #_(let [{env' :env bindings' :form} - (analyze-seq|let*|bindings env bindings) - {env'' :env body' :form type-info' :type-info} - (analyze-seq|do env' body)] - (->expr-info {:env env - :form (list 'let* bindings' body') - :type-info type-info'}))) - -(defns ?resolve-with-env [sym t/symbol?, env ::env] - (let [local (c/get env sym)] - (if (some? local) - (if (ast/unbound? local) - local - (TODO "Need to figure out what to do when resolving local vars")) - (let [resolved (ns-resolve *ns* sym)] - (log/ppr :warn "Not sure how to handle non-local symbol; resolved it for now" (kw-map sym resolved)) - resolved)))) - -(defns methods->type - "Creates a type given ->`methods`." - [methods (s/seq-of t/any? #_method?) > t/type?] - ;; TODO room for plenty of optimization here - (let [methods|by-ct (->> methods - (c/group-by (fn-> :argtypes count)) - (sort-by first <)) - ;; non-primitive classes in Java aren't guaranteed to be non-null - >class-type (fn [x] - (ifs (class? x) - (-> x t/>type (cond-> (not (t/primitive-class? x)) t/?)) - (t/type? x) - x - (err/not-supported! `>class-type x))) - partition-deep - (fn partition-deep [t methods' arglist-size i|arg depth] - (let [_ (when (> depth 3) (TODO)) - methods'|by-class - (->> methods' - ;; TODO optimize further via `group-by-into` - (c/group-by (fn-> :argtypes (c/get i|arg))) - ;; classes will be sorted from most to least specific - (sort-by (fn-> first t/>type) t/<))] - (r/for [[c methods''] methods'|by-class - t' t] - (update t' :clauses conj - [(>class-type c) - (if (= (inc depth) arglist-size) - ;; here, methods'' count will be = 1 - (-> methods'' first :rtype >class-type) - (partition-deep - (xp/condpf-> t/<= (xp/get (inc i|arg))) - methods'' - arglist-size - (inc i|arg) - (inc depth)))]))))] - (r/for [[ct methods'] methods|by-ct - t (xp/casef count)] - (if (zero? ct) - (c/assoc-in t [:cases 0] (-> methods' first :rtype >class-type)) - (c/assoc-in t [:cases ct] (partition-deep (xp/condpf-> t/<= (xp/get 0)) methods' ct 0 0)))))) - -#?(:clj -(defns ?cast-call->type - "Given a cast call like `clojure.lang.RT/uncheckedBooleanCast`, returns the - corresponding type. - - Unchecked fns could be assumed to actually *want* to shift the range over if the - range hits a certain point, but we do not make that assumption here." - [c t/class?, method t/symbol? > (? t/type?)] - (when (identical? c clojure.lang.RT) - (case method - (uncheckedBooleanCast booleanCast) t/boolean? - (uncheckedByteCast byteCast) t/byte? - (uncheckedCharCast charCast) t/char? - (uncheckedShortCast shortCast) t/char? - (uncheckedIntCast intCast) t/int? - (uncheckedLongCast longCast) t/long? - (uncheckedFloatCast floatCast) t/float? - (uncheckedDoubleCast doubleCast) t/double? - nil)))) - -(defns- analyze-seq|dot|method-call - "A note will be made of what methods match the argument types. - If only one method is found, that is noted too. If no matching method is found, an - exception is thrown." - [env ::env, form _, target _, target-class t/class?, static? t/boolean?, method-form simple-symbol?, args-forms _ #_(seq-of form?)] - ;; TODO cache type by method - (if-not-let [methods-for-name (-> target-class class->methods|with-cache (c/get (name method-form)))] - (if (empty? args-forms) - (err! "No such method or field in class" {:class target-class :method-or-field method-form}) - (err! "No such method in class" {:class target-class :methods method-form})) - (if-not-let [methods-for-count (c/get methods-for-name (c/count args-forms))] - (err! "Incorrect number of arguments for method" - {:class target-class :method method-form :possible-counts (set (keys methods-for-name))}) - (let [static?>kind (fn [static?] (if static? :static :instance))] - (if-not-let [methods (c/get methods-for-count (static?>kind static?))] - (err! (istr "Method found for arg-count, but was ~(static?>kind (not static?)), not ~(static?>kind static?)") - {:class target-class :method method-form :args args-forms}) - (let [args-ct (c/count args-forms) - call (ast/method-call - {:env env - :form form - :target target - :method method-form - :args [] - :type (methods->type methods #_(count arg-forms))}) - with-arg-types - (r/fori [arg-form args-forms - call' call - i|arg] - (prl! call' arg-form) - (let [arg-node (analyze* env arg-form)] - ;; TODO can incrementally calculate return value, but possibly not worth it - (update call' :args conj arg-node))) - with-ret-type - (update with-arg-types :type - (fn [ret-type] (->> with-arg-types :args (mapv :type) ret-type))) - ?cast-type (?cast-call->type target-class method-form) - _ (when ?cast-type - (ppr :warn "Not yet able to statically validate whether primitive cast will succeed at runtime" {:form form}) - #_(s/validate (-> with-ret-type :args first :type) #(t/>= % (t/numerically ?cast-type))))] - with-ret-type)))))) - -(defns- analyze-seq|dot|field-access - [env ::env, form _, target _, field-form simple-symbol?, field (t/isa? Field)] - (ast/field-access - {:env env - :form form - :target target - :field field-form - :type (-> field :class t/>type)})) - -(defns classes>class - "Ensure that given a set of classes, that set consists of at most a class C and nil. - If so, returns C. Otherwise, throws." - [cs (s/set-of (? t/class?)) > t/class?] - (let [cs' (disj cs nil)] - (if (-> cs' count (= 1)) - (first cs') - (err! "Found more than one class" cs)))) - -;; TODO type these arguments; e.g. check that ?method||field, if present, is an unqualified symbol -(defns- analyze-seq|dot [env ::env, form _, [target-form _, ?method-or-field _ & ?args _] _] - {:pre [(prl! env form target-form ?method-or-field ?args)] - :post [(prl! %)]} - (let [target (analyze* #_?resolve-with-env env target-form) - method-or-field (if (symbol? ?method-or-field) ?method-or-field (first ?method-or-field)) - args-forms (if (symbol? ?method-or-field) ?args (rest ?method-or-field))] - (if (t/= (:type target) t/nil?) - (err! "Cannot use the dot operator on nil." {:form form}) - (let [;; `nilable?` because technically any non-primitive in Java is nilable and we can't - ;; necessarily rely on all e.g. "@nonNull" annotations - {:as ?target-static-class-map target-static-class :class target-static-class-nilable? :nilable?} - (-> target :type t/type>?class-value) - target-classes - (if ?target-static-class-map - (cond-> #{target-static-class} target-static-class-nilable? (conj nil)) - (-> target :type t/type>classes)) - target-class-nilable? (contains? target-classes nil) - target-class (classes>class target-classes)] - ;; TODO determine how to handle `target-class-nilable?`; for now we will just let it slip through - ;; to `NullPointerException` at runtime rather than create a potentially more helpful custom - ;; exception - (if-let [field (and (empty? args-forms) - (-> target-class class->fields|with-cache (c/get (name method-or-field))))] - (analyze-seq|dot|field-access env form target method-or-field field) - (analyze-seq|dot|method-call env form target target-class (boolean ?target-static-class-map) - method-or-field args-forms)))))) - -;; TODO move this -(defns truthy-expr? [{:as expr t [:type _]} _ > t/boolean?] - (ifs (or (t/= t t/nil?) - (t/= t t/false?)) false - (or (t/> t t/nil?) - (t/> t t/false?)) nil ; representing "unknown" - true)) - -(defns- analyze-seq|if - "If `*conditional-branch-pruning?*` is falsey, the dead branch's original form will be - retained, but it will not be type-analyzed." - [env ::env, form _, [pred-form _, true-form _, false-form _ :as body] _] - {:post [(prl! %)]} - (if (-> body count (not= 3)) - (err! "`if` accepts exactly 3 arguments: one predicate test and two branches; received" - {:body body}) - (let [pred-expr (analyze* env pred-form) - true-expr (delay (analyze* env true-form)) - false-expr (delay (analyze* env false-form)) - whole-expr - (delay - (ast/if-expr - {:env env - :form (list 'if (:form pred-expr) (:form @true-expr) (:form @false-expr)) - :pred-expr pred-expr - :true-expr @true-expr - :false-expr @false-expr - :type (apply t/or (->> [(:type @true-expr) (:type @false-expr)] - (remove nil?)))}))] - (case (truthy-expr? pred-expr) - true (do (ppr :warn "Predicate in `if` expression is always true" {:pred pred-form}) - (-> @true-expr - (assoc :env env) - (cond-> (not *conditional-branch-pruning?*) - (assoc :form (list 'if pred-form (:form @true-expr) false-form))))) - false (do (ppr :warn "Predicate in `if` expression is always false" {:pred pred-form}) - (-> @false-expr - (assoc :env env) - (cond-> (not *conditional-branch-pruning?*) - (assoc :form (list 'if pred-form true-form (:form @false-expr)))))) - nil @whole-expr)))) - -(defns- analyze-seq|quote [env ::env, form _, body _] - {:post [(prl! %)]} - (ast/quoted env form (tcore/most-primitive-class-of body))) - -(defns- analyze-seq|new [env ::env, form _ [c|form _ #_t/class? & args _ :as body] _] - {:pre [(prl! env form body)]} - (let [c|analyzed (analyze* env c|form)] - (if-not (and (-> c|analyzed :type t/value-type?) - (-> c|analyzed :type utr/value-type>value class?)) - (err! "Supplied non-class to `new` expression" {:x c|form}) - (let [c (-> c|analyzed :type utr/value-type>value) - args|analyzed (mapv #(analyze* env %) args)] - (ast/new-expr {:env env - :form (list* 'new c|form (map :form args|analyzed)) - :class c - :args args|analyzed - :type (t/isa? c)}))))) - -(defns- analyze-seq|throw [env ::env, form _ [arg _ :as body] _] - {:pre [(prl! env form body)]} - (if (-> body count (not= 1)) - (err! "Must supply exactly one input to `throw`; supplied" {:body body}) - (let [arg|analyzed (analyze* env arg)] - ;; TODO this is not quite true for CLJS but it's nice at least - (if-not (-> arg|analyzed :type (t/<= t/throwable?)) - (err! "`throw` requires a throwable; received" {:arg arg :type (:type arg|analyzed)}) - (ast/throw-expr {:env env - :form (list 'throw (:form arg|analyzed)) - :arg arg|analyzed - ;; `t/none?` because nothing is actually returned - :type t/none?}))))) - -(defns- analyze-seq* - "Analyze a seq after it has been macro-expanded. - The ->`form` is post- incremental macroexpansion." - [env ::env, [caller|form _ & body _ :as form] _] - (ifs (special-symbols caller|form) - (case caller|form - do (analyze-seq|do env form body) - let* (analyze-seq|let* env form body) - deftype* (TODO "deftype*") - fn* (TODO "fn*") - def (TODO "def") - . (analyze-seq|dot env form body) - if (analyze-seq|if env form body) - quote (analyze-seq|quote env form body) - new (analyze-seq|new env form body) - throw (analyze-seq|throw env form body)) - ;; TODO support recursion - (let [caller|expr (analyze* env caller|form) - caller|type (:type caller|expr) - args-ct (count body)] - (case (t/compare caller|type t/callable?) - (1 2) (err! "It is not known whether expression be called" {:expr caller|expr}) - 3 (err! "Expression cannot be called" {:expr caller|expr}) - (-1 0) (let [caller-kind - (ifs (t/<= caller|type t/keyword?) :keyword - (t/<= caller|type t/+map|built-in?) :map - (t/<= caller|type t/+vector|built-in?) :vector - (t/<= caller|type t/+set|built-in?) :set - (t/<= caller|type t/fnt?) :fnt - (t/<= caller|type t/fn?) :fn - ;; If it's callable but not fn, we might have missed something in - ;; this dispatch so for now we throw - (err! "Don't know how how to handle non-fn callable" - {:caller caller|expr})) - assert-valid-args-ct - (case caller-kind - (:keyword :map) - (when-not (or (= args-ct 1) (= args-ct 2)) - (err! (str "Keywords and `clojure.core` persistent maps must be " - "provided with exactly one or two args when calling " - "them") - {:args-ct args-ct :caller caller|expr})) - - (:vector :set) - (when-not (= args-ct 1) - (err! (str "`clojure.core` persistent vectors and `clojure.core` " - "persistent sets must be provided with exactly one arg " - "when calling them") - {:args-ct args-ct :caller caller|expr})) - - :fnt - (TODO "Don't know how to handle typed fns yet" {:caller caller|expr}) - ;; For non-typed fns, unknown; we will have to risk runtime exception - ;; because we can't necessarily rely on metadata to tell us the - ;; whole truth - :fn nil) - ;; TODO incrementally check by analyzing each arg in `reduce` and pruning - ;; branches of what the type could be, and throwing if it's found something - ;; that's an impossible combination - arg-exprs (->> body - (c/map+ #(analyze* env %)) - (reduce (fn [args arg|analyzed] - (conj args arg|analyzed)) - [])) - out-type - (case caller-kind - ;; We could do a little smarter analysis here but we'll keep it simple - ;; for now - (:keyword :map :vector :set :fn) t/any? - :fnt (TODO "Use `::t/type` metadata to make this decision"))] - (ast/call-expr - {:env env - :form form - :caller caller|expr - :args arg-exprs - :type out-type})))))) - -(defns- analyze-seq [env ::env, form _] - {:post [(prl! %)]} - (let [expanded-form (ufeval/macroexpand form)] - (if (== form expanded-form) - (analyze-seq* env expanded-form) - (ast/macro-call {:env env :form form :expanded (analyze-seq* env expanded-form)})))) - -(defns- analyze-symbol [env ::env, form t/symbol?] - {:post [(prl! %)]} - (let [resolved (?resolve-with-env form env)] - (if-not resolved - (err! "Could not resolve symbol" {:sym form}) - (ast/symbol env form - (ifs (ast/node? resolved) - (:type resolved) - (or (t/literal? resolved) (t/class? resolved)) - (t/value resolved) - (var? resolved) - (or (-> resolved meta ::t/type) (t/value @resolved)) - (utpred/unbound? resolved) - ;; Because the var could be anything and cannot have metadata (type or otherwise) - t/any? - (TODO "Unsure of what to do in this case" (kw-map env form resolved))))))) - -(defns- analyze* [env ::env, form _] - (prl! env form) - (when (> (swap! *analyze-i inc) 100) (throw (ex-info "Stack too deep" {:form form}))) - (ifs (symbol? form) - (analyze-symbol env form) - (t/literal? form) - (ast/literal env form (t/>type form)) - (or (vector? form) - (set? form)) - (analyze-non-map-seqable env form (empty form) (fn stop [& [a b :as args]] (prl! args) (err! "STOP"))) - (map? form) - (analyze-map env form) - (seq? form) - (analyze-seq env form) - (throw (ex-info "Unrecognized form" {:form form})))) - -(defns analyze - ([body _] (analyze {} body)) - ([env ::env, body _] - (reset! *analyze-i 0) - (analyze* env body))) - -;; ===== (DE)FNT ===== ;; - -;; Internal specs - -(s/def ::expanded-overload|arg-classes (s/vec-of t/class?)) -(s/def ::expanded-overload|arg-types (s/seq-of t/type?)) - -;; This is the overload after the input specs are split by their respective `t/or` constituents, -;; and after primitivization, but before readiness for incorporation into a `reify`. -;; One of these corresponds to one reify overload. -(s/def ::expanded-overload - (s/kv {:arg-classes ::expanded-overload|arg-classes - :arg-types ::expanded-overload|arg-types - :arglist-code|fn|hinted t/any? - :arglist-code|reify|unhinted t/any? - :body-form t/any? - :out-class (? t/class?) - :out-type t/type? - :positional-args-ct t/nneg-int? - ;; When present, varargs are considered to be of class Object - :variadic? t/boolean?})) - -(s/def ::reify|overload - (s/keys :req-un [:quantum.core.specs/interface - :reify|overload/out-class - :reify/method-sym - :reify/arglist-code - :reify|overload/body-form])) - -(s/def ::reify - (s/kv {:form t/any? - :name simple-symbol? - :non-primitivized-overload ::reify|overload - :overloads (s/vec-of ::reify|overload)})) - -(s/def ::lang #{:clj :cljs}) - -(s/def ::input-types-decl - (s/kv {:form t/any? - :name simple-symbol? - :arg-type|split (s/vec-of t/type?)})) - -(s/def ::direct-dispatch-data - (s/kv {:i-arg->input-types-decl (s/vec-of ::input-types-decl) - :reify-seq (s/vec-of ::reify)})) - -(s/def ::i-overload->direct-dispatch-data (s/vec-of ::direct-dispatch-data)) - -(s/def ::direct-dispatch - (s/kv {:form t/any? - :i-overload->direct-dispatch-data ::i-overload->direct-dispatch-data})) - -(s/def ::expanded-overload-group|arg-types|form (s/vec-of t/any?)) - -(s/def ::expanded-overload-group - (s/kv {:arg-types|form ::expanded-overload-group|arg-types|form - :non-primitivized ::expanded-overload - :primitivized (s/nilable (s/seq-of ::expanded-overload))})) - -(s/def ::expanded-overload-groups|arg-types|split (s/vec-of (s/vec-of t/type?))) -(s/def ::expanded-overload-groups|pre-type|form t/any?) -(s/def ::expanded-overload-groups|post-type|form t/any?) - -(s/def ::expanded-overload-groups - (s/kv {:arg-types|pre-split|form ::expanded-overload-group|arg-types|form - :pre-type|form ::expanded-overload-groups|pre-type|form - :post-type|form ::expanded-overload-groups|post-type|form - :arg-types|split ::expanded-overload-groups|arg-types|split - :arg-types|recombined (s/vec-of (s/vec-of t/type?)) - :expanded-overload-group-seq (s/seq-of ::expanded-overload-group)})) - -#_(:clj -(defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] - (cond (not= k :spec) java.lang.Object; default class - (symbol? spec) (pred->class lang spec)))) - -;; TODO optimize such that `post-type|form` doesn't create a new type-validator wholesale every -;; time the function gets run; e.g. extern it -(defn >with-post-type|form [body post-type|form] `(t/validate ~body ~post-type|form)) - -#?(:clj -(var/def sort-guide "for use in arity sorting, in increasing conceptual (and bit) size" - {Object 0 - tdef/boolean 1 - tdef/byte 2 - tdef/short 3 - tdef/char 4 - tdef/int 5 - tdef/long 6 - tdef/float 7 - tdef/double 8})) - -#?(:clj -(defns arg-types>arg-classes-seq|primitivized - "'primitivized' meaning given an arglist whose types are `[t/any?]` this will output: - [[java.lang.Object] - [boolean] - [byte] - [short] - [char] - [int] - [long] - [float] - [double]] - which includes all primitive subclasses of the type." - [arg-types (s/seq-of t/type?) > (s/seq-of ::expanded-overload|arg-classes)] - (->> arg-types - (c/lmap (fn [t #_t/type?] - (if (-> t meta :ref?) - (-> t t/type>classes (disj nil) seq) - (let [cs (type>most-primitive-classes t) - base-classes - (cond-> (>set cs) - (contains? cs nil) (-> (disj nil) (conj java.lang.Object)))] - (->> cs - (c/map+ tcore/class>prim-subclasses) - (educe (aritoid nil identity set/union) base-classes) - ;; for purposes of cleanliness and reproducibility in tests - (sort-by sort-guide)))))) - (apply combo/cartesian-product) - (c/lmap >vec)))) - -;; TODO spec args -#?(:clj -(defns- >expanded-overload - "Is given `arg-classes` and `arg-types`. In order to determine the out-type, performs an analysis - using (in part) these pieces of data, but does not use the possibly-updated `arg-types` as - computed in the analysis. As a result, does not yet support type inference." - [{:keys [arg-bindings _, arg-classes ::expanded-overload|arg-classes - post-type|form _ - arg-types ::expanded-overload|arg-types, body-codelist|pre-analyze _, lang ::lang - varargs _, varargs-binding _]} _ - > ::expanded-overload] - (let [env (->> (zipmap arg-bindings arg-types) - (c/map' (fn [[arg-binding arg-type]] - [arg-binding (ast/unbound nil arg-binding arg-type)]))) - analyzed (analyze env (ufgen/?wrap-do body-codelist|pre-analyze)) - arg-classes|simplest (->> arg-classes (c/map class>simplest-class)) - hint-arg|fn (fn [i arg-binding] - (ufth/with-type-hint arg-binding - (ufth/>fn-arglist-tag - (c/get arg-classes|simplest i) - lang - (c/count arg-bindings) - varargs))) - ;; TODO this becomes an issue when `post-type|form` references local bindings - post-type (eval post-type|form) - post-type|runtime? (-> post-type meta :runtime?) - out-type (if post-type - (if post-type|runtime? - (case (t/compare post-type (:type analyzed)) - -1 post-type - 1 (:type analyzed) - 0 post-type - (2 3) (err! "Body and output type comparison not handled" - {:body analyzed :output-type post-type})) - (if (t/<= (:type analyzed) post-type) - (:type analyzed) - (err! "Body does not match output type" - {:body analyzed :output-type post-type}))) - (:type analyzed)) - body-form - (-> (:form analyzed) - (cond-> post-type|runtime? (>with-post-type|form post-type|form)) - (ufth/cast-bindings|code - (->> (c/zipmap-into (map/om) arg-bindings arg-classes) - (c/remove-vals' (fn-or nil? (fn= java.lang.Object) t/primitive-class?)))))] - {:arg-classes arg-classes|simplest - :arg-types arg-types - :arglist-code|fn|hinted (cond-> (->> arg-bindings (c/map-indexed hint-arg|fn)) - varargs-binding (conj '& varargs-binding)) ; TODO use `` - :arglist-code|reify|unhinted (cond-> arg-bindings varargs-binding (conj varargs-binding)) - :body-form body-form - :positional-args-ct (count arg-bindings) - :out-type out-type - :out-class (out-type>class out-type) - :variadic? (boolean varargs)}))) - -(defns >expanded-overload-group - [{:as in :keys [arg-types ::expanded-overload-group|arg-types|form]} _ - > ::expanded-overload-group] - (let [arg-types|form (mapv >form arg-types) - ;; `non-primitivized` is first because of class sorting - [non-primitivized & primitivized :as overloads] - (->> arg-types - arg-types>arg-classes-seq|primitivized - (mapv (fn [arg-classes #_::expanded-overload|arg-classes] - (let [arg-types|satisfying-primitivization - (c/mergev-with - (fn [_ s #_t/type? c #_t/class?] - (cond-> s (t/primitive-class? c) (t/and c))) - arg-types arg-classes)] - (>expanded-overload - (assoc in :arg-classes arg-classes - :arg-types arg-types|satisfying-primitivization))))))] - (kw-map arg-types|form non-primitivized primitivized))) - -;; TODO spec -#?(:clj ; really, reserve for metalanguage -(defns fnt|overload-data>expanded-overload-groups - "Given an `fnt` overload, computes a seq of 'expanded-overload groups'. Each expanded-overload - group is the foundation for one `reify`. - - Rather than rigging together something in which either: - 1) the Clojure compiler will try to cross its fingers and evaluate code meant to be evaluated in - ClojureScript - 2) we use a CLJS-in-CLJS compiler and alienate the mainstream CLJS-in-CLJ (cljsbuild) workflow, - which includes our own workflow - 3) we wait for CLJS-in-CLJS to become mainstream, which could take years if it really ever - happens - - we decide instead to evaluate types in languages in which the metalanguage (compiler language) - is the same as the object language (e.g. Clojure), and symbolically analyze types in the rest - (e.g. vanilla ClojureScript), deferring code analyzed as functions to be enforced at runtime." - [{:as in {:keys [args _, varargs _] - pre-type|form [:pre _] - [_ _, post-type|form _] [:post _]} [:arglist _] - body-codelist|pre-analyze [:body _]} _ - {:as opts :keys [::lang ::lang, symbolic-analysis? t/boolean?]} _ - > ::expanded-overload-groups] - (if symbolic-analysis? - (err! "Symbolic analysis not supported yet") - (let [_ (when pre-type|form (TODO "Need to handle pre")) - _ (when varargs (TODO "Need to handle varargs")) - post-type|form (if (= post-type|form '_) `t/any? post-type|form) - varargs-binding (when varargs - ;; TODO this assertion is purely temporary until destructuring is - ;; supported - (assert (-> varargs :binding-form first (= :sym)))) - arg-bindings - (->> args - (mapv (fn [{[kind binding-] :binding-form}] - ;; TODO this assertion is purely temporary until destructuring is - ;; supported - (assert kind :sym) - binding-))) - arg-types|pre-split|form - (->> args - (mapv (fn [{[kind #_#{:any :spec}, t #_t/form?] :spec}] - (case kind :any `t/any? :spec t)))) - arg-types|pre-split (->> arg-types|pre-split|form (mapv (fn-> eval t/>type))) - arg-types|split - ;; NOTE Only `t/or`s are splittable for now - (->> arg-types|pre-split - (c/map (fn [t] (if (utr/or-type? t) (utr/or-type>args t) [t])))) - arg-types|recombined (->> arg-types|split - (apply combo/cartesian-product) - (c/map vec)) - expanded-overload-group-seq - (->> arg-types|recombined - (mapv (fn [arg-types] - (>expanded-overload-group - (kw-map arg-bindings arg-types body-codelist|pre-analyze lang - arg-types|pre-split|form pre-type|form post-type|form - varargs varargs-binding)))))] - (kw-map arg-types|pre-split|form pre-type|form post-type|form - arg-types|split arg-types|recombined - expanded-overload-group-seq))))) - -(def fnt-method-sym 'invoke) - -(defns- class>interface-part-name [c t/class? > t/string?] - (if (= c java.lang.Object) - "Object" - (let [illegal-pattern #"\|\+"] - (if (->> c >name (re-find illegal-pattern)) - (err! "Class cannot contain pattern" {:class c :pattern illegal-pattern}) - (-> c >name (str/replace "." "|")))))) - -(defns fnt-overload>interface-sym [args-classes (s/seq-of t/class?), out-class t/class? > t/symbol?] - (>symbol (str (->> args-classes (lmap class>interface-part-name) (str/join "+")) - ">" (class>interface-part-name out-class)))) - -;; TODO finish specing args -(defns fnt-overload>interface [args-classes _, out-class t/class?, gen-gensym fn?] - (let [interface-sym (fnt-overload>interface-sym args-classes out-class) - hinted-method-sym (ufth/with-type-hint fnt-method-sym - (ufth/>interface-method-tag out-class)) - hinted-args (ufth/hint-arglist-with - (ufgen/gen-args 0 (count args-classes) "xint" gen-gensym) - (map ufth/>interface-method-tag args-classes))] - `(~'definterface ~interface-sym (~hinted-method-sym ~hinted-args)))) - -;; TODO spec args -#?(:clj -(defns expanded-overload>reify-overload - [{:as overload - :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, out-class t/class?]} - ::expanded-overload - gen-gensym fn? - > (s/seq-of ::reify|overload)] - (let [interface-k {:out out-class :in arg-classes} - interface - (-> *interfaces - (swap! update interface-k - #(or % (eval (fnt-overload>interface arg-classes out-class gen-gensym)))) - (c/get interface-k)) - arglist-code - (>vec (concat [(gen-gensym '_)] - (->> arglist-code|reify|unhinted - (map-indexed - (fn [i arg] - (ufth/with-type-hint arg - (-> arg-classes (c/get i) ufth/>arglist-embeddable-tag)))))))] - {:arglist-code arglist-code - :body-form body-form - :interface interface - :method-sym fnt-method-sym - :out-class out-class}))) - -(defns >reify|name - [{:keys [::uss/fn|name ::uss/fn|name, i|fnt-overload t/index? - i|expanded-overload-group t/index?]} _ > simple-symbol?] - (>symbol (str fn|name "|__" i|fnt-overload "|" i|expanded-overload-group))) - -#?(:clj -(defns expanded-overload-group>reify - [{:as in - :keys [::uss/fn|name ::uss/fn|name, i|fnt-overload t/index?, i|expanded-overload-group t/index? - expanded-overload-group ::expanded-overload-group]} _ - gen-gensym fn? > ::reify] - (let [reify-overloads (->> (concat [(:non-primitivized expanded-overload-group)] - (:primitivized expanded-overload-group)) - (c/map #(expanded-overload>reify-overload % gen-gensym))) - reify-name (>reify|name in) - form `(~'def ~reify-name - ~(list* `reify* - (->> reify-overloads (mapv #(-> % :interface >name >symbol))) - (->> reify-overloads - (c/lmap (fn [{:keys [out-class method-sym arglist-code - body-form]} #_::reify|overload] - `(~(ufth/with-type-hint method-sym - (ufth/>arglist-embeddable-tag out-class)) - ~arglist-code ~body-form))))))] - {:form form - :name reify-name - :non-primitivized-overload (first reify-overloads) - :overloads reify-overloads}))) - -(defns >input-type-decl|name - [fn|name ::uss/fn|name, i|fnt-overload t/index?, i|arg t/index? > simple-symbol?] - (>symbol (str fn|name "|__" i|fnt-overload "|input" i|arg "|types"))) - -(defns >i-arg->input-types-decl - "The evaluated `form` of each input-types-decl is an array of non-primitivized types that the - dynamic dispatch uses to dispatch off input types." - [{:as in - :keys [arg-types|split ::expanded-overload-groups|arg-types|split - fn|name ::uss/fn|name - i|fnt-overload t/index?]} _ - > (s/vec-of ::input-types-decl)] - (->> arg-types|split - (c/map-indexed - (fn [i|arg arg-type|split] - (let [decl-name (>input-type-decl|name fn|name i|fnt-overload i|arg) - form (list 'def (ufth/with-type-hint decl-name "[Ljava.lang.Object;") - (list* `arr/*<> (map >form arg-type|split)))] - (assoc (kw-map form arg-type|split) :name decl-name)))))) - -(def allowed-shorthand-tag-chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") -(def min-shorthand-tag-length 1) -(def max-shorthand-tag-length 64) ; for now - -(defn >all-shorthand-tags [] - (->> (range min-shorthand-tag-length (inc max-shorthand-tag-length)) - c/unchunk - (c/lmap (fn [n] (apply combo/cartesian-product (repeat n allowed-shorthand-tag-chars)))) - lcat - (c/lmap #(apply str %)) - c/unchunk)) - -(defonce *class>shorthand-tag|cache - (atom {:remaining (>all-shorthand-tags)})) - -;; dynamic for testing purposes -(def ^:dynamic **class>shorthand-tag|cache* *class>shorthand-tag|cache) - -(defns class>shorthand-tag [c t/class?] - (or (c/get @**class>shorthand-tag|cache* c) - (-> (swap! **class>shorthand-tag|cache* - (fn [{:as m :keys [remaining]}] - (assoc m c (first remaining) - :remaining (next remaining)))) - (get c)))) - -;; TODO spec -(defn assert-monotonically-increasing-types! - "Asserts that each type in an overload of the same arity and arg-position - are in monotonically increasing order in terms of `t/compare`." - [overloads|grouped-by-arity] - (doseq [[arity-ct overloads] overloads|grouped-by-arity] - (educe - (fn [prev-overload [i|overload overload]] - (when prev-overload - (reduce-2 - (fn [_ arg|type|prev [i|arg arg|type]] - (when (= (t/compare arg|type arg|type|prev) -1) - ;; TODO provide code context, line number, etc. - (err! (istr "At overload ~{i|overload}, arg ~{i|arg}: type is not in monotonically increasing order in terms of `t/compare`") - {:overload overload - :prev-overload prev-overload - :prev-type arg|type|prev - :type arg|type}))) - (:arg-types prev-overload) - (c/lindexed (:arg-types overload)))) - overload) - nil - overloads))) - -;; TODO spec -(defns unsupported! [name- _ #_t/qualified-symbol?, args t/indexed?, i t/index?] - (TODO)) - -(defns >direct-dispatch - [{:keys [::uss/fn|name ::uss/fn|name - expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups) - gen-gensym fn? - lang ::lang]} _ - > ::direct-dispatch] - (case lang - :clj - (let [i-overload->direct-dispatch-data - (->> expanded-overload-groups-by-fnt-overload - (c/map-indexed - (fn [i|fnt-overload {:keys [arg-types|split expanded-overload-group-seq]}] - {:i-arg->input-types-decl - (>i-arg->input-types-decl (kw-map arg-types|split fn|name i|fnt-overload)) - :reify-seq - (->> expanded-overload-group-seq - (c/map-indexed - (fn [i|expanded-overload-group - {:as expanded-overload-group :keys [arg-types|form]}] - (let [in (assoc (kw-map i|fnt-overload - i|expanded-overload-group - expanded-overload-group) - ::uss/fn|name fn|name)] - (expanded-overload-group>reify in gen-gensym)))))}))) - form (->> i-overload->direct-dispatch-data - (c/map (fn [{:keys [i-arg->input-types-decl reify-seq]}] - (concat (c/lmap :form i-arg->input-types-decl) - (c/lmap :form reify-seq)))) - c/lcat)] - (kw-map form i-overload->direct-dispatch-data)) - :cljs (TODO))) - -(defns >dynamic-dispatch-fn|type-decl - [expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups)] - (list* `t/fn (->> expanded-overload-groups-by-fnt-overload - (map (fn [{:keys [arg-types|pre-split|form - pre-type|form post-type|form]}] - (cond-> (or arg-types|pre-split|form []) - pre-type|form (conj :| pre-type|form) - post-type|form (conj :> post-type|form))))))) - -(defns >dynamic-dispatch|reify-call [reify- ::reify, arglist (s/vec-of simple-symbol?)] - (let [dotted-reify-method-sym - (symbol (str "." (-> reify- :non-primitivized-overload :method-sym))) - hinted-reify-sym - (ufth/with-type-hint (:name reify-) - (-> reify- :non-primitivized-overload :interface >name))] - `(~dotted-reify-method-sym ~hinted-reify-sym ~@arglist))) - -(defns >dynamic-dispatch|conditional - [fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?), i|arg t/index?, body _] - (if (-> body count (= 1)) - (first body) - `(ifs ~@body (unsupported! (quote ~(qualify fn|name)) [~@arglist] ~i|arg)))) - -(defns >dynamic-dispatch|body-for-arity - ([fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?) - direct-dispatch-data-for-arity (s/seq-of ::direct-dispatch-data)] - (if (empty? arglist) - (>dynamic-dispatch|reify-call - (-> direct-dispatch-data-for-arity first :reify-seq first) arglist) - (let [i|arg 0 - branches (->> direct-dispatch-data-for-arity - (c/lmap - (fn [{:keys [reify-seq i-arg->input-types-decl]}] - (>dynamic-dispatch|body-for-arity fn|name arglist reify-seq - i-arg->input-types-decl (atom 0) i|arg))) - c/lcat)] - (>dynamic-dispatch|conditional fn|name arglist i|arg branches)))) - ([fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?), reify-seq (s/vec-of ::reify) - input-types-decl-group' (s/seq-of ::input-types-decl), *i|reify _, i|arg t/index?] - (let [{:as input-types-decl :keys [arg-type|split]} (first input-types-decl-group') - input-types-decl-group'' (rest input-types-decl-group')] - (->> arg-type|split - (c/lmap-indexed - (fn [i|arg-type' _] - [`((Array/get ~(:name input-types-decl) ~i|arg-type') ~(get arglist i|arg)) - (if (empty? input-types-decl-group'') - (with-do (>dynamic-dispatch|reify-call (get reify-seq @*i|reify) arglist) - ;; TODO take out this ugly bit - (swap! *i|reify inc)) - (let [i|arg' (inc i|arg) - next-branch (>dynamic-dispatch|body-for-arity fn|name arglist reify-seq - input-types-decl-group'' *i|reify i|arg')] - (>dynamic-dispatch|conditional fn|name arglist i|arg' next-branch)))])) - c/lcat)))) - -(defns >dynamic-dispatch-fn|form - [{:keys [::uss/fn|name ::uss/fn|name - expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups) - gen-gensym fn? - lang ::lang - i-overload->direct-dispatch-data ::i-overload->direct-dispatch-data]} _] - `(defn ~fn|name - {::t/type ~(>dynamic-dispatch-fn|type-decl expanded-overload-groups-by-fnt-overload)} - ~@(->> i-overload->direct-dispatch-data - (group-by (fn-> :i-arg->input-types-decl count)) - (map (fn [[arg-ct direct-dispatch-data-for-arity]] - (let [arglist (ufgen/gen-args 0 arg-ct "x" gen-gensym) - body (>dynamic-dispatch|body-for-arity - fn|name arglist direct-dispatch-data-for-arity)] - (list arglist body))))))) - -(defns fnt|code [kind #{:fn :defn}, lang ::lang, args _] - (let [{:keys [:quantum.core.specs/fn|name - :quantum.core.defnt/overloads - :quantum.core.specs/meta] :as args'} - (s/validate args (case kind :defn ::defnt :fn ::fnt)) - symbolic-analysis? false ; TODO parameterize this - gen-gensym-base (ufgen/>reproducible-gensym|generator) - gen-gensym (fn [x] (symbol (str (gen-gensym-base x) "__"))) - inline? (s/validate (-> fn|name core/meta :inline) (t/? t/boolean?)) - fn|name (if inline? - (do (log/pr :warn "requested `:inline`; ignoring until feature is implemented") - (update-meta fn|name dissoc :inline)) - fn|name) - expanded-overload-groups-by-fnt-overload - (->> overloads (mapv #(fnt|overload-data>expanded-overload-groups % - {::lang lang :symbolic-analysis? symbolic-analysis?}))) - args (assoc (kw-map expanded-overload-groups-by-fnt-overload gen-gensym lang) - ::uss/fn|name fn|name) - {:as direct-dispatch :keys [i-overload->direct-dispatch-data]} (>direct-dispatch args) - fn-codelist - (case lang - :clj (->> `[~@(:form direct-dispatch) - ~(>dynamic-dispatch-fn|form - (merge args (kw-map i-overload->direct-dispatch-data)))] - (remove nil?)) - :cljs (TODO)) - code (case kind - :fn (TODO) - :defn `(~'do ~@fn-codelist))] - code)) - -#?(:clj (defmacro fnt [& args] (fnt|code :fn (ufeval/env-lang) args))) -#?(:clj (defmacro defnt [& args] (fnt|code :defn (ufeval/env-lang) args))) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 6101f6ff..3fabf20f 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -3,12 +3,8 @@ (ns quantum.core.test.defnt-equivalences (:refer-clojure :exclude [*]) (:require - [clojure.core :as c] - [quantum.core.defnt - :refer [analyze defnt fnt fnt|code *fn->type unsupported!]] - [quantum.untyped.core.analyze.expr :as xp] - [quantum.untyped.core.collections.diff :as diff - :refer [diff]] + [quantum.untyped.core.type.defnt + :refer [defnt fnt unsupported!]] [quantum.untyped.core.core :as ucore :refer [code=]] [quantum.untyped.core.data.array @@ -28,13 +24,8 @@ :refer [? *]] [quantum.untyped.core.type.reifications :as utr]) (:import - clojure.lang.Named - clojure.lang.Reduced - clojure.lang.ISeq - clojure.lang.ASeq - clojure.lang.LazySeq - clojure.lang.Seqable - quantum.core.data.Array + [clojure.lang ASeq ISeq LazySeq Named Reduced Seqable] + [quantum.core.data Array] [quantum.core Numeric Primitive])) ;; Just in case diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc new file mode 100644 index 00000000..6d7f3e0d --- /dev/null +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -0,0 +1,564 @@ +(ns quantum.untyped.core.analyze + (:require + ;; TODO excise this reference + [quantum.core.type.core :as tcore] + [quantum.untyped.core.analyze.ast :as uast] + [quantum.untyped.core.analyze.expr :as uxp] + [quantum.untyped.core.collections :as c + :refer [>vec]] + [quantum.untyped.core.compare :as ucomp] + [quantum.untyped.core.core + :refer [istr]] + [quantum.untyped.core.data + :refer [kw-map]] + [quantum.untyped.core.defnt + :refer [defns defns- fns]] + [quantum.untyped.core.error :as uerr + :refer [TODO err!]] + [quantum.untyped.core.fn + :refer [<- fn-> fn->>]] + [quantum.untyped.core.form.evaluate :as ufeval] + [quantum.untyped.core.log :as log + :refer [prl!]] + [quantum.untyped.core.logic + :refer [if-not-let ifs]] + [quantum.untyped.core.reducers :as r + :refer [educe reducei]] + [quantum.untyped.core.spec :as s] + [quantum.untyped.core.type :as t + :refer [?]] + [quantum.untyped.core.type.predicates :as utpred] + [quantum.untyped.core.type.reifications :as utr] + [quantum.untyped.core.vars :as uvar + :refer [update-meta]])) + +; ----- REFLECTION ----- ; + +#?(:clj +(defrecord Method + [^String name ^Class rtype ^"[Ljava.lang.Class;" argtypes ^clojure.lang.Keyword kind] + fipp.ednize/IOverride + fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "M") (into (array-map) this))))) + +#?(:clj (defns method? [x _] (instance? Method x))) + +#?(:clj +(defns class->methods [^Class c t/class? > t/map?] + (->> (.getMethods c) + (c/remove+ (fn [^java.lang.reflect.Method x] + (java.lang.reflect.Modifier/isPrivate (.getModifiers x)))) + (c/map+ (fn [^java.lang.reflect.Method x] + (Method. (.getName x) (.getReturnType x) (.getParameterTypes x) + (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) + :static + :instance)))) + (c/group-by (fn [^Method x] (.-name x))) ; TODO all of these need to be into !vector and !hash-map + (c/map-vals+ (fn->> (c/group-by (fn [^Method x] (count (.-argtypes x)))) + (c/map-vals+ (fn->> (c/group-by (fn [^Method x] (.-kind x))))) + (r/join {}))) + (r/join {})))) + +(defonce class->methods|with-cache + (memoize (fn [c] (class->methods c)))) + +(defrecord Field [^String name ^Class class ^clojure.lang.Keyword kind] + fipp.ednize/IOverride + fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "F") (into (array-map) this)))) + +(defns class->fields [^Class c t/class? > t/map?] + (->> (.getFields c) + (c/remove+ (fn [^java.lang.reflect.Field x] + (java.lang.reflect.Modifier/isPrivate (.getModifiers x)))) + (c/map+ (fn [^java.lang.reflect.Field x] + [(.getName x) + (Field. (.getName x) (.getType x) + (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) + :static + :instance))])) + (r/join {}))) ; TODO !hash-map + +(def class->fields|with-cache + (memoize (fn [c] (class->fields c)))) + +(def ^:dynamic *conditional-branch-pruning?* true) + +(defonce *analyze-depth (atom 0)) + +(defn add-file-context [to from] + (let [from-meta (meta from)] + (update-meta to assoc :line (:line from-meta) :column (:column from-meta)))) + +(defn persistent!-and-add-file-context [form ast-ret] + (update ast-ret :form (fn-> persistent! (add-file-context form)))) + +(def special-symbols '#{do let* deftype* fn* def . if quote new throw}) ; TODO make more complete + +;; TODO move +(deftype WatchableMutable + [^:unsynchronized-mutable v ^:unsynchronized-mutable ^clojure.lang.IFn watch] + clojure.lang.IDeref (deref [this] v) + clojure.lang.IRef (addWatch [this _ f] (set! watch f ) this) + (removeWatch [this _] (set! watch nil) this) + clojure.lang.IAtom (reset [this newv] (set! v newv) v) + (swap [this f] + (let [oldv v] + (set! v (f v)) + (when (some? watch) (watch nil this oldv v)) + v)) + Object (equals [this that] + (and (instance? WatchableMutable that) + (= v (.-v ^WatchableMutable that)))) + fipp.ednize/IOverride + fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "!@") v))) + +;; TODO move +(defn !ref + ([v] (->WatchableMutable v nil)) + ([v watch] (->WatchableMutable v watch))) + +(s/def ::env (s/map-of t/symbol? t/any?)) + +(declare analyze*) + +(defns- analyze-non-map-seqable + "Analyzes a non-map seqable." + {:params-doc + '{merge-types-fn "2-arity fn that merges two types (or sets of types). + The first argument is the current deduced type of the + overall expression; the second is the deduced type of + the current subexpression."}} + [env ::env, form _, empty-form _, rf _] + (->> form + (reducei (fn [accum form' i] (rf accum (analyze* (:env accum) form') i)) + {:env env :form (transient empty-form) :body (transient [])}) + (persistent!-and-add-file-context form) + (<- (update :body persistent!)))) + +(defns- analyze-map + {:todo #{"If the map is bound to a variable, preserve type info for it such that lookups + can start out with a guarantee of a certain type."}} + [env ::env, form _] + (TODO "analyze-map") + #_(->> form + (reduce-kv (fn [{env' :env forms :form} form'k form'v] + (let [ast-ret-k (analyze* env' form'k) + ast-ret-v (analyze* env' form'v)] + (->expr-info {:env env' + :form (assoc! forms (:form ast-ret-k) (:form ast-ret-v)) + ;; TODO fix; we want the types of the keys and vals to be deduced + :type-info nil}))) + (->expr-info {:env env :form (transient {})})) + (persistent!-and-add-file-context form))) + +(defns- analyze-seq|do [env ::env, form _, body _] + (if (empty? body) + (uast/do {:env env + :unexpanded-form form + :form form + :body (>vec body) + :type t/nil?}) + (let [expr (analyze-non-map-seqable env body [] + (fn [accum expr _] + (assoc expr ;; The env should be the same as whatever it was originally + ;; because no new scopes are created + :env (:env accum) + :form (conj! (:form accum) (:form expr)) + :body (conj! (:body accum) expr))))] + (uast/do {:env env + :unexpanded-form form + :form (list* 'do (:form expr)) + :body (:body expr) + ;; To types, only the last subexpression ever matters, as each is independent + ;; from the others + :type (-> expr :body c/last :type)})))) + +(defns analyze-seq|let*|bindings [env ::env, bindings _] + (TODO "`let*|bindings` analysis") + #_(->> bindings + (partition-all+ 2) + (reduce (fn [{env' :env forms :form} [sym form]] + (let [expr-ret (analyze* env' form)] + (->expr-info + {:env (assoc env' sym (->type-info {:reifieds (:reifieds expr-ret) ; TODO should use type info or exprinfo? + :abstracts (:abstracts expr-ret) + :fn-types (:fn-types expr-ret)})) + :form (conj! (conj! forms sym) (:form expr-ret))}))) + (->expr-info {:env env :form (transient [])})) + (persistent!-and-add-file-context bindings))) + +(defns analyze-seq|let* [env ::env, form _, [bindings _ & body _] _] + {:pre [(prl! env bindings body)]} + (let [env' (analyze-seq|let*|bindings env ) + expr (analyze-seq|do env' (list* 'do form) body)] + (prl! expr) + (TODO "`let*` analysis") + #_(uast/let* {:env env + :form form + :bindings (bindings>env bindings) + :body (>vec body) + :type (:type expr)})) + + #_(let [{env' :env bindings' :form} + (analyze-seq|let*|bindings env bindings) + {env'' :env body' :form type-info' :type-info} + (analyze-seq|do env' body)] + (->expr-info {:env env + :form (list 'let* bindings' body') + :type-info type-info'}))) + +(defns ?resolve-with-env [sym t/symbol?, env ::env] + (let [local (c/get env sym)] + (if (some? local) + (if (uast/unbound? local) + local + (TODO "Need to figure out what to do when resolving local vars")) + (let [resolved (ns-resolve *ns* sym)] + (log/ppr :warn "Not sure how to handle non-local symbol; resolved it for now" (kw-map sym resolved)) + resolved)))) + +(defns methods->type + "Creates a type given ->`methods`." + [methods (s/seq-of t/any? #_method?) > t/type?] + ;; TODO room for plenty of optimization here + (let [methods|by-ct (->> methods + (c/group-by (fn-> :argtypes count)) + (sort-by first <)) + ;; non-primitive classes in Java aren't guaranteed to be non-null + >class-type (fn [x] + (ifs (class? x) + (-> x t/>type (cond-> (not (t/primitive-class? x)) t/?)) + (t/type? x) + x + (uerr/not-supported! `>class-type x))) + partition-deep + (fn partition-deep [t methods' arglist-size i|arg depth] + (let [_ (when (> depth 3) (TODO)) + methods'|by-class + (->> methods' + ;; TODO optimize further via `group-by-into` + (c/group-by (fn-> :argtypes (c/get i|arg))) + ;; classes will be sorted from most to least specific + (sort-by (fn-> first t/>type) t/<))] + (r/for [[c methods''] methods'|by-class + t' t] + (update t' :clauses conj + [(>class-type c) + (if (= (inc depth) arglist-size) + ;; here, methods'' count will be = 1 + (-> methods'' first :rtype >class-type) + (partition-deep + (uxp/condpf-> t/<= (uxp/get (inc i|arg))) + methods'' + arglist-size + (inc i|arg) + (inc depth)))]))))] + (r/for [[ct methods'] methods|by-ct + t (uxp/casef count)] + (if (zero? ct) + (c/assoc-in t [:cases 0] (-> methods' first :rtype >class-type)) + (c/assoc-in t [:cases ct] (partition-deep (uxp/condpf-> t/<= (uxp/get 0)) methods' ct 0 0)))))) + +#?(:clj +(defns ?cast-call->type + "Given a cast call like `clojure.lang.RT/uncheckedBooleanCast`, returns the + corresponding type. + + Unchecked fns could be assumed to actually *want* to shift the range over if the + range hits a certain point, but we do not make that assumption here." + [c t/class?, method t/symbol? > (? t/type?)] + (when (identical? c clojure.lang.RT) + (case method + (uncheckedBooleanCast booleanCast) t/boolean? + (uncheckedByteCast byteCast) t/byte? + (uncheckedCharCast charCast) t/char? + (uncheckedShortCast shortCast) t/char? + (uncheckedIntCast intCast) t/int? + (uncheckedLongCast longCast) t/long? + (uncheckedFloatCast floatCast) t/float? + (uncheckedDoubleCast doubleCast) t/double? + nil)))) + +(defns- analyze-seq|dot|method-call + "A note will be made of what methods match the argument types. + If only one method is found, that is noted too. If no matching method is found, an + exception is thrown." + [env ::env, form _, target _, target-class t/class?, static? t/boolean?, method-form simple-symbol?, args-forms _ #_(seq-of form?)] + ;; TODO cache type by method + (if-not-let [methods-for-name (-> target-class class->methods|with-cache (c/get (name method-form)))] + (if (empty? args-forms) + (err! "No such method or field in class" {:class target-class :method-or-field method-form}) + (err! "No such method in class" {:class target-class :methods method-form})) + (if-not-let [methods-for-count (c/get methods-for-name (c/count args-forms))] + (err! "Incorrect number of arguments for method" + {:class target-class :method method-form :possible-counts (set (keys methods-for-name))}) + (let [static?>kind (fn [static?] (if static? :static :instance))] + (if-not-let [methods (c/get methods-for-count (static?>kind static?))] + (err! (istr "Method found for arg-count, but was ~(static?>kind (not static?)), not ~(static?>kind static?)") + {:class target-class :method method-form :args args-forms}) + (let [args-ct (c/count args-forms) + call (uast/method-call + {:env env + :form form + :target target + :method method-form + :args [] + :type (methods->type methods #_(count arg-forms))}) + with-arg-types + (r/fori [arg-form args-forms + call' call + i|arg] + (prl! call' arg-form) + (let [arg-node (analyze* env arg-form)] + ;; TODO can incrementally calculate return value, but possibly not worth it + (update call' :args conj arg-node))) + with-ret-type + (update with-arg-types :type + (fn [ret-type] (->> with-arg-types :args (mapv :type) ret-type))) + ?cast-type (?cast-call->type target-class method-form) + _ (when ?cast-type + (log/ppr :warn "Not yet able to statically validate whether primitive cast will succeed at runtime" {:form form}) + #_(s/validate (-> with-ret-type :args first :type) #(t/>= % (t/numerically ?cast-type))))] + with-ret-type)))))) + +(defns- analyze-seq|dot|field-access + [env ::env, form _, target _, field-form simple-symbol?, field (t/isa? Field)] + (uast/field-access + {:env env + :form form + :target target + :field field-form + :type (-> field :class t/>type)})) + +(defns classes>class + "Ensure that given a set of classes, that set consists of at most a class C and nil. + If so, returns C. Otherwise, throws." + [cs (s/set-of (? t/class?)) > t/class?] + (let [cs' (disj cs nil)] + (if (-> cs' count (= 1)) + (first cs') + (err! "Found more than one class" cs)))) + +;; TODO type these arguments; e.g. check that ?method||field, if present, is an unqualified symbol +(defns- analyze-seq|dot [env ::env, form _, [target-form _, ?method-or-field _ & ?args _] _] + {:pre [(prl! env form target-form ?method-or-field ?args)] + :post [(prl! %)]} + (let [target (analyze* #_?resolve-with-env env target-form) + method-or-field (if (symbol? ?method-or-field) ?method-or-field (first ?method-or-field)) + args-forms (if (symbol? ?method-or-field) ?args (rest ?method-or-field))] + (if (t/= (:type target) t/nil?) + (err! "Cannot use the dot operator on nil." {:form form}) + (let [;; `nilable?` because technically any non-primitive in Java is nilable and we can't + ;; necessarily rely on all e.g. "@nonNull" annotations + {:as ?target-static-class-map target-static-class :class target-static-class-nilable? :nilable?} + (-> target :type t/type>?class-value) + target-classes + (if ?target-static-class-map + (cond-> #{target-static-class} target-static-class-nilable? (conj nil)) + (-> target :type t/type>classes)) + target-class-nilable? (contains? target-classes nil) + target-class (classes>class target-classes)] + ;; TODO determine how to handle `target-class-nilable?`; for now we will just let it slip through + ;; to `NullPointerException` at runtime rather than create a potentially more helpful custom + ;; exception + (if-let [field (and (empty? args-forms) + (-> target-class class->fields|with-cache (c/get (name method-or-field))))] + (analyze-seq|dot|field-access env form target method-or-field field) + (analyze-seq|dot|method-call env form target target-class (boolean ?target-static-class-map) + method-or-field args-forms)))))) + +;; TODO move this +(defns truthy-expr? [{:as expr t [:type _]} _ > t/boolean?] + (ifs (or (t/= t t/nil?) + (t/= t t/false?)) false + (or (t/> t t/nil?) + (t/> t t/false?)) nil ; representing "unknown" + true)) + +(defns- analyze-seq|if + "If `*conditional-branch-pruning?*` is falsey, the dead branch's original form will be + retained, but it will not be type-analyzed." + [env ::env, form _, [pred-form _, true-form _, false-form _ :as body] _] + {:post [(prl! %)]} + (if (-> body count (not= 3)) + (err! "`if` accepts exactly 3 arguments: one predicate test and two branches; received" + {:body body}) + (let [pred-expr (analyze* env pred-form) + true-expr (delay (analyze* env true-form)) + false-expr (delay (analyze* env false-form)) + whole-expr + (delay + (uast/if-expr + {:env env + :form (list 'if (:form pred-expr) (:form @true-expr) (:form @false-expr)) + :pred-expr pred-expr + :true-expr @true-expr + :false-expr @false-expr + :type (apply t/or (->> [(:type @true-expr) (:type @false-expr)] + (remove nil?)))}))] + (case (truthy-expr? pred-expr) + true (do (log/ppr :warn "Predicate in `if` expression is always true" {:pred pred-form}) + (-> @true-expr + (assoc :env env) + (cond-> (not *conditional-branch-pruning?*) + (assoc :form (list 'if pred-form (:form @true-expr) false-form))))) + false (do (log/ppr :warn "Predicate in `if` expression is always false" {:pred pred-form}) + (-> @false-expr + (assoc :env env) + (cond-> (not *conditional-branch-pruning?*) + (assoc :form (list 'if pred-form true-form (:form @false-expr)))))) + nil @whole-expr)))) + +(defns- analyze-seq|quote [env ::env, form _, body _] + {:post [(prl! %)]} + (uast/quoted env form (tcore/most-primitive-class-of body))) + +(defns- analyze-seq|new [env ::env, form _ [c|form _ #_t/class? & args _ :as body] _] + {:pre [(prl! env form body)]} + (let [c|analyzed (analyze* env c|form)] + (if-not (and (-> c|analyzed :type t/value-type?) + (-> c|analyzed :type utr/value-type>value class?)) + (err! "Supplied non-class to `new` expression" {:x c|form}) + (let [c (-> c|analyzed :type utr/value-type>value) + args|analyzed (mapv #(analyze* env %) args)] + (uast/new-expr {:env env + :form (list* 'new c|form (map :form args|analyzed)) + :class c + :args args|analyzed + :type (t/isa? c)}))))) + +(defns- analyze-seq|throw [env ::env, form _ [arg _ :as body] _] + {:pre [(prl! env form body)]} + (if (-> body count (not= 1)) + (err! "Must supply exactly one input to `throw`; supplied" {:body body}) + (let [arg|analyzed (analyze* env arg)] + ;; TODO this is not quite true for CLJS but it's nice at least + (if-not (-> arg|analyzed :type (t/<= t/throwable?)) + (err! "`throw` requires a throwable; received" {:arg arg :type (:type arg|analyzed)}) + (uast/throw-expr {:env env + :form (list 'throw (:form arg|analyzed)) + :arg arg|analyzed + ;; `t/none?` because nothing is actually returned + :type t/none?}))))) + +(defns- analyze-seq* + "Analyze a seq after it has been macro-expanded. + The ->`form` is post- incremental macroexpansion." + [env ::env, [caller|form _ & body _ :as form] _] + (ifs (special-symbols caller|form) + (case caller|form + do (analyze-seq|do env form body) + let* (analyze-seq|let* env form body) + deftype* (TODO "deftype*") + fn* (TODO "fn*") + def (TODO "def") + . (analyze-seq|dot env form body) + if (analyze-seq|if env form body) + quote (analyze-seq|quote env form body) + new (analyze-seq|new env form body) + throw (analyze-seq|throw env form body)) + ;; TODO support recursion + (let [caller|expr (analyze* env caller|form) + caller|type (:type caller|expr) + args-ct (count body)] + (case (t/compare caller|type t/callable?) + (1 2) (err! "It is not known whether expression be called" {:expr caller|expr}) + 3 (err! "Expression cannot be called" {:expr caller|expr}) + (-1 0) (let [caller-kind + (ifs (t/<= caller|type t/keyword?) :keyword + (t/<= caller|type t/+map|built-in?) :map + (t/<= caller|type t/+vector|built-in?) :vector + (t/<= caller|type t/+set|built-in?) :set + (t/<= caller|type t/fnt?) :fnt + (t/<= caller|type t/fn?) :fn + ;; If it's callable but not fn, we might have missed something in + ;; this dispatch so for now we throw + (err! "Don't know how how to handle non-fn callable" + {:caller caller|expr})) + assert-valid-args-ct + (case caller-kind + (:keyword :map) + (when-not (or (= args-ct 1) (= args-ct 2)) + (err! (str "Keywords and `clojure.core` persistent maps must be " + "provided with exactly one or two args when calling " + "them") + {:args-ct args-ct :caller caller|expr})) + + (:vector :set) + (when-not (= args-ct 1) + (err! (str "`clojure.core` persistent vectors and `clojure.core` " + "persistent sets must be provided with exactly one arg " + "when calling them") + {:args-ct args-ct :caller caller|expr})) + + :fnt + (TODO "Don't know how to handle typed fns yet" {:caller caller|expr}) + ;; For non-typed fns, unknown; we will have to risk runtime exception + ;; because we can't necessarily rely on metadata to tell us the + ;; whole truth + :fn nil) + ;; TODO incrementally check by analyzing each arg in `reduce` and pruning + ;; branches of what the type could be, and throwing if it's found something + ;; that's an impossible combination + arg-exprs (->> body + (c/map+ #(analyze* env %)) + (reduce (fn [args arg|analyzed] + (conj args arg|analyzed)) + [])) + out-type + (case caller-kind + ;; We could do a little smarter analysis here but we'll keep it simple + ;; for now + (:keyword :map :vector :set :fn) t/any? + :fnt (TODO "Use `::t/type` metadata to make this decision"))] + (uast/call-expr + {:env env + :form form + :caller caller|expr + :args arg-exprs + :type out-type})))))) + +(defns- analyze-seq [env ::env, form _] + {:post [(prl! %)]} + (let [expanded-form (ufeval/macroexpand form)] + (if (ucomp/== form expanded-form) + (analyze-seq* env expanded-form) + (uast/macro-call {:env env :form form :expanded (analyze-seq* env expanded-form)})))) + +(defns- analyze-symbol [env ::env, form t/symbol?] + {:post [(prl! %)]} + (let [resolved (?resolve-with-env form env)] + (if-not resolved + (err! "Could not resolve symbol" {:sym form}) + (uast/symbol env form + (ifs (uast/node? resolved) + (:type resolved) + (or (t/literal? resolved) (t/class? resolved)) + (t/value resolved) + (var? resolved) + (or (-> resolved meta ::t/type) (t/value @resolved)) + (utpred/unbound? resolved) + ;; Because the var could be anything and cannot have metadata (type or otherwise) + t/any? + (TODO "Unsure of what to do in this case" (kw-map env form resolved))))))) + +(defns- analyze* [env ::env, form _] + (prl! env form) + (when (> (swap! *analyze-depth inc) 100) (throw (ex-info "Stack too deep" {:form form}))) + (ifs (symbol? form) + (analyze-symbol env form) + (t/literal? form) + (uast/literal env form (t/>type form)) + (or (vector? form) + (set? form)) + (analyze-non-map-seqable env form (empty form) (fn stop [& [a b :as args]] (prl! args) (err! "STOP"))) + (map? form) + (analyze-map env form) + (seq? form) + (analyze-seq env form) + (throw (ex-info "Unrecognized form" {:form form})))) + +(defns analyze + ([body _] (analyze {} body)) + ([env ::env, body _] + (reset! *analyze-depth 0) + (analyze* env body))) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 476eafcc..1a5374e7 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -100,7 +100,7 @@ fipp.ednize/IEdn (-edn [this] (list `do (into (array-map) this)))) -(defn do [m] (map->Do* m)) +(defn do [m] (map->Do m)) (defrecord MacroCall [env #_::env diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index d943c2a6..b76c2e5f 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -460,8 +460,8 @@ (defns fn-type? [x _ > c/boolean?] (instance? FnType x)) -(defns fn - [arg _ & args _] ; TODO fix — & args should have been sufficient but `defnt` has a bug that way +(defn fn + [arg & args ] ; TODO fix — & args should have been sufficient but `defnt` has a bug that way (FnType. (cons arg args)) #_[name- (s/nilable c/symbol?) lookup _ #_(t/map-of t/integer? diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc new file mode 100644 index 00000000..56e3fde4 --- /dev/null +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -0,0 +1,648 @@ +(ns quantum.untyped.core.type.defnt + (:require + [clojure.core :as core] + [clojure.string :as str] + ;; TODO excise this reference + [quantum.core.type.core :as tcore] + ;; TODO excise this reference + [quantum.core.type.defs :as tdef] + [quantum.untyped.core.analyze :as uana] + [quantum.untyped.core.analyze.ast :as uast] + [quantum.untyped.core.core + :refer [istr]] ; TODO use quantum.untyped.core.string/istr instead + [quantum.untyped.core.defnt + :refer [defns defns- fns]] + [quantum.untyped.core.collections :as c + :refer [>set >vec]] + [quantum.untyped.core.convert + :refer [>name >symbol]] + [quantum.untyped.core.data + :refer [kw-map]] + [quantum.untyped.core.data.array :as uarr] + [quantum.untyped.core.data.map :as umap] + [quantum.untyped.core.data.set :as uset] + [quantum.untyped.core.error :as err + :refer [TODO err!]] + [quantum.untyped.core.fn + :refer [aritoid fn-> with-do]] + [quantum.untyped.core.form :as uform + :refer [>form]] + [quantum.untyped.core.form.evaluate :as ufeval] + [quantum.untyped.core.form.generate :as ufgen] + [quantum.untyped.core.form.type-hint :as ufth] + [quantum.untyped.core.log :as ulog] + [quantum.untyped.core.logic :as ul + :refer [fn-or fn= ifs]] + [quantum.untyped.core.loops + :refer [reduce-2]] + [quantum.untyped.core.numeric.combinatorics :as ucombo] + [quantum.untyped.core.qualify + :refer [qualify]] + [quantum.untyped.core.reducers :as r + :refer [reducei educe]] + [quantum.untyped.core.spec :as s] + [quantum.untyped.core.specs :as uss] + [quantum.untyped.core.type :as t + :refer [?]] + [quantum.untyped.core.type.reifications :as utr] + [quantum.untyped.core.vars :as uvar + :refer [update-meta]]) + (:import + [quantum.core Numeric] + [quantum.core.data Array])) + +#?(:clj +(defns class>simplest-class + "This ensures that special overloads are not created for non-primitive subclasses + of java.lang.Object (e.g. String, etc.)." + [c (? t/class?) > (? t/class?)] + (if (t/primitive-class? c) + c + (or (tcore/boxed->unboxed c) java.lang.Object)))) + +#?(:clj +(defns class>most-primitive-class [c (? t/class?), nilable? t/boolean? > (? t/class?)] + (if nilable? c (or (tcore/boxed->unboxed c) c)))) + +#?(:clj +(defns type>most-primitive-classes [t t/type? > (s/set-of (? t/class?))] + (let [cs (t/type>classes t) nilable? (contains? cs nil)] + (->> cs + (c/map+ #(class>most-primitive-class % nilable?)) + (r/join #{}))))) + +#?(:clj +(defns type>most-primitive-class [t t/type? > (? t/class?)] + (let [cs (type>most-primitive-classes t)] + (if (-> cs count (not= 1)) + (err! "Not exactly 1 class found" (kw-map t cs)) + (first cs))))) + +#?(:clj +(defns out-type>class [t t/type? > (? t/class?)] + (let [cs (t/type>classes t) cs' (disj cs nil)] + (if (-> cs' count (not= 1)) + ;; NOTE: we don't need to vary the output class if there are multiple output possibilities + ;; or just nil + java.lang.Object + (-> (class>most-primitive-class (first cs') (contains? cs nil)) + class>simplest-class))))) + +; ----- TYPED PART ----- ; + +(defonce *fn->type (atom {})) + +(defonce defnt-cache (atom {})) ; TODO For now — but maybe lock-free concurrent hash map to come + +(defonce *interfaces (atom {})) + +;; ===== (DE)FNT ===== ;; + +;; Internal specs + +(s/def ::expanded-overload|arg-classes (s/vec-of t/class?)) +(s/def ::expanded-overload|arg-types (s/seq-of t/type?)) + +;; This is the overload after the input specs are split by their respective `t/or` constituents, +;; and after primitivization, but before readiness for incorporation into a `reify`. +;; One of these corresponds to one reify overload. +(s/def ::expanded-overload + (s/kv {:arg-classes ::expanded-overload|arg-classes + :arg-types ::expanded-overload|arg-types + :arglist-code|fn|hinted t/any? + :arglist-code|reify|unhinted t/any? + :body-form t/any? + :out-class (? t/class?) + :out-type t/type? + :positional-args-ct t/nneg-int? + ;; When present, varargs are considered to be of class Object + :variadic? t/boolean?})) + +(s/def ::reify|overload + (s/keys :req-un [:quantum.core.specs/interface + :reify|overload/out-class + :reify/method-sym + :reify/arglist-code + :reify|overload/body-form])) + +(s/def ::reify + (s/kv {:form t/any? + :name simple-symbol? + :non-primitivized-overload ::reify|overload + :overloads (s/vec-of ::reify|overload)})) + +(s/def ::lang #{:clj :cljs}) + +(s/def ::input-types-decl + (s/kv {:form t/any? + :name simple-symbol? + :arg-type|split (s/vec-of t/type?)})) + +(s/def ::direct-dispatch-data + (s/kv {:i-arg->input-types-decl (s/vec-of ::input-types-decl) + :reify-seq (s/vec-of ::reify)})) + +(s/def ::i-overload->direct-dispatch-data (s/vec-of ::direct-dispatch-data)) + +(s/def ::direct-dispatch + (s/kv {:form t/any? + :i-overload->direct-dispatch-data ::i-overload->direct-dispatch-data})) + +(s/def ::expanded-overload-group|arg-types|form (s/vec-of t/any?)) + +(s/def ::expanded-overload-group + (s/kv {:arg-types|form ::expanded-overload-group|arg-types|form + :non-primitivized ::expanded-overload + :primitivized (s/nilable (s/seq-of ::expanded-overload))})) + +(s/def ::expanded-overload-groups|arg-types|split (s/vec-of (s/vec-of t/type?))) +(s/def ::expanded-overload-groups|pre-type|form t/any?) +(s/def ::expanded-overload-groups|post-type|form t/any?) + +(s/def ::expanded-overload-groups + (s/kv {:arg-types|pre-split|form ::expanded-overload-group|arg-types|form + :pre-type|form ::expanded-overload-groups|pre-type|form + :post-type|form ::expanded-overload-groups|post-type|form + :arg-types|split ::expanded-overload-groups|arg-types|split + :arg-types|recombined (s/vec-of (s/vec-of t/type?)) + :expanded-overload-group-seq (s/seq-of ::expanded-overload-group)})) + +#_(:clj +(defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] + (cond (not= k :spec) java.lang.Object; default class + (symbol? spec) (pred->class lang spec)))) + +;; TODO optimize such that `post-type|form` doesn't create a new type-validator wholesale every +;; time the function gets run; e.g. extern it +(defn >with-post-type|form [body post-type|form] `(t/validate ~body ~post-type|form)) + +#?(:clj +(uvar/def sort-guide "for use in arity sorting, in increasing conceptual (and bit) size" + {Object 0 + tdef/boolean 1 + tdef/byte 2 + tdef/short 3 + tdef/char 4 + tdef/int 5 + tdef/long 6 + tdef/float 7 + tdef/double 8})) + +#?(:clj +(defns arg-types>arg-classes-seq|primitivized + "'primitivized' meaning given an arglist whose types are `[t/any?]` this will output: + [[java.lang.Object] + [boolean] + [byte] + [short] + [char] + [int] + [long] + [float] + [double]] + which includes all primitive subclasses of the type." + [arg-types (s/seq-of t/type?) > (s/seq-of ::expanded-overload|arg-classes)] + (->> arg-types + (c/lmap (fn [t #_t/type?] + (if (-> t meta :ref?) + (-> t t/type>classes (disj nil) seq) + (let [cs (type>most-primitive-classes t) + base-classes + (cond-> (>set cs) + (contains? cs nil) (-> (disj nil) (conj java.lang.Object)))] + (->> cs + (c/map+ tcore/class>prim-subclasses) + (educe (aritoid nil identity uset/union) base-classes) + ;; for purposes of cleanliness and reproducibility in tests + (sort-by sort-guide)))))) + (apply ucombo/cartesian-product) + (c/lmap >vec)))) + +;; TODO spec args +#?(:clj +(defns- >expanded-overload + "Is given `arg-classes` and `arg-types`. In order to determine the out-type, performs an analysis + using (in part) these pieces of data, but does not use the possibly-updated `arg-types` as + computed in the analysis. As a result, does not yet support type inference." + [{:keys [arg-bindings _, arg-classes ::expanded-overload|arg-classes + post-type|form _ + arg-types ::expanded-overload|arg-types, body-codelist|pre-analyze _, lang ::lang + varargs _, varargs-binding _]} _ + > ::expanded-overload] + (let [env (->> (zipmap arg-bindings arg-types) + (c/map' (fn [[arg-binding arg-type]] + [arg-binding (uast/unbound nil arg-binding arg-type)]))) + analyzed (uana/analyze env (ufgen/?wrap-do body-codelist|pre-analyze)) + arg-classes|simplest (->> arg-classes (c/map class>simplest-class)) + hint-arg|fn (fn [i arg-binding] + (ufth/with-type-hint arg-binding + (ufth/>fn-arglist-tag + (c/get arg-classes|simplest i) + lang + (c/count arg-bindings) + varargs))) + ;; TODO this becomes an issue when `post-type|form` references local bindings + post-type (eval post-type|form) + post-type|runtime? (-> post-type meta :runtime?) + out-type (if post-type + (if post-type|runtime? + (case (t/compare post-type (:type analyzed)) + -1 post-type + 1 (:type analyzed) + 0 post-type + (2 3) (err! "Body and output type comparison not handled" + {:body analyzed :output-type post-type})) + (if (t/<= (:type analyzed) post-type) + (:type analyzed) + (err! "Body does not match output type" + {:body analyzed :output-type post-type}))) + (:type analyzed)) + body-form + (-> (:form analyzed) + (cond-> post-type|runtime? (>with-post-type|form post-type|form)) + (ufth/cast-bindings|code + (->> (c/zipmap-into (umap/om) arg-bindings arg-classes) + (c/remove-vals' (fn-or nil? (fn= java.lang.Object) t/primitive-class?)))))] + {:arg-classes arg-classes|simplest + :arg-types arg-types + :arglist-code|fn|hinted (cond-> (->> arg-bindings (c/map-indexed hint-arg|fn)) + varargs-binding (conj '& varargs-binding)) ; TODO use `` + :arglist-code|reify|unhinted (cond-> arg-bindings varargs-binding (conj varargs-binding)) + :body-form body-form + :positional-args-ct (count arg-bindings) + :out-type out-type + :out-class (out-type>class out-type) + :variadic? (boolean varargs)}))) + +(defns >expanded-overload-group + [{:as in :keys [arg-types ::expanded-overload-group|arg-types|form]} _ + > ::expanded-overload-group] + (let [arg-types|form (mapv >form arg-types) + ;; `non-primitivized` is first because of class sorting + [non-primitivized & primitivized :as overloads] + (->> arg-types + arg-types>arg-classes-seq|primitivized + (mapv (fn [arg-classes #_::expanded-overload|arg-classes] + (let [arg-types|satisfying-primitivization + (c/mergev-with + (fn [_ s #_t/type? c #_t/class?] + (cond-> s (t/primitive-class? c) (t/and c))) + arg-types arg-classes)] + (>expanded-overload + (assoc in :arg-classes arg-classes + :arg-types arg-types|satisfying-primitivization))))))] + (kw-map arg-types|form non-primitivized primitivized))) + +;; TODO spec +#?(:clj ; really, reserve for metalanguage +(defns fnt|overload-data>expanded-overload-groups + "Given an `fnt` overload, computes a seq of 'expanded-overload groups'. Each expanded-overload + group is the foundation for one `reify`. + + Rather than rigging together something in which either: + 1) the Clojure compiler will try to cross its fingers and evaluate code meant to be evaluated in + ClojureScript + 2) we use a CLJS-in-CLJS compiler and alienate the mainstream CLJS-in-CLJ (cljsbuild) workflow, + which includes our own workflow + 3) we wait for CLJS-in-CLJS to become mainstream, which could take years if it really ever + happens + + we decide instead to evaluate types in languages in which the metalanguage (compiler language) + is the same as the object language (e.g. Clojure), and symbolically analyze types in the rest + (e.g. vanilla ClojureScript), deferring code analyzed as functions to be enforced at runtime." + [{:as in {:keys [args _, varargs _] + pre-type|form [:pre _] + [_ _, post-type|form _] [:post _]} [:arglist _] + body-codelist|pre-analyze [:body _]} _ + {:as opts :keys [::lang ::lang, symbolic-analysis? t/boolean?]} _ + > ::expanded-overload-groups] + (if symbolic-analysis? + (err! "Symbolic analysis not supported yet") + (let [_ (when pre-type|form (TODO "Need to handle pre")) + _ (when varargs (TODO "Need to handle varargs")) + post-type|form (if (= post-type|form '_) `t/any? post-type|form) + varargs-binding (when varargs + ;; TODO this assertion is purely temporary until destructuring is + ;; supported + (assert (-> varargs :binding-form first (= :sym)))) + arg-bindings + (->> args + (mapv (fn [{[kind binding-] :binding-form}] + ;; TODO this assertion is purely temporary until destructuring is + ;; supported + (assert kind :sym) + binding-))) + arg-types|pre-split|form + (->> args + (mapv (fn [{[kind #_#{:any :spec}, t #_t/form?] :spec}] + (case kind :any `t/any? :spec t)))) + arg-types|pre-split (->> arg-types|pre-split|form (mapv (fn-> eval t/>type))) + arg-types|split + ;; NOTE Only `t/or`s are splittable for now + (->> arg-types|pre-split + (c/map (fn [t] (if (utr/or-type? t) (utr/or-type>args t) [t])))) + arg-types|recombined (->> arg-types|split + (apply ucombo/cartesian-product) + (c/map vec)) + expanded-overload-group-seq + (->> arg-types|recombined + (mapv (fn [arg-types] + (>expanded-overload-group + (kw-map arg-bindings arg-types body-codelist|pre-analyze lang + arg-types|pre-split|form pre-type|form post-type|form + varargs varargs-binding)))))] + (kw-map arg-types|pre-split|form pre-type|form post-type|form + arg-types|split arg-types|recombined + expanded-overload-group-seq))))) + +(def fnt-method-sym 'invoke) + +(defns- class>interface-part-name [c t/class? > t/string?] + (if (= c java.lang.Object) + "Object" + (let [illegal-pattern #"\|\+"] + (if (->> c >name (re-find illegal-pattern)) + (err! "Class cannot contain pattern" {:class c :pattern illegal-pattern}) + (-> c >name (str/replace "." "|")))))) + +(defns fnt-overload>interface-sym [args-classes (s/seq-of t/class?), out-class t/class? > t/symbol?] + (>symbol (str (->> args-classes (c/lmap class>interface-part-name) (str/join "+")) + ">" (class>interface-part-name out-class)))) + +;; TODO finish specing args +(defns fnt-overload>interface [args-classes _, out-class t/class?, gen-gensym fn?] + (let [interface-sym (fnt-overload>interface-sym args-classes out-class) + hinted-method-sym (ufth/with-type-hint fnt-method-sym + (ufth/>interface-method-tag out-class)) + hinted-args (ufth/hint-arglist-with + (ufgen/gen-args 0 (count args-classes) "xint" gen-gensym) + (map ufth/>interface-method-tag args-classes))] + `(~'definterface ~interface-sym (~hinted-method-sym ~hinted-args)))) + +;; TODO spec args +#?(:clj +(defns expanded-overload>reify-overload + [{:as overload + :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, out-class t/class?]} + ::expanded-overload + gen-gensym fn? + > (s/seq-of ::reify|overload)] + (let [interface-k {:out out-class :in arg-classes} + interface + (-> *interfaces + (swap! update interface-k + #(or % (eval (fnt-overload>interface arg-classes out-class gen-gensym)))) + (c/get interface-k)) + arglist-code + (>vec (concat [(gen-gensym '_)] + (->> arglist-code|reify|unhinted + (map-indexed + (fn [i arg] + (ufth/with-type-hint arg + (-> arg-classes (c/get i) ufth/>arglist-embeddable-tag)))))))] + {:arglist-code arglist-code + :body-form body-form + :interface interface + :method-sym fnt-method-sym + :out-class out-class}))) + +(defns >reify|name + [{:keys [::uss/fn|name ::uss/fn|name, i|fnt-overload t/index? + i|expanded-overload-group t/index?]} _ > simple-symbol?] + (>symbol (str fn|name "|__" i|fnt-overload "|" i|expanded-overload-group))) + +#?(:clj +(defns expanded-overload-group>reify + [{:as in + :keys [::uss/fn|name ::uss/fn|name, i|fnt-overload t/index?, i|expanded-overload-group t/index? + expanded-overload-group ::expanded-overload-group]} _ + gen-gensym fn? > ::reify] + (let [reify-overloads (->> (concat [(:non-primitivized expanded-overload-group)] + (:primitivized expanded-overload-group)) + (c/map #(expanded-overload>reify-overload % gen-gensym))) + reify-name (>reify|name in) + form `(~'def ~reify-name + ~(list* `reify* + (->> reify-overloads (mapv #(-> % :interface >name >symbol))) + (->> reify-overloads + (c/lmap (fn [{:keys [out-class method-sym arglist-code + body-form]} #_::reify|overload] + `(~(ufth/with-type-hint method-sym + (ufth/>arglist-embeddable-tag out-class)) + ~arglist-code ~body-form))))))] + {:form form + :name reify-name + :non-primitivized-overload (first reify-overloads) + :overloads reify-overloads}))) + +(defns >input-type-decl|name + [fn|name ::uss/fn|name, i|fnt-overload t/index?, i|arg t/index? > simple-symbol?] + (>symbol (str fn|name "|__" i|fnt-overload "|input" i|arg "|types"))) + +(defns >i-arg->input-types-decl + "The evaluated `form` of each input-types-decl is an array of non-primitivized types that the + dynamic dispatch uses to dispatch off input types." + [{:as in + :keys [arg-types|split ::expanded-overload-groups|arg-types|split + fn|name ::uss/fn|name + i|fnt-overload t/index?]} _ + > (s/vec-of ::input-types-decl)] + (->> arg-types|split + (c/map-indexed + (fn [i|arg arg-type|split] + (let [decl-name (>input-type-decl|name fn|name i|fnt-overload i|arg) + form (list 'def (ufth/with-type-hint decl-name "[Ljava.lang.Object;") + (list* `uarr/*<> (map >form arg-type|split)))] + (assoc (kw-map form arg-type|split) :name decl-name)))))) + +(def allowed-shorthand-tag-chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") +(def min-shorthand-tag-length 1) +(def max-shorthand-tag-length 64) ; for now + +(defn >all-shorthand-tags [] + (->> (range min-shorthand-tag-length (inc max-shorthand-tag-length)) + c/unchunk + (c/lmap (fn [n] (apply ucombo/cartesian-product (repeat n allowed-shorthand-tag-chars)))) + c/lcat + (c/lmap #(apply str %)) + c/unchunk)) + +(defonce *class>shorthand-tag|cache + (atom {:remaining (>all-shorthand-tags)})) + +;; dynamic for testing purposes +(def ^:dynamic **class>shorthand-tag|cache* *class>shorthand-tag|cache) + +(defns class>shorthand-tag [c t/class?] + (or (c/get @**class>shorthand-tag|cache* c) + (-> (swap! **class>shorthand-tag|cache* + (fn [{:as m :keys [remaining]}] + (assoc m c (first remaining) + :remaining (next remaining)))) + (get c)))) + +;; TODO spec +(defn assert-monotonically-increasing-types! + "Asserts that each type in an overload of the same arity and arg-position + are in monotonically increasing order in terms of `t/compare`." + [overloads|grouped-by-arity] + (doseq [[arity-ct overloads] overloads|grouped-by-arity] + (educe + (fn [prev-overload [i|overload overload]] + (when prev-overload + (reduce-2 + (fn [_ arg|type|prev [i|arg arg|type]] + (when (= (t/compare arg|type arg|type|prev) -1) + ;; TODO provide code context, line number, etc. + (err! (istr "At overload ~{i|overload}, arg ~{i|arg}: type is not in monotonically increasing order in terms of `t/compare`") + {:overload overload + :prev-overload prev-overload + :prev-type arg|type|prev + :type arg|type}))) + (:arg-types prev-overload) + (c/lindexed (:arg-types overload)))) + overload) + nil + overloads))) + +;; TODO spec +(defns unsupported! [name- _ #_t/qualified-symbol?, args t/indexed?, i t/index?] + (TODO)) + +(defns >direct-dispatch + [{:keys [::uss/fn|name ::uss/fn|name + expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups) + gen-gensym fn? + lang ::lang]} _ + > ::direct-dispatch] + (case lang + :clj + (let [i-overload->direct-dispatch-data + (->> expanded-overload-groups-by-fnt-overload + (c/map-indexed + (fn [i|fnt-overload {:keys [arg-types|split expanded-overload-group-seq]}] + {:i-arg->input-types-decl + (>i-arg->input-types-decl (kw-map arg-types|split fn|name i|fnt-overload)) + :reify-seq + (->> expanded-overload-group-seq + (c/map-indexed + (fn [i|expanded-overload-group + {:as expanded-overload-group :keys [arg-types|form]}] + (let [in (assoc (kw-map i|fnt-overload + i|expanded-overload-group + expanded-overload-group) + ::uss/fn|name fn|name)] + (expanded-overload-group>reify in gen-gensym)))))}))) + form (->> i-overload->direct-dispatch-data + (c/map (fn [{:keys [i-arg->input-types-decl reify-seq]}] + (concat (c/lmap :form i-arg->input-types-decl) + (c/lmap :form reify-seq)))) + c/lcat)] + (kw-map form i-overload->direct-dispatch-data)) + :cljs (TODO))) + +(defns >dynamic-dispatch-fn|type-decl + [expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups)] + (list* `t/fn (->> expanded-overload-groups-by-fnt-overload + (map (fn [{:keys [arg-types|pre-split|form + pre-type|form post-type|form]}] + (cond-> (or arg-types|pre-split|form []) + pre-type|form (conj :| pre-type|form) + post-type|form (conj :> post-type|form))))))) + +(defns >dynamic-dispatch|reify-call [reify- ::reify, arglist (s/vec-of simple-symbol?)] + (let [dotted-reify-method-sym + (symbol (str "." (-> reify- :non-primitivized-overload :method-sym))) + hinted-reify-sym + (ufth/with-type-hint (:name reify-) + (-> reify- :non-primitivized-overload :interface >name))] + `(~dotted-reify-method-sym ~hinted-reify-sym ~@arglist))) + +(defns >dynamic-dispatch|conditional + [fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?), i|arg t/index?, body _] + (if (-> body count (= 1)) + (first body) + `(ifs ~@body (unsupported! (quote ~(qualify fn|name)) [~@arglist] ~i|arg)))) + +(defns >dynamic-dispatch|body-for-arity + ([fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?) + direct-dispatch-data-for-arity (s/seq-of ::direct-dispatch-data)] + (if (empty? arglist) + (>dynamic-dispatch|reify-call + (-> direct-dispatch-data-for-arity first :reify-seq first) arglist) + (let [i|arg 0 + branches (->> direct-dispatch-data-for-arity + (c/lmap + (fn [{:keys [reify-seq i-arg->input-types-decl]}] + (>dynamic-dispatch|body-for-arity fn|name arglist reify-seq + i-arg->input-types-decl (atom 0) i|arg))) + c/lcat)] + (>dynamic-dispatch|conditional fn|name arglist i|arg branches)))) + ([fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?), reify-seq (s/vec-of ::reify) + input-types-decl-group' (s/seq-of ::input-types-decl), *i|reify _, i|arg t/index?] + (let [{:as input-types-decl :keys [arg-type|split]} (first input-types-decl-group') + input-types-decl-group'' (rest input-types-decl-group')] + (->> arg-type|split + (c/lmap-indexed + (fn [i|arg-type' _] + [`((Array/get ~(:name input-types-decl) ~i|arg-type') ~(get arglist i|arg)) + (if (empty? input-types-decl-group'') + (with-do (>dynamic-dispatch|reify-call (get reify-seq @*i|reify) arglist) + ;; TODO take out this ugly bit + (swap! *i|reify inc)) + (let [i|arg' (inc i|arg) + next-branch (>dynamic-dispatch|body-for-arity fn|name arglist reify-seq + input-types-decl-group'' *i|reify i|arg')] + (>dynamic-dispatch|conditional fn|name arglist i|arg' next-branch)))])) + c/lcat)))) + +(defns >dynamic-dispatch-fn|form + [{:keys [::uss/fn|name ::uss/fn|name + expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups) + gen-gensym fn? + lang ::lang + i-overload->direct-dispatch-data ::i-overload->direct-dispatch-data]} _] + `(defn ~fn|name + {::t/type ~(>dynamic-dispatch-fn|type-decl expanded-overload-groups-by-fnt-overload)} + ~@(->> i-overload->direct-dispatch-data + (group-by (fn-> :i-arg->input-types-decl count)) + (map (fn [[arg-ct direct-dispatch-data-for-arity]] + (let [arglist (ufgen/gen-args 0 arg-ct "x" gen-gensym) + body (>dynamic-dispatch|body-for-arity + fn|name arglist direct-dispatch-data-for-arity)] + (list arglist body))))))) + +(defns fnt|code [kind #{:fn :defn}, lang ::lang, args _] + (let [{:keys [:quantum.core.specs/fn|name + :quantum.core.defnt/overloads + :quantum.core.specs/meta] :as args'} + (s/validate args (case kind :defn :quantum.core.defnt/defnt + :fn :quantum.core.defnt/fnt)) + symbolic-analysis? false ; TODO parameterize this + gen-gensym-base (ufgen/>reproducible-gensym|generator) + gen-gensym (fn [x] (symbol (str (gen-gensym-base x) "__"))) + inline? (s/validate (-> fn|name core/meta :inline) (t/? t/boolean?)) + fn|name (if inline? + (do (ulog/pr :warn "requested `:inline`; ignoring until feature is implemented") + (update-meta fn|name dissoc :inline)) + fn|name) + expanded-overload-groups-by-fnt-overload + (->> overloads (mapv #(fnt|overload-data>expanded-overload-groups % + {::lang lang :symbolic-analysis? symbolic-analysis?}))) + args (assoc (kw-map expanded-overload-groups-by-fnt-overload gen-gensym lang) + ::uss/fn|name fn|name) + {:as direct-dispatch :keys [i-overload->direct-dispatch-data]} (>direct-dispatch args) + fn-codelist + (case lang + :clj (->> `[~@(:form direct-dispatch) + ~(>dynamic-dispatch-fn|form + (merge args (kw-map i-overload->direct-dispatch-data)))] + (remove nil?)) + :cljs (TODO)) + code (case kind + :fn (TODO) + :defn `(~'do ~@fn-codelist))] + code)) + +#?(:clj (defmacro fnt [& args] (fnt|code :fn (ufeval/env-lang) args))) +#?(:clj (defmacro defnt [& args] (fnt|code :defn (ufeval/env-lang) args))) From 06f5508545a3c7995491ec6559d69fc4b7a1a93e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 25 Jul 2018 15:36:53 -0600 Subject: [PATCH 163/810] Clean up arities --- src-dev/quantum/core/defnt_equivalences.cljc | 8 +-- src-untyped/quantum/untyped/core/analyze.cljc | 71 ++++++++++--------- .../quantum/untyped/core/analyze/ast.cljc | 2 +- 3 files changed, 41 insertions(+), 40 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 3fabf20f..6061bf3f 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -5,7 +5,7 @@ (:require [quantum.untyped.core.type.defnt :refer [defnt fnt unsupported!]] - [quantum.untyped.core.core :as ucore + [quantum.untyped.core.core :as ucore :refer [code=]] [quantum.untyped.core.data.array :refer [*<>]] @@ -17,10 +17,10 @@ :refer [tag]] [quantum.untyped.core.logic :refer [ifs]] - [quantum.untyped.core.spec :as s] - [quantum.untyped.core.test :as test + [quantum.untyped.core.spec :as s] + [quantum.untyped.core.test :as test :refer [deftest is is= is-code= testing throws]] - [quantum.untyped.core.type :as t + [quantum.untyped.core.type :as t :refer [? *]] [quantum.untyped.core.type.reifications :as utr]) (:import diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 6d7f3e0d..94cc561d 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -150,27 +150,28 @@ (->expr-info {:env env :form (transient {})})) (persistent!-and-add-file-context form))) -(defns- analyze-seq|do [env ::env, form _, body _] - (if (empty? body) - (uast/do {:env env - :unexpanded-form form - :form form - :body (>vec body) - :type t/nil?}) - (let [expr (analyze-non-map-seqable env body [] - (fn [accum expr _] - (assoc expr ;; The env should be the same as whatever it was originally - ;; because no new scopes are created - :env (:env accum) - :form (conj! (:form accum) (:form expr)) - :body (conj! (:body accum) expr))))] - (uast/do {:env env - :unexpanded-form form - :form (list* 'do (:form expr)) - :body (:body expr) +(defns- analyze-seq|do [env ::env, [_ _ & body|form _ :as form] _] + (if (empty? body|form) + (uast/do {:env env + :form form + :expanded-form form + :body [] + :type t/nil?}) + (let [{expanded-form :form body :body} + (analyze-non-map-seqable env body|form [] + (fn [accum expr _] + (assoc expr ;; The env should be the same as whatever it was originally + ;; because no new scopes are created + :env (:env accum) + :form (conj! (:form accum) (:form expr)) + :body (conj! (:body accum) expr))))] + (uast/do {:env env + :form form + :expanded-form (with-meta (list* 'do expanded-form) (meta expanded-form)) + :body body ;; To types, only the last subexpression ever matters, as each is independent ;; from the others - :type (-> expr :body c/last :type)})))) + :type (-> body c/last :type)})))) (defns analyze-seq|let*|bindings [env ::env, bindings _] (TODO "`let*|bindings` analysis") @@ -186,10 +187,10 @@ (->expr-info {:env env :form (transient [])})) (persistent!-and-add-file-context bindings))) -(defns analyze-seq|let* [env ::env, form _, [bindings _ & body _] _] - {:pre [(prl! env bindings body)]} - (let [env' (analyze-seq|let*|bindings env ) - expr (analyze-seq|do env' (list* 'do form) body)] +(defns analyze-seq|let* [env ::env, [_ _, bindings|form _ & body|form _ :as form] _] + {:pre [(prl! env form)]} + (let [env' (analyze-seq|let*|bindings env bindings|form) + expr (analyze-seq|do env' (list* 'do body|form))] (prl! expr) (TODO "`let*` analysis") #_(uast/let* {:env env @@ -339,7 +340,7 @@ (err! "Found more than one class" cs)))) ;; TODO type these arguments; e.g. check that ?method||field, if present, is an unqualified symbol -(defns- analyze-seq|dot [env ::env, form _, [target-form _, ?method-or-field _ & ?args _] _] +(defns- analyze-seq|dot [env ::env, [_ _, target-form _, ?method-or-field _ & ?args _ :as form] _] {:pre [(prl! env form target-form ?method-or-field ?args)] :post [(prl! %)]} (let [target (analyze* #_?resolve-with-env env target-form) @@ -377,7 +378,7 @@ (defns- analyze-seq|if "If `*conditional-branch-pruning?*` is falsey, the dead branch's original form will be retained, but it will not be type-analyzed." - [env ::env, form _, [pred-form _, true-form _, false-form _ :as body] _] + [env ::env, [_ _ & [pred-form _, true-form _, false-form _ :as body] _ :as form] _] {:post [(prl! %)]} (if (-> body count (not= 3)) (err! "`if` accepts exactly 3 arguments: one predicate test and two branches; received" @@ -408,12 +409,12 @@ (assoc :form (list 'if pred-form true-form (:form @false-expr)))))) nil @whole-expr)))) -(defns- analyze-seq|quote [env ::env, form _, body _] +(defns- analyze-seq|quote [env ::env, [_ _ & body _ :as form] _] {:post [(prl! %)]} (uast/quoted env form (tcore/most-primitive-class-of body))) -(defns- analyze-seq|new [env ::env, form _ [c|form _ #_t/class? & args _ :as body] _] - {:pre [(prl! env form body)]} +(defns- analyze-seq|new [env ::env, [_ _ & [c|form _ #_t/class? & args _ :as body] _ :as form] _] + {:pre [(prl! env form)]} (let [c|analyzed (analyze* env c|form)] (if-not (and (-> c|analyzed :type t/value-type?) (-> c|analyzed :type utr/value-type>value class?)) @@ -446,16 +447,16 @@ [env ::env, [caller|form _ & body _ :as form] _] (ifs (special-symbols caller|form) (case caller|form - do (analyze-seq|do env form body) - let* (analyze-seq|let* env form body) + do (analyze-seq|do env form) + let* (analyze-seq|let* env form) deftype* (TODO "deftype*") fn* (TODO "fn*") def (TODO "def") - . (analyze-seq|dot env form body) - if (analyze-seq|if env form body) - quote (analyze-seq|quote env form body) - new (analyze-seq|new env form body) - throw (analyze-seq|throw env form body)) + . (analyze-seq|dot env form) + if (analyze-seq|if env form) + quote (analyze-seq|quote env form) + new (analyze-seq|new env form) + throw (analyze-seq|throw env form)) ;; TODO support recursion (let [caller|expr (analyze* env caller|form) caller|type (:type caller|expr) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 1a5374e7..cea2b1a2 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -92,7 +92,7 @@ (defrecord Do [env #_::env form #_::t/form - unexpanded-form #_::t/form + expanded-form #_::t/form body #_(t/and t/sequential? t/indexed? (t/every? ::node)) type #_t/type?] INode From b15718eccebf7b0311c260fed40111268718278e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 25 Jul 2018 17:09:56 -0600 Subject: [PATCH 164/810] Fix some let* analysis --- src-untyped/quantum/untyped/core/analyze.cljc | 79 ++++++++++--------- .../quantum/untyped/core/analyze/ast.cljc | 20 ++--- 2 files changed, 51 insertions(+), 48 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 94cc561d..4ff52a5e 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -22,6 +22,8 @@ :refer [prl!]] [quantum.untyped.core.logic :refer [if-not-let ifs]] + [quantum.untyped.core.print + :refer [ppr]] [quantum.untyped.core.reducers :as r :refer [educe reducei]] [quantum.untyped.core.spec :as s] @@ -173,28 +175,25 @@ ;; from the others :type (-> body c/last :type)})))) -(defns analyze-seq|let*|bindings [env ::env, bindings _] - (TODO "`let*|bindings` analysis") - #_(->> bindings - (partition-all+ 2) - (reduce (fn [{env' :env forms :form} [sym form]] - (let [expr-ret (analyze* env' form)] - (->expr-info - {:env (assoc env' sym (->type-info {:reifieds (:reifieds expr-ret) ; TODO should use type info or exprinfo? - :abstracts (:abstracts expr-ret) - :fn-types (:fn-types expr-ret)})) - :form (conj! (conj! forms sym) (:form expr-ret))}))) - (->expr-info {:env env :form (transient [])})) - (persistent!-and-add-file-context bindings))) +(defns analyze-seq|let*|bindings [env ::env, bindings|form _] + (->> bindings|form + (c/partition-all+ 2) + (reduce (fn [{env' :env !bindings :form} [sym form :as binding|form]] + (let [expr (analyze* env' form)] ; environment is additive with each binding + {:env (assoc env' sym expr) + :form (conj! (conj! !bindings sym) (:form expr))})) + {:env env :form (transient [])}) + (persistent!-and-add-file-context bindings|form))) (defns analyze-seq|let* [env ::env, [_ _, bindings|form _ & body|form _ :as form] _] {:pre [(prl! env form)]} - (let [env' (analyze-seq|let*|bindings env bindings|form) - expr (analyze-seq|do env' (list* 'do body|form))] - (prl! expr) + (let [{env' :env bindings|form' :form} (analyze-seq|let*|bindings env bindings|form) + {body|form :form :as expr} (analyze-seq|do env' (list* 'do body|form))] + (prl! env' expr) (TODO "`let*` analysis") #_(uast/let* {:env env :form form + :expanded-form (list* 'let* bindings|form' body|form') :bindings (bindings>env bindings) :body (>vec body) :type (:type expr)})) @@ -208,14 +207,12 @@ :type-info type-info'}))) (defns ?resolve-with-env [sym t/symbol?, env ::env] - (let [local (c/get env sym)] - (if (some? local) - (if (uast/unbound? local) - local - (TODO "Need to figure out what to do when resolving local vars")) - (let [resolved (ns-resolve *ns* sym)] - (log/ppr :warn "Not sure how to handle non-local symbol; resolved it for now" (kw-map sym resolved)) - resolved)))) + (if-let [[_ local] (find env sym)] + {:value local} + (let [resolved (ns-resolve *ns* sym)] + (log/ppr :warn "Not sure how to handle non-local symbol; resolved it for now" + (kw-map sym resolved)) + (when resolved {:value resolved})))) (defns methods->type "Creates a type given ->`methods`." @@ -523,24 +520,28 @@ (let [expanded-form (ufeval/macroexpand form)] (if (ucomp/== form expanded-form) (analyze-seq* env expanded-form) - (uast/macro-call {:env env :form form :expanded (analyze-seq* env expanded-form)})))) + (let [expanded (analyze-seq* env expanded-form)] + (uast/macro-call + {:env env + :form form + :expanded-form (:form expanded) + :expanded expanded}))))) (defns- analyze-symbol [env ::env, form t/symbol?] {:post [(prl! %)]} - (let [resolved (?resolve-with-env form env)] - (if-not resolved - (err! "Could not resolve symbol" {:sym form}) - (uast/symbol env form - (ifs (uast/node? resolved) - (:type resolved) - (or (t/literal? resolved) (t/class? resolved)) - (t/value resolved) - (var? resolved) - (or (-> resolved meta ::t/type) (t/value @resolved)) - (utpred/unbound? resolved) - ;; Because the var could be anything and cannot have metadata (type or otherwise) - t/any? - (TODO "Unsure of what to do in this case" (kw-map env form resolved))))))) + (if-not-let [{resolved :value} (?resolve-with-env form env)] + (err! "Could not resolve symbol" {:sym form}) + (uast/symbol env form resolved + (ifs (uast/node? resolved) + (:type resolved) + (or (t/literal? resolved) (t/class? resolved)) + (t/value resolved) + (var? resolved) + (or (-> resolved meta ::t/type) (t/value @resolved)) + (utpred/unbound? resolved) + ;; Because the var could be anything and cannot have metadata (type or otherwise) + t/any? + (TODO "Unsure of what to do in this case" (kw-map env form resolved)))))) (defns- analyze* [env ::env, form _] (prl! env form) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index cea2b1a2..0b9fed3e 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -51,17 +51,18 @@ ([env form t] (Literal. env form t))) (defrecord Symbol - [env #_::env - form #_t/symbol? - type #_t/type?] + [env #_::env + form #_t/symbol? + value #_t/any? + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn (-edn [this] (list `symbol (into (array-map) this)))) (defn symbol - ([form t] (symbol nil form t)) - ([env form t] (Symbol. env form t))) + ([form value t] (symbol nil form value t)) + ([env form value t] (Symbol. env form value t))) (defn symbol? [x] (instance? Symbol x)) @@ -103,10 +104,11 @@ (defn do [m] (map->Do m)) (defrecord MacroCall - [env #_::env - form #_::t/form - expanded #_::node - type #_t/type?] + [env #_::env + form #_::t/form + expanded-form #_::t/form ; the *fully* expanded form + expanded #_::node + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn From 840c0b090c4278832195adfd0259159bd8ca6ff1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 25 Jul 2018 17:10:21 -0600 Subject: [PATCH 165/810] `t/or` nil and Object now yields U --- src-untyped/quantum/untyped/core/type.cljc | 29 +++++++++++++--------- test/quantum/test/untyped/core/type.cljc | 11 +++++++- 2 files changed, 27 insertions(+), 13 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index b76c2e5f..2ab0cdb5 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -280,6 +280,10 @@ (-def class-type? (isa? ClassType)) (-def value-type? (isa? ValueType)) +;; For use in logical operators +(-def nil? (value nil)) +(-def object? (isa? #?(:clj java.lang.Object :cljs js/Object))) + ;; ===== Miscellaneous ===== ;; (defns * @@ -322,14 +326,18 @@ (defns- create-logical-type|inner|or [{:as accum :keys [t' utr/type?]} _, t* utr/type?, c* utc/comparison?] - (if ;; `s` must be either `><` or `<>` w.r.t. to all other args - (case c* (2 3) true false) - (if ;; Tautology/universal-set: (| A (! A)) - (c/and (c/= c* <>ident) ; optimization before `complementary?` - (complementary? t' t*)) - (reduced (assoc accum :conj-t? false :types [universal-set])) - (update accum :types conj t*)) - (reduced (assoc accum :prefer-orig-args? true)))) + (if #?(:clj (c/or (c/and (c/= t' object?) (c/= t* nil?)) + (c/and (c/= t* object?) (c/= t' nil?))) + :cljs false) + (reduced (assoc accum :conj-t? false :types [universal-set])) + (if ;; `s` must be either `><` or `<>` w.r.t. to all other args + (case c* (2 3) true false) + (if ;; Tautology/universal-set: (| A (! A)) + (c/and (c/= c* <>ident) ; optimization before `complementary?` + (complementary? t' t*)) + (reduced (assoc accum :conj-t? false :types [universal-set])) + (update accum :types conj t*)) + (reduced (assoc accum :prefer-orig-args? true))))) (defns- create-logical-type|inner|and [{:as accum :keys [conj-t? c/boolean?, prefer-orig-args? c/boolean?, t' utr/type?, types _]} _ @@ -592,10 +600,7 @@ (-def none? empty-set) (-def any? universal-set) - (-def nil? (value nil)) - (-def object? (isa? #?(:clj java.lang.Object :cljs js/Object))) - - ;; TODO this is incomplete for CLJS base classes, I think + ;; TODO this is incomplete for CLJS base classes, I think (-def val|by-class? (or object? #?@(:cljs [(isa? js/String) (isa? js/Symbol)]))) (-def val? (not nil?)) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 7bca3717..d0d2effc 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -103,6 +103,15 @@ (| a b)) (is= (| (| a b ><0) (| a ><0 b)) (| a b ><0))) + (testing "via universal class + nil" + (is= t/universal-set (| (t/isa? Object) (t/value nil))) + (is= t/universal-set (| (t/value nil) (t/isa? Object))) + (is= t/universal-set (| (t/isa? Object) (t/value nil) (t/value 1))) + (is= t/universal-set (| (t/isa? Object) (t/value 1) (t/value nil))) + (is= t/universal-set (| (t/value nil) (t/isa? Object) (t/value 1))) + (is= t/universal-set (| (t/value nil) (t/value 1) (t/isa? Object))) + (is= t/universal-set (| (t/value 1) (t/isa? Object) (t/value nil))) + (is= t/universal-set (| (t/value 1) (t/value nil) (t/isa? Object)))) (testing "nested `or` is expanded" (is= (| (| a b) (| ><0 ><1)) (| a b ><0 ><1)) @@ -230,7 +239,7 @@ (is= (& (| a b) (! b) (| ><0 b)) t/empty-set)) (is= (& t/primitive? (! t/boolean?)) - (| t/byte? t/char? t/short? t/int? t/long? t/float? t/double?))) + (| t/byte? t/short? t/char? t/int? t/long? t/float? t/double?))) (testing "#{<+ =} -> #{=}" (is= (& i|>a+b i|>a0 i|a) i|a)) From bafc8aeecce1278b1d3640042f2edaa13d365d09 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 25 Jul 2018 18:20:22 -0600 Subject: [PATCH 166/810] Make U and null set metable --- .../quantum/untyped/core/type/reifications.cljc | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 100b998c..ea28f507 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -30,9 +30,11 @@ (udt/deftype ^{:doc "Represents the set of all sets that do not include themselves (including the empty set). Equivalent to `(constantly true)`."} - UniversalSetType [] + UniversalSetType [meta #_(t/? ::meta)] {PType nil ?Fn {invoke ([_ x] true)} + ?Meta {meta ([this] meta) + with-meta ([this meta'] (UniversalSetType. meta'))} ?Hash {hash ([this] (hash UniversalSetType))} ?Object {hash-code ([this] (uhash/code UniversalSetType)) equals ([this that] (or (== this that) (instance? UniversalSetType that)))} @@ -40,16 +42,18 @@ fedn/IOverride nil fedn/IEdn {-edn ([this] 'quantum.untyped.core.type/U)}}) -(def universal-set (UniversalSetType.)) +(def universal-set (UniversalSetType. nil)) ;; ----- EmptySetType (`t/∅`) ----- ;; (udt/deftype ^{:doc "Represents the empty set. Equivalent to `(constantly false)`."} - EmptySetType [] + EmptySetType [meta #_(t/? ::meta)] {PType nil ?Fn {invoke ([_ x] false)} + ?Meta {meta ([this] meta) + with-meta ([this meta'] (EmptySetType. meta'))} ?Hash {hash ([this] (hash EmptySetType))} ?Object {hash-code ([this] (uhash/code EmptySetType)) equals ([this that] (or (== this that) (instance? EmptySetType that)))} @@ -57,7 +61,7 @@ fedn/IOverride nil fedn/IEdn {-edn ([this] 'quantum.untyped.core.type/∅)}}) -(def empty-set (EmptySetType.)) +(def empty-set (EmptySetType. nil)) ;; ----- NotType (`t/not` / `t/!`) ----- ;; From 24ad7fed32d083361a228e441ef28eaec2a2d299 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 25 Jul 2018 18:20:43 -0600 Subject: [PATCH 167/810] Analysis on `let*` seems to work! --- src-untyped/quantum/untyped/core/analyze.cljc | 68 +++++++++---------- 1 file changed, 32 insertions(+), 36 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 4ff52a5e..d212df71 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -178,33 +178,25 @@ (defns analyze-seq|let*|bindings [env ::env, bindings|form _] (->> bindings|form (c/partition-all+ 2) - (reduce (fn [{env' :env !bindings :form} [sym form :as binding|form]] + (reduce (fn [{env' :env !bindings :form :keys [bindings-map]} [sym form :as binding|form]] (let [expr (analyze* env' form)] ; environment is additive with each binding - {:env (assoc env' sym expr) - :form (conj! (conj! !bindings sym) (:form expr))})) - {:env env :form (transient [])}) + {:env (assoc env' sym expr) + :form (conj! (conj! !bindings sym) (:form expr)) + :bindings-map (assoc bindings-map sym expr)})) + {:env env :form (transient []) :bindings-map {}}) (persistent!-and-add-file-context bindings|form))) (defns analyze-seq|let* [env ::env, [_ _, bindings|form _ & body|form _ :as form] _] - {:pre [(prl! env form)]} - (let [{env' :env bindings|form' :form} (analyze-seq|let*|bindings env bindings|form) - {body|form :form :as expr} (analyze-seq|do env' (list* 'do body|form))] - (prl! env' expr) - (TODO "`let*` analysis") - #_(uast/let* {:env env - :form form - :expanded-form (list* 'let* bindings|form' body|form') - :bindings (bindings>env bindings) - :body (>vec body) - :type (:type expr)})) - - #_(let [{env' :env bindings' :form} - (analyze-seq|let*|bindings env bindings) - {env'' :env body' :form type-info' :type-info} - (analyze-seq|do env' body)] - (->expr-info {:env env - :form (list 'let* bindings' body') - :type-info type-info'}))) + (let [{env' :env bindings|form' :form :keys [bindings-map]} + (analyze-seq|let*|bindings env bindings|form) + {body|form' :expanded-form body|type :type body :body} + (analyze-seq|do env' (list* 'do body|form))] + (uast/let* {:env env + :form form + :expanded-form (list* 'let* bindings|form' (rest body|form')) + :bindings bindings-map + :body body + :type body|type}))) (defns ?resolve-with-env [sym t/symbol?, env ::env] (if-let [[_ local] (find env sym)] @@ -281,6 +273,7 @@ If only one method is found, that is noted too. If no matching method is found, an exception is thrown." [env ::env, form _, target _, target-class t/class?, static? t/boolean?, method-form simple-symbol?, args-forms _ #_(seq-of form?)] + (log/pr!) ;; TODO cache type by method (if-not-let [methods-for-name (-> target-class class->methods|with-cache (c/get (name method-form)))] (if (empty? args-forms) @@ -305,7 +298,6 @@ (r/fori [arg-form args-forms call' call i|arg] - (prl! call' arg-form) (let [arg-node (analyze* env arg-form)] ;; TODO can incrementally calculate return value, but possibly not worth it (update call' :args conj arg-node))) @@ -320,6 +312,7 @@ (defns- analyze-seq|dot|field-access [env ::env, form _, target _, field-form simple-symbol?, field (t/isa? Field)] + (log/pr!) (uast/field-access {:env env :form form @@ -331,6 +324,7 @@ "Ensure that given a set of classes, that set consists of at most a class C and nil. If so, returns C. Otherwise, throws." [cs (s/set-of (? t/class?)) > t/class?] + (log/pr!) (let [cs' (disj cs nil)] (if (-> cs' count (= 1)) (first cs') @@ -338,8 +332,7 @@ ;; TODO type these arguments; e.g. check that ?method||field, if present, is an unqualified symbol (defns- analyze-seq|dot [env ::env, [_ _, target-form _, ?method-or-field _ & ?args _ :as form] _] - {:pre [(prl! env form target-form ?method-or-field ?args)] - :post [(prl! %)]} + (log/pr!) (let [target (analyze* #_?resolve-with-env env target-form) method-or-field (if (symbol? ?method-or-field) ?method-or-field (first ?method-or-field)) args-forms (if (symbol? ?method-or-field) ?args (rest ?method-or-field))] @@ -366,6 +359,7 @@ ;; TODO move this (defns truthy-expr? [{:as expr t [:type _]} _ > t/boolean?] + (log/pr!) (ifs (or (t/= t t/nil?) (t/= t t/false?)) false (or (t/> t t/nil?) @@ -376,7 +370,7 @@ "If `*conditional-branch-pruning?*` is falsey, the dead branch's original form will be retained, but it will not be type-analyzed." [env ::env, [_ _ & [pred-form _, true-form _, false-form _ :as body] _ :as form] _] - {:post [(prl! %)]} + (log/pr!) (if (-> body count (not= 3)) (err! "`if` accepts exactly 3 arguments: one predicate test and two branches; received" {:body body}) @@ -407,11 +401,11 @@ nil @whole-expr)))) (defns- analyze-seq|quote [env ::env, [_ _ & body _ :as form] _] - {:post [(prl! %)]} + (log/pr!) (uast/quoted env form (tcore/most-primitive-class-of body))) (defns- analyze-seq|new [env ::env, [_ _ & [c|form _ #_t/class? & args _ :as body] _ :as form] _] - {:pre [(prl! env form)]} + (log/pr!) (let [c|analyzed (analyze* env c|form)] (if-not (and (-> c|analyzed :type t/value-type?) (-> c|analyzed :type utr/value-type>value class?)) @@ -425,7 +419,7 @@ :type (t/isa? c)}))))) (defns- analyze-seq|throw [env ::env, form _ [arg _ :as body] _] - {:pre [(prl! env form body)]} + (log/pr!) (if (-> body count (not= 1)) (err! "Must supply exactly one input to `throw`; supplied" {:body body}) (let [arg|analyzed (analyze* env arg)] @@ -442,6 +436,7 @@ "Analyze a seq after it has been macro-expanded. The ->`form` is post- incremental macroexpansion." [env ::env, [caller|form _ & body _ :as form] _] + (log/pr!) (ifs (special-symbols caller|form) (case caller|form do (analyze-seq|do env form) @@ -516,7 +511,7 @@ :type out-type})))))) (defns- analyze-seq [env ::env, form _] - {:post [(prl! %)]} + (log/pr!) (let [expanded-form (ufeval/macroexpand form)] (if (ucomp/== form expanded-form) (analyze-seq* env expanded-form) @@ -528,7 +523,7 @@ :expanded expanded}))))) (defns- analyze-symbol [env ::env, form t/symbol?] - {:post [(prl! %)]} + (log/pr!) (if-not-let [{resolved :value} (?resolve-with-env form env)] (err! "Could not resolve symbol" {:sym form}) (uast/symbol env form resolved @@ -544,7 +539,7 @@ (TODO "Unsure of what to do in this case" (kw-map env form resolved)))))) (defns- analyze* [env ::env, form _] - (prl! env form) + (log/pr! form) (when (> (swap! *analyze-depth inc) 100) (throw (ex-info "Stack too deep" {:form form}))) (ifs (symbol? form) (analyze-symbol env form) @@ -560,7 +555,8 @@ (throw (ex-info "Unrecognized form" {:form form})))) (defns analyze - ([body _] (analyze {} body)) - ([env ::env, body _] + ([form _] (analyze {} form)) + ([env ::env, form _] + (log/pr! form) (reset! *analyze-depth 0) - (analyze* env body))) + (analyze* env form))) From e9b891c3c9782eea7112e696a6720d0dcd718f5c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 25 Jul 2018 18:21:01 -0600 Subject: [PATCH 168/810] typed `map/>!identity-map` --- src/quantum/core/data/map.cljc | 32 +++++++++++++++++++++++--------- 1 file changed, 23 insertions(+), 9 deletions(-) diff --git a/src/quantum/core/data/map.cljc b/src/quantum/core/data/map.cljc index 0908d3fc..49391633 100644 --- a/src/quantum/core/data/map.cljc +++ b/src/quantum/core/data/map.cljc @@ -5,10 +5,13 @@ (:refer-clojure :exclude [split-at, merge, sorted-map sorted-map-by, array-map, hash-map]) (:require - [quantum.core.defnt - :refer [defnt]] + ;; TODO TYPED + #_[quantum.core.reducers :as r + :refer [reduce-pair]] [quantum.untyped.core.data.map :as u] [quantum.untyped.core.type :as t] + [quantum.untyped.core.type.defnt + :refer [defnt]] [quantum.untyped.core.vars :refer [defaliases]]) (:import @@ -47,37 +50,44 @@ ;; ===== Unordered identity-semantic maps ===== ;; ;; TODO generate this via macro? +(in-ns 'quantum.core.data.map) (defnt >!identity-map "Creates a single-threaded, mutable identity map. On the JVM, this is a `java.util.IdentityHashMap`. On JS, this is a `js/Map` (ECMAScript 6 Map)." ([> t/!identity-map?] #?(:clj (IdentityHashMap.) :cljs (js/Map.))) - ([k0 _, v0 _] + ([k0 (t/ref t/any?), v0 (t/ref t/any?)] (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0))) - #_([k0 _, v0 _, k1 _, v1 _] + ([k0 (t/ref t/any?), v0 (t/ref t/any?), k1 (t/ref t/any?), v1 (t/ref t/any?)] (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0) (#?(:clj .put :cljs .set) k1 v1))) - #_([k0 _, v0 _, k1 _, v1 _, k2 _, v2 _] + ([k0 (t/ref t/any?), v0 (t/ref t/any?), k1 (t/ref t/any?), v1 (t/ref t/any?) + k2 (t/ref t/any?), v2 (t/ref t/any?)] (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0) (#?(:clj .put :cljs .set) k1 v1) (#?(:clj .put :cljs .set) k2 v2))) - #_([k0 _, v0 _, k1 _, v1 _, k2 _, v2 _, k3 _, v3 _] + ([k0 (t/ref t/any?), v0 (t/ref t/any?), k1 (t/ref t/any?), v1 (t/ref t/any?) + k2 (t/ref t/any?), v2 (t/ref t/any?), k3 (t/ref t/any?), v3 (t/ref t/any?)] (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0) (#?(:clj .put :cljs .set) k1 v1) (#?(:clj .put :cljs .set) k2 v2) (#?(:clj .put :cljs .set) k3 v3))) - #_([k0 _, v0 _, k1 _, v1 _, k2 _, v2 _, k3 _, v3 _, k4 _, v4 _] + ([k0 (t/ref t/any?), v0 (t/ref t/any?), k1 (t/ref t/any?), v1 (t/ref t/any?) + k2 (t/ref t/any?), v2 (t/ref t/any?), k3 (t/ref t/any?), v3 (t/ref t/any?) + k4 (t/ref t/any?), v4 (t/ref t/any?)] (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0) (#?(:clj .put :cljs .set) k1 v1) (#?(:clj .put :cljs .set) k2 v2) (#?(:clj .put :cljs .set) k3 v3) (#?(:clj .put :cljs .set) k4 v4))) - #_([k0 _, v0 _, k1 _, v1 _, k2 _, v2 _, k3 _, v3 _, k4 _, v4 _, k5 _, v5 _] + ([k0 (t/ref t/any?), v0 (t/ref t/any?), k1 (t/ref t/any?), v1 (t/ref t/any?) + k2 (t/ref t/any?), v2 (t/ref t/any?), k3 (t/ref t/any?), v3 (t/ref t/any?) + k4 (t/ref t/any?), v4 (t/ref t/any?), k5 (t/ref t/any?), v5 (t/ref t/any?)] (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0) (#?(:clj .put :cljs .set) k1 v1) @@ -85,7 +95,11 @@ (#?(:clj .put :cljs .set) k3 v3) (#?(:clj .put :cljs .set) k4 v4) (#?(:clj .put :cljs .set) k5 v5))) - #_([k0 _, v0 _, k1 _, v1 _, k2 _, v2 _, k3 _, v3 _, k4 _, v4 _, k5 _, v5 _ k6, _ v6, _ & kvs _] + ;; TODO TYPED handle varargs +#_([k0 (t/ref t/any?), v0 (t/ref t/any?), k1 (t/ref t/any?), v1 (t/ref t/any?) + k2 (t/ref t/any?), v2 (t/ref t/any?), k3 (t/ref t/any?), v3 (t/ref t/any?) + k4 (t/ref t/any?), v4 (t/ref t/any?), k5 (t/ref t/any?), v5 (t/ref t/any?) + k6 (t/ref t/any?), v6 (t/ref t/any?) & kvs _] (reduce-pair (fn [#?(:clj ^IdentityHashMap m :cljs m) k v] (doto m (#?(:clj .put :cljs .set) k v))) (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) From 52b7f98797472e85106216a2dace03eebe99e64d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 25 Jul 2018 18:52:41 -0600 Subject: [PATCH 169/810] Fields not in functor position now resolve correctly --- src-untyped/quantum/untyped/core/analyze.cljc | 6 +++++- src-untyped/quantum/untyped/core/type.cljc | 2 ++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index d212df71..9510131d 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -204,7 +204,11 @@ (let [resolved (ns-resolve *ns* sym)] (log/ppr :warn "Not sure how to handle non-local symbol; resolved it for now" (kw-map sym resolved)) - (when resolved {:value resolved})))) + (ifs resolved + {:value resolved} + (some-> sym namespace symbol resolve class?) + {:value (analyze-seq|dot env (list '. (-> sym namespace symbol) (-> sym name symbol)))} + nil)))) (defns methods->type "Creates a type given ->`methods`." diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 2ab0cdb5..cab521a8 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -595,6 +595,8 @@ (list* `or)))] `(do ~@(concat anys [any->any]))))) +;; TODO TYPED — split the below predicate definitions into appropriate namespaces + ;; ===== General ===== ;; (-def none? empty-set) From 5533f848fd24cfa063d046d62e3f525c40d0af4f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 25 Jul 2018 18:52:57 -0600 Subject: [PATCH 170/810] Add a few more typed fns --- src/quantum/core/data/map.cljc | 65 ++++++++++++++++++++++++++-------- 1 file changed, 50 insertions(+), 15 deletions(-) diff --git a/src/quantum/core/data/map.cljc b/src/quantum/core/data/map.cljc index 49391633..3121167f 100644 --- a/src/quantum/core/data/map.cljc +++ b/src/quantum/core/data/map.cljc @@ -3,17 +3,18 @@ :attribution "alexandergunnarson"} quantum.core.data.map (:refer-clojure :exclude - [split-at, merge, sorted-map sorted-map-by, array-map, hash-map]) + [split-at, merge, sorted-map sorted-map-by]) (:require - ;; TODO TYPED - #_[quantum.core.reducers :as r - :refer [reduce-pair]] - [quantum.untyped.core.data.map :as u] - [quantum.untyped.core.type :as t] - [quantum.untyped.core.type.defnt - :refer [defnt]] - [quantum.untyped.core.vars - :refer [defaliases]]) + #?(:clj [clojure.data.int-map]) + ;; TODO TYPED + #_[quantum.core.reducers :as r + :refer [reduce-pair]] + [quantum.untyped.core.data.map :as u] + [quantum.untyped.core.type :as t] + [quantum.untyped.core.type.defnt + :refer [defnt]] + [quantum.untyped.core.vars + :refer [defalias]]) (:import #?@(:clj [[java.util HashMap IdentityHashMap LinkedHashMap TreeMap] [it.unimi.dsi.fastutil.ints Int2ReferenceOpenHashMap] @@ -50,12 +51,12 @@ ;; ===== Unordered identity-semantic maps ===== ;; ;; TODO generate this via macro? -(in-ns 'quantum.core.data.map) (defnt >!identity-map "Creates a single-threaded, mutable identity map. On the JVM, this is a `java.util.IdentityHashMap`. On JS, this is a `js/Map` (ECMAScript 6 Map)." - ([> t/!identity-map?] #?(:clj (IdentityHashMap.) :cljs (js/Map.))) + > t/!identity-map? + ([] #?(:clj (IdentityHashMap.) :cljs (js/Map.))) ([k0 (t/ref t/any?), v0 (t/ref t/any?)] (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0))) @@ -112,14 +113,48 @@ (#?(:clj .put :cljs .set) k6 v6)) kvs))) +;; ===== Unordered value-semantic maps ===== ;; + +(defnt >array-map + "Creates a persistent array map. If any keys are equal, they are handled as if by repeated + applications of `assoc`." + > t/+array-map? + ([] (. clojure.lang.PersistentArrayMap EMPTY)) + ;; TODO TYPED handle varargs +#_([& kvs] + (clojure.lang.PersistentArrayMap/createAsIfByAssoc (to-array kvs)))) + +;; ----- Hash maps ----- ;; + +(defnt >hash-map + "Creates a persistent hash map. If any keys are equal, they are handled as if by repeated + applications of `assoc`." + > t/+array-map? + ([] clojure.lang.PersistentArrayMap/EMPTY) + ;; TODO TYPED handle varargs +#_([& keyvals] + (clojure.lang.PersistentHashMap/create kvs))) + +(def +hash-map|long->ref? (t/isa? clojure.data.int_map.PersistentIntMap)) + +#?(:clj +(defnt >hash-map|long->ref + "Creates a persistent integer map that can only have non-negative integers as keys." + > +hash-map|long->ref? + ([] (clojure.data.int_map.PersistentIntMap. clojure.data.int_map.Nodes$Empty/EMPTY 0 nil)) + ;; TODO TYPED handle varargs + ([k t/nneg-int? v (t/ref t/any?)] (assoc (>hash-map|long->ref) k v)) + ;; TODO TYPED handle calling other typed fns +#_([kv & kvs] (apply assoc (>hash-map|long->ref) k v kvs)))) + +#?(:clj (defalias int-map hash-map|long->ref)) + ; `(apply hash-map pairs)` <~> `lodash/fromPairs` (defaliases u - #?@(:clj [int-map hash-map|long->ref]) - array-map hash-map ordered-map om #?(:clj !ordered-map) #?(:clj kw-omap) + ordered-map om #?(:clj !ordered-map) #?(:clj kw-omap) sorted-map sorted-map-by sorted-map-by-val sorted-rank-map sorted-rank-map-by nearest rank-of subrange split-key split-at - #?(:clj hash-map?) merge #?(:clj pmerge) !hash-map #?@(:clj [!hash-map|int->ref !hash-map|int->object From 2e3af41777d282726a5105a88c4351e5c9267818 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 26 Jul 2018 08:27:05 -0600 Subject: [PATCH 171/810] Add note --- resources-dev/defnt.cljc | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 946f50cc..c5806356 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -1,10 +1,13 @@ #_" -LEFT OFF LAST TIME (7/24/2018): +LEFT OFF LAST TIME (7/25/2018): +- handle calling of other `fnt`s from `fnt`s + - `(defnt >long ...)` : enable to refer to `>long*` and have that analyzed + - finish `>long` example + - quantum.core.data.map - expressions (`quantum.untyped.core.analyze.expr`) - `t/fn` -- `(defnt >long ...)` : enable to refer to `>long*` and have that analyzed -- finish `>long` example +- handle `defnt` varargs From 5b23cf8728188ec01a9212c20edc164ffaec7f66 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 26 Jul 2018 10:53:00 -0600 Subject: [PATCH 172/810] code -> form --- .../quantum/untyped/core/analyze/expr.cljc | 119 ++++++++---------- src-untyped/quantum/untyped/core/form.cljc | 16 ++- 2 files changed, 67 insertions(+), 68 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze/expr.cljc b/src-untyped/quantum/untyped/core/analyze/expr.cljc index 30a59224..b5436c36 100644 --- a/src-untyped/quantum/untyped/core/analyze/expr.cljc +++ b/src-untyped/quantum/untyped/core/analyze/expr.cljc @@ -15,6 +15,8 @@ [quantum.untyped.core.core :as ucore] [quantum.untyped.core.error :as uerr :refer [err! TODO]] + [quantum.untyped.core.form :as uform + :refer [>form]] [quantum.untyped.core.print :as upr] [quantum.untyped.core.qualify :as uqual] [quantum.untyped.core.reducers :as ur @@ -24,21 +26,18 @@ (ucore/log-this-ns) -(do - -(defn expr>code [x] (cond-> x (fn? x) >symbol)) +(defn expr>form [x] (cond-> x (fn? x) >symbol)) (#?(:clj definterface :cljs defprotocol) IExpr) (defprotocol PExpr - (>code [this]) - (with-code [this code']) - (update-code [this f]) + (with-form [this form']) + (update-form [this f]) (>evaled [this])) (#?(:clj definterface :cljs defprotocol) ICall) -(defn icall? [x] (instance? ICall x)) +(defn icall? [x] (#?(:clj instance? :cljs satisfies?) ICall x)) #?(:clj (defmacro def [sym x] @@ -68,7 +67,7 @@ fipp.ednize/IEdn (-edn [this] (if upr/*print-as-code?* - (list* `casef (expr>code f) (map upr/>group cases)) + (list* `casef (expr>form f) (map upr/>group cases)) (list* `casef f cases)))) (defn casef [f & cases] @@ -94,8 +93,8 @@ (-edn [this] (if upr/*print-as-code?* (list* `condpf-> - (expr>code pred) - (expr>code f) + (expr>form pred) + (expr>form f) (map upr/>group clauses)) (list* `condpf-> pred f clauses)))) @@ -123,72 +122,58 @@ (-edn [this] (concat [`fn] (when name [name]) arities))) (udt/deftype - ^{:doc "All possible behaviors of `code` are inherited except function-callability, which - is used for calling the evaled code itself. - A code form may consist of any of the following, recursively: - - nil - - number - - double - - long - - bigdec (`M`) - - bigint (`N`) - - string - - symbol - - keyword - - seq - - vector - - map + ^{:doc "All possible behaviors of `form` are inherited except function-callability, which + is used for calling the evaled form itself. Modification of a tagged literal is only supported to the extent the quoted form of the literal may be modified."} - Expression [code evaled] + Expression [form evaled] {;; expression-like - IExpr nil - PExpr {>code ([this] code) - with-code ([this code'] (Expression. code' (#?(:clj eval :cljs (TODO "eval not supported")) code'))) - update-code ([this f] (with-code this (f code))) - >evaled ([this] evaled)} - ;; `code`-like - ?Associative {assoc ([this k v] (with-code this (assoc code k v))) - dissoc ([this k] (with-code this (dissoc code k))) - keys ([this] (with-code this (keys code))) - vals ([this] (with-code this (vals code))) - contains? ([this] (contains? code)) - find (([this k] (with-code this (find code))) - ([this k else] (with-code this (find code else))))} - ?Collection {empty ([this] (with-code this (empty code))) - conj ([this x] (with-code this (conj code x))) - empty? ([this] (empty? code)) - equals ([this that] (or (== this that) - (and (instance? Expression that) - (let [^Expression that that] - (= evaled (.-evaled that)) - (= code (.-code that))))))} - ?Counted {count ([this] (count code))} - ?Indexed {nth ([this i] (with-code this (nth code i)))} - ?Lookup {get (([this k] (with-code this (core/get code k))) - #_([this k else] (with-code this (core/get code k else))))} ; TODO make it work - ?Meta {meta ([this] (meta code)) - with-meta ([this meta'] (Expression. (with-meta code meta') evaled))} - ?Reversible {rseq ([this] (with-code this (rseq code)))} - ?Seq {first ([this] (with-code this (first code))) - rest ([this] (with-code this (rest code))) - next ([this] (with-code this (next code)))} - ?Seqable {seq ([this] (with-code this (seq code)))} - ?Stack {peek ([this] (with-code this (peek code))) - pop ([this] (with-code this (pop code)))} + IExpr nil + uform/PGenForm {>form ([this] form)} + PExpr {with-form ([this form'] + (Expression. form' + (#?(:clj eval :cljs (TODO "eval not supported")) form'))) + update-form ([this f] (with-form this (f form))) + >evaled ([this] evaled)} + ;; `form`-like + ?Associative {assoc ([this k v] (with-form this (assoc form k v))) + dissoc ([this k] (with-form this (dissoc form k))) + keys ([this] (with-form this (keys form))) + vals ([this] (with-form this (vals form))) + contains? ([this] (contains? form)) + find (([this k] (with-form this (find form))) + ([this k else] (with-form this (find form else))))} + ?Collection {empty ([this] (with-form this (empty form))) + conj ([this x] (with-form this (conj form x))) + empty? ([this] (empty? form)) + equals ([this that] (or (== this that) + (and (instance? Expression that) + (let [^Expression that that] + (= evaled (.-evaled that)) + (= form (.-form that))))))} + ?Counted {count ([this] (count form))} + ?Indexed {nth ([this i] (with-form this (nth form i)))} + ?Lookup {get (([this k] (with-form this (core/get form k))) + #_([this k else] (with-form this (core/get form k else))))} ; TODO make it work + ?Meta {meta ([this] (meta form)) + with-meta ([this meta'] (Expression. (with-meta form meta') evaled))} + ?Reversible {rseq ([this] (with-form this (rseq form)))} + ?Seq {first ([this] (with-form this (first form))) + rest ([this] (with-form this (rest form))) + next ([this] (with-form this (next form)))} + ?Seqable {seq ([this] (with-form this (seq form)))} + ?Stack {peek ([this] (with-form this (peek form))) + pop ([this] (with-form this (pop form)))} ;; `evaled`-like - ?Fn {invoke (([this] (evaled)) - ([this a0] (evaled a0)) - ([this a0 a1] (evaled a0 a1)))} + ?Fn {invoke (([this] (evaled)) + ([this a0] (evaled a0)) + ([this a0 a1] (evaled a0 a1)))} ;; printing fipp.ednize/IOverride nil - fipp.ednize/IEdn - {-edn ([this] (tagged-literal 'expr code))}}) + fipp.ednize/IEdn {-edn ([this] (tagged-literal 'expr form))}}) #?(:clj (defmacro >expr [expr-] `(quantum.untyped.core.analyze.expr.Expression. '~expr- ~expr-))) #?(:clj (defn expr? [x] (instance? Expression x))) - -) diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index bd7bb84b..78bda356 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -13,7 +13,21 @@ If evaluated, the form should evaluate to something exactly equivalent to the value of the object (even stronger than a `=` guarantee — all properties up to but not including identity). - Effectively the inverse of `eval`.")) + Effectively the inverse of `eval`. + + A form may consist of any of the following, recursively: + - nil + - number + - double + - long + - bigdec (`M`) + - bigint (`N`) + - string + - symbol + - keyword + - seq + - vector + - map")) (extend-protocol PGenForm nil (>form [x] nil) From 9f510aa1fa3fc0ed54a7a9fe52c7b3c700e382d2 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 26 Jul 2018 11:20:53 -0600 Subject: [PATCH 173/810] Clear up some terminology --- src-untyped/quantum/untyped/core/analyze.cljc | 105 +++++++++--------- .../quantum/untyped/core/analyze/ast.cljc | 30 ++--- .../quantum/untyped/core/analyze/expr.cljc | 37 +++--- 3 files changed, 86 insertions(+), 86 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 9510131d..5c657a67 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -90,8 +90,8 @@ (let [from-meta (meta from)] (update-meta to assoc :line (:line from-meta) :column (:column from-meta)))) -(defn persistent!-and-add-file-context [form ast-ret] - (update ast-ret :form (fn-> persistent! (add-file-context form)))) +(defn persistent!-and-add-file-context [form ast-data] + (update ast-data :form (fn-> persistent! (add-file-context form)))) (def special-symbols '#{do let* deftype* fn* def . if quote new throw}) ; TODO make more complete @@ -127,8 +127,8 @@ {:params-doc '{merge-types-fn "2-arity fn that merges two types (or sets of types). The first argument is the current deduced type of the - overall expression; the second is the deduced type of - the current subexpression."}} + overall AST node; the second is the deduced type of + the current sub-AST-node."}} [env ::env, form _, empty-form _, rf _] (->> form (reducei (fn [accum form' i] (rf accum (analyze* (:env accum) form') i)) @@ -143,10 +143,10 @@ (TODO "analyze-map") #_(->> form (reduce-kv (fn [{env' :env forms :form} form'k form'v] - (let [ast-ret-k (analyze* env' form'k) - ast-ret-v (analyze* env' form'v)] + (let [ast-node-k (analyze* env' form'k) + ast-node-v (analyze* env' form'v)] (->expr-info {:env env' - :form (assoc! forms (:form ast-ret-k) (:form ast-ret-v)) + :form (assoc! forms (:form ast-node-k) (:form ast-node-v)) ;; TODO fix; we want the types of the keys and vals to be deduced :type-info nil}))) (->expr-info {:env env :form (transient {})})) @@ -161,17 +161,18 @@ :type t/nil?}) (let [{expanded-form :form body :body} (analyze-non-map-seqable env body|form [] - (fn [accum expr _] - (assoc expr ;; The env should be the same as whatever it was originally - ;; because no new scopes are created - :env (:env accum) - :form (conj! (:form accum) (:form expr)) - :body (conj! (:body accum) expr))))] + (fn [accum ast-data _] + (assoc ast-data + ;; The env should be the same as whatever it was originally + ;; because no new scopes are created + :env (:env accum) + :form (conj! (:form accum) (:form ast-data)) + :body (conj! (:body accum) ast-data))))] (uast/do {:env env :form form :expanded-form (with-meta (list* 'do expanded-form) (meta expanded-form)) :body body - ;; To types, only the last subexpression ever matters, as each is independent + ;; To types, only the last sub-AST-node ever matters, as each is independent ;; from the others :type (-> body c/last :type)})))) @@ -179,10 +180,10 @@ (->> bindings|form (c/partition-all+ 2) (reduce (fn [{env' :env !bindings :form :keys [bindings-map]} [sym form :as binding|form]] - (let [expr (analyze* env' form)] ; environment is additive with each binding - {:env (assoc env' sym expr) - :form (conj! (conj! !bindings sym) (:form expr)) - :bindings-map (assoc bindings-map sym expr)})) + (let [node (analyze* env' form)] ; environment is additive with each binding + {:env (assoc env' sym node) + :form (conj! (conj! !bindings sym) (:form node)) + :bindings-map (assoc bindings-map sym node)})) {:env env :form (transient []) :bindings-map {}}) (persistent!-and-add-file-context bindings|form))) @@ -362,7 +363,7 @@ method-or-field args-forms)))))) ;; TODO move this -(defns truthy-expr? [{:as expr t [:type _]} _ > t/boolean?] +(defns truthy-node? [{:as ast t [:type _]} _ > t/boolean?] (log/pr!) (ifs (or (t/= t t/nil?) (t/= t t/false?)) false @@ -378,31 +379,31 @@ (if (-> body count (not= 3)) (err! "`if` accepts exactly 3 arguments: one predicate test and two branches; received" {:body body}) - (let [pred-expr (analyze* env pred-form) - true-expr (delay (analyze* env true-form)) - false-expr (delay (analyze* env false-form)) - whole-expr + (let [pred-node (analyze* env pred-form) + true-node (delay (analyze* env true-form)) + false-node (delay (analyze* env false-form)) + whole-node (delay - (uast/if-expr + (uast/if-node {:env env - :form (list 'if (:form pred-expr) (:form @true-expr) (:form @false-expr)) - :pred-expr pred-expr - :true-expr @true-expr - :false-expr @false-expr - :type (apply t/or (->> [(:type @true-expr) (:type @false-expr)] + :form (list 'if (:form pred-node) (:form @true-node) (:form @false-node)) + :pred-node pred-node + :true-node @true-node + :false-node @false-node + :type (apply t/or (->> [(:type @true-node) (:type @false-node)] (remove nil?)))}))] - (case (truthy-expr? pred-expr) - true (do (log/ppr :warn "Predicate in `if` expression is always true" {:pred pred-form}) - (-> @true-expr + (case (truthy-node? pred-node) + true (do (log/ppr :warn "Predicate in `if` node is always true" {:pred pred-form}) + (-> @true-node (assoc :env env) (cond-> (not *conditional-branch-pruning?*) - (assoc :form (list 'if pred-form (:form @true-expr) false-form))))) - false (do (log/ppr :warn "Predicate in `if` expression is always false" {:pred pred-form}) - (-> @false-expr + (assoc :form (list 'if pred-form (:form @true-node) false-form))))) + false (do (log/ppr :warn "Predicate in `if` node is always false" {:pred pred-form}) + (-> @false-node (assoc :env env) (cond-> (not *conditional-branch-pruning?*) - (assoc :form (list 'if pred-form true-form (:form @false-expr)))))) - nil @whole-expr)))) + (assoc :form (list 'if pred-form true-form (:form @false-node)))))) + nil @whole-node)))) (defns- analyze-seq|quote [env ::env, [_ _ & body _ :as form] _] (log/pr!) @@ -413,10 +414,10 @@ (let [c|analyzed (analyze* env c|form)] (if-not (and (-> c|analyzed :type t/value-type?) (-> c|analyzed :type utr/value-type>value class?)) - (err! "Supplied non-class to `new` expression" {:x c|form}) + (err! "Supplied non-class to `new` form" {:x c|form}) (let [c (-> c|analyzed :type utr/value-type>value) args|analyzed (mapv #(analyze* env %) args)] - (uast/new-expr {:env env + (uast/new-node {:env env :form (list* 'new c|form (map :form args|analyzed)) :class c :args args|analyzed @@ -430,7 +431,7 @@ ;; TODO this is not quite true for CLJS but it's nice at least (if-not (-> arg|analyzed :type (t/<= t/throwable?)) (err! "`throw` requires a throwable; received" {:arg arg :type (:type arg|analyzed)}) - (uast/throw-expr {:env env + (uast/throw-node {:env env :form (list 'throw (:form arg|analyzed)) :arg arg|analyzed ;; `t/none?` because nothing is actually returned @@ -454,12 +455,12 @@ new (analyze-seq|new env form) throw (analyze-seq|throw env form)) ;; TODO support recursion - (let [caller|expr (analyze* env caller|form) - caller|type (:type caller|expr) + (let [caller|node (analyze* env caller|form) + caller|type (:type caller|node) args-ct (count body)] (case (t/compare caller|type t/callable?) - (1 2) (err! "It is not known whether expression be called" {:expr caller|expr}) - 3 (err! "Expression cannot be called" {:expr caller|expr}) + (1 2) (err! "It is not known whether form can be called" {:node caller|node}) + 3 (err! "Form cannot be called" {:node caller|node}) (-1 0) (let [caller-kind (ifs (t/<= caller|type t/keyword?) :keyword (t/<= caller|type t/+map|built-in?) :map @@ -470,7 +471,7 @@ ;; If it's callable but not fn, we might have missed something in ;; this dispatch so for now we throw (err! "Don't know how how to handle non-fn callable" - {:caller caller|expr})) + {:caller caller|node})) assert-valid-args-ct (case caller-kind (:keyword :map) @@ -478,17 +479,17 @@ (err! (str "Keywords and `clojure.core` persistent maps must be " "provided with exactly one or two args when calling " "them") - {:args-ct args-ct :caller caller|expr})) + {:args-ct args-ct :caller caller|node})) (:vector :set) (when-not (= args-ct 1) (err! (str "`clojure.core` persistent vectors and `clojure.core` " "persistent sets must be provided with exactly one arg " "when calling them") - {:args-ct args-ct :caller caller|expr})) + {:args-ct args-ct :caller caller|node})) :fnt - (TODO "Don't know how to handle typed fns yet" {:caller caller|expr}) + (TODO "Don't know how to handle typed fns yet" {:caller caller|node}) ;; For non-typed fns, unknown; we will have to risk runtime exception ;; because we can't necessarily rely on metadata to tell us the ;; whole truth @@ -496,7 +497,7 @@ ;; TODO incrementally check by analyzing each arg in `reduce` and pruning ;; branches of what the type could be, and throwing if it's found something ;; that's an impossible combination - arg-exprs (->> body + arg-nodes (->> body (c/map+ #(analyze* env %)) (reduce (fn [args arg|analyzed] (conj args arg|analyzed)) @@ -507,11 +508,11 @@ ;; for now (:keyword :map :vector :set :fn) t/any? :fnt (TODO "Use `::t/type` metadata to make this decision"))] - (uast/call-expr + (uast/call-node {:env env :form form - :caller caller|expr - :args arg-exprs + :caller caller|node + :args arg-nodes :type out-type})))))) (defns- analyze-seq [env ::env, form _] diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 0b9fed3e..5d0c6a52 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -116,19 +116,19 @@ (defn macro-call [m] (-> m map->MacroCall (assoc :type (-> m :expanded :type)))) -(defrecord IfExpr +(defrecord IfNode [env #_::env form #_::t/form - pred-expr #_::node - true-expr #_::node - false-expr #_::node + pred-node #_::node + true-node #_::node + false-node #_::node type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `if-expr (into (array-map) this)))) + (-edn [this] (list `if-node (into (array-map) this)))) -(defn if-expr [m] (map->IfExpr m)) +(defn if-node [m] (map->IfNode m)) ;; ===== RUNTIME CALLS ===== ;; @@ -159,7 +159,7 @@ (defn method-call [m] (map->MethodCall m)) -(defrecord CallExpr ; by a `t/callable?` +(defrecord CallNode ; by a `t/callable?` [env #_::env form #_::t/form caller #_::node @@ -168,11 +168,11 @@ INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `call-expr (into (array-map) this)))) + (-edn [this] (list `call-node (into (array-map) this)))) -(defn call-expr [m] (map->CallExpr m)) +(defn call-node [m] (map->CallNode m)) -(defrecord NewExpr +(defrecord NewNode [env #_::env form #_::t/form class #_t/class? @@ -181,11 +181,11 @@ INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `new-expr (into (array-map) this)))) + (-edn [this] (list `new-node (into (array-map) this)))) -(defn new-expr [m] (map->NewExpr m)) +(defn new-node [m] (map->NewNode m)) -(defrecord ThrowExpr +(defrecord ThrowNode [env #_::env form #_::t/form arg #_::node @@ -193,8 +193,8 @@ INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `throw-expr (into (array-map) this)))) + (-edn [this] (list `throw-node (into (array-map) this)))) -(defn throw-expr [m] (map->ThrowExpr m)) +(defn throw-node [m] (map->ThrowNode m)) ) diff --git a/src-untyped/quantum/untyped/core/analyze/expr.cljc b/src-untyped/quantum/untyped/core/analyze/expr.cljc index b5436c36..d80b0afd 100644 --- a/src-untyped/quantum/untyped/core/analyze/expr.cljc +++ b/src-untyped/quantum/untyped/core/analyze/expr.cljc @@ -37,7 +37,7 @@ (#?(:clj definterface :cljs defprotocol) ICall) -(defn icall? [x] (#?(:clj instance? :cljs satisfies?) ICall x)) +(defn call? [x] (#?(:clj instance? :cljs satisfies?) ICall x)) #?(:clj (defmacro def [sym x] @@ -45,8 +45,7 @@ #?(:clj (defalias -def def)) -(defrecord NamedExpr - [sym #_symbol? x #__] +(defrecord NamedExpr [sym #_symbol? x #__] IExpr fipp.ednize/IOverride fipp.ednize/IEdn @@ -61,7 +60,7 @@ (#?(:clj invoke :cljs -invoke) [_ x] (let [dispatch (f x)] (if-let [[_ then] (find cases dispatch)] - (if (icall? then) (then x) then) + (if (call? then) (then x) then) (err! "No matching clause found" {:dispatch dispatch})))) fipp.ednize/IOverride fipp.ednize/IEdn @@ -86,7 +85,7 @@ (let [[condition then] clause] (pred v condition))))) first)] - (if (icall? then) (then x) then) + (if (call? then) (then x) then) (err! "No matching clause found" {:v v})))) fipp.ednize/IOverride fipp.ednize/IEdn @@ -122,8 +121,8 @@ (-edn [this] (concat [`fn] (when name [name]) arities))) (udt/deftype - ^{:doc "All possible behaviors of `form` are inherited except function-callability, which - is used for calling the evaled form itself. + ^{:doc "All possible behaviors of `form` (e.g. `get`/`update`/`conj`) are inherited except + function-callability, which is used for calling the evaled form itself. Modification of a tagged literal is only supported to the extent the quoted form of the literal may be modified."} @@ -139,24 +138,24 @@ ;; `form`-like ?Associative {assoc ([this k v] (with-form this (assoc form k v))) dissoc ([this k] (with-form this (dissoc form k))) - keys ([this] (with-form this (keys form))) - vals ([this] (with-form this (vals form))) + keys ([this] (with-form this (keys form))) + vals ([this] (with-form this (vals form))) contains? ([this] (contains? form)) - find (([this k] (with-form this (find form))) - ([this k else] (with-form this (find form else))))} - ?Collection {empty ([this] (with-form this (empty form))) - conj ([this x] (with-form this (conj form x))) - empty? ([this] (empty? form)) + find (([this k] (with-form this (find form))) + ([this k else] (with-form this (find form else))))} + ?Collection {empty ([this] (with-form this (empty form))) + conj ([this x] (with-form this (conj form x))) + empty? ([this] (empty? form)) equals ([this that] (or (== this that) (and (instance? Expression that) (let [^Expression that that] (= evaled (.-evaled that)) (= form (.-form that))))))} - ?Counted {count ([this] (count form))} - ?Indexed {nth ([this i] (with-form this (nth form i)))} - ?Lookup {get (([this k] (with-form this (core/get form k))) - #_([this k else] (with-form this (core/get form k else))))} ; TODO make it work - ?Meta {meta ([this] (meta form)) + ?Counted {count ([this] (count form))} + ?Indexed {nth ([this i] (with-form this (nth form i)))} + ?Lookup {get (([this k] (with-form this (core/get form k))) + #_([this k else] (with-form this (core/get form k else))))} ; TODO make it work + ?Meta {meta ([this] (meta form)) with-meta ([this meta'] (Expression. (with-meta form meta') evaled))} ?Reversible {rseq ([this] (with-form this (rseq form)))} ?Seq {first ([this] (with-form this (first form))) From 12aed6a23823f278577281f93b2e20dd230ec4bd Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 26 Jul 2018 12:34:59 -0600 Subject: [PATCH 174/810] Fix compilation --- src-untyped/quantum/untyped/core/analyze.cljc | 30 ++++++++++--------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 5c657a67..5df6bd7f 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -199,18 +199,6 @@ :body body :type body|type}))) -(defns ?resolve-with-env [sym t/symbol?, env ::env] - (if-let [[_ local] (find env sym)] - {:value local} - (let [resolved (ns-resolve *ns* sym)] - (log/ppr :warn "Not sure how to handle non-local symbol; resolved it for now" - (kw-map sym resolved)) - (ifs resolved - {:value resolved} - (some-> sym namespace symbol resolve class?) - {:value (analyze-seq|dot env (list '. (-> sym namespace symbol) (-> sym name symbol)))} - nil)))) - (defns methods->type "Creates a type given ->`methods`." [methods (s/seq-of t/any? #_method?) > t/type?] @@ -338,7 +326,7 @@ ;; TODO type these arguments; e.g. check that ?method||field, if present, is an unqualified symbol (defns- analyze-seq|dot [env ::env, [_ _, target-form _, ?method-or-field _ & ?args _ :as form] _] (log/pr!) - (let [target (analyze* #_?resolve-with-env env target-form) + (let [target (analyze* env target-form) method-or-field (if (symbol? ?method-or-field) ?method-or-field (first ?method-or-field)) args-forms (if (symbol? ?method-or-field) ?args (rest ?method-or-field))] (if (t/= (:type target) t/nil?) @@ -456,6 +444,7 @@ throw (analyze-seq|throw env form)) ;; TODO support recursion (let [caller|node (analyze* env caller|form) + _ (ppr caller|node) caller|type (:type caller|node) args-ct (count body)] (case (t/compare caller|type t/callable?) @@ -466,8 +455,9 @@ (t/<= caller|type t/+map|built-in?) :map (t/<= caller|type t/+vector|built-in?) :vector (t/<= caller|type t/+set|built-in?) :set - (t/<= caller|type t/fnt?) :fnt (t/<= caller|type t/fn?) :fn + ;; TODO maybe have a better check? + (t/<= caller|type t/fnt?) :fnt ;; If it's callable but not fn, we might have missed something in ;; this dispatch so for now we throw (err! "Don't know how how to handle non-fn callable" @@ -527,6 +517,18 @@ :expanded-form (:form expanded) :expanded expanded}))))) +(defns ?resolve-with-env [sym t/symbol?, env ::env] + (if-let [[_ local] (find env sym)] + {:value local} + (let [resolved (ns-resolve *ns* sym)] + (log/ppr :warn "Not sure how to handle non-local symbol; resolved it for now" + (kw-map sym resolved)) + (ifs resolved + {:value resolved} + (some-> sym namespace symbol resolve class?) + {:value (analyze-seq|dot env (list '. (-> sym namespace symbol) (-> sym name symbol)))} + nil)))) + (defns- analyze-symbol [env ::env, form t/symbol?] (log/pr!) (if-not-let [{resolved :value} (?resolve-with-env form env)] From e1d7bd6dc81be30571834dadbf56546227ea4757 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 26 Jul 2018 12:35:14 -0600 Subject: [PATCH 175/810] Add some documentation and start in on t/fn tests --- .../quantum/untyped/core/analyze/expr.cljc | 1 + test/quantum/test/untyped/core/type/compare.cljc | 16 ++++++++++++++++ 2 files changed, 17 insertions(+) diff --git a/src-untyped/quantum/untyped/core/analyze/expr.cljc b/src-untyped/quantum/untyped/core/analyze/expr.cljc index d80b0afd..fafb1da9 100644 --- a/src-untyped/quantum/untyped/core/analyze/expr.cljc +++ b/src-untyped/quantum/untyped/core/analyze/expr.cljc @@ -1,4 +1,5 @@ (ns quantum.untyped.core.analyze.expr + "An expression is an object whose form is retained and editable to form new objects." (:refer-clojure :exclude [flatten get ==]) (:require diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 57f2fda3..9bf25759 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -780,3 +780,19 @@ (test-comparison 0 t/any? t/universal-set) (testing "universal class(-set) identity" (is (t/= t/val? (& t/any? t/val?))))) + +;; TODO incorporate into the other test? +(deftest test|fn + #_"What does it mean to compare with a `t/fn`? + t/fn A could be t/<= w.r.t. t/fn B if A's input types are t/>= B's and A's output types t/<= B's. + + When we compare a t/fn to another t/fn, we are comparing sets of capabilities. + If you give t/fn #1 A, B, and C, can t/fn #2 handle it too?" + (test-comparison 0 (t/fn []) + (t/fn [])) + (test-comparison -1 (t/fn []) + (t/fn [] [t/any?])) + (test-comparison 0 (t/fn [] [t/any?]) + (t/fn [] [t/any?])) + (test-comparison -1 (t/fn [t/any?]) + (t/fn [] [t/any?]))) From 40759bfdc1bdcf0aa988c92e5f09ecdc15bb6430 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 27 Jul 2018 12:45:04 -0600 Subject: [PATCH 176/810] Update doc --- doc/cljc/quantum/core/defnt.md | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/doc/cljc/quantum/core/defnt.md b/doc/cljc/quantum/core/defnt.md index e934e19b..41a838c5 100644 --- a/doc/cljc/quantum/core/defnt.md +++ b/doc/cljc/quantum/core/defnt.md @@ -255,7 +255,7 @@ Take the below code: It is infeasible to do inferences in the general case for the following reasons: - The code will be complex and greatly increase time it takes to get any value out of `defnt` - The code will likely have high computational complexity even if some impressive algorithm comes out of it -- Even if the code could do it instantly, it would still be a maintenance issue to try to mentally work out for each inference what that ends up being. Labels help quite a lot. +- **Even if the code could do it instantly, it would still be a maintenance issue to try to mentally work out for each inference what that ends up being. Labels help quite a lot.** I think the best approach is not inference, but rather being able to at least do: - Input/output specs that rely on the input/output specs of other spec'ed fns @@ -265,13 +265,13 @@ Thus the code turns into: *(TODO: conditionally optional arities etc.)* ```clojure -(t/def rf? "Reducing function" - (t/fn [ {:doc "seed arity"}] - [_ {:doc "completing arity"}] - [_ _ {:doc "reducing arity"}])) +(def rf? "Reducing function" + (t/fn [ {:doc "seed arity"}] + [:_ {:doc "completing arity"}] + [:_ :_ {:doc "reducing arity"}])) -(t/def xf? "Transforming function" - (t/fn [rf? > rf?])) +(def xf? "Transforming function" + (t/fn [rf? :> rf?])) (defnt transduce ([ f rf?, xs t/reducible?] (transduce identity f xs)) From c5856e8a50e877a4bfc852a3353f0c7c4946060c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 27 Jul 2018 12:45:18 -0600 Subject: [PATCH 177/810] Clean up `t/fn` a little --- src-untyped/quantum/untyped/core/type.cljc | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index cab521a8..3c8d0436 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -461,16 +461,18 @@ fipp.ednize/IEdn {-edn ([this] (list `fn name lookup))}})) (udt/deftype FnType - [arg] + [arities] {PType nil fipp.ednize/IOverride nil - fipp.ednize/IEdn {-edn ([this] (list `fn arg))}}) + fipp.ednize/IEdn {-edn ([this] (list `fn arities))}}) (defns fn-type? [x _ > c/boolean?] (instance? FnType x)) +(defns fn-type>arities [^FnType x fn-type?] (.-arities x)) + (defn fn - [arg & args ] ; TODO fix — & args should have been sufficient but `defnt` has a bug that way - (FnType. (cons arg args)) + [arity & arities] ; TODO fix — & args should have been sufficient but `defnt` has a bug that way + (FnType. (cons arity arities)) #_[name- (s/nilable c/symbol?) lookup _ #_(t/map-of t/integer? (t/or (spec spec? "output-spec") From 4fb5a1039dcf085b3e66157b17de174bdaa4d950 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 27 Jul 2018 12:45:32 -0600 Subject: [PATCH 178/810] Begin to flesh out `test|fn` --- .../test/untyped/core/type/compare.cljc | 268 +++++++++++++++++- 1 file changed, 253 insertions(+), 15 deletions(-) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 9bf25759..4ada4781 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -15,6 +15,7 @@ :refer [deftest testing is is= throws]] [quantum.untyped.core.type :as t :refer [& | !]] + [quantum.untyped.core.type.compare :as tcomp] [quantum.untyped.core.type.reifications :as utr] [quantum.untyped.core.defnt :refer [defns]])) @@ -569,7 +570,8 @@ (testing "Extensible Concrete" (test-comparison -1 a (& t/iterable? (t/isa? java.util.RandomAccess)))) (testing "Abstract" - (test-comparison -1 (t/isa? java.util.AbstractMap$SimpleEntry) (& (t/isa? java.util.Map$Entry) (t/isa? java.io.Serializable)))) + (test-comparison -1 (t/isa? java.util.AbstractMap$SimpleEntry) + (& (t/isa? java.util.Map$Entry) (t/isa? java.io.Serializable)))) (testing "Interface" (test-comparison -1 i|a (& i|>a0 i|>a1)))) (testing "#{<}" @@ -589,7 +591,8 @@ (testing "#{< ><}" (test-comparison 2 i|a (& i|>a+b i|>a0 i|>a1 i|><0 i|><1))) (testing "#{< >< <>}" - (test-comparison 2 t/java-set? (& t/java-coll? t/char-seq? (t/isa? java.nio.ByteBuffer)))) + (test-comparison 2 t/java-set? (& t/java-coll? t/char-seq? + (t/isa? java.nio.ByteBuffer)))) (testing "#{< <>}" (test-comparison 3 t/string? (& t/char-seq? t/java-set?)) (test-comparison 3 ><0 (& (! ><1) (! ><0))) @@ -783,16 +786,251 @@ ;; TODO incorporate into the other test? (deftest test|fn - #_"What does it mean to compare with a `t/fn`? - t/fn A could be t/<= w.r.t. t/fn B if A's input types are t/>= B's and A's output types t/<= B's. - - When we compare a t/fn to another t/fn, we are comparing sets of capabilities. - If you give t/fn #1 A, B, and C, can t/fn #2 handle it too?" - (test-comparison 0 (t/fn []) - (t/fn [])) - (test-comparison -1 (t/fn []) - (t/fn [] [t/any?])) - (test-comparison 0 (t/fn [] [t/any?]) - (t/fn [] [t/any?])) - (test-comparison -1 (t/fn [t/any?]) - (t/fn [] [t/any?]))) + #_"When we compare a t/fn to another t/fn, we are comparing set extensionality, as always. + If we take the Wiener–Hausdorff–Kuratowski definition of a function as our definition of + choice, then we may model a function as a set of ordered pairs, each of whose first element + consists of an ordered tuple of inputs, and whose second element consists of one output. Thus + under this model, if we wish to compare the extension of two functions, it would be in error + to compare the extension of their inputs and the extension of their outputs separately. + + That said, it's not clear how useful this sort of comparison is. + Furthermore, is it the case that `(t/< [[] t/any?] (t/fn []))`? Intuitively it doesn't seem + like it should be, but under the WHK model it nevertheless seems to be the case. + + So we opt to make `t/fn`s `t/compare`-able only with what its underlying function object is + `t/compare`-able with, and introduce instead a `t/compare|input` and `t/compare|output`. + See `quantum.test.untyped.core.type.compare` for how these sorts of comparisons are supposed + to behave. + " + ;; [0 1 2] means t/compare|input is 0, t/compare|output is 1, and t/compare is 2 + (testing "input arities <" + (testing "input types <" + (testing "output <" + (test-comparison|fn [-1 -1 -1] (t/fn [t/boolean? :> t/boolean?]) + (t/fn [] [t/any?]))) + (testing "output =" + (test-comparison|fn [-1 0 ?] (t/fn [t/boolean?]) + (t/fn [] [t/any?]))) + (testing "output >" + (test-comparison|fn [-1 1 2] (t/fn [t/boolean?]) + (t/fn [] [t/any? :> t/boolean?]))) + (testing "output ><" + (test-comparison|fn [-1 2 2] (t/fn [t/boolean? :> i|><0]) + (t/fn [] [t/any? :> i|><1]))) + (testing "output <>" + (test-comparison|fn [-1 3 2] (t/fn [t/boolean? :> t/boolean?]) + (t/fn [] [t/any? :> t/long?])))) + (testing "input types =" + (testing "output <" + (test-comparison|fn [-1 -1 -1] (t/fn [:> t/boolean?]) + (t/fn [] [t/any?]))) + (testing "output =" + (test-comparison|fn [-1 0 ?] (t/fn []) + (t/fn [] [t/any?]))) + (testing "output >" + (test-comparison|fn [-1 1 2] (t/fn []) + (t/fn [:> t/boolean?] [t/any? :> t/long?]))) + (testing "output ><") + (testing "output <>")) + (testing "input types >" + (testing "output <") + (testing "output =" + (test-comparison|fn [ 2 0 ?] (t/fn [t/any?]) + (t/fn [] [t/boolean?]))) + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "input types ><" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "input types <>" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>"))) + (testing "input arities =" + (testing "input types <" + (testing "output <" + (test-comparison|fn [-1 -1 -1] (t/fn [t/boolean? :> t/boolean?]) + (t/fn [t/any?]))) + (testing "output =" + (test-comparison|fn [-1 0 -1] (t/fn [t/boolean?]) + (t/fn [t/any?]))) + (testing "output >" + (test-comparison|fn [-1 1 2] (t/fn [t/boolean?]) + (t/fn [t/any? :> t/boolean?]))) + (testing "output ><" + (test-comparison|fn [-1 2 2] (t/fn [t/boolean? :> i|><0]) + (t/fn [t/any? :> i|><1]))) + (testing "output <>" + (test-comparison|fn [-1 3 ?] (t/fn [t/boolean? :> i|><0]) + (t/fn [t/any? :> i|><1])))) + (testing "input types =" + (testing "output <") + (testing "output =" + (test-comparison|fn [ 0 0 0] (t/fn []) + (t/fn []))) + (testing "output >" + (test-comparison|fn [ 0 1 1] (t/fn []) + (t/fn [:> t/boolean?]))) + (testing "output ><") + (testing "output <>")) + (testing "input types >" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "input types ><" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "input types <>" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>"))) + (testing "input arities >" + (testing "input types <" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "input types =" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "input types >" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "input types ><" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "input types <>" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>"))) + (testing "input arities ><" + (testing "input types <" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "input types =" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "input types >" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "input types ><" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "input types <>" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>"))) + (testing "input arities <>" + (testing "input types <" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "input types =" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "input types >" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "input types ><" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "input types <>" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")))) + +(require '[quantum.untyped.core.data.bits :as ubit]) +(let [cs [0 0]] + (first + (reduce + (fn [[ret found] c] + (let [found' (-> found (ubit/conj c) long)] + (ifs (ubit/contains? found' tcomp/ident) + (ubit/contains? found' tcomp/<>ident))) + [tcomp/>arity|x0 (->> x0 fn>arities (group-by arity>count) (c/map-vals' first)) + ct->arity|x1 (->> x1 fn>arities (group-by arity>count) (c/map-vals' first)) + arity-cts-only-in-x0 (uset/- (-> ct->arity|x0 keys set) (-> ct->arity|x1 keys set)) + arity-cts-only-in-x1 (uset/- (-> ct->arity|x1 keys set) (-> ct->arity|x0 keys set))] + (->> ct->arity|x0 + (filter (fn-> first ct->arity|x1)) + (map (fn [ct arity|x0] (combine-in-some-way + (c/lmap t/compare arity|x0 (ct->arity|x1 ct))))) + combine-in-some-possibly-other-way))) + +(defns compare|output [x0 t/fnt-type?, x1 t/fnt-type?] + (t/compare (->> x0 fn>arities (c/lmap fn|arity>output) (apply t/or)) + (->> x1 fn>arities (c/lmap fn|arity>output) (apply t/or)))) + +(defns compare|fn+fn [x0 t/fnt-type?, x1 t/fnt-type?] + (combine-comparisons-in-a-tand???-sort-of-way ; maybe the combination is similar (or the same?) to the above not-yet-fleshed-out combination fns + (compare|input x0 x1) + (compare|output x0 x1))) From 6d58b2c9b53dd8adce19be7dc07baa4d23ea928e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 14 Aug 2018 14:43:41 -0600 Subject: [PATCH 179/810] Add more complete comparison logic to `ucomp` --- src-untyped/quantum/untyped/core/compare.cljc | 53 ++++++++++++++++--- 1 file changed, 45 insertions(+), 8 deletions(-) diff --git a/src-untyped/quantum/untyped/core/compare.cljc b/src-untyped/quantum/untyped/core/compare.cljc index e2bc2672..427e1577 100644 --- a/src-untyped/quantum/untyped/core/compare.cljc +++ b/src-untyped/quantum/untyped/core/compare.cljc @@ -2,23 +2,60 @@ (:refer-clojure :exclude [==]) (:require [quantum.untyped.core.core :as ucore - :refer [defaliases]])) + :refer [defaliases]] + [quantum.untyped.core.fn + :refer [fn']])) (ucore/log-this-ns) (def == identical?) (def not== (comp not identical?)) +(def ^:const ident 1) +(def ^:const >ident 3) + +(def comparisons #{ident >ident}) +(def comparison? comparisons) + +(defn invert [c #_comparison? #_> #_comparison?] + (case c + -1 >ident + 1 = [c] (or (= c >ident) (= c =ident))) +(defn comparison> [c] (= c >ident)) +(defn comparison>< [c] (= c > [c] (= c <>ident)) + +(defn compf< [compf x0 x1] (comparison< (compf x0 x1))) +(defn compf<= [compf x0 x1] (comparison<= (compf x0 x1))) +(defn compf= [compf x0 x1] (comparison= (compf x0 x1))) +(defn compf-not= [compf x0 x1] (comparison-not= (compf x0 x1))) +(defn compf>= [compf x0 x1] (comparison>= (compf x0 x1))) +(defn compf> [compf x0 x1] (comparison> (compf x0 x1))) +(defn compf>< [compf x0 x1] (comparison>< (compf x0 x1))) +(defn compf<> [compf x0 x1] (comparison<> (compf x0 x1))) + +(defn comp< [x0 x1] (compf< compare x0 x1)) +(defn comp<= [x0 x1] (compf<= compare x0 x1)) +(defn comp= [x0 x1] (compf= compare x0 x1)) +(defn comp-not= [x0 x1] (compf-not= compare x0 x1)) +(defn comp>= [x0 x1] (compf>= compare x0 x1)) +(defn comp> [x0 x1] (compf> compare x0 x1)) +(defn comp>< [x0 x1] (compf>< compare x0 x1)) +(defn comp<> [x0 x1] (compf<> compare x0 x1)) + (def class->comparator {#?@(:clj [Class (fn [^Class a ^Class b] (.compareTo (.getName a) (.getName b)))])}) -(defn invert [c] - (case c - nil c - 0 c - -1 1 - 1 -1)) - (defaliases ucore seq= code=) From 83fdafb343a8a065575c75ddaa08660f1b944d64 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 14 Aug 2018 14:44:11 -0600 Subject: [PATCH 180/810] Add set comparison logic --- .../quantum/untyped/core/data/set.cljc | 51 +++++++++++++++++-- 1 file changed, 46 insertions(+), 5 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/set.cljc b/src-untyped/quantum/untyped/core/data/set.cljc index 33a808c2..1ed7502a 100644 --- a/src-untyped/quantum/untyped/core/data/set.cljc +++ b/src-untyped/quantum/untyped/core/data/set.cljc @@ -1,12 +1,15 @@ (ns quantum.untyped.core.data.set - (:refer-clojure :exclude [not]) + (:refer-clojure :exclude [- +, not < <= >= >]) (:require #?@(:clj [[seqspert.hash-set]]) - [clojure.core :as core] - [clojure.set :as set] - [linked.core :as linked] - [quantum.untyped.core.core :as ucore])) + [clojure.core :as core] + [clojure.set :as set] + [linked.core :as linked] + [quantum.untyped.core.compare :as ucomp] + [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.vars + :refer [defalias]])) (ucore/log-this-ns) @@ -17,6 +20,11 @@ (def not complement) +; (and a (not b)) +(defalias differencel set/difference) +(defalias - differencel) +(defalias relative-complement differencel) + #?(:clj (defn union "337.050528 msecs (core/union s1 s2) @@ -34,3 +42,36 @@ ([s0 s1 & ss] (reduce union (union s0 s1) ss))) :cljs (def union set/union)) + +(defalias + union) + +;; ===== Comparison ===== ;; + +(defn compare [s0 #_set?, s1 #_set?] + (if (empty? s0) + (if (empty? s1) ucomp/=ident ucomp/<>ident) + (if (empty? s1) + ucomp/<>ident + ;; TODO do fewer comparisons here + (let [diff0 (- s0 s1), diff1 (- s1 s0)] + (if (empty? diff0) + (if (empty? diff1) + ucomp/=ident + ucomp/ident + (if (some #(contains? s1 %) s0) + ucomp/>ident))))))) + +(defn < [x0 x1] (ucomp/compf< compare x0 x1)) +(defalias proper-subset? <) +(defn <= [x0 x1] (ucomp/compf<= compare x0 x1)) +(defalias subset? <=) +(defn >= [x0 x1] (ucomp/compf>= compare x0 x1)) +(defalias superset? >=) +(defn > [x0 x1] (ucomp/compf> compare x0 x1)) +(defalias proper-superset? >) +(defn >< [x0 x1] (ucomp/compf>< compare x0 x1)) +(defn <> [x0 x1] (ucomp/compf<> compare x0 x1)) +(defalias disjoint? >) From 939b347a2d06d5c0ce680e0e8785d4e32bfb11a9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 14 Aug 2018 14:44:48 -0600 Subject: [PATCH 181/810] Extract `xset?` and alias --- src/quantum/core/data/set.cljc | 32 ++++++-------------------------- 1 file changed, 6 insertions(+), 26 deletions(-) diff --git a/src/quantum/core/data/set.cljc b/src/quantum/core/data/set.cljc index 3d655d28..67789bad 100644 --- a/src/quantum/core/data/set.cljc +++ b/src/quantum/core/data/set.cljc @@ -4,14 +4,14 @@ :attribution "alexandergunnarson"} quantum.core.data.set (:refer-clojure :exclude - [+ - and or not split-at hash-set]) + [+ -, and or not, compare, split-at hash-set]) (:require [clojure.core :as core] [clojure.set :as set] [clojure.data.avl :as avl] [linked.core :as linked] [quantum.core.vars :as var - :refer [defalias]] + :refer [defalias defaliases]] [quantum.core.error :as err :refer [>ex-info TODO]] [quantum.core.fn :as fn] @@ -72,26 +72,9 @@ {:see-also "net/openhft/chronicle/algo/bitset/ConcurrentFlatBitSetFrame"} [& args] (TODO))) -; ============ PREDICATES ============ - -(defn xset? - {:attribution "alexandergunnarson" - :todo ["A cool idea... but improve performance"]} - [fn-key set1 set2] - (let [funcs - (case fn-key - :sub {:eq <= :fn #(vector (partial contains? %2) %1)} - :super {:eq >= :fn #(vector (partial contains? %1) %2)} - :proper-sub {:eq < :fn #(vector %2 %1)} - :proper-super {:eq > :fn #(vector %1 %2)})] - (core/and ((:eq funcs) (count set1) (count set2)) - (apply every? ((:fn funcs) set1 set2))))) - -#_(def subset? #(xset? :sub %1 %2)) -(defalias subset? set/subset?) -(def superset? #(xset? :super %1 %2)) -(def proper-subset? #(xset? :proper-sub %1 %2)) -(def proper-superset? #(xset? :proper-super %1 %2)) +;; ===== Comparison ===== ;; + +(defaliases u compare < proper-subset? <= subset? >= superset? > proper-superset?) ; ============ OPERATIONS ============ @@ -130,10 +113,7 @@ (defalias and intersection ) ; (and a (not b)) -(defalias difference set/difference ) -(defalias - difference ) -(defalias relative-complement difference ) -(defalias differencel difference ) +(defaliases u - relative-complement differencel) (def differencer (fn/reversea differencel)) From 79330d4d6f8c4109a71ea525cda971a5a19998fd Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 14 Aug 2018 14:45:26 -0600 Subject: [PATCH 182/810] Better `t/fn` --- src-untyped/quantum/untyped/core/type.cljc | 64 +++++-------------- .../untyped/core/type/reifications.cljc | 31 ++++++++- 2 files changed, 45 insertions(+), 50 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 3c8d0436..bb189392 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -50,7 +50,7 @@ :refer [educe join]] [quantum.untyped.core.refs :refer [?deref]] - [quantum.untyped.core.spec :as s] + [quantum.untyped.core.spec :as us] [quantum.untyped.core.type.compare :as utc :refer [ident >ident]] [quantum.untyped.core.type.core :as utcore] @@ -73,7 +73,8 @@ UniversalSetType EmptySetType NotType OrType AndType ProtocolType ClassType - ValueType]))) + ValueType + FnType]))) (ucore/log-this-ns) @@ -97,7 +98,7 @@ ;; ===== Comparison ===== ;; -(uvar/defaliases utc compare < <= = not= >= > >< <> inverse) +(uvar/defaliases utc compare compare|in compare|out < <= = not= >= > >< <> inverse) ;; ===== Type Reification Constructors ===== ;; @@ -195,7 +196,7 @@ 0 empty-set 1 (first args) (OrType. uhash/default uhash/default args (atom nil)))))))))) - ([t0 utr/type?, t1 utr/type? & ts (s/seq-of utr/type?) > utr/type?] (reduce - (- t0 t1) ts))) + ([t0 utr/type?, t1 utr/type? & ts (us/seq-of utr/type?) > utr/type?] (reduce - (- t0 t1) ts))) (defn isa? [x] (ifs (utpred/protocol? x) @@ -208,7 +209,7 @@ (defns >type "Coerces ->`x` to a type, recording its ->`name-sym` if provided." ([x _ > utr/type?] (>type x nil)) - ([x _, name-sym (s/nilable c/symbol?) > utr/type?] + ([x _, name-sym (us/nilable c/symbol?) > utr/type?] #?(:clj (ifs (satisfies? PType x) @@ -442,48 +443,13 @@ "Creates a type that ... TODO" [pred (<= iterable?), t utr/type?] (TODO)) -;; TODO do this -#_(do - -(udt/deftype FnType - [name #_(t/? t/symbol?) - dispatch ... - meta] - {PType nil - ;; Outputs whether the args match any input spec - ?Fn {invoke ([this args] - (if-let [arity-specs (get lookup (count args))] - (->> arity-specs (uc/map+ first) (seq-or #(% args))) - false))} - ?Meta {meta ([this] meta) - with-meta ([this meta'] (FnSpec. name lookup spec meta'))} - fipp.ednize/IOverride nil - fipp.ednize/IEdn {-edn ([this] (list `fn name lookup))}})) - -(udt/deftype FnType - [arities] - {PType nil - fipp.ednize/IOverride nil - fipp.ednize/IEdn {-edn ([this] (list `fn arities))}}) - -(defns fn-type? [x _ > c/boolean?] (instance? FnType x)) - -(defns fn-type>arities [^FnType x fn-type?] (.-arities x)) - -(defn fn - [arity & arities] ; TODO fix — & args should have been sufficient but `defnt` has a bug that way - (FnType. (cons arity arities)) - #_[name- (s/nilable c/symbol?) - lookup _ #_(t/map-of t/integer? - (t/or (spec spec? "output-spec") - (t/vec-of (t/tuple (t/vec-of (spec spec? "input-spec")) - (spec spec? "output-spec")))))] - #_(let [spec (->> lookup vals - (uc/map+ (c/fn [spec-or-arity-specs] - (if (spec? spec-or-arity-specs) - spec-or-arity-specs - (->> spec-or-arity-specs (map (TODO)))))))] - (FnType. name- lookup spec nil))) +(defn fn [arity & arities] ; TODO fix — & args should have been sufficient but `defnt` has a bug that way + (let [name- nil + arities-form (cons arity arities) + arities (->> arities-form + (uc/map+ #(us/conform ::fn-type|arity %)) + (uc/group-by #(-> % :input-types count)))] + (FnType. name- arities-form arities))) (defn unkeyed "Creates an unkeyed collection type, in which the collection may @@ -518,7 +484,7 @@ #?(:clj (def primitive-classes (->> unboxed-symbol->type-meta vals (uc/map+ :unboxed) (join #{})))) (defns- -type>classes - [t utr/type?, classes c/set? > (s/set-of (s/nilable #?(:clj c/class? :cljs c/fn?)))] + [t utr/type?, classes c/set? > (us/set-of (us/nilable #?(:clj c/class? :cljs c/fn?)))] (cond (utr/class-type? t) (conj classes (utr/class-type>class t)) (utr/value-type? t) @@ -540,7 +506,7 @@ (defns type>classes "Outputs the set of all the classes ->`t` can embody according to its various conditional branches, if any. Ignores nils, treating in Clojure simply as a `java.lang.Object`." - [t utr/type? > (s/set-of (s/nilable #?(:clj c/class? :cljs c/fn?)))] (-type>classes t #{})) + [t utr/type? > (us/set-of (us/nilable #?(:clj c/class? :cljs c/fn?)))] (-type>classes t #{})) #?(:clj (defns- -type>?class-value [t utr/type?, type-nilable? c/boolean?] diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index ea28f507..479d8117 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -2,6 +2,7 @@ (:refer-clojure :exclude [==]) (:require + [clojure.set :as set] [fipp.ednize :as fedn] [quantum.untyped.core.analyze.expr #?@(:cljs [:refer [Expression]])] @@ -9,11 +10,15 @@ :refer [== not==]] [quantum.untyped.core.core :as ucore] [quantum.untyped.core.data.hash :as uhash] + [quantum.untyped.core.defnt :refer [defns]] + [quantum.untyped.core.error + :refer [TODO]] [quantum.untyped.core.form :as uform :refer [>form]] - [quantum.untyped.core.form.generate.deftype :as udt]) + [quantum.untyped.core.form.generate.deftype :as udt] + [quantum.untyped.core.spec :as us]) #?(:clj (:import [quantum.untyped.core.analyze.expr Expression]))) @@ -218,3 +223,27 @@ (defns value-type? [x _] (instance? ValueType x)) (defns value-type>value [v value-type?] (.-v ^ValueType v)) + +;; ----- FnType ----- ;; + +(udt/deftype FnType + [name arities-form arities] + {PType nil + ;; Outputs whether the args match any input spec + ?Fn {invoke ([this args] (TODO))} + fipp.ednize/IOverride nil + fipp.ednize/IEdn {-edn ([this] (list 'quantum.untyped.core.type/fn arities-form))}}) + +(defns fn-type? [x _ > boolean?] (instance? FnType x)) + +(defns fn-type>arities [^FnType x fn-type?] (.-arities x)) + +(us/def :quantum.untyped.core.type/fn-type|arity + (us/and + (us/cat + :input-types (us/* type?) + :output-type-pair (us/? (us/cat :ident #{:>} :type type?))) + (us/conformer + (fn [x] (-> x (update :output-type-pair #(or (:type %) universal-set)) + (update :input-types vec) + (set/rename-keys {:output-type-pair :output-type})))))) From 832fa686beec77537faef227e89dbf5beef0fdca Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 14 Aug 2018 14:46:13 -0600 Subject: [PATCH 183/810] Add more tests: `test-comparison|set` and the beginning of `test-comparison|fn` --- .../test/untyped/core/type/compare.cljc | 308 ++++++++++-------- 1 file changed, 169 insertions(+), 139 deletions(-) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 4ada4781..6b3389e6 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -3,6 +3,7 @@ [clojure.core :as core] [quantum.untyped.core.analyze.expr :as xp :refer [>expr]] + [quantum.untyped.core.compare :as ucomp] [quantum.untyped.core.data.hash :as uhash] [quantum.untyped.core.fn :refer [fn1]] @@ -160,8 +161,33 @@ [a*# (type>type-combos ~a) b*# (type>type-combos ~b)] ;; Symmetry - (is= c# (t/compare a*# b*#)) - (is= (t/inverse c#) (t/compare b*# a*#)))))) + (is= c# (t/compare a*# b*#)) + (is= (ucomp/invert c#) (t/compare b*# a*#)))))) + +#?(:clj +(defmacro test-comparison|set + "Performs a `t/compare` on `a` and `b`, ensuring that their relationship is symmetric, and that + the inputs are internally commutative if applicable (e.g. if `a` is an `AndType`, ensures that + it is commutative). + The basis comparison is the first input." + [c #_t/comparisons a #_t/type? b #_t/type?] + `(let [c# ~c, a# ~a, b# ~b] + ;; Symmetry + (is= c# (tcomp/compare|set a# b#)) + (is= (ucomp/invert c#) (tcomp/compare|set b# a#))))) + +#?(:clj +(defmacro test-comparison|fn + "Performs a `tcomp/compare|input` and `tcomp/compare|output` on `a` and `b`, ensuring that the + comparison-relationship between `a` and `b` is symmetric. + The basis comparison is the first input." + [[c|out #_t/comparisons, c|in #_t/comparisons] #__, a #_t/type? b #_t/type?] + `(let [c|out# ~c|out, c|in# ~c|in, a# ~a, b# ~b] + ;; Symmetry + (is= c|in# (tcomp/compare|in a# b#)) + (is= (ucomp/invert c|in#) (tcomp/compare|in b# a#)) + (is= c|out# (tcomp/compare|out a# b#)) + (is= (ucomp/invert c|out#) (tcomp/compare|out b# a#))))) (def comparison-combinations ["#{<}" @@ -784,6 +810,24 @@ (testing "universal class(-set) identity" (is (t/= t/val? (& t/any? t/val?))))) +(deftest test|set + (testing "< , >" + (test-comparison|set -1 #{1} #{1 2}) + (test-comparison|set -1 #{1 2} #{1 2 3})) + (testing "=" + (test-comparison|set 0 #{} #{}) + (test-comparison|set 0 #{1} #{1}) + (test-comparison|set 0 #{1 2} #{1 2})) + (testing "><" + (test-comparison|set 2 #{1 2} #{1 3}) + (test-comparison|set 2 #{1 2} #{1 3}) + (test-comparison|set 2 #{1 2 3} #{1 4})) + (testing "<>" + (test-comparison|set 3 #{} #{1}) + (test-comparison|set 3 #{} #{1 2}) + (test-comparison|set 3 #{1} #{2}) + (test-comparison|set 3 #{3} #{1 2}))) + ;; TODO incorporate into the other test? (deftest test|fn #_"When we compare a t/fn to another t/fn, we are comparing set extensionality, as always. @@ -803,40 +847,139 @@ to behave. " ;; [0 1 2] means t/compare|input is 0, t/compare|output is 1, and t/compare is 2 + "Liskov’s Substitution Principle + Contract satisfaction ('Growth') is `t/<=|input` (you cannot require more) and `t/>=|output` + (you cannot guarantee less) + - Inputs + - I require an animal and you give me a sheep: + - `(t/<= sheep? animal?)` + - If I require an animal and you give me a sheep and some wheat, it has to be in an + acceptable open container of some sort (generally a map) because the caller is not + guaranteed to know how to handle it otherwise: + - `(t/<> (t/tuple sheep? wheat?) animal?) + - `(t/<> (t/map :requirement sheep? :extra0 wheat?) animal?) + - `(t/<= (t/closed-map :requirement sheep? :extra0 wheat?) + (t/merge (t/closed-map :requirement animal?) (t/map-of t/keyword? t/any?))) + - `(t/<= (t/map :requirement sheep? :extra0 wheat?) + (t/map :requirement animal?)) + - Outputs + - I guarantee an animal and I provide a sheep: + - `(t/<= sheep? animal?)` + - If I guarantee an animal and I provide a sheep and some wheat, it has to be in an + acceptable open container of some sort (generally a map) because the caller is not + guaranteed to know how to handle it otherwise: + - `(t/<> (t/tuple sheep? wheat?) animal?) + - `(t/<> (t/map :guarantee sheep? :extra0 wheat?) animal?) + - `(t/<= (t/closed-map :guarantee sheep? :extra0 wheat?) + (t/merge (t/closed-map :requirement animal?) (t/map-of t/keyword? t/any?))) + Contract non-satisfaction ('Breakage') is `>=|input` (input covariance) and `t/<=|output` + (output contravariance) + - Inputs + - I require an animal but you give me any old organism + - Outputs + - I guarantee an animal but I provide any old organism + - I guarantee a sheep and some wheat but I provide only a sheep + - (t/?? (t/map :guarantee))" + + ;; For comparing arities: + ;; (This uses set/difference in both directions) + ;; (set/compare (-> f0 fn>arities (map count) set) (-> f1 fn>arities (map count) set)) + + (testing "output <" + (testing "input <" + (test-comparison|fn [-1 -1] (t/fn [t/boolean? :> t/boolean?]) + (t/fn [] + [t/any?]))) + (testing "input =") + (testing "input >") + (testing "input ><") + (testing "input <>")) + (testing "output =" + (testing "input <" + (testing "due to input arity <" + (test-comparison|fn [ 0 -1] (t/fn [t/any?]) + (t/fn [] + [t/any?]))) + (testing "due to input types <" + (test-comparison|fn [ 0 -1] (t/fn [] + [t/boolean?]) + (t/fn [] + [t/any?]))) + (testing "due to input arity and types <" + (test-comparison|fn [ 0 -1] (t/fn [t/boolean?]) + (t/fn [] + [t/any?])))) + (testing "input =" + (test-comparison|fn [ 0 0] (t/fn []) + (t/fn []))) + (testing "input >") + (testing "input ><") + (testing "input <>")) + (testing "output >" + (testing "input <" + (testing "due to input arity <" + (test-comparison|fn [ 1 -1] (t/fn [t/any?]) + (t/fn [] + [t/any? :> t/boolean?]))) + (testing "due to input types <" + (test-comparison|fn [ 1 -1] (t/fn [] + [t/boolean?]) + (t/fn [] + [t/any? :> t/boolean?]))) + (testing "due to input arity and types <" + (test-comparison|fn [ 1 -1] (t/fn [t/boolean?]) + (t/fn [] + [t/any? :> t/boolean?])))) + (testing "input =" + (test-comparison|fn [ 1 0] (t/fn [:> t/boolean?]) + (t/fn [])) + (test-comparison|fn [ 1 0] (t/fn [:> t/boolean?] + [t/any? :> t/boolean?]) + (t/fn [] + [t/any?]))) + (testing "input >") + (testing "input ><") + (testing "input <>")) + (testing "output ><" + (testing "input <" + (test-comparison|fn [ 2 -1] (t/fn [t/boolean? :> i|><0]) + (t/fn [] + [t/any? :> i|><1]))) + (testing "input =") + (testing "input >") + (testing "input ><") + (testing "input <>")) + (testing "output <>" + (testing "input <") + (testing "input =") + (testing "input >") + (testing "input ><") + (testing "input <>")) + (testing "input arities <" (testing "input types <" - (testing "output <" - (test-comparison|fn [-1 -1 -1] (t/fn [t/boolean? :> t/boolean?]) - (t/fn [] [t/any?]))) - (testing "output =" - (test-comparison|fn [-1 0 ?] (t/fn [t/boolean?]) - (t/fn [] [t/any?]))) - (testing "output >" - (test-comparison|fn [-1 1 2] (t/fn [t/boolean?]) - (t/fn [] [t/any? :> t/boolean?]))) - (testing "output ><" - (test-comparison|fn [-1 2 2] (t/fn [t/boolean? :> i|><0]) - (t/fn [] [t/any? :> i|><1]))) (testing "output <>" - (test-comparison|fn [-1 3 2] (t/fn [t/boolean? :> t/boolean?]) - (t/fn [] [t/any? :> t/long?])))) + (test-comparison|fn [-1 3 ?] (t/fn [t/boolean? :> t/boolean?]) + (t/fn [] [t/any? :> t/long?])))) (testing "input types =" (testing "output <" - (test-comparison|fn [-1 -1 -1] (t/fn [:> t/boolean?]) - (t/fn [] [t/any?]))) + (test-comparison|fn [-1 -1 ?] (t/fn [:> t/boolean?]) + (t/fn [] [t/any?]))) (testing "output =" (test-comparison|fn [-1 0 ?] (t/fn []) - (t/fn [] [t/any?]))) + (t/fn [] [t/any?]))) (testing "output >" - (test-comparison|fn [-1 1 2] (t/fn []) + (test-comparison|fn [-1 1 ?] (t/fn []) (t/fn [:> t/boolean?] [t/any? :> t/long?]))) (testing "output ><") (testing "output <>")) (testing "input types >" - (testing "output <") + (testing "output <" + (test-comparison|fn [ 2 -1 ?] (t/fn [t/any?]) + (t/fn [] [t/long?]))) (testing "output =" - (test-comparison|fn [ 2 0 ?] (t/fn [t/any?]) - (t/fn [] [t/boolean?]))) + (test-comparison|fn [ 2 0 ?] (t/fn [t/any?]) + (t/fn [] [t/boolean?]))) (testing "output >") (testing "output ><") (testing "output <>")) @@ -862,7 +1005,7 @@ (t/fn [t/any?]))) (testing "output >" (test-comparison|fn [-1 1 2] (t/fn [t/boolean?]) - (t/fn [t/any? :> t/boolean?]))) + (t/fn [t/any? :> t/boolean?]))) (testing "output ><" (test-comparison|fn [-1 2 2] (t/fn [t/boolean? :> i|><0]) (t/fn [t/any? :> i|><1]))) @@ -872,124 +1015,11 @@ (testing "input types =" (testing "output <") (testing "output =" - (test-comparison|fn [ 0 0 0] (t/fn []) - (t/fn []))) + ) (testing "output >" - (test-comparison|fn [ 0 1 1] (t/fn []) - (t/fn [:> t/boolean?]))) - (testing "output ><") - (testing "output <>")) - (testing "input types >" - (testing "output <") - (testing "output =") - (testing "output >") - (testing "output ><") - (testing "output <>")) - (testing "input types ><" - (testing "output <") - (testing "output =") - (testing "output >") + ) (testing "output ><") (testing "output <>")) - (testing "input types <>" - (testing "output <") - (testing "output =") - (testing "output >") - (testing "output ><") - (testing "output <>"))) - (testing "input arities >" - (testing "input types <" - (testing "output <") - (testing "output =") - (testing "output >") - (testing "output ><") - (testing "output <>")) - (testing "input types =" - (testing "output <") - (testing "output =") - (testing "output >") - (testing "output ><") - (testing "output <>")) - (testing "input types >" - (testing "output <") - (testing "output =") - (testing "output >") - (testing "output ><") - (testing "output <>")) - (testing "input types ><" - (testing "output <") - (testing "output =") - (testing "output >") - (testing "output ><") - (testing "output <>")) - (testing "input types <>" - (testing "output <") - (testing "output =") - (testing "output >") - (testing "output ><") - (testing "output <>"))) - (testing "input arities ><" - (testing "input types <" - (testing "output <") - (testing "output =") - (testing "output >") - (testing "output ><") - (testing "output <>")) - (testing "input types =" - (testing "output <") - (testing "output =") - (testing "output >") - (testing "output ><") - (testing "output <>")) - (testing "input types >" - (testing "output <") - (testing "output =") - (testing "output >") - (testing "output ><") - (testing "output <>")) - (testing "input types ><" - (testing "output <") - (testing "output =") - (testing "output >") - (testing "output ><") - (testing "output <>")) - (testing "input types <>" - (testing "output <") - (testing "output =") - (testing "output >") - (testing "output ><") - (testing "output <>"))) - (testing "input arities <>" - (testing "input types <" - (testing "output <") - (testing "output =") - (testing "output >") - (testing "output ><") - (testing "output <>")) - (testing "input types =" - (testing "output <") - (testing "output =") - (testing "output >") - (testing "output ><") - (testing "output <>")) - (testing "input types >" - (testing "output <") - (testing "output =") - (testing "output >") - (testing "output ><") - (testing "output <>")) - (testing "input types ><" - (testing "output <") - (testing "output =") - (testing "output >") - (testing "output ><") - (testing "output <>")) - (testing "input types <>" - (testing "output <") - (testing "output =") - (testing "output >") - (testing "output ><") - (testing "output <>")))) (require '[quantum.untyped.core.data.bits :as ubit]) (let [cs [0 0]] From 88109032595c36ef921de85e139b6fdd3cad7787 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 14 Aug 2018 14:46:28 -0600 Subject: [PATCH 184/810] Beginnings of `compare|fn` --- .../quantum/untyped/core/type/compare.cljc | 58 ++++++++++--------- 1 file changed, 31 insertions(+), 27 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index 459a25df..1de50422 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -10,10 +10,11 @@ :refer [seq-and seq-or]] ;; TODO remove this dependency [quantum.untyped.core.classes :as uclass] - [quantum.untyped.core.compare - :refer [==]] + [quantum.untyped.core.compare :as ucomp + :refer [== ident >ident comparison?]] [quantum.untyped.core.core :as ucore] [quantum.untyped.core.data.bits :as ubit] + [quantum.untyped.core.data.set :as uset] [quantum.untyped.core.defnt :refer [defns defns-]] [quantum.untyped.core.error @@ -30,6 +31,7 @@ not-type? or-type? and-type? protocol-type? class-type? value-type? + fn-type? #?@(:cljs [UniversalSetType EmptySetType NotType OrType AndType ProtocolType ClassType @@ -50,27 +52,12 @@ ;; ===== (Comparison) idents ===== ;; -(def ^:const ident 1) -(def ^:const >ident 3) - (def- fn< (fn' (fn' >ident)) (def- fn>< (fn' > (fn' <>ident)) -(def comparisons #{ident >ident}) -(def comparison? comparisons) - -(defns inverse [comparison comparison? > comparison?] - (case comparison - -1 >ident - 1 `t0` is a strict subset of that of ->`t1`." ([t1 type?] #(< % t1)) - ([t0 type?, t1 type? > boolean?] (c/= (compare t0 t1) boolean?] (ucomp/compf< compare t0 t1))) (defns <= "Computes whether the extension of type ->`t0` is a (lax) subset of that of ->`t1`." ([t1 type?] #(<= % t1)) - ([t0 type?, t1 type? > boolean?] - (let [ret (compare t0 t1)] (or (c/= ret boolean?] (ucomp/compf<= compare t0 t1))) (defns = "Computes whether the extension of type ->`t0` is equal to that of ->`t1`." ([t1 type?] #(= % t1)) - ([t0 type?, t1 type? > boolean?] (c/= (compare t0 t1) =ident))) + ([t0 type?, t1 type? > boolean?] (ucomp/compf= compare t0 t1))) (defns not= "Computes whether the extension of type ->`t0` is not equal to that of ->`t1`." ([t1 type?] #(not= % t1)) - ([t0 type?, t1 type? > boolean?] (not (= t0 t1)))) + ([t0 type?, t1 type? > boolean?] (ucomp/compf-not= compare t0 t1))) (defns >= "Computes whether the extension of type ->`t0` is a (lax) superset of that of ->`t1`." ([t1 type?] #(>= % t1)) - ([t0 type?, t1 type? > boolean?] - (let [ret (compare t0 t1)] (or (c/= ret >ident) (c/= ret =ident))))) + ([t0 type?, t1 type? > boolean?] (ucomp/compf>= compare t0 t1))) (defns > "Computes whether the extension of type ->`t0` is a strict superset of that of ->`t1`." ([t1 type?] #(> % t1)) - ([t0 type?, t1 type? > boolean?] (c/= (compare t0 t1) >ident))) + ([t0 type?, t1 type? > boolean?] (ucomp/compf> compare t0 t1))) (defns >< "Computes whether it is the case that the intersect of the extensions of type ->`t0` and ->`t1` is non-empty, and neither ->`t0` nor ->`t1` share a subset/equality/superset relationship." ([t1 type?] #(>< % t1)) - ([t0 type?, t1 type? > boolean?] (c/= (compare t0 t1) > boolean?] (ucomp/compf>< compare t0 t1))) (defns <> "Computes whether the respective extensions of types ->`t0` and ->`t1` are disjoint." ([t1 type?] #(<> % t1)) - ([t0 type? t1 type? > boolean?] (c/= (compare t0 t1) <>ident))) + ([t0 type? t1 type? > boolean?] (ucomp/compf<> compare t0 t1))) + +;; ===== FnType ===== ;; + +(do + (defns compare|in [t0 fn-type?, t1 fn-type?] + (let [a0 (utr/fn-type>arities t0) + a1 (utr/fn-type>arities t1) + arglist-count-comparison (uset/compare (-> a0 keys set) (-> a1 keys set))] + arglist-count-comparison)) + (compare|in + (quantum.untyped.core.type/fn + []) + (quantum.untyped.core.type/fn + [] + [quantum.untyped.core.type/any?]))) + + + +(defns compare|out [t0 fn-type?, t1 fn-type?] 3) From 2d0ef9ff10889969045e8a1135a6dd98b1900e7c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 15 Aug 2018 22:25:45 -0600 Subject: [PATCH 185/810] `logic/xor` --- src-untyped/quantum/untyped/core/logic.cljc | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/logic.cljc b/src-untyped/quantum/untyped/core/logic.cljc index fb237f70..bb266689 100644 --- a/src-untyped/quantum/untyped/core/logic.cljc +++ b/src-untyped/quantum/untyped/core/logic.cljc @@ -40,14 +40,20 @@ #?(:clj (defmacro nor [& args] `(not (or ~@args)))) +;; NOTE: n-ary `xor` is true when the number of 1-bits is odd. +;; The below implements "some but not all" as in `(and (some identity args) (not (every? identity args)))` #?(:clj (defmacro xor {:attribution 'alexandergunnarson} ([] nil) - ([x] false) - ([x y] (if x (not y) y)) - ([x y & next] - `(if ~x (when-not (and ~y ~@next) ~x) (xor ~y ~@next))))) + ([a] false) + ([a b] `(let [a# ~a b# ~b] (if a# (not b#) b#))) + ([a b & next] + `(let [a# ~a b# ~b] + (if a# + (when-not (and b# ~@next) a#) + (xor b# ~@next)))))) + ;; TODO `xnor` #?(:clj (declare xnor)) From f7d57742640687373d75938bf52a58e1027519b1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 31 Aug 2018 17:23:28 -0600 Subject: [PATCH 186/810] Fix compilation --- src-untyped/quantum/untyped/core/type.cljc | 13 ++++++------- src-untyped/quantum/untyped/core/type/compare.cljc | 4 +--- 2 files changed, 7 insertions(+), 10 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index bb189392..51d25258 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -24,8 +24,8 @@ [quantum.untyped.core.collections :as uc] [quantum.untyped.core.collections.logic :refer [seq-and seq-or]] - [quantum.untyped.core.compare - :refer [==]] + [quantum.untyped.core.compare :as ucomp + :refer [== ident >ident]] [quantum.untyped.core.convert :refer [>symbol]] [quantum.untyped.core.core :as ucore] @@ -51,8 +51,7 @@ [quantum.untyped.core.refs :refer [?deref]] [quantum.untyped.core.spec :as us] - [quantum.untyped.core.type.compare :as utc - :refer [ident >ident]] + [quantum.untyped.core.type.compare :as utcomp] [quantum.untyped.core.type.core :as utcore] [quantum.untyped.core.type.defs :as utdef] [quantum.untyped.core.type.predicates :as utpred] @@ -98,7 +97,7 @@ ;; ===== Comparison ===== ;; -(uvar/defaliases utc compare compare|in compare|out < <= = not= >= > >< <> inverse) +(uvar/defaliases utcomp compare compare|in compare|out < <= = not= >= > >< <>) ;; ===== Type Reification Constructors ===== ;; @@ -326,7 +325,7 @@ (defns complementary? [t0 utr/type? t1 utr/type?] (= t0 (not t1))) (defns- create-logical-type|inner|or - [{:as accum :keys [t' utr/type?]} _, t* utr/type?, c* utc/comparison?] + [{:as accum :keys [t' utr/type?]} _, t* utr/type?, c* ucomp/comparison?] (if #?(:clj (c/or (c/and (c/= t' object?) (c/= t* nil?)) (c/and (c/= t* object?) (c/= t' nil?))) :cljs false) @@ -342,7 +341,7 @@ (defns- create-logical-type|inner|and [{:as accum :keys [conj-t? c/boolean?, prefer-orig-args? c/boolean?, t' utr/type?, types _]} _ - t* utr/type?, c* utc/comparison?] + t* utr/type?, c* ucomp/comparison?] (if ;; Contradiction/empty-set: (& A (! A)) (c/or (c/= c* <>ident) ; optimization before `complementary?` (complementary? t' t*)) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index 1de50422..dea49166 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -294,7 +294,7 @@ ;; TODO take away var indirection once done (def- compare|dispatch - (let [inverted (fn [f] (fn [t0 t1] (inverse (f t1 t0))))] + (let [inverted (fn [f] (fn [t0 t1] (ucomp/invert (f t1 t0))))] {UniversalSetType {UniversalSetType #'fn= EmptySetType #'compare|universal+empty @@ -462,6 +462,4 @@ [] [quantum.untyped.core.type/any?]))) - - (defns compare|out [t0 fn-type?, t1 fn-type?] 3) From 4525d43978bc6c926e9c3fe1f54d424478e13702 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 31 Aug 2018 17:23:43 -0600 Subject: [PATCH 187/810] set comparison tests moved to proper place --- test/quantum/test/untyped/core/data/set.cljc | 36 +++++++++++++++ .../test/untyped/core/type/compare.cljc | 46 ++++--------------- 2 files changed, 44 insertions(+), 38 deletions(-) create mode 100644 test/quantum/test/untyped/core/data/set.cljc diff --git a/test/quantum/test/untyped/core/data/set.cljc b/test/quantum/test/untyped/core/data/set.cljc new file mode 100644 index 00000000..0d3869ba --- /dev/null +++ b/test/quantum/test/untyped/core/data/set.cljc @@ -0,0 +1,36 @@ +(ns quantum.untyped.test.core.data.set + (:require + [quantum.untyped.core.compare :as ucomp] + [quantum.untyped.core.data.set :as uset] + [quantum.untyped.core.test :as test + :refer [deftest is is= testing]])) + +#?(:clj +(defmacro test-comparison|set + "Performs a `t/compare` on `a` and `b`, ensuring that their relationship is symmetric, and that + the inputs are internally commutative if applicable (e.g. if `a` is an `AndType`, ensures that + it is commutative). + The basis comparison is the first input." + [c #_ucomp/comparisons a #_set? b #_set?] + `(let [c# ~c, a# ~a, b# ~b] + ;; Symmetry + (is= c# (uset/compare a# b#)) + (is= (ucomp/invert c#) (uset/compare b# a#))))) + +(deftest test|set + (testing "< , >" + (test-comparison|set -1 #{1} #{1 2}) + (test-comparison|set -1 #{1 2} #{1 2 3})) + (testing "=" + (test-comparison|set 0 #{} #{}) + (test-comparison|set 0 #{1} #{1}) + (test-comparison|set 0 #{1 2} #{1 2})) + (testing "><" + (test-comparison|set 2 #{1 2} #{1 3}) + (test-comparison|set 2 #{1 2} #{1 3}) + (test-comparison|set 2 #{1 2 3} #{1 4})) + (testing "<>" + (test-comparison|set 3 #{} #{1}) + (test-comparison|set 3 #{} #{1 2}) + (test-comparison|set 3 #{1} #{2}) + (test-comparison|set 3 #{3} #{1 2}))) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 6b3389e6..aae6dff9 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -164,18 +164,6 @@ (is= c# (t/compare a*# b*#)) (is= (ucomp/invert c#) (t/compare b*# a*#)))))) -#?(:clj -(defmacro test-comparison|set - "Performs a `t/compare` on `a` and `b`, ensuring that their relationship is symmetric, and that - the inputs are internally commutative if applicable (e.g. if `a` is an `AndType`, ensures that - it is commutative). - The basis comparison is the first input." - [c #_t/comparisons a #_t/type? b #_t/type?] - `(let [c# ~c, a# ~a, b# ~b] - ;; Symmetry - (is= c# (tcomp/compare|set a# b#)) - (is= (ucomp/invert c#) (tcomp/compare|set b# a#))))) - #?(:clj (defmacro test-comparison|fn "Performs a `tcomp/compare|input` and `tcomp/compare|output` on `a` and `b`, ensuring that the @@ -810,24 +798,6 @@ (testing "universal class(-set) identity" (is (t/= t/val? (& t/any? t/val?))))) -(deftest test|set - (testing "< , >" - (test-comparison|set -1 #{1} #{1 2}) - (test-comparison|set -1 #{1 2} #{1 2 3})) - (testing "=" - (test-comparison|set 0 #{} #{}) - (test-comparison|set 0 #{1} #{1}) - (test-comparison|set 0 #{1 2} #{1 2})) - (testing "><" - (test-comparison|set 2 #{1 2} #{1 3}) - (test-comparison|set 2 #{1 2} #{1 3}) - (test-comparison|set 2 #{1 2 3} #{1 4})) - (testing "<>" - (test-comparison|set 3 #{} #{1}) - (test-comparison|set 3 #{} #{1 2}) - (test-comparison|set 3 #{1} #{2}) - (test-comparison|set 3 #{3} #{1 2}))) - ;; TODO incorporate into the other test? (deftest test|fn #_"When we compare a t/fn to another t/fn, we are comparing set extensionality, as always. @@ -1027,18 +997,18 @@ (reduce (fn [[ret found] c] (let [found' (-> found (ubit/conj c) long)] - (ifs (ubit/contains? found' tcomp/ident) - (ubit/contains? found' tcomp/<>ident))) - [tcomp/>ident) + (ubit/contains? found' ucomp/<>ident))) + [ucomp/> Date: Sat, 1 Sep 2018 01:45:25 -0600 Subject: [PATCH 188/810] set/compare works more sensibly with null sets --- src-untyped/quantum/untyped/core/data/set.cljc | 8 ++++---- test/quantum/test/untyped/core/data/set.cljc | 4 ++-- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/set.cljc b/src-untyped/quantum/untyped/core/data/set.cljc index 1ed7502a..41d532d1 100644 --- a/src-untyped/quantum/untyped/core/data/set.cljc +++ b/src-untyped/quantum/untyped/core/data/set.cljc @@ -49,9 +49,9 @@ (defn compare [s0 #_set?, s1 #_set?] (if (empty? s0) - (if (empty? s1) ucomp/=ident ucomp/<>ident) + (if (empty? s1) ucomp/=ident ucomp/ident + ucomp/>ident ;; TODO do fewer comparisons here (let [diff0 (- s0 s1), diff1 (- s1 s0)] (if (empty? diff0) @@ -65,7 +65,7 @@ ucomp/<>ident))))))) (defn < [x0 x1] (ucomp/compf< compare x0 x1)) -(defalias proper-subset? <) +(defalias proper-subset? <) (defn <= [x0 x1] (ucomp/compf<= compare x0 x1)) (defalias subset? <=) (defn >= [x0 x1] (ucomp/compf>= compare x0 x1)) @@ -74,4 +74,4 @@ (defalias proper-superset? >) (defn >< [x0 x1] (ucomp/compf>< compare x0 x1)) (defn <> [x0 x1] (ucomp/compf<> compare x0 x1)) -(defalias disjoint? >) +(defalias disjoint? <>) diff --git a/test/quantum/test/untyped/core/data/set.cljc b/test/quantum/test/untyped/core/data/set.cljc index 0d3869ba..2ef7ebcf 100644 --- a/test/quantum/test/untyped/core/data/set.cljc +++ b/test/quantum/test/untyped/core/data/set.cljc @@ -19,6 +19,8 @@ (deftest test|set (testing "< , >" + (test-comparison|set -1 #{} #{1}) + (test-comparison|set -1 #{} #{1 2}) (test-comparison|set -1 #{1} #{1 2}) (test-comparison|set -1 #{1 2} #{1 2 3})) (testing "=" @@ -30,7 +32,5 @@ (test-comparison|set 2 #{1 2} #{1 3}) (test-comparison|set 2 #{1 2 3} #{1 4})) (testing "<>" - (test-comparison|set 3 #{} #{1}) - (test-comparison|set 3 #{} #{1 2}) (test-comparison|set 3 #{1} #{2}) (test-comparison|set 3 #{3} #{1 2}))) From 602f50fcdb6646150a36d27adb062af42c43d5af Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Sep 2018 01:45:31 -0600 Subject: [PATCH 189/810] `compare|in` and `compare|out` work!! --- src-untyped/quantum/untyped/core/type.cljc | 34 +- .../quantum/untyped/core/type/compare.cljc | 51 +- .../test/untyped/core/type/compare.cljc | 633 ++++++++---------- 3 files changed, 367 insertions(+), 351 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 51d25258..da0ac775 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -33,6 +33,7 @@ [quantum.untyped.core.data.hash :as uhash] [quantum.untyped.core.data.map #?@(:cljs [:refer [MutableHashMap]])] + [quantum.untyped.core.data.set :as uset] [quantum.untyped.core.data.tuple] [quantum.untyped.core.defnt :refer [defns defns-]] @@ -97,7 +98,7 @@ ;; ===== Comparison ===== ;; -(uvar/defaliases utcomp compare compare|in compare|out < <= = not= >= > >< <>) +(uvar/defaliases utcomp compare < <= = not= >= > >< <>) ;; ===== Type Reification Constructors ===== ;; @@ -450,6 +451,37 @@ (uc/group-by #(-> % :input-types count)))] (FnType. name- arities-form arities))) +(defns compare|in [x0 utr/fn-type?, x1 utr/fn-type? > ucomp/comparison?] + (let [ct->overloads|x0 (utr/fn-type>arities x0) + ct->overloads|x1 (utr/fn-type>arities x1) + cts-only-in-x0 (uset/- (-> ct->overloads|x0 keys set) (-> ct->overloads|x1 keys set)) + cts-only-in-x1 (uset/- (-> ct->overloads|x1 keys set) (-> ct->overloads|x0 keys set)) + comparison|cts (uset/compare cts-only-in-x0 cts-only-in-x1) + cts-in-both (->> ct->overloads|x0 (filter (fn-> first ct->overloads|x1))) + overloads->ored-input-types + ;; Yes, there must be a more performant way to do this + (c/fn [overloads] (->> overloads (uc/lmap :input-types) (apply uc/lmap or)))] + (utcomp/combine-comparisons + comparison|cts + (->> cts-in-both + (map (c/fn [[ct overloads|x0]] + (if (zero? ct) + 0 + (utcomp/combine-comparisons + (uc/lmap utcomp/compare + (->> overloads|x0 overloads->ored-input-types) + (->> ct ct->overloads|x1 overloads->ored-input-types)))))) + utcomp/combine-comparisons)))) + +(defns compare|out [x0 utr/fn-type?, x1 utr/fn-type?] + (let [fn-type>output-type + (c/fn [f] (->> f utr/fn-type>arities + vals + (apply concat) + (uc/lmap :output-type) + (apply or)))] + (utcomp/compare (fn-type>output-type x0) (fn-type>output-type x1)))) + (defn unkeyed "Creates an unkeyed collection type, in which the collection may or may not be sequential or even seqable, but must not have key-value diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index dea49166..d0fc8583 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -449,17 +449,40 @@ ;; ===== FnType ===== ;; -(do - (defns compare|in [t0 fn-type?, t1 fn-type?] - (let [a0 (utr/fn-type>arities t0) - a1 (utr/fn-type>arities t1) - arglist-count-comparison (uset/compare (-> a0 keys set) (-> a1 keys set))] - arglist-count-comparison)) - (compare|in - (quantum.untyped.core.type/fn - []) - (quantum.untyped.core.type/fn - [] - [quantum.untyped.core.type/any?]))) - -(defns compare|out [t0 fn-type?, t1 fn-type?] 3) +;; TODO unknown if this is `and`- or `or`-style combination +(defns combine-comparisons + "Commutative in the 2-ary arity" + ([cs _ #_(seq-of ucomp/comparison?) > ucomp/comparison?] + (reduce (fn [c' c] (combine-comparisons c' c)) (first cs) (rest cs))) + ([^long c0 ucomp/comparison?, ^long c1 ucomp/comparison? > ucomp/comparison?] + (case c0 + -1 (case c1 + -1 ident) + 0 (case c1 + -1 ident + 2 >ident) + 1 (case c1 + -1 >ident + 1 >ident + 2 >ident) + 2 (case c1 + -1 >ident) + 3 (case c1 + -1 <>ident + 0 <>ident + 1 <>ident + 2 <>ident + 3 <>ident)))) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index aae6dff9..00d845cd 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -3,8 +3,13 @@ [clojure.core :as core] [quantum.untyped.core.analyze.expr :as xp :refer [>expr]] - [quantum.untyped.core.compare :as ucomp] + [quantum.untyped.core.collections :as c] + [quantum.untyped.core.compare :as ucomp + :refer [ident >ident]] [quantum.untyped.core.data.hash :as uhash] + [quantum.untyped.core.data.set :as uset] + [quantum.untyped.core.defnt + :refer [defns]] [quantum.untyped.core.fn :refer [fn1]] [quantum.untyped.core.logic @@ -17,9 +22,7 @@ [quantum.untyped.core.type :as t :refer [& | !]] [quantum.untyped.core.type.compare :as tcomp] - [quantum.untyped.core.type.reifications :as utr] - [quantum.untyped.core.defnt - :refer [defns]])) + [quantum.untyped.core.type.reifications :as utr])) ;; Here, `NotType` labels on `testing` mean such *after* simplification @@ -166,16 +169,16 @@ #?(:clj (defmacro test-comparison|fn - "Performs a `tcomp/compare|input` and `tcomp/compare|output` on `a` and `b`, ensuring that the + "Performs a `t/compare|in` and `t/compare|out` on `a` and `b`, ensuring that the comparison-relationship between `a` and `b` is symmetric. The basis comparison is the first input." - [[c|out #_t/comparisons, c|in #_t/comparisons] #__, a #_t/type? b #_t/type?] + [[c|in #_t/comparisons, c|out #_t/comparisons] #__, a #_t/type? b #_t/type?] `(let [c|out# ~c|out, c|in# ~c|in, a# ~a, b# ~b] ;; Symmetry - (is= c|in# (tcomp/compare|in a# b#)) - (is= (ucomp/invert c|in#) (tcomp/compare|in b# a#)) - (is= c|out# (tcomp/compare|out a# b#)) - (is= (ucomp/invert c|out#) (tcomp/compare|out b# a#))))) + (is= c|in# (t/compare|in a# b#)) + (is= (ucomp/invert c|in#) (t/compare|in b# a#)) + (is= c|out# (t/compare|out a# b#)) + (is= (ucomp/invert c|out#) (t/compare|out b# a#))))) (def comparison-combinations ["#{<}" @@ -213,60 +216,60 @@ (deftest test|in|compare (testing "UniversalSetType" (testing "+ UniversalSetType" - (test-comparison 0 t/universal-set t/universal-set)) + (test-comparison =ident t/universal-set t/universal-set)) (testing "+ EmptySetType" - (test-comparison 1 t/universal-set t/empty-set)) + (test-comparison >ident t/universal-set t/empty-set)) (testing "+ NotType" - (test-comparison 1 t/universal-set (! a))) + (test-comparison >ident t/universal-set (! a))) (testing "+ OrType" - (test-comparison 1 t/universal-set (| ><0 ><1))) + (test-comparison >ident t/universal-set (| ><0 ><1))) (testing "+ AndType") (testing "+ Expression") (testing "+ ProtocolType" (doseq [t protocol-types] - (test-comparison 1 t/universal-set t))) + (test-comparison >ident t/universal-set t))) (testing "+ ClassType") (testing "+ ValueType" (doseq [t [(t/value t/universal-set) (t/value t/empty-set) (t/value 0) (t/value nil)]] - (test-comparison 1 t/universal-set t)))) + (test-comparison >ident t/universal-set t)))) ;; The null set is considered to always (vacuously) be a subset of any set (testing "EmptySetType" (testing "+ EmptySetType" - (test-comparison 0 t/empty-set t/empty-set)) + (test-comparison =ident t/empty-set t/empty-set)) (testing "+ NotType" (testing "Inner ClassType" - (test-comparison -1 t/empty-set (! a))) + (test-comparison <0 ><1))) + (test-comparison <0 ><1))) (testing "+ AndType") (testing "+ Expression") (testing "+ ProtocolType" (doseq [t protocol-types] - (test-comparison -1 t/empty-set t))) + (test-comparison a)) - (test-comparison -1 (! a) (! ident (! a) (! >a)) + (test-comparison }") ; Impossible for `OrType` #_(testing "#{< = > ><}") ; Impossible for `OrType` @@ -280,44 +283,44 @@ #_(testing "#{< > >< <>}") ; Impossible for `OrType` #_(testing "#{< > <>}") ; Impossible for `OrType` (testing "#{< ><}" - #_(test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1)) - #_(test-comparison -1 i|>a0 (| i|>a+b i|>a0))) + #_(test-comparison a+b i|>a0 i|><0 i|><1)) + #_(test-comparison a0 (| i|>a+b i|>a0))) (testing "#{< >< <>}" - #_(test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1 t/string?))) + #_(test-comparison a+b i|>a0 i|><0 i|><1 t/string?))) (testing "#{< <>}" - #_(test-comparison -1 a (| >a ><0 ><1))) + #_(test-comparison a ><0 ><1))) #_(testing "#{=}") ; Impossible for `OrType` #_(testing "#{= >}") ; Impossible for `OrType` #_(testing "#{= > ><}") ; Impossible for `OrType` #_(testing "#{= > >< <>}") ; Impossible for `OrType` #_(testing "#{= > <>}") ; Impossible for `OrType` (testing "#{= ><}" - (test-comparison -1 (! a) (| (! a) i|><0 i|><1)) - (test-comparison -1 (! i|a) (| (! i|a) i|><0 i|><1))) + (test-comparison <0 i|><1)) + (test-comparison <0 i|><1))) (testing "#{= >< <>}" - #_(test-comparison -1 i|a (| i|a i|><0 i|><1 t/string?))) + #_(test-comparison <0 i|><1 t/string?))) (testing "#{= <>}" - (test-comparison -1 (! a) (| (! a) }" - #_(test-comparison 1 a (| ident a (| ident i|a (| i| ><}" - #_(test-comparison 2 i|a (| i|<0 i|><1))) + #_(test-comparison ><0 i|><1))) (testing "#{> >< <>}" - #_(test-comparison 2 i|a (| i|<0 i|><1 t/string?))) + #_(test-comparison ><0 i|><1 t/string?))) (testing "#{> <>}" - (test-comparison 2 (! a) (| b a)) - (test-comparison 2 (! b) (| a b)) - (test-comparison 2 (! ><0) (| ><0 ><1)) - (test-comparison 2 (! ><1) (| ><1 ><0))) + (test-comparison ><0) (| ><0 ><1)) + (test-comparison ><1) (| ><1 ><0))) (testing "#{><}" - #_(test-comparison 2 i|a (| i|><0 i|><1))) + #_(test-comparison ><0 i|><1))) (testing "#{>< <>}" - #_(test-comparison 2 i|a (| i|><0 i|><1 t/string?))) + #_(test-comparison ><0 i|><1 t/string?))) (testing "#{<>}" - (test-comparison 3 (! a) (| ident (! a) (| }" @@ -325,43 +328,43 @@ (testing "+ Expression") (testing "+ ProtocolType") (testing "+ ClassType" - (test-comparison 3 (! a) a) ; inner = - (test-comparison 3 (! i|a) i|a) ; inner = - (test-comparison 3 (! a) - (test-comparison 3 (! i|a) i| - (test-comparison 2 (! a) >a) ; inner < - (test-comparison 2 (! i|a) i|>a0) ; inner >< - (test-comparison 1 (! a ) ><0) ; inner <> - (test-comparison 2 (! i|a) i|><0) ; inner >< - (test-comparison 2 (! a) Uc) ; inner < - (test-comparison 2 (! i|a) Uc) ; inner < - (test-comparison 2 (! a) ; inner < - (test-comparison 2 (! i|a0) ; inner < - (test-comparison 1 (! <0) ; inner <> - (test-comparison 2 (! i|<0) ; inner >< - (test-comparison 2 (! a) a) ; inner > - (test-comparison 3 (! i|>a0) i|a) ; inner > - (test-comparison 3 (! >a) - (test-comparison 3 (! i|>a0) i| - (test-comparison 1 (! >a) ><0) ; inner <> - (test-comparison 2 (! i|>a0) i|><0) ; inner >< - (test-comparison 2 (! >a) Uc) ; inner < - (test-comparison 2 (! i|>a0) Uc) ; inner < - (test-comparison 1 (! ><0) a) ; inner <> - (test-comparison 2 (! i|><0) i|a) ; inner >< - (test-comparison 1 (! ><0) - (test-comparison 2 (! i|><0) i|< - (test-comparison 1 (! ><0) >a) ; inner <> - (test-comparison 2 (! i|><0) i|>a0) ; inner >< - (test-comparison 2 (! ><0) Uc) ; inner < - (test-comparison 2 (! i|><0) Uc) ; inner < + (test-comparison <>ident (! a) a) ; inner = + (test-comparison <>ident (! i|a) i|a) ; inner = + (test-comparison <>ident (! a) + (test-comparison <>ident (! i|a) i| + (test-comparison >a) ; inner < + (test-comparison >a0) ; inner >< + (test-comparison >ident (! a ) ><0) ; inner <> + (test-comparison ><0) ; inner >< + (test-comparison >a) ; inner < + (test-comparison >a0) ; inner < + (test-comparison >ident (! <0) ; inner <> + (test-comparison ><0) ; inner >< + (test-comparison >ident (! >a) a) ; inner > + (test-comparison <>ident (! i|>a0) i|a) ; inner > + (test-comparison <>ident (! >a) + (test-comparison <>ident (! i|>a0) i| + (test-comparison >ident (! >a) ><0) ; inner <> + (test-comparison >a0) i|><0) ; inner >< + (test-comparison >a) Uc) ; inner < + (test-comparison >a0) Uc) ; inner < + (test-comparison >ident (! ><0) a) ; inner <> + (test-comparison ><0) i|a) ; inner >< + (test-comparison >ident (! ><0) + (test-comparison ><0) i|< + (test-comparison >ident (! ><0) >a) ; inner <> + (test-comparison ><0) i|>a0) ; inner >< + (test-comparison ><0) Uc) ; inner < + (test-comparison ><0) Uc) ; inner < (testing "+ ValueType" - (test-comparison -1 (t/value 1) (! (t/value 2))) - (test-comparison 3 (t/value "") (! t/string?)))) + (test-comparison ident (t/value "") (! t/string?)))) (testing "OrType" (testing "+ OrType" ;; Comparison annotations achieved by first comparing each element of the first/left @@ -369,77 +372,77 @@ ;; entire first/left ;; TODO add complete comparisons via `comparison-combinations` (testing "#{<}, #{<}" - ;; comparisons: < < < < - (test-comparison 0 (| a b) (| a b)) - ;; comparisons: < < < < - (test-comparison 0 (| i|>a+b i|>a0) (| i|>a+b i|>a0))) + ;; comparisons: < < < < + (test-comparison =ident (| a b) (| a b)) + ;; comparisons: < < < < + (test-comparison =ident (| i|>a+b i|>a0) (| i|>a+b i|>a0))) (testing "#{<}, #{<, ><}" - ;; comparisons: < < < < >< >< - (test-comparison -1 (| i|>a+b i|>a0) (| i|>a+b i|>a0 i|><0 i|><1)) - ;; comparisons: < < < < >< >< >< - (test-comparison -1 (| i|>a+b i|>a0) (| i|>a+b i|>a0 i|>a1 i|><0 i|><1)) - ;; comparisons: < < < < < < >< >< - (test-comparison -1 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|>a0 i|>a1 i|><0 i|><1))) + ;; comparisons: < < < < >< >< + (test-comparison a+b i|>a0) (| i|>a+b i|>a0 i|><0 i|><1)) + ;; comparisons: < < < < >< >< >< + (test-comparison a+b i|>a0) (| i|>a+b i|>a0 i|>a1 i|><0 i|><1)) + ;; comparisons: < < < < < < >< >< + (test-comparison a+b i|>a0 i|>a1) (| i|>a+b i|>a0 i|>a1 i|><0 i|><1))) (testing "#{<, ><}, #{<}" - ;; comparisons: < < >< < < - (test-comparison 1 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|>a0)) - ;; comparisons: >< < < < < - (test-comparison 1 (| i|a i|><0 i|><1) (| i|><0 i|><1))) + ;; comparisons: < < >< < < + (test-comparison >ident (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|>a0)) + ;; comparisons: >< < < < < + (test-comparison >ident (| i|a i|><0 i|><1) (| i|><0 i|><1))) (testing "#{<, ><}, #{<, ><}" - ;; comparisons: < >< < >< - (test-comparison 2 (| i|>a+b i|>a0) (| i|>a+b i|><0)) - ;; comparisons: < >< >< < >< >< - (test-comparison 2 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|><0 i|><1)) - ;; comparisons: < < >< < < >< >< - (test-comparison 2 (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|>a0 i|><0 i|><1)) - ;; comparisons: < < >< < >< - (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|a i|><0)) - ;; comparisons: < >< >< < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|a i|><0 i|><1)) - ;; comparisons: >< < < >< - (test-comparison 2 (| i|a i|><0) (| i|><0 i|><1)) - ;; comparisons: >< < >< >< < - (test-comparison 2 (| i|a i|><1 i|><2) (| i|><0 i|><1)) - ;; comparisons: >< >< < < >< - (test-comparison 2 (| i|a i|><0 i|><1) (| i|><1 i|><2))) + ;; comparisons: < >< < >< + (test-comparison >a+b i|>a0) (| i|>a+b i|><0)) + ;; comparisons: < >< >< < >< >< + (test-comparison >a+b i|>a0 i|>a1) (| i|>a+b i|><0 i|><1)) + ;; comparisons: < < >< < < >< >< + (test-comparison >a+b i|>a0 i|>a1) (| i|>a+b i|>a0 i|><0 i|><1)) + ;; comparisons: < < >< < >< + (test-comparison >a+b i|>a0) (| i|a i|><0)) + ;; comparisons: < >< >< < >< >< + (test-comparison >a+b i|>a0) (| i|a i|><0 i|><1)) + ;; comparisons: >< < < >< + (test-comparison ><0) (| i|><0 i|><1)) + ;; comparisons: >< < >< >< < + (test-comparison ><1 i|><2) (| i|><0 i|><1)) + ;; comparisons: >< >< < < >< + (test-comparison ><0 i|><1) (| i|><1 i|><2))) (testing "#{<, ><}, #{><}" - ;; comparisons: < >< >< >< - (test-comparison 2 (| i|a i|><0) (| i|>a+b i|>a0)) - ;; comparisons: < >< >< >< >< - (test-comparison 2 (| i|a i|><0 i|><1) (| i|>a+b i|>a0)) - ;; comparisons: < >< >< >< >< - (test-comparison 2 (| i|a i|><0) (| i|>a+b i|>a0 i|>a1)) - ;; comparisons: < >< >< >< >< >< - (test-comparison 2 (| i|a i|><0 i|><1) (| i|>a+b i|>a0 i|>a1))) + ;; comparisons: < >< >< >< + (test-comparison ><0) (| i|>a+b i|>a0)) + ;; comparisons: < >< >< >< >< + (test-comparison ><0 i|><1) (| i|>a+b i|>a0)) + ;; comparisons: < >< >< >< >< + (test-comparison ><0) (| i|>a+b i|>a0 i|>a1)) + ;; comparisons: < >< >< >< >< >< + (test-comparison ><0 i|><1) (| i|>a+b i|>a0 i|>a1))) (testing "#{<, <>}, #{<, <>}" - ;; comparisons: < <> < <> - (test-comparison 2 (| a b) (| a ><1)) - ;; comparisons: <> < < <> - (test-comparison 2 (| a b) (| b ><1))) + ;; comparisons: < <> < <> + (test-comparison ><1)) + ;; comparisons: <> < < <> + (test-comparison ><1))) (testing "#{<, <>}, #{><, <>}" - ;; comparisons: <, <> >< <> <> - (test-comparison 2 (| a b) (| >a ><0 ><1))) + ;; comparisons: <, <> >< <> <> + (test-comparison >a ><0 ><1))) (testing "#{><}, #{<, ><}" - ;; comparisons: >< >< >< < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|<0 i|><1)) - ;; comparisons: >< >< >< >< < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0 i|>a1) (| i|<0 i|><1)) - ;; comparisons: >< >< >< < < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|<0 i|><1)) - ;; comparisons: >< >< >< >< < < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0 i|>a1) (| i|<0 i|><1)) - ;; comparisons: >< >< >< < < < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0) (| i|<0 i|><1)) - ;; comparisons: >< >< >< >< < < < >< >< - (test-comparison 2 (| i|a i|>a+b i|>a0 i|>a1) (| i|<0 i|><1))) + ;; comparisons: >< >< >< < >< >< + (test-comparison >a+b i|>a0) (| i|<0 i|><1)) + ;; comparisons: >< >< >< >< < >< >< + (test-comparison >a+b i|>a0 i|>a1) (| i|<0 i|><1)) + ;; comparisons: >< >< >< < < >< >< + (test-comparison >a+b i|>a0) (| i|<0 i|><1)) + ;; comparisons: >< >< >< >< < < >< >< + (test-comparison >a+b i|>a0 i|>a1) (| i|<0 i|><1)) + ;; comparisons: >< >< >< < < < >< >< + (test-comparison >a+b i|>a0) (| i|<0 i|><1)) + ;; comparisons: >< >< >< >< < < < >< >< + (test-comparison >a+b i|>a0 i|>a1) (| i|<0 i|><1))) (testing "#{><}, #{><}" - ;; comparisons: >< >< >< >< - (test-comparison 2 (| i|a i|><2) (| i|><0 i|><1)) - ;; comparisons: >< >< >< >< - (test-comparison 2 (| i|a i|><0) (| i|><1 i|><2))) + ;; comparisons: >< >< >< >< + (test-comparison ><2) (| i|><0 i|><1)) + ;; comparisons: >< >< >< >< + (test-comparison ><0) (| i|><1 i|><2))) (testing "#{<>}, #{<>}" - ;; comparisons: <> <> <> <> - (test-comparison 3 (| a b) (| ><0 ><1))))) + ;; comparisons: <> <> <> <> + (test-comparison <>ident (| a b) (| ><0 ><1))))) ;; TODO fix tests/impl #_(testing "+ AndType" ;; Comparison annotations achieved by first comparing each element of the first/left @@ -450,50 +453,50 @@ ;; comparisons: [-1, -1], [-1, -1] (test-comparison 1 (| a >a+b >a0) (& >a+b >a0)) ;; comparisons: [-1, -1, 3], [-1, -1] - (test-comparison 1 (| a >a+b >a0 >a1) (& >a+b >a0)) + (test-comparison >ident (| a >a+b >a0 >a1) (& >a+b >a0)) ;; comparisons: [-1, -1], [-1, -1, 3] - (test-comparison 3 (| a >a+b >a0) (& >a+b >a0 >a1)) + (test-comparison <>ident (| a >a+b >a0) (& >a+b >a0 >a1)) ;; comparisons: [-1, -1, -1], [-1, -1, -1] - (test-comparison 1 (| a >a+b >a0 >a1) (& >a+b >a0 >a1))) + (test-comparison >ident (| a >a+b >a0 >a1) (& >a+b >a0 >a1))) (testing "+ #{∅+}" ;; comparisons: [3, 3, 3], [3, 3] - (test-comparison 3 (| a >a+b >a0) (& ><0 ><1))) + (test-comparison <>ident (| a >a+b >a0) (& ><0 ><1))) (testing "+ #{<+ ∅+}" ;; comparisons: [-1, 3], [-1, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& >a+b ><0 ><1)) + (test-comparison <>ident (| a >a+b >a0) (& >a+b ><0 ><1)) ;; comparisons: [-1, 3, 3], [-1, 3, 3] - (test-comparison 3 (| a >a+b >a0 >a1) (& >a+b ><0 ><1)) + (test-comparison <>ident (| a >a+b >a0 >a1) (& >a+b ><0 ><1)) ;; comparisons: [-1, -1], [-1, -1, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& >a+b >a0 ><0 ><1)) + (test-comparison <>ident (| a >a+b >a0) (& >a+b >a0 ><0 ><1)) ;; comparisons: [-1, -1, 3], [-1, -1, 3, 3] - (test-comparison 3 (| a >a+b >a0 >a1) (& >a+b >a0 ><0 ><1)) + (test-comparison <>ident (| a >a+b >a0 >a1) (& >a+b >a0 ><0 ><1)) ;; comparisons: [-1, -1], [-1, -1, 3, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& >a+b >a0 >a1 ><0 ><1)) + (test-comparison <>ident (| a >a+b >a0) (& >a+b >a0 >a1 ><0 ><1)) ;; comparisons: [-1, -1, -], [-1, -1, -1, 3, 3] - (test-comparison 3 (| a >a+b >a0 >a1) (& >a+b >a0 >a1 ><0 ><1))) + (test-comparison <>ident (| a >a+b >a0 >a1) (& >a+b >a0 >a1 ><0 ><1))) (testing "+ #{= ∅+}" ;; comparisons: [3, 3], [-1, 3] - (test-comparison 3 (| a >a+b >a0) (& a ><0)) + (test-comparison <>ident (| a >a+b >a0) (& a ><0)) ;; comparisons: [3, 3], [-1, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& a ><0 ><1))) + (test-comparison <>ident (| a >a+b >a0) (& a ><0 ><1))) (testing "+ #{>+ ∅+}" ;; comparisons: [3, 3], [-1, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& <0 ><1)) + (test-comparison <>ident (| a >a+b >a0) (& <0 ><1)) ;; comparisons: [3, 3, 3], [-1, 3, 3] - (test-comparison 3 (| a >a+b >a0 >a1) (& <0 ><1)) + (test-comparison <>ident (| a >a+b >a0 >a1) (& <0 ><1)) ;; comparisons: [3, 3], [-1, -1, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& <0 ><1)) + (test-comparison <>ident (| a >a+b >a0) (& <0 ><1)) ;; comparisons: [3, 3, 3], [-1, -1, 3, 3] - (test-comparison 3 (| a >a+b >a0 >a1) (& <0 ><1)) + (test-comparison <>ident (| a >a+b >a0 >a1) (& <0 ><1)) ;; comparisons: [3, 3], [-1, -1, 3, 3, 3] - (test-comparison 3 (| a >a+b >a0) (& <0 ><1)) + (test-comparison <>ident (| a >a+b >a0) (& <0 ><1)) ;; comparisons: [3, 3, 3], [-1, -1, -1, 3, 3] - (test-comparison 3 (| a >a+b >a0 >a1) (& <0 ><1))))) + (test-comparison <>ident (| a >a+b >a0 >a1) (& <0 ><1))))) (testing "+ Expression") (testing "+ ProtocolType") (testing "+ ClassType" (testing "#{<}" - (test-comparison -1 i|a+b i|>a0 i|>a1))) + (test-comparison a+b i|>a0 i|>a1))) #_(testing "#{< =}") ; Impossible for `OrType` #_(testing "#{< = >}") ; Impossible for `OrType` #_(testing "#{< = > ><}") ; Impossible for `OrType` @@ -507,49 +510,49 @@ #_(testing "#{< > >< <>}") ; Impossible for `OrType` #_(testing "#{< > <>}") ; Impossible for `OrType` (testing "#{< ><}" - (test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1)) - (test-comparison -1 i|>a0 (| i|>a+b i|>a0))) + (test-comparison a+b i|>a0 i|><0 i|><1)) + (test-comparison a0 (| i|>a+b i|>a0))) (testing "#{< >< <>}" - (test-comparison -1 i|a (| i|>a+b i|>a0 i|><0 i|><1 t/string?))) + (test-comparison a+b i|>a0 i|><0 i|><1 t/string?))) (testing "#{< <>}" - (test-comparison -1 a (| >a ><0 ><1))) + (test-comparison a ><0 ><1))) #_(testing "#{=}") ; Impossible for `OrType` #_(testing "#{= >}") ; Impossible for `OrType` #_(testing "#{= > ><}") ; Impossible for `OrType` #_(testing "#{= > >< <>}") ; Impossible for `OrType` #_(testing "#{= > <>}") ; Impossible for `OrType` (testing "#{= ><}" - (test-comparison -1 i|a (| i|a i|><0 i|><1))) + (test-comparison <0 i|><1))) (testing "#{= >< <>}" - (test-comparison -1 i|a (| i|a i|><0 i|><1 t/string?))) + (test-comparison <0 i|><1 t/string?))) (testing "#{= <>}" - (test-comparison -1 a (| a ><0 ><1))) + (test-comparison <0 ><1))) (testing "#{>}" - (test-comparison 1 a (| ident a (| ident i|a (| i| ><}" - (test-comparison 2 i|a (| i|<0 i|><1))) + (test-comparison ><0 i|><1))) (testing "#{> >< <>}" - (test-comparison 2 i|a (| i|<0 i|><1 t/string?))) + (test-comparison ><0 i|><1 t/string?))) (testing "#{> <>}" - (test-comparison 2 a (| <0 ><1))) + (test-comparison ><0 ><1))) (testing "#{><}" - (test-comparison 2 i|a (| i|><0 i|><1))) + (test-comparison ><0 i|><1))) (testing "#{>< <>}" - (test-comparison 2 i|a (| i|><0 i|><1 t/string?))) + (test-comparison ><0 i|><1 t/string?))) (testing "#{<>}" - (test-comparison 3 a (| ><0 ><1))) + (test-comparison <>ident a (| ><0 ><1))) (testing "Nilable" (testing "< nilabled: #{< <>}" - (test-comparison -1 t/long? (t/? t/object?))) + (test-comparison }" - (test-comparison -1 t/long? (t/? t/long?))) + (test-comparison nilabled: #{> <>}" - (test-comparison 2 t/object? (t/? t/long?))) + (test-comparison >< nilabled: #{>< <>}" - (test-comparison 2 t/iterable? (t/? t/comparable?))) + (test-comparison > nilabled: #{<>}" - (test-comparison 3 t/long? (t/? t/string?))))) + (test-comparison <>ident t/long? (t/? t/string?))))) (testing "+ ValueType" (testing "arg <" (testing "+ arg <") @@ -557,20 +560,20 @@ (testing "+ arg >") (testing "+ arg ><") (testing "+ arg <>" - (test-comparison -1 (t/value "a") (| t/string? t/byte?)) - (test-comparison -1 (t/value 1) (| (t/value 1) (t/value 2))) - (test-comparison -1 (t/value 1) (| (t/value 2) (t/value 1))) + (test-comparison " - (test-comparison -1 (t/value 1) (| (t/value 1) (t/value 2) (t/value 3))) - (test-comparison -1 (t/value 1) (| (t/value 2) (t/value 1) (t/value 3))) - (test-comparison -1 (t/value 1) (| (t/value 2) (t/value 3) (t/value 1)))))) + (test-comparison " - (test-comparison -1 t/nil? (| t/nil? t/string?)))) + (test-comparison " (testing "+ arg <>" - (test-comparison 3 (t/value "a") (| t/byte? t/long?)) - (test-comparison 3 (t/value 3) (| (t/value 1) (t/value 2))))))) + (test-comparison <>ident (t/value "a") (| t/byte? t/long?)) + (test-comparison <>ident (t/value 3) (| (t/value 1) (t/value 2))))))) (testing "AndType" (testing "+ AndType") (testing "+ Expression") @@ -578,18 +581,18 @@ (testing "+ ClassType" (testing "#{<}" (testing "Boxed Primitive" - (test-comparison -1 t/byte? (& t/number? t/comparable?))) + (test-comparison a0 i|>a1)))) + (test-comparison a0 i|>a1)))) (testing "#{<}" - (test-comparison -1 i|a (& i|>a0 i|>a1))) + (test-comparison a0 i|>a1))) #_(testing "#{< =}") ; Impossible for `AndType` #_(testing "#{< = >}") ; Impossible for `AndType` #_(testing "#{< = > ><}") ; Impossible for `AndType` @@ -603,45 +606,45 @@ #_(testing "#{< > >< <>}") ; Impossible for `AndType` #_(testing "#{< > <>}") ; Impossible for `AndType` (testing "#{< ><}" - (test-comparison 2 i|a (& i|>a+b i|>a0 i|>a1 i|><0 i|><1))) + (test-comparison >a+b i|>a0 i|>a1 i|><0 i|><1))) (testing "#{< >< <>}" - (test-comparison 2 t/java-set? (& t/java-coll? t/char-seq? - (t/isa? java.nio.ByteBuffer)))) + (test-comparison >}" - (test-comparison 3 t/string? (& t/char-seq? t/java-set?)) - (test-comparison 3 ><0 (& (! ><1) (! ><0))) - (test-comparison 3 a (& (! a) (! b)))) + (test-comparison <>ident t/string? (& t/char-seq? t/java-set?)) + (test-comparison <>ident ><0 (& (! ><1) (! ><0))) + (test-comparison <>ident a (& (! a) (! b)))) #_(testing "#{=}") ; Impossible for `AndType` #_(testing "#{= >}") ; Impossible for `AndType` #_(testing "#{= > ><}") ; Impossible for `AndType` #_(testing "#{= > >< <>}") ; Impossible for `AndType` #_(testing "#{= > <>}") ; Impossible for `AndType` (testing "#{= ><}" - (test-comparison 1 i|a (& i|a i|><0 i|><1)) - (test-comparison 1 t/char-seq? (& t/char-seq? t/java-set?)) - (test-comparison 1 t/char-seq? (& t/char-seq? t/java-set? a))) - (testing "#{= >< <>}") ; <- TODO comparison should be 1 + (test-comparison >ident i|a (& i|a i|><0 i|><1)) + (test-comparison >ident t/char-seq? (& t/char-seq? t/java-set?)) + (test-comparison >ident t/char-seq? (& t/char-seq? t/java-set? a))) + (testing "#{= >< <>}") ; <- TODO comparison should be >ident ;; TODO fix (testing "#{= <>}" - (test-comparison 1 a (& a t/java-set?))) + (test-comparison >ident a (& a t/java-set?))) (testing "#{>}" - (test-comparison 1 i|a (& i|ident i|a (& i| ><}" - (test-comparison 2 i|a (& i|<0 i|><1)) - (test-comparison 2 a (& (t/isa? javax.management.AttributeList) t/java-set?)) - (test-comparison 2 t/comparable? (& (t/isa? java.nio.ByteBuffer) t/java-set?))) + (test-comparison ><0 i|><1)) + (test-comparison > >< <>}" - (test-comparison 2 i|a (& i|<0 a))) + (test-comparison ><0 a))) (testing "#{> <>}") ; <- TODO comparison should be 1 (testing "#{><}" - (test-comparison 2 i|a (& i|><0 i|><1)) - (test-comparison 2 t/char-seq? (& t/java-set? a))) + (test-comparison ><0 i|><1)) + (test-comparison >< <>}") ; <- TODO comparison should be 3 (testing "#{<>}" - (test-comparison 3 t/string? (& a t/java-set?)))) + (test-comparison <>ident t/string? (& a t/java-set?)))) (testing "+ ValueType" (testing "#{<}" - (test-comparison -1 (t/value "a") (& t/char-seq? t/comparable?))) + (test-comparison }") ; not possible for `AndType`; `>` not possible for `ValueType` #_(testing "#{< = > ><}") ; not possible for `AndType`; `>` and `><` not possible for `ValueType` @@ -657,8 +660,8 @@ #_(testing "#{< ><}") ; `><` not possible for `ValueType` #_(testing "#{< >< <>}") ; `><` not possible for `ValueType` (testing "#{< <>}" - (test-comparison 3 (t/value "a") (& t/char-seq? a)) - (test-comparison 3 (t/value "a") (& t/char-seq? t/java-set?))) + (test-comparison <>ident (t/value "a") (& t/char-seq? a)) + (test-comparison <>ident (t/value "a") (& t/char-seq? t/java-set?))) #_(testing "#{=}") ; not possible for `AndType` #_(testing "#{= >}") ; not possible for `AndType`; `>` not possible for `ValueType` #_(testing "#{= > ><}") ; not possible for `AndType`; `>` and `><` not possible for `ValueType` @@ -674,7 +677,7 @@ #_(testing "#{><}") ; `><` not possible for `ValueType` #_(testing "#{>< <>}") ; `><` not possible for `ValueType` (testing "#{<>}" - (test-comparison 3 (t/value "a") (& a t/java-set?))))) + (test-comparison <>ident (t/value "a") (& a t/java-set?))))) (testing "Expression" (testing "+ Expression") (testing "+ ProtocolType") @@ -682,112 +685,112 @@ (testing "+ ValueType")) (testing "ProtocolType" (testing "+ ProtocolType" - (test-comparison 0 (t/isa? AProtocolAll) (t/isa? AProtocolAll)) - (test-comparison 3 (t/isa? AProtocolAll) (t/isa? AProtocolNone))) + (test-comparison =ident (t/isa? AProtocolAll) (t/isa? AProtocolAll)) + (test-comparison <>ident (t/isa? AProtocolAll) (t/isa? AProtocolNone))) (testing "+ ClassType") (testing "+ ValueType" (let [values #{t/universal-set t/empty-set nil {} 1 "" AProtocolAll quantum.test.untyped.core.type.compare.AProtocolAll}] (doseq [v values] - (test-comparison -1 (t/value v) (t/isa? AProtocolAll))) + (test-comparison ident (t/value v) (t/isa? AProtocolString))) (doseq [v (disj values nil)] - (test-comparison -1 (t/value v) (t/isa? AProtocolNonNil))) + (test-comparison ident (t/value v) (t/isa? AProtocolNonNil))) (doseq [v [nil]] - (test-comparison -1 (t/value v) (t/isa? AProtocolOnlyNil))) + (test-comparison ident (t/value v) (t/isa? AProtocolOnlyNil))) (doseq [v values] - (test-comparison 3 (t/value v) (t/isa? AProtocolNone)))))) + (test-comparison <>ident (t/value v) (t/isa? AProtocolNone)))))) (testing "ClassType" (testing "+ ClassType" (testing "Boxed Primitive + Boxed Primitive" - (test-comparison 0 t/long? t/long?) - (test-comparison 3 t/long? t/int?)) + (test-comparison =ident t/long? t/long?) + (test-comparison <>ident t/long? t/int?)) (testing "Boxed Primitive + Final Concrete" - (test-comparison 3 t/long? t/string?)) + (test-comparison <>ident t/long? t/string?)) (testing "Boxed Primitive + Extensible Concrete" (testing "< , >" - (test-comparison -1 t/long? t/object?)) + (test-comparison " - (test-comparison 3 t/long? t/thread?))) + (test-comparison <>ident t/long? t/thread?))) (testing "Boxed Primitive + Abstract" - (test-comparison 3 t/long? (t/isa? java.util.AbstractCollection))) + (test-comparison <>ident t/long? (t/isa? java.util.AbstractCollection))) (testing "Boxed Primitive + Interface" - (test-comparison 3 t/long? t/char-seq?)) + (test-comparison <>ident t/long? t/char-seq?)) (testing "Final Concrete + Final Concrete" - (test-comparison 0 t/string? t/string?)) + (test-comparison =ident t/string? t/string?)) (testing "Final Concrete + Extensible Concrete" (testing "< , >" - (test-comparison -1 t/string? t/object?)) + (test-comparison " - (test-comparison 3 t/string? a))) + (test-comparison <>ident t/string? a))) (testing "Final Concrete + Abstract") (testing "Final Concrete + Interface" (testing "< , >" - (test-comparison -1 t/string? t/comparable?)) + (test-comparison " - (test-comparison 3 t/string? t/java-coll?))) + (test-comparison <>ident t/string? t/java-coll?))) (testing "Extensible Concrete + Extensible Concrete" - (test-comparison 0 t/object? t/object?) + (test-comparison =ident t/object? t/object?) (testing "< , >" - (test-comparison -1 a t/object?)) + (test-comparison " - (test-comparison 3 a t/thread?))) + (test-comparison <>ident a t/thread?))) (testing "Extensible Concrete + Abstract" (testing "< , >" - (test-comparison -1 (t/isa? java.util.AbstractCollection) t/object?) - (test-comparison -1 a (t/isa? java.util.AbstractCollection))) + (test-comparison " - (test-comparison 3 t/thread? (t/isa? java.util.AbstractCollection)) - (test-comparison 3 (t/isa? java.util.AbstractCollection) t/thread?))) + (test-comparison <>ident t/thread? (t/isa? java.util.AbstractCollection)) + (test-comparison <>ident (t/isa? java.util.AbstractCollection) t/thread?))) (testing "Extensible Concrete + Interface" - (test-comparison 2 a t/char-seq?)) + (test-comparison >" - (test-comparison -1 (t/isa? java.util.AbstractList) (t/isa? java.util.AbstractCollection))) + (test-comparison " - (test-comparison 3 (t/isa? java.util.AbstractList) (t/isa? java.util.AbstractQueue)))) + (test-comparison <>ident (t/isa? java.util.AbstractList) (t/isa? java.util.AbstractQueue)))) (testing "Abstract + Interface" (testing "< , >" - (test-comparison -1 (t/isa? java.util.AbstractCollection) t/java-coll?)) + (test-comparison <" - (test-comparison 2 (t/isa? java.util.AbstractCollection) t/comparable?))) + (test-comparison >" - (test-comparison -1 t/java-coll? t/iterable?)) + (testing "< , >", + (test-comparison <" - (test-comparison 2 t/char-seq? t/comparable?)))) + (test-comparison >" - (test-comparison 3 (t/value "a") t/byte?)))) + (test-comparison <>ident (t/value "a") t/byte?)))) (testing "ValueType" (testing "+ ValueType" (testing "=" - (test-comparison 0 (t/value nil) (t/value nil)) - (test-comparison 0 (t/value 1 ) (t/value 1 )) - (test-comparison 0 (t/value "a") (t/value "a"))) + (test-comparison =ident (t/value nil) (t/value nil)) + (test-comparison =ident (t/value 1 ) (t/value 1 )) + (test-comparison =ident (t/value "a") (t/value "a"))) (testing "=, non-strict" - (test-comparison 0 (t/value (vector) ) (t/value (list) )) - (test-comparison 0 (t/value (vector (vector))) (t/value (vector (list)))) - (test-comparison 0 (t/value (hash-map) ) (t/value (sorted-map) ))) + (test-comparison =ident (t/value (vector) ) (t/value (list) )) + (test-comparison =ident (t/value (vector (vector))) (t/value (vector (list)))) + (test-comparison =ident (t/value (hash-map) ) (t/value (sorted-map) ))) (testing "<>" - (test-comparison 3 (t/value 1 ) (t/value 2 )) - (test-comparison 3 (t/value "a") (t/value "b")) - (test-comparison 3 (t/value 1 ) (t/value "a")) - (test-comparison 3 (t/value nil) (t/value "a")))))) + (test-comparison <>ident (t/value 1 ) (t/value 2 )) + (test-comparison <>ident (t/value "a") (t/value "b")) + (test-comparison <>ident (t/value 1 ) (t/value "a")) + (test-comparison <>ident (t/value nil) (t/value "a")))))) (deftest test|= ;; Takes an inordinately long time to do `test-comparison 0 ...` even without instrumentation @@ -965,23 +968,25 @@ (testing "output >") (testing "output ><") (testing "output <>"))) + + ;; Tests that pass!! (testing "input arities =" (testing "input types <" (testing "output <" - (test-comparison|fn [-1 -1 -1] (t/fn [t/boolean? :> t/boolean?]) - (t/fn [t/any?]))) + (test-comparison|fn [ t/boolean?]) + (t/fn [t/any?]))) (testing "output =" - (test-comparison|fn [-1 0 -1] (t/fn [t/boolean?]) - (t/fn [t/any?]))) + (test-comparison|fn [" - (test-comparison|fn [-1 1 2] (t/fn [t/boolean?]) - (t/fn [t/any? :> t/boolean?]))) + (test-comparison|fn [ident] (t/fn [t/boolean?]) + (t/fn [t/any? :> t/boolean?]))) (testing "output ><" - (test-comparison|fn [-1 2 2] (t/fn [t/boolean? :> i|><0]) - (t/fn [t/any? :> i|><1]))) + (test-comparison|fn [ i|><0]) + (t/fn [t/any? :> i|><1]))) (testing "output <>" - (test-comparison|fn [-1 3 ?] (t/fn [t/boolean? :> i|><0]) - (t/fn [t/any? :> i|><1])))) + (test-comparison|fn [ident] (t/fn [t/boolean? :> ><0]) + (t/fn [t/any? :> ><1])))) (testing "input types =" (testing "output <") (testing "output =" @@ -989,48 +994,4 @@ (testing "output >" ) (testing "output ><") - (testing "output <>")) - -(require '[quantum.untyped.core.data.bits :as ubit]) -(let [cs [0 0]] - (first - (reduce - (fn [[ret found] c] - (let [found' (-> found (ubit/conj c) long)] - (ifs (ubit/contains? found' ucomp/ident) - (ubit/contains? found' ucomp/<>ident))) - [ucomp/>arity|x0 (->> x0 fn>arities (group-by arity>count) (c/map-vals' first)) - ct->arity|x1 (->> x1 fn>arities (group-by arity>count) (c/map-vals' first)) - arity-cts-only-in-x0 (uset/- (-> ct->arity|x0 keys set) (-> ct->arity|x1 keys set)) - arity-cts-only-in-x1 (uset/- (-> ct->arity|x1 keys set) (-> ct->arity|x0 keys set))] - (->> ct->arity|x0 - (filter (fn-> first ct->arity|x1)) - (map (fn [ct arity|x0] (combine-in-some-way - (c/lmap t/compare arity|x0 (ct->arity|x1 ct))))) - combine-in-some-possibly-other-way))) - -(defns compare|output [x0 t/fnt-type?, x1 t/fnt-type?] - (t/compare (->> x0 fn>arities (c/lmap fn|arity>output) (apply t/or)) - (->> x1 fn>arities (c/lmap fn|arity>output) (apply t/or)))) - -(defns compare|fn+fn [x0 t/fnt-type?, x1 t/fnt-type?] - (combine-comparisons-in-a-tand???-sort-of-way ; maybe the combination is similar (or the same?) to the above not-yet-fleshed-out combination fns - (compare|input x0 x1) - (compare|output x0 x1))) + (testing "output <>")))) From bdd033d566793a1de8097f2b9e3a83a1c89dc99c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Sep 2018 12:00:49 -0600 Subject: [PATCH 190/810] More tests pass! --- .../test/untyped/core/type/compare.cljc | 71 ++++++++++++------- 1 file changed, 45 insertions(+), 26 deletions(-) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 00d845cd..007295c7 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -929,49 +929,52 @@ (testing "input ><") (testing "input <>")) + ;; Tests that pass (testing "input arities <" - (testing "input types <" - (testing "output <>" - (test-comparison|fn [-1 3 ?] (t/fn [t/boolean? :> t/boolean?]) - (t/fn [] [t/any? :> t/long?])))) - (testing "input types =" + (testing "same-arity input types <" (testing "output <" - (test-comparison|fn [-1 -1 ?] (t/fn [:> t/boolean?]) - (t/fn [] [t/any?]))) + (test-comparison|fn [ t/boolean?]) + (t/fn [] [t/any? :> t/long?]))) + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "same-arity input types =" + (testing "output <" + (test-comparison|fn [ t/boolean?]) + (t/fn [] [t/any?]))) (testing "output =" - (test-comparison|fn [-1 0 ?] (t/fn []) - (t/fn [] [t/any?]))) + (test-comparison|fn [ " - (test-comparison|fn [-1 1 ?] (t/fn []) - (t/fn [:> t/boolean?] [t/any? :> t/long?]))) + (test-comparison|fn [ ident] (t/fn []) + (t/fn [:> t/boolean?] [t/any? :> t/long?]))) (testing "output ><") (testing "output <>")) - (testing "input types >" + (testing "same-arity input types >" (testing "output <" - (test-comparison|fn [ 2 -1 ?] (t/fn [t/any?]) - (t/fn [] [t/long?]))) + (test-comparison|fn [> t/boolean?]) + (t/fn [] [t/boolean?]))) (testing "output =" - (test-comparison|fn [ 2 0 ?] (t/fn [t/any?]) - (t/fn [] [t/boolean?]))) + (test-comparison|fn [>") (testing "output ><") (testing "output <>")) - (testing "input types ><" + (testing "same-arity input types ><" (testing "output <") (testing "output =") (testing "output >") (testing "output ><") (testing "output <>")) - (testing "input types <>" + (testing "same-arity input types <>" (testing "output <") (testing "output =") (testing "output >") (testing "output ><") (testing "output <>"))) - - ;; Tests that pass!! (testing "input arities =" - (testing "input types <" + (testing "same-arity input types <" (testing "output <" (test-comparison|fn [ t/boolean?]) (t/fn [t/any?]))) @@ -987,11 +990,27 @@ (testing "output <>" (test-comparison|fn [ident] (t/fn [t/boolean? :> ><0]) (t/fn [t/any? :> ><1])))) - (testing "input types =" + (testing "same-arity input types =" (testing "output <") - (testing "output =" - ) - (testing "output >" - ) + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "same-arity input types >" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "same-arity input types ><" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "same-arity input types <>" + (testing "output <") + (testing "output =") + (testing "output >") (testing "output ><") (testing "output <>")))) From 4a2ac2c57a52eee4394439e84c266b6c49b3905e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Sep 2018 12:06:19 -0600 Subject: [PATCH 191/810] Set up rest of t/fn test --- .../test/untyped/core/type/compare.cljc | 174 ++++++++++-------- 1 file changed, 96 insertions(+), 78 deletions(-) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 007295c7..953ef982 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -853,90 +853,15 @@ - I guarantee an animal but I provide any old organism - I guarantee a sheep and some wheat but I provide only a sheep - (t/?? (t/map :guarantee))" - - ;; For comparing arities: - ;; (This uses set/difference in both directions) - ;; (set/compare (-> f0 fn>arities (map count) set) (-> f1 fn>arities (map count) set)) - - (testing "output <" - (testing "input <" - (test-comparison|fn [-1 -1] (t/fn [t/boolean? :> t/boolean?]) - (t/fn [] - [t/any?]))) - (testing "input =") - (testing "input >") - (testing "input ><") - (testing "input <>")) - (testing "output =" - (testing "input <" - (testing "due to input arity <" - (test-comparison|fn [ 0 -1] (t/fn [t/any?]) - (t/fn [] - [t/any?]))) - (testing "due to input types <" - (test-comparison|fn [ 0 -1] (t/fn [] - [t/boolean?]) - (t/fn [] - [t/any?]))) - (testing "due to input arity and types <" - (test-comparison|fn [ 0 -1] (t/fn [t/boolean?]) - (t/fn [] - [t/any?])))) - (testing "input =" - (test-comparison|fn [ 0 0] (t/fn []) - (t/fn []))) - (testing "input >") - (testing "input ><") - (testing "input <>")) - (testing "output >" - (testing "input <" - (testing "due to input arity <" - (test-comparison|fn [ 1 -1] (t/fn [t/any?]) - (t/fn [] - [t/any? :> t/boolean?]))) - (testing "due to input types <" - (test-comparison|fn [ 1 -1] (t/fn [] - [t/boolean?]) - (t/fn [] - [t/any? :> t/boolean?]))) - (testing "due to input arity and types <" - (test-comparison|fn [ 1 -1] (t/fn [t/boolean?]) - (t/fn [] - [t/any? :> t/boolean?])))) - (testing "input =" - (test-comparison|fn [ 1 0] (t/fn [:> t/boolean?]) - (t/fn [])) - (test-comparison|fn [ 1 0] (t/fn [:> t/boolean?] - [t/any? :> t/boolean?]) - (t/fn [] - [t/any?]))) - (testing "input >") - (testing "input ><") - (testing "input <>")) - (testing "output ><" - (testing "input <" - (test-comparison|fn [ 2 -1] (t/fn [t/boolean? :> i|><0]) - (t/fn [] - [t/any? :> i|><1]))) - (testing "input =") - (testing "input >") - (testing "input ><") - (testing "input <>")) - (testing "output <>" - (testing "input <") - (testing "input =") - (testing "input >") - (testing "input ><") - (testing "input <>")) - - ;; Tests that pass (testing "input arities <" (testing "same-arity input types <" (testing "output <" (test-comparison|fn [ t/boolean?]) (t/fn [] [t/any? :> t/long?]))) (testing "output =") - (testing "output >") + (testing "output >" + (test-comparison|fn [ ident] (t/fn [t/boolean?]) + (t/fn [:> t/boolean?] [t/any? :> t/boolean?]))) (testing "output ><") (testing "output <>")) (testing "same-arity input types =" @@ -1008,6 +933,99 @@ (testing "output >") (testing "output ><") (testing "output <>")) + (testing "same-arity input types <>" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>"))) + (testing "input arities >" + (testing "same-arity input types <" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "same-arity input types =" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "same-arity input types >" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "same-arity input types ><" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "same-arity input types <>" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>"))) + (testing "input arities ><" + (testing "same-arity input types <" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "same-arity input types =" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "same-arity input types >" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "same-arity input types ><" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "same-arity input types <>" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>"))) + (testing "input arities <>" + (testing "same-arity input types <" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "same-arity input types =" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "same-arity input types >" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) + (testing "same-arity input types ><" + (testing "output <") + (testing "output =") + (testing "output >") + (testing "output ><") + (testing "output <>")) (testing "same-arity input types <>" (testing "output <") (testing "output =") From ce55d12c645476d77a804c43ec2a684ab9c49adb Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Sep 2018 12:06:30 -0600 Subject: [PATCH 192/810] Add a few more tests --- .../test/untyped/core/type/compare.cljc | 28 +++++++++++-------- 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 953ef982..2bf4314d 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -901,23 +901,27 @@ (testing "input arities =" (testing "same-arity input types <" (testing "output <" - (test-comparison|fn [ t/boolean?]) - (t/fn [t/any?]))) + (test-comparison|fn [ t/boolean?]) + (t/fn [t/any?]))) (testing "output =" - (test-comparison|fn [" - (test-comparison|fn [ident] (t/fn [t/boolean?]) - (t/fn [t/any? :> t/boolean?]))) + (test-comparison|fn [ ident] (t/fn [t/boolean?]) + (t/fn [t/any? :> t/boolean?]))) (testing "output ><" - (test-comparison|fn [ i|><0]) - (t/fn [t/any? :> i|><1]))) + (test-comparison|fn [ i|><0]) + (t/fn [t/any? :> i|><1]))) (testing "output <>" - (test-comparison|fn [ident] (t/fn [t/boolean? :> ><0]) - (t/fn [t/any? :> ><1])))) + (test-comparison|fn [ ident] (t/fn [t/boolean? :> ><0]) + (t/fn [t/any? :> ><1])))) (testing "same-arity input types =" - (testing "output <") - (testing "output =") + (testing "output <" + (test-comparison|fn [ =ident >ident] (t/fn []) + (t/fn [:> t/boolean?]))) + (testing "output =" + (test-comparison|fn [ =ident =ident] (t/fn []) + (t/fn []))) (testing "output >") (testing "output ><") (testing "output <>")) From 5a6acb4d61fb4954fe52850f16be231c83afc9a0 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Sep 2018 18:02:55 -0600 Subject: [PATCH 193/810] Now incrementally compile-time dispatches as it analyzes --- src-dev/quantum/core/defnt_equivalences.cljc | 7 +- src-untyped/quantum/untyped/core/analyze.cljc | 83 ++++++++++++++----- src-untyped/quantum/untyped/core/type.cljc | 17 ++-- .../quantum/untyped/core/type/compare.cljc | 3 +- .../untyped/core/type/reifications.cljc | 3 +- 5 files changed, 82 insertions(+), 31 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 6061bf3f..6586a169 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -934,8 +934,9 @@ (is (identical? (>long* (byte 1)) (clojure.lang.RT/uncheckedLongCast (byte 1))))))))) -(defnt defnt-reference-test - ([] (>long* 1))) +(deftest defnt-reference-test + (defnt defnt-reference + ([] (>long* 1)))) (is-code= @@ -943,6 +944,8 @@ (defnt >long {:source "clojure.lang.RT.longCast"} > t/long? + ;; TODO multi-arity `t/-` + ;; TODO fix reference to `>long*` ([x (t/- t/primitive? t/boolean? t/float? t/double?)] (>long* x)) ([x (t/and (t/or t/double? t/float?) ;; TODO add this back in diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 5df6bd7f..91826ccf 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -425,6 +425,57 @@ ;; `t/none?` because nothing is actually returned :type t/none?}))))) +(defns- call>arg-nodes+out-type + [env _, caller|node _, caller|type _, caller-kind _, args-ct _, body _ + > (s/kv {:arg-nodes t/any? #_(s/seq-of ast/node?) + :out-type t/type?})] + {:post [(doto % (println))]} + (dissoc + (if (zero? args-ct) + {:arg-nodes [] + :out-type (case caller-kind + ;; We could do a little smarter analysis here but we'll + ;; keep it simple for now + :fn t/any? + :fnt (-> caller|type (get args-ct) first :output-type))} + (->> body + (c/map+ #(analyze* env %)) + (reducei (fn [{:as ret :keys [satisfying-overloads-seq]} + arg|analyzed i] + ;; TODO review this part as it's passing back a nil out-type somehow + (if (= :fnt caller-kind) + (if-let [satisfying-overloads-seq' + (->> satisfying-overloads-seq + (c/lfilter + (fn [{:keys [input-types]}] + (t/<= (:type arg|analyzed) + (get input-types i)))) + seq)] + (-> ret + (update :arg-nodes conj arg|analyzed) + (assoc :satisfying-overloads-seq satisfying-overloads-seq' + :out-type + (when (and (= i (dec args-ct)) + (= (bounded-count 2 satisfying-overloads-seq') + 1)) + (-> satisfying-overloads-seq' + first + :output-type)))) + (err! "No overloads satisfy the arguments" + {:caller caller|node + :args body})) + (update ret :arg-nodes conj arg|analyzed))) + {:arg-nodes [] + ;; We could do a little smarter analysis here but we'll + ;; keep it simple for now + :out-type (when-not (= :fnt caller-kind) t/any?) + :satisfying-overloads-seq + (when (= :fnt caller-kind) + (-> caller|type + utr/fn-type>arities + (get args-ct)))}))) + :satisfying-overloads-seq)) + (defns- analyze-seq* "Analyze a seq after it has been macro-expanded. The ->`form` is post- incremental macroexpansion." @@ -447,17 +498,20 @@ _ (ppr caller|node) caller|type (:type caller|node) args-ct (count body)] - (case (t/compare caller|type t/callable?) + ;; TODO fix this line of code and extend t/compare so the comparison checks below + ;; will work with t/fn + (case (if (utr/fn-type? caller|type) + -1 + (t/compare caller|type t/callable?)) (1 2) (err! "It is not known whether form can be called" {:node caller|node}) 3 (err! "Form cannot be called" {:node caller|node}) (-1 0) (let [caller-kind - (ifs (t/<= caller|type t/keyword?) :keyword + (ifs (utr/fn-type? caller|type) :fnt + (t/<= caller|type t/keyword?) :keyword (t/<= caller|type t/+map|built-in?) :map (t/<= caller|type t/+vector|built-in?) :vector (t/<= caller|type t/+set|built-in?) :set (t/<= caller|type t/fn?) :fn - ;; TODO maybe have a better check? - (t/<= caller|type t/fnt?) :fnt ;; If it's callable but not fn, we might have missed something in ;; this dispatch so for now we throw (err! "Don't know how how to handle non-fn callable" @@ -479,25 +533,16 @@ {:args-ct args-ct :caller caller|node})) :fnt - (TODO "Don't know how to handle typed fns yet" {:caller caller|node}) + (when-not (-> caller|type utr/fn-type>arities (contains? args-ct)) + (err! "Unhandled number of arguments for fnt" + {:args-ct args-ct :caller caller|node})) ;; For non-typed fns, unknown; we will have to risk runtime exception ;; because we can't necessarily rely on metadata to tell us the ;; whole truth :fn nil) - ;; TODO incrementally check by analyzing each arg in `reduce` and pruning - ;; branches of what the type could be, and throwing if it's found something - ;; that's an impossible combination - arg-nodes (->> body - (c/map+ #(analyze* env %)) - (reduce (fn [args arg|analyzed] - (conj args arg|analyzed)) - [])) - out-type - (case caller-kind - ;; We could do a little smarter analysis here but we'll keep it simple - ;; for now - (:keyword :map :vector :set :fn) t/any? - :fnt (TODO "Use `::t/type` metadata to make this decision"))] + {:keys [arg-nodes out-type]} + (call>arg-nodes+out-type + env caller|node caller|type caller-kind args-ct body)] (uast/call-node {:env env :form form diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index da0ac775..ab7aa044 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -473,14 +473,15 @@ (->> ct ct->overloads|x1 overloads->ored-input-types)))))) utcomp/combine-comparisons)))) -(defns compare|out [x0 utr/fn-type?, x1 utr/fn-type?] - (let [fn-type>output-type - (c/fn [f] (->> f utr/fn-type>arities - vals - (apply concat) - (uc/lmap :output-type) - (apply or)))] - (utcomp/compare (fn-type>output-type x0) (fn-type>output-type x1)))) +(defns fn-type>output-type [x utr/fn-type? > type?] + (->> x utr/fn-type>arities + vals + (apply concat) + (uc/lmap :output-type) + (apply or))) + +(defns compare|out [x0 utr/fn-type?, x1 utr/fn-type? > ucomp/comparison?] + (utcomp/compare (fn-type>output-type x0) (fn-type>output-type x1))) (defn unkeyed "Creates an unkeyed collection type, in which the collection may diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index d0fc8583..295a3629 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -451,7 +451,8 @@ ;; TODO unknown if this is `and`- or `or`-style combination (defns combine-comparisons - "Commutative in the 2-ary arity" + "Used in `t/compare|in` and `t/compare|out`. Might be used for other things too in the future. + Commutative in the 2-ary arity." ([cs _ #_(seq-of ucomp/comparison?) > ucomp/comparison?] (reduce (fn [c' c] (combine-comparisons c' c)) (first cs) (rest cs))) ([^long c0 ucomp/comparison?, ^long c1 ucomp/comparison? > ucomp/comparison?] diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 479d8117..76a76fe6 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -227,7 +227,8 @@ ;; ----- FnType ----- ;; (udt/deftype FnType - [name arities-form arities] + [name arities-form + arities #_(s/map-of non-zero-int? (s/seq-of ::t/fn-type|arity))] {PType nil ;; Outputs whether the args match any input spec ?Fn {invoke ([this args] (TODO))} From 192c3fc63b617fa3718f36801c8d7ddc03cbbc2e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Sep 2018 18:24:53 -0600 Subject: [PATCH 194/810] First `defnt` reference works! --- src-dev/quantum/core/defnt_equivalences.cljc | 7 +++++-- src-untyped/quantum/untyped/core/analyze.cljc | 13 +++++-------- src-untyped/quantum/untyped/core/type/defnt.cljc | 2 +- 3 files changed, 11 insertions(+), 11 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 6586a169..2ebd9e33 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -29,7 +29,9 @@ [quantum.core Numeric Primitive])) ;; Just in case -(clojure.spec.test.alpha/instrument) +(clojure.spec.test.alpha/unstrument) +(do (require '[orchestra.spec.test :as st]) + (orchestra.spec.test/instrument)) #?(:clj (deftest test|pid @@ -936,7 +938,8 @@ (deftest defnt-reference-test (defnt defnt-reference - ([] (>long* 1)))) + ([] (>long* 1))) + (is (identical? (defnt-reference) 1))) (is-code= diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 91826ccf..eee8432a 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -429,13 +429,12 @@ [env _, caller|node _, caller|type _, caller-kind _, args-ct _, body _ > (s/kv {:arg-nodes t/any? #_(s/seq-of ast/node?) :out-type t/type?})] - {:post [(doto % (println))]} + (dissoc (if (zero? args-ct) {:arg-nodes [] :out-type (case caller-kind - ;; We could do a little smarter analysis here but we'll - ;; keep it simple for now + ;; We could do a little smarter analysis here but we'll keep it simple for now :fn t/any? :fnt (-> caller|type (get args-ct) first :output-type))} (->> body @@ -455,9 +454,7 @@ (update :arg-nodes conj arg|analyzed) (assoc :satisfying-overloads-seq satisfying-overloads-seq' :out-type - (when (and (= i (dec args-ct)) - (= (bounded-count 2 satisfying-overloads-seq') - 1)) + (when (= i (dec args-ct)) (-> satisfying-overloads-seq' first :output-type)))) @@ -466,8 +463,8 @@ :args body})) (update ret :arg-nodes conj arg|analyzed))) {:arg-nodes [] - ;; We could do a little smarter analysis here but we'll - ;; keep it simple for now + ;; We could do a little smarter analysis here but we'll keep it simple for + ;; now :out-type (when-not (= :fnt caller-kind) t/any?) :satisfying-overloads-seq (when (= :fnt caller-kind) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 56e3fde4..5e3151dd 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -386,7 +386,7 @@ :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, out-class t/class?]} ::expanded-overload gen-gensym fn? - > (s/seq-of ::reify|overload)] + > ::reify|overload] (let [interface-k {:out out-class :in arg-classes} interface (-> *interfaces From 56e3a67f3cddcf8f3f643a0aba47ae612b5f3144 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Sep 2018 18:32:51 -0600 Subject: [PATCH 195/810] Cleanup --- src-untyped/quantum/untyped/core/analyze.cljc | 70 +++++++++---------- 1 file changed, 34 insertions(+), 36 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index eee8432a..76158fa5 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -433,44 +433,42 @@ (dissoc (if (zero? args-ct) {:arg-nodes [] - :out-type (case caller-kind - ;; We could do a little smarter analysis here but we'll keep it simple for now - :fn t/any? - :fnt (-> caller|type (get args-ct) first :output-type))} + :out-type + (if (= :fnt caller-kind) + (-> caller|type (get args-ct) first :output-type) + ;; We could do a little smarter analysis here but we'll keep it simple for now + t/any?)} (->> body (c/map+ #(analyze* env %)) - (reducei (fn [{:as ret :keys [satisfying-overloads-seq]} - arg|analyzed i] - ;; TODO review this part as it's passing back a nil out-type somehow - (if (= :fnt caller-kind) - (if-let [satisfying-overloads-seq' - (->> satisfying-overloads-seq - (c/lfilter - (fn [{:keys [input-types]}] - (t/<= (:type arg|analyzed) - (get input-types i)))) - seq)] - (-> ret - (update :arg-nodes conj arg|analyzed) - (assoc :satisfying-overloads-seq satisfying-overloads-seq' - :out-type - (when (= i (dec args-ct)) - (-> satisfying-overloads-seq' - first - :output-type)))) - (err! "No overloads satisfy the arguments" - {:caller caller|node - :args body})) - (update ret :arg-nodes conj arg|analyzed))) - {:arg-nodes [] - ;; We could do a little smarter analysis here but we'll keep it simple for - ;; now - :out-type (when-not (= :fnt caller-kind) t/any?) - :satisfying-overloads-seq - (when (= :fnt caller-kind) - (-> caller|type - utr/fn-type>arities - (get args-ct)))}))) + (reducei + (fn [{:as ret :keys [satisfying-overloads-seq]} arg|analyzed i] + (if (= :fnt caller-kind) + (if-let [satisfying-overloads-seq' + (->> satisfying-overloads-seq + (c/lfilter + (fn [{:keys [input-types]}] + (t/<= (:type arg|analyzed) (get input-types i)))) + seq)] + (-> ret + (update :arg-nodes conj arg|analyzed) + (assoc :satisfying-overloads-seq satisfying-overloads-seq' + :out-type + (when-let [last-arg-to-check? (= i (dec args-ct))] + (-> satisfying-overloads-seq' + first + :output-type)))) + (err! "No overloads satisfy the arguments" + {:caller caller|node + :args body})) + (update ret :arg-nodes conj arg|analyzed))) + {:arg-nodes [] + ;; We could do a little smarter analysis here but we'll keep it simple for now + :out-type (when-not (= :fnt caller-kind) t/any?) + :satisfying-overloads-seq + (when (= :fnt caller-kind) + (-> caller|type + utr/fn-type>arities + (get args-ct)))}))) :satisfying-overloads-seq)) (defns- analyze-seq* From efb37f37e474c3b763a19a83509aa9ff95c8a14f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Sep 2018 18:33:08 -0600 Subject: [PATCH 196/810] More cleanup --- src-untyped/quantum/untyped/core/analyze.cljc | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 76158fa5..8b62a653 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -452,11 +452,10 @@ (-> ret (update :arg-nodes conj arg|analyzed) (assoc :satisfying-overloads-seq satisfying-overloads-seq' - :out-type - (when-let [last-arg-to-check? (= i (dec args-ct))] - (-> satisfying-overloads-seq' - first - :output-type)))) + :out-type (when-let [last-arg-to-check? (= i (dec args-ct))] + (-> satisfying-overloads-seq' + first + :output-type)))) (err! "No overloads satisfy the arguments" {:caller caller|node :args body})) From d2c84a50877a7a56c16510d100c52f22465e713e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Sep 2018 18:34:23 -0600 Subject: [PATCH 197/810] Cleanup --- src-untyped/quantum/untyped/core/analyze.cljc | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 8b62a653..19396897 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -451,18 +451,18 @@ seq)] (-> ret (update :arg-nodes conj arg|analyzed) - (assoc :satisfying-overloads-seq satisfying-overloads-seq' - :out-type (when-let [last-arg-to-check? (= i (dec args-ct))] - (-> satisfying-overloads-seq' - first - :output-type)))) + (assoc :satisfying-overloads-seq satisfying-overloads-seq' + :out-type (when-let [last-arg-to-check? (= i (dec args-ct))] + (-> satisfying-overloads-seq' + first + :output-type)))) (err! "No overloads satisfy the arguments" {:caller caller|node - :args body})) - (update ret :arg-nodes conj arg|analyzed))) + :args body})) + (update ret :arg-nodes conj arg|analyzed))) {:arg-nodes [] ;; We could do a little smarter analysis here but we'll keep it simple for now - :out-type (when-not (= :fnt caller-kind) t/any?) + :out-type (when-not (= :fnt caller-kind) t/any?) :satisfying-overloads-seq (when (= :fnt caller-kind) (-> caller|type From 48e0e627ee04514831d4155dcfd34d1c28e5f0b9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Sep 2018 21:51:49 -0600 Subject: [PATCH 198/810] Clean up `>long-checked` test --- src-dev/quantum/core/defnt_equivalences.cljc | 418 ++++++++++--------- src-untyped/quantum/untyped/core/form.cljc | 2 + 2 files changed, 217 insertions(+), 203 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 2ebd9e33..9b6fcd2e 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -941,209 +941,221 @@ ([] (>long* 1))) (is (identical? (defnt-reference) 1))) -(is-code= - -(macroexpand ' -(defnt >long - {:source "clojure.lang.RT.longCast"} - > t/long? - ;; TODO multi-arity `t/-` - ;; TODO fix reference to `>long*` - ([x (t/- t/primitive? t/boolean? t/float? t/double?)] (>long* x)) - ([x (t/and (t/or t/double? t/float?) - ;; TODO add this back in - #_(fnt [x (t/or t/double? t/float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] - (>long* x)) - ([x (t/and (t/isa? clojure.lang.BigInt) - ;; TODO add this back in - #_(fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] - (.lpart x)) - ([x (t/and (t/isa? java.math.BigInteger) - ;; TODO add this back in - #_(fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] - (.longValue x)) - ([x t/ratio?] (>long (.bigIntegerValue x))) - ([x (t/value true)] 1) - ([x (t/value false)] 0) - ([x t/string?] (Long/parseLong x)) - ([x t/string?, radix t/int?] (Long/parseLong x radix)))) - -;; ----- expanded code ----- ;; - -(case (env-lang) - :clj ($ (do #_[x (t/- t/primitive? t/boolean? t/float? t/double?)] - - #_(def ~'>long|__0|input-types (*<> t/byte?)) - (def ~'>long|__0 - (reify byte>long - (~(tag "long" 'invoke) [_## ~(tag "byte" 'x)] - ;; Resolved from `(>long* x)` - (.invoke >long*|__0 ~'x)))) - - #_(def ~'>long|__1|input-types (*<> t/char?)) - (def ~'>long|__1 - (reify char>long - (~(tag "long" 'invoke) [_## ~(tag "char" 'x)] - ;; Resolved from `(>long* x)` - (.invoke >long*|__1 ~'x)))) - - #_(def ~'>long|__2|input-types (*<> t/short?)) - (def ~'>long|__2 - (reify short>long - (~(tag "long" 'invoke) [_## ~(tag "short" 'x)] - ;; Resolved from `(>long* x)` - (.invoke >long*|__2 ~'x)))) - - #_(def ~'>long|__3|input-types (*<> t/int?)) - (def ~'>long|__3 - (reify int>long - (~(tag "long" 'invoke) [_## ~(tag "int" 'x)] - ;; Resolved from `(>long* x)` - (.invoke >long*|__3 ~'x)))) - - #_(def ~'>long|__4|input-types (*<> t/long?)) - (def ~'>long|__4 - (reify long>long - (~(tag "long" 'invoke) [_## ~(tag "long" 'x)] - ;; Resolved from `(>long* x)` - (.invoke >long*|__4 ~'x)))) - - #_[x (t/and (t/or t/double? t/float?) - (fnt [x (t/or double? float?)] - (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] - - #_(def ~'>long|__5|input-types - (*<> (t/and t/double? - (fnt [x (t/or double? float?)] - (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE)))))) - (def ~'>long|__5 - (reify double>long - (~(tag "long" 'invoke) [_## ~(tag "double" 'x)] - ;; Resolved from `(>long* x)` - (.invoke >long*|__6 ~'x)))) - - #_(def ~'>long|__6|input-types - (*<> (t/and t/float? - (fnt [x (t/or double? float?)] - (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE)))))) - (def ~'>long|__6 - (reify float>long - (~(tag "long" 'invoke) [_## ~(tag "float" 'x)] - ;; Resolved from `(>long* x)` - (.invoke >long*|__5 ~'x)))) - - #_[(t/and (t/isa? clojure.lang.BigInt) - (fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] - - #_(def ~'>long|__7|input-types - (*<> (t/and (t/isa? clojure.lang.BigInt) - (fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x)))))) - (def ~'>long|__7 - (reify Object>long - (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] - (let* [~(tag "clojure.lang.BigInt" 'x) ~'x] ~'(.lpart x))))) - - #_[x (t/and (t/isa? java.math.BigInteger) - (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] - - #_(def ~'>long|__8|input-types - (*<> (t/and (t/isa? java.math.BigInteger) - (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64))))) - (def ~'>long|__8 - (reify Object>long - (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] - (let* [~(tag "java.math.BigInteger" 'x) ~'x] ~'(.longValue x))))) - - #_[x t/ratio?] - - #_(def ~'>long|__9|input-types - (*<> t/ratio?)) - #_(def ~'>long|__9|conditions - (*<> (-> long|__8|input-types (get 0) utr/and-type>args (get 1)))) - (def ~'>long|__9 - (reify Object>long - (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] - (let* [~(tag "clojure.lang.Ratio" 'x) ~'x] - ;; Resolved from `(>long (.bigIntegerValue x))` - ;; In this case, `(t/compare (type-of '(.bigIntegerValue x)) overload-type)`: - ;; - `(t/- t/primitive? t/boolean? t/float? t/double?)` -> t/<> - ;; - `(t/and (t/or t/double? t/float?) ...)` -> t/<> - ;; - `(t/and (t/isa? clojure.lang.BigInt) ...)` -> t/<> - ;; - `(t/and (t/isa? java.math.BigInteger) ...)` -> t/> - ;; - `t/ratio?` -> t/<> - ;; - `(t/value true)` -> t/<> - ;; - `(t/value false)` -> t/<> - ;; - `t/string?` -> t/<> - ;; - ;; Since there is no overload that results in t/<, no compile-time match can - ;; be found, but a possible runtime match lies in the overload that results in - ;; t/>. The remaining uncertainty will have to be resolved at compile time. - ;; Note that if there had been multiple overloads with t/>, we would have had - ;; to dispatch on that and resolve accordingly. - (let [x## ~'(.bigIntegerValue x)] - (if ((Array/get >long|__9|conditions 0) x##) - (.invoke >long|__8 x##) - (unsupported! `>long x##))))))) - - #_[x (t/value true)] - - #_(def ~'>long|__10|input-types - (*<> (t/value true))) - (def ~'>long|__10 - (reify boolean>long - (~(tag "long" 'invoke) [_## ~(tag "boolean" 'x)] 1))) - - #_[x (t/value false)] - - #_(def ~'>long|__11|input-types - (*<> (t/value false))) - (def ~'>long|__11 - (reify boolean>long - (~(tag "long" 'invoke) [_## ~(tag "boolean" 'x)] 0))) - - #_[x t/string?] - - #_(def ~'>long|__12|input-types - (*<> t/string?)) - (def ~'>long|__12 - (reify Object>long - (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] - ~'(Long/parseLong x)))) - - #_[x t/string?] - - #_(def ~'>long|__13|input-types - (*<> t/string? t/int?)) - (def ~'>long|__13 - (reify Object+int>long - (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x) ~(tag "int" 'radix)] - ~'(Long/parseLong x radix)))) - - #_(defn >long - {::t/type - (t/fn - [(t/- t/primitive? t/boolean? t/float? t/double?)] - [(t/and (t/or t/double? t/float?) - (fnt [x (t/or double? float?)] - (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] - [(t/and (t/isa? clojure.lang.BigInt) - (fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] - [(t/and (t/isa? java.math.BigInteger) - (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] - [t/ratio?] - [(t/value true)] - [(t/value false)] - [t/string?] - [t/string? t/int?])} - ([x0##] (ifs ((Array/get >long|__0|input-types 0) x0##) - (.invoke >long|__0 x0##) - ((Array/get >long|__1|input-types 0) x0##) - (.invoke >long|__0 x0##) - ((Array/get >long|__2|input-types 0) x0##) - (.invoke >long|__2 x0##))) - ([x0## x1##] ...))))) - -) +;; NOTE would use `>long` but that's already an interface +(deftest test|>long-checked + (let [actual + (macroexpand ' + (defnt >long-checked + {:source "clojure.lang.RT.longCast"} + > t/long? + ;; TODO multi-arity `t/-` + ([x (t/- (t/- (t/- t/primitive? t/boolean?) t/float?) t/double?)] (>long* x)) + ([x (t/and (t/or t/double? t/float?) + ;; TODO add this back in + #_(fnt [x (t/or t/double? t/float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] + (>long* x)) + ([x (t/and (t/isa? clojure.lang.BigInt) + ;; TODO add this back in + #_(fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] + (.lpart x)) + ([x (t/and (t/isa? java.math.BigInteger) + ;; TODO add this back in + #_(fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] + (.longValue x)) + ;; TODO support recursion + #_([x t/ratio?] (>long-checked (.bigIntegerValue x))) + ([x (t/value true)] 1) + ([x (t/value false)] 0) + ([x t/string?] (Long/parseLong x)) + ([x t/string?, radix t/int?] (Long/parseLong x radix)))) + expected + (case (env-lang) + :clj ($ (do #_[x (t/- t/primitive? t/boolean? t/float? t/double?)] + + #_(def ~'>long|__0|input-types (*<> t/byte?)) + (def ~'>long|__0 + (reify byte>long + (~(tag "long" 'invoke) [_## ~(tag "byte" 'x)] + ;; Resolved from `(>long* x)` + (.invoke >long*|__0 ~'x)))) + + #_(def ~'>long|__1|input-types (*<> t/char?)) + (def ~'>long|__1 + (reify char>long + (~(tag "long" 'invoke) [_## ~(tag "char" 'x)] + ;; Resolved from `(>long* x)` + (.invoke >long*|__1 ~'x)))) + + #_(def ~'>long|__2|input-types (*<> t/short?)) + (def ~'>long|__2 + (reify short>long + (~(tag "long" 'invoke) [_## ~(tag "short" 'x)] + ;; Resolved from `(>long* x)` + (.invoke >long*|__2 ~'x)))) + + #_(def ~'>long|__3|input-types (*<> t/int?)) + (def ~'>long|__3 + (reify int>long + (~(tag "long" 'invoke) [_## ~(tag "int" 'x)] + ;; Resolved from `(>long* x)` + (.invoke >long*|__3 ~'x)))) + + #_(def ~'>long|__4|input-types (*<> t/long?)) + (def ~'>long|__4 + (reify long>long + (~(tag "long" 'invoke) [_## ~(tag "long" 'x)] + ;; Resolved from `(>long* x)` + (.invoke >long*|__4 ~'x)))) + + #_[x (t/and (t/or t/double? t/float?) + (fnt [x (t/or double? float?)] + (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] + + #_(def ~'>long|__5|input-types + (*<> (t/and t/double? + (fnt [x (t/or double? float?)] + (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE)))))) + (def ~'>long|__5 + (reify double>long + (~(tag "long" 'invoke) [_## ~(tag "double" 'x)] + ;; Resolved from `(>long* x)` + (.invoke >long*|__6 ~'x)))) + + #_(def ~'>long|__6|input-types + (*<> (t/and t/float? + (fnt [x (t/or double? float?)] + (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE)))))) + (def ~'>long|__6 + (reify float>long + (~(tag "long" 'invoke) [_## ~(tag "float" 'x)] + ;; Resolved from `(>long* x)` + (.invoke >long*|__5 ~'x)))) + + #_[(t/and (t/isa? clojure.lang.BigInt) + (fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] + + #_(def ~'>long|__7|input-types + (*<> (t/and (t/isa? clojure.lang.BigInt) + (fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x)))))) + (def ~'>long|__7 + (reify Object>long + (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] + (let* [~(tag "clojure.lang.BigInt" 'x) ~'x] ~'(.lpart x))))) + + #_[x (t/and (t/isa? java.math.BigInteger) + (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] + + #_(def ~'>long|__8|input-types + (*<> (t/and (t/isa? java.math.BigInteger) + (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64))))) + (def ~'>long|__8 + (reify Object>long + (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] + (let* [~(tag "java.math.BigInteger" 'x) ~'x] ~'(.longValue x))))) + + #_[x t/ratio?] + + #_(def ~'>long|__9|input-types + (*<> t/ratio?)) + #_(def ~'>long|__9|conditions + (*<> (-> long|__8|input-types (get 0) utr/and-type>args (get 1)))) + (def ~'>long|__9 + (reify Object>long + (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] + (let* [~(tag "clojure.lang.Ratio" 'x) ~'x] + ;; Resolved from `(>long (.bigIntegerValue x))` + ;; In this case, `(t/compare (type-of '(.bigIntegerValue x)) overload-type)`: + ;; - `(t/- t/primitive? t/boolean? t/float? t/double?)` -> t/<> + ;; - `(t/and (t/or t/double? t/float?) ...)` -> t/<> + ;; - `(t/and (t/isa? clojure.lang.BigInt) ...)` -> t/<> + ;; - `(t/and (t/isa? java.math.BigInteger) ...)` -> t/> + ;; - `t/ratio?` -> t/<> + ;; - `(t/value true)` -> t/<> + ;; - `(t/value false)` -> t/<> + ;; - `t/string?` -> t/<> + ;; + ;; Since there is no overload that results in t/<, no compile-time match can + ;; be found, but a possible runtime match lies in the overload that results in + ;; t/>. The remaining uncertainty will have to be resolved at compile time. + ;; Note that if there had been multiple overloads with t/>, we would have had + ;; to dispatch on that and resolve accordingly. + (let [x## ~'(.bigIntegerValue x)] + (if ((Array/get >long|__9|conditions 0) x##) + (.invoke >long|__8 x##) + (unsupported! `>long x##))))))) + + #_[x (t/value true)] + + #_(def ~'>long|__10|input-types + (*<> (t/value true))) + (def ~'>long|__10 + (reify boolean>long + (~(tag "long" 'invoke) [_## ~(tag "boolean" 'x)] 1))) + + #_[x (t/value false)] + + #_(def ~'>long|__11|input-types + (*<> (t/value false))) + (def ~'>long|__11 + (reify boolean>long + (~(tag "long" 'invoke) [_## ~(tag "boolean" 'x)] 0))) + + #_[x t/string?] + + #_(def ~'>long|__12|input-types + (*<> t/string?)) + (def ~'>long|__12 + (reify Object>long + (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] + ~'(Long/parseLong x)))) + + #_[x t/string?] + + #_(def ~'>long|__13|input-types + (*<> t/string? t/int?)) + (def ~'>long|__13 + (reify Object+int>long + (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x) ~(tag "int" 'radix)] + ~'(Long/parseLong x radix)))) + + #_(defn >long + {::t/type + (t/fn + [(t/- t/primitive? t/boolean? t/float? t/double?)] + [(t/and (t/or t/double? t/float?) + (fnt [x (t/or double? float?)] + (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] + [(t/and (t/isa? clojure.lang.BigInt) + (fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] + [(t/and (t/isa? java.math.BigInteger) + (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] + [t/ratio?] + [(t/value true)] + [(t/value false)] + [t/string?] + [t/string? t/int?])} + ([x0##] (ifs ((Array/get >long|__0|input-types 0) x0##) + (.invoke >long|__0 x0##) + ((Array/get >long|__1|input-types 0) x0##) + (.invoke >long|__0 x0##) + ((Array/get >long|__2|input-types 0) x0##) + (.invoke >long|__2 x0##))) + ([x0## x1##] ...)))))] + ;; TODO fix this + #_(testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval + '(do (throws (>long-checked)) + (throws (>long-checked nil)) + (throws (>long-checked "")) + (is (identical? (>long-checked 1) (clojure.lang.RT/longCast 1))) + (is (identical? (>long-checked 1.0) (clojure.lang.RT/longCast 1.0))) + (is (identical? (>long-checked 1.1) (clojure.lang.RT/longCast 1.1))) + (is (identical? (>long-checked -1) (clojure.lang.RT/longCast -1))) + (is (identical? (>long-checked -1.0) (clojure.lang.RT/longCast -1.0))) + (is (identical? (>long-checked -1.1) (clojure.lang.RT/longCast -1.1))) + (is (identical? (>long-checked (byte 1)) (clojure.lang.RT/longCast (byte 1))))))))) ;; =====|=====|=====|=====|===== ;; diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index 78bda356..790e3db1 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -31,6 +31,8 @@ (extend-protocol PGenForm nil (>form [x] nil) + #?(:clj java.lang.Boolean + :cljs boolean) (>form [x] x) java.lang.Long (>form [x] x) #?(:clj clojure.lang.Symbol :cljs cljs.core.Symbol) (>form [x] (list 'quote x)) From 7e01e00e689a55421ade1e6419b15d391dc6b80b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 2 Sep 2018 00:59:03 -0600 Subject: [PATCH 199/810] `test|!str`, etc. --- src-dev/quantum/core/defnt_equivalences.cljc | 91 +++++++++++++++----- 1 file changed, 71 insertions(+), 20 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 9b6fcd2e..0b9e09fa 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -1157,19 +1157,67 @@ (is (identical? (>long-checked -1.1) (clojure.lang.RT/longCast -1.1))) (is (identical? (>long-checked (byte 1)) (clojure.lang.RT/longCast (byte 1))))))))) -;; =====|=====|=====|=====|===== ;; - -(macroexpand ' -(defnt !str > #?(:clj (t/isa? StringBuilder) - :cljs (t/isa? StringBuffer)) - ([] #?(:clj (StringBuilder.) :cljs (StringBuffer.))) - ;; If we had combined this arity, `t/or`ing the `t/string?` means it wouldn't have been - ;; handled any differently than `t/char-seq?` -#?(:clj ([x t/string?] (StringBuilder. x))) - ([x #?(:clj (t/or t/char-seq? t/int?) - :cljs t/val?)] - #?(:clj (StringBuilder. x) :cljs (StringBuffer. x)))) -) +(deftest test|!str + (let [actual + (macroexpand ' + (defnt !str > #?(:clj (t/isa? StringBuilder) + :cljs (t/isa? StringBuffer)) + ([] #?(:clj (StringBuilder.) :cljs (StringBuffer.))) + ;; If we had combined this arity, `t/or`ing the `t/string?` means it wouldn't have been + ;; handled any differently than `t/char-seq?` + #?(:clj ([x t/string?] (StringBuilder. x))) + ([x #?(:clj (t/or t/char-seq? t/int?) + :cljs t/val?)] + #?(:clj (StringBuilder. x) :cljs (StringBuffer. x))))) + expected + (case (env-lang) + :clj ($ (do (def ~'!str|__0|0 + (reify* [>Object] + (~(tag "java.lang.Object" 'invoke) [~'_0__] + ~'(StringBuilder.)))) + + (def ~'!str|__1|input0|types + (*<> (t/isa? java.lang.String))) + (def ~'!str|__1|0 + (reify* [Object>Object] + (~(tag "java.lang.Object" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] + (let* [~(tag "java.lang.String" 'x) ~'x] ~'(StringBuilder. x))))) + + (def ~'!str|__2|input0|types + (*<> (t/isa? java.lang.CharSequence) + (t/isa? java.lang.Integer))) + (def ~'!str|__2|0 + (reify* [Object>Object] + (~(tag "java.lang.Object" 'invoke) [~'_2__ ~(tag "java.lang.Object" 'x)] + (let* [~(tag "java.lang.CharSequence" 'x) ~'x] + ~'(StringBuilder. x))))) + (def ~'!str|__2|1 + (reify* [int>Object] + (~(tag "java.lang.Object" 'invoke) [~'_3__ ~(tag "int" 'x)] + ~'(StringBuilder. x)))) + + (defn ~'!str + {::t/type (t/fn ~'[ :> (t/isa? StringBuilder)] + ~'[t/string? :> (t/isa? StringBuilder)] + ~'[(t/or t/char-seq? t/int?) :> (t/isa? StringBuilder)])} + ([] (.invoke ~'!str|__0|0)) + ([~'x00__] + (ifs + ((Array/get ~'!str|__1|input0|types 0) ~'x00__) + (.invoke !str|__1|0 ~'x00__) + ((Array/get ~'!str|__2|input0|types 0) ~'x00__) + (.invoke !str|__2|0 ~'x00__) + ((Array/get ~'!str|__2|input0|types 1) ~'x00__) + (.invoke !str|__2|1 ~'x00__) + (unsupported! `!str [~'x00__] 0)))))))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval + '(do (is (instance? StringBuilder (!str))) + (is (instance? StringBuilder (!str "asd"))) + (is (instance? StringBuilder (!str (int 123)))) + (is (instance? StringBuilder (!str (.subSequence "abc" 0 1))))))))) ;; ----- expanded code ----- ;; @@ -1209,20 +1257,23 @@ ;; =====|=====|=====|=====|===== ;; +;; TODO handle inline (macroexpand ' -(defnt #_:inline str > t/string? +(defnt #_:inline str|test > t/string? ([] "") ([x t/nil?] "") ;; could have inferred but there may be other objects who have overridden .toString - #?(:clj ([x (t/isa? Object)] (.toString x)) + #?(#_:clj #_([x (t/isa? Object) > (* t/string?)] (.toString x)) ;; Can't infer that it returns a string (without a pre-constructed list of built-in fns) ;; As such, must explicitly mark :cljs ([x t/any? > (t/assume t/string?)] (.join #js [x] ""))) ;; TODO only one variadic arity allowed currently; theoretically could dispatch on at ;; least pre-variadic args, if not variadic ;; TODO should have automatic currying? - ([x (t/fn> str t/any?) & xs (? (t/seq-of t/any?)) #?@(:cljs [> (t/assume t/string?)])] - (let* [sb (-> x str !str)] ; determined to be StringBuilder + ;; TODO need to handle varargs + #_([x (t/fn> str|test t/any?) & xs (? (t/seq-of t/any?)) + #?@(:cljs [> (t/assume t/string?)])] + (let* [sb (-> x str|test !str)] ; determined to be StringBuilder ;; TODO is `doseq` the right approach, or using reduction? (doseq [x' xs] (.append sb (str x'))) (.toString sb)))) @@ -1309,7 +1360,7 @@ ; TODO CLJS version will come after #?(:clj (macroexpand ' -(defnt seq +(defnt seq|test "Taken from `clojure.lang.RT/seq`" > (t/? (t/isa? ISeq)) ([xs t/nil? ] nil) @@ -1317,8 +1368,8 @@ ([xs (t/or (t/isa? LazySeq) (t/isa? Seqable))] (.seq xs)) ([xs t/iterable? ] (clojure.lang.RT/chunkIteratorSeq (.iterator xs))) - ([xs t/char-seq? ] (StringSeq/create xs)) - ([xs (t/isa? Map) ] (seq (.entrySet xs))) + ([xs t/char-seq? ] (clojure.lang.StringSeq/create xs)) + ([xs (t/isa? java.util.Map) ] (seq|test (.entrySet xs))) ([xs t/array? ] (ArraySeq/createFromObject xs)))) ) From 59a2240779db638e847e1dc7aa4c6f7883f6ad8c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 2 Sep 2018 00:59:22 -0600 Subject: [PATCH 200/810] Dynamic dispatch resolution introduced --- src-untyped/quantum/untyped/core/analyze.cljc | 146 ++++++++++++------ 1 file changed, 98 insertions(+), 48 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 19396897..a48d618f 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -6,6 +6,7 @@ [quantum.untyped.core.analyze.expr :as uxp] [quantum.untyped.core.collections :as c :refer [>vec]] + [quantum.untyped.core.collections.logic :as clogic] [quantum.untyped.core.compare :as ucomp] [quantum.untyped.core.core :refer [istr]] @@ -20,7 +21,7 @@ [quantum.untyped.core.form.evaluate :as ufeval] [quantum.untyped.core.log :as log :refer [prl!]] - [quantum.untyped.core.logic + [quantum.untyped.core.logic :as l :refer [if-not-let ifs]] [quantum.untyped.core.print :refer [ppr]] @@ -201,7 +202,7 @@ (defns methods->type "Creates a type given ->`methods`." - [methods (s/seq-of t/any? #_method?) > t/type?] + [methods (s/seq-of t/any? #_method?) #_> #_t/type?] ;; TODO room for plenty of optimization here (let [methods|by-ct (->> methods (c/group-by (fn-> :argtypes count)) @@ -425,50 +426,100 @@ ;; `t/none?` because nothing is actually returned :type t/none?}))))) -(defns- call>arg-nodes+out-type - [env _, caller|node _, caller|type _, caller-kind _, args-ct _, body _ - > (s/kv {:arg-nodes t/any? #_(s/seq-of ast/node?) +(defn- filter-dynamic-dispatchable-overloads + "An example of dynamic dispatch: + - When we call `seq` on an input of type `(t/? (t/isa? java.util.Set))`, direct dispatch will + fail as it is not `t/<=` to any overload (including `t/iterable?` which is the only one under + which `(t/isa? java.util.Set)` falls). + However since all branches of the `t/or` are guaranteed to result in a successful dispatch + (i.e. `t/nil?` and `t/iterable?`) then dynamic dispatch will go forward without an error." + [{:as ret :keys [dispatchable-overloads-seq]} input|analyzed i caller|node body] + (if (-> input|analyzed :type utr/or-type?) + (let [or-types (-> input|analyzed :type utr/or-type>args) + {:keys [dispatchable-overloads-seq' non-dispatchable-or-types]} + (->> dispatchable-overloads-seq + (reduce + (fn [ret {:as overload :keys [input-types]}] + (if-let [or-types-that-match + (->> or-types (c/lfilter #(t/<= % (get input-types i))) seq)] + (-> ret + (update :dispatchable-overloads-seq' conj overload) + (update :non-dispatchable-or-types + #(apply disj % or-types-that-match))) + ret)) + {:dispatchable-overloads-seq' [] + :non-dispatchable-or-types (set or-types)}))] + (if (or (empty? dispatchable-overloads-seq') + (c/contains? non-dispatchable-or-types)) + (err! "No overloads satisfy the inputs, whether direct or dynamic" + {:caller caller|node + :inputs body}) + (assoc ret :dispatchable-overloads-seq dispatchable-overloads-seq' + :dispatch-type :dynamic))) + (err! "Cannot currently do a dynamic dispatch on a non-`t/or` input type" + {:input|analyzed input|analyzed}))) + +(defn- filter-direct-dispatchable-overloads + [{:as ret :keys [dispatchable-overloads-seq]} input|analyzed i caller|node body] + (if-let [dispatchable-overloads-seq' + (->> dispatchable-overloads-seq + (c/lfilter + (fn [{:keys [input-types]}] + (t/<= (:type input|analyzed) (get input-types i)))) + seq)] + (assoc ret :dispatchable-overloads-seq dispatchable-overloads-seq') + (filter-dynamic-dispatchable-overloads ret input|analyzed i caller|node body))) + +(defn- >dispatch|out-type [dispatch-type dispatchable-overloads-seq] + (case dispatch-type + :direct (-> dispatchable-overloads-seq first :output-type) + :dynamic (->> dispatchable-overloads-seq + (c/lmap :output-type) + ;; Technically we could do a complex + ;; conditional instead of a simple `t/or` + ;; but no need + (apply t/or)))) + +(defns- call>input-nodes+out-type + [env _, caller|node _, caller|type _, caller-kind _, inputs-ct _, body _ + > (s/kv {:input-nodes t/any? #_(s/seq-of ast/node?) :out-type t/type?})] - (dissoc - (if (zero? args-ct) - {:arg-nodes [] + (if (zero? inputs-ct) + {:input-nodes [] :out-type (if (= :fnt caller-kind) - (-> caller|type (get args-ct) first :output-type) + (-> caller|type (get inputs-ct) first :output-type) ;; We could do a little smarter analysis here but we'll keep it simple for now t/any?)} (->> body (c/map+ #(analyze* env %)) (reducei - (fn [{:as ret :keys [satisfying-overloads-seq]} arg|analyzed i] + (fn [{:as ret :keys [dispatch-type]} input|analyzed i] (if (= :fnt caller-kind) - (if-let [satisfying-overloads-seq' - (->> satisfying-overloads-seq - (c/lfilter - (fn [{:keys [input-types]}] - (t/<= (:type arg|analyzed) (get input-types i)))) - seq)] - (-> ret - (update :arg-nodes conj arg|analyzed) - (assoc :satisfying-overloads-seq satisfying-overloads-seq' - :out-type (when-let [last-arg-to-check? (= i (dec args-ct))] - (-> satisfying-overloads-seq' - first - :output-type)))) - (err! "No overloads satisfy the arguments" - {:caller caller|node - :args body})) - (update ret :arg-nodes conj arg|analyzed))) - {:arg-nodes [] + (let [{:as ret' :keys [dispatchable-overloads-seq]} + (case dispatch-type + :direct (filter-direct-dispatchable-overloads + ret input|analyzed i caller|node body) + :dynamic (filter-dynamic-dispatchable-overloads + ret input|analyzed i caller|node body))] + (-> ret' + (update :input-nodes conj input|analyzed) + (assoc :out-type + (when-let [last-input-to-check? (= i (dec inputs-ct))] + (>dispatch|out-type + dispatch-type dispatchable-overloads-seq))))) + (update ret :input-nodes conj input|analyzed))) + {:input-nodes [] ;; We could do a little smarter analysis here but we'll keep it simple for now :out-type (when-not (= :fnt caller-kind) t/any?) - :satisfying-overloads-seq + :dispatch-type :direct + :dispatchable-overloads-seq (when (= :fnt caller-kind) (-> caller|type utr/fn-type>arities - (get args-ct)))}))) - :satisfying-overloads-seq)) + (get inputs-ct)))}))) + :dispatchable-overloads-seq)) (defns- analyze-seq* "Analyze a seq after it has been macro-expanded. @@ -489,9 +540,8 @@ throw (analyze-seq|throw env form)) ;; TODO support recursion (let [caller|node (analyze* env caller|form) - _ (ppr caller|node) caller|type (:type caller|node) - args-ct (count body)] + inputs-ct (count body)] ;; TODO fix this line of code and extend t/compare so the comparison checks below ;; will work with t/fn (case (if (utr/fn-type? caller|type) @@ -510,38 +560,38 @@ ;; this dispatch so for now we throw (err! "Don't know how how to handle non-fn callable" {:caller caller|node})) - assert-valid-args-ct + assert-valid-inputs-ct (case caller-kind (:keyword :map) - (when-not (or (= args-ct 1) (= args-ct 2)) + (when-not (or (= inputs-ct 1) (= inputs-ct 2)) (err! (str "Keywords and `clojure.core` persistent maps must be " - "provided with exactly one or two args when calling " + "provided with exactly one or two inputs when calling " "them") - {:args-ct args-ct :caller caller|node})) + {:inputs-ct inputs-ct :caller caller|node})) (:vector :set) - (when-not (= args-ct 1) + (when-not (= inputs-ct 1) (err! (str "`clojure.core` persistent vectors and `clojure.core` " - "persistent sets must be provided with exactly one arg " - "when calling them") - {:args-ct args-ct :caller caller|node})) + "persistent sets must be provided with exactly one " + "input when calling them") + {:inputs-ct inputs-ct :caller caller|node})) :fnt - (when-not (-> caller|type utr/fn-type>arities (contains? args-ct)) - (err! "Unhandled number of arguments for fnt" - {:args-ct args-ct :caller caller|node})) + (when-not (-> caller|type utr/fn-type>arities (contains? inputs-ct)) + (err! "Unhandled number of inputs for fnt" + {:inputs-ct inputs-ct :caller caller|node})) ;; For non-typed fns, unknown; we will have to risk runtime exception ;; because we can't necessarily rely on metadata to tell us the ;; whole truth :fn nil) - {:keys [arg-nodes out-type]} - (call>arg-nodes+out-type - env caller|node caller|type caller-kind args-ct body)] + {:keys [input-nodes out-type]} + (call>input-nodes+out-type + env caller|node caller|type caller-kind inputs-ct body)] (uast/call-node {:env env :form form :caller caller|node - :args arg-nodes + :args input-nodes :type out-type})))))) (defns- analyze-seq [env ::env, form _] From e99784e228e1a702986383757a3cbb686a66cfd3 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 2 Sep 2018 01:23:21 -0600 Subject: [PATCH 201/810] More tests pass! :D --- src-dev/quantum/core/defnt_equivalences.cljc | 43 ++++++++++++++++---- 1 file changed, 34 insertions(+), 9 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 0b9e09fa..a389f70e 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -1,7 +1,7 @@ ;; See https://jsperf.com/js-property-access-comparison — all property accesses (at least of length 1) seem to be equal (ns quantum.core.test.defnt-equivalences - (:refer-clojure :exclude [*]) + (:refer-clojure :exclude [* zero? count]) (:require [quantum.untyped.core.type.defnt :refer [defnt fnt unsupported!]] @@ -1315,12 +1315,13 @@ ;; =====|=====|=====|=====|===== ;; +;; TODO enable the disabled parts of this (macroexpand ' -(defnt #_:inline count > t/nneg-integer? - ([xs t/array? > t/nneg-int?] (.-length xs)) - ([xs t/string? > #?(:clj t/nneg-int? :cljs (t/assume t/nneg-int?))] +(defnt #_:inline count #_> #_t/nneg-integer? + ([xs t/array? #_> #_t/nneg-int?] (.length xs)) + #_([xs t/string? > #?(:clj t/nneg-int? :cljs (t/assume t/nneg-int?))] (#?(:clj .length :cljs .-length) xs)) - ([xs !+vector? > t/nneg-int?] (#?(:clj count :cljs (do (TODO) 0)) xs))) + #_([xs !+vector? > t/nneg-int?] (#?(:clj count :cljs (do (TODO) 0)) xs))) ) ;; ----- expanded code ----- ;; @@ -1357,6 +1358,9 @@ ;; =====|=====|=====|=====|===== ;; +(defnt zero? > t/boolean? + ([x (t/- t/primitive? t/boolean?)] (Numeric/isZero x))) + ; TODO CLJS version will come after #?(:clj (macroexpand ' @@ -1367,10 +1371,31 @@ ([xs (t/isa? ASeq) ] xs) ([xs (t/or (t/isa? LazySeq) (t/isa? Seqable))] (.seq xs)) - ([xs t/iterable? ] (clojure.lang.RT/chunkIteratorSeq (.iterator xs))) - ([xs t/char-seq? ] (clojure.lang.StringSeq/create xs)) - ([xs (t/isa? java.util.Map) ] (seq|test (.entrySet xs))) - ([xs t/array? ] (ArraySeq/createFromObject xs)))) + ([xs t/iterable?] (clojure.lang.RT/chunkIteratorSeq (.iterator xs))) + ([xs t/char-seq?] (clojure.lang.StringSeq/create xs)) + ;; TODO recursion + #_([xs (t/isa? java.util.Map)] (seq|test (.entrySet xs))) + ;; TODO for these, use `count` not `clojure.lang.RT/alength` + ([xs t/booleans?] (when-not (zero? (clojure.lang.RT/alength xs)) + (clojure.lang.ArraySeq$ArraySeq_boolean. nil xs 0))) + ([xs t/bytes?] (when-not (zero? (clojure.lang.RT/alength xs)) + (clojure.lang.ArraySeq$ArraySeq_byte. nil xs 0))) + ([xs t/chars?] (when-not (zero? (clojure.lang.RT/alength xs)) + (clojure.lang.ArraySeq$ArraySeq_char. nil xs 0))) + ([xs t/shorts?] (when-not (zero? (clojure.lang.RT/alength xs)) + (clojure.lang.ArraySeq$ArraySeq_short. nil xs 0))) + ([xs t/ints?] (when-not (zero? (clojure.lang.RT/alength xs)) + (clojure.lang.ArraySeq$ArraySeq_int. nil xs 0))) + ([xs t/longs?] (when-not (zero? (clojure.lang.RT/alength xs)) + (clojure.lang.ArraySeq$ArraySeq_long. nil xs 0))) + ([xs t/floats?] (when-not (zero? (clojure.lang.RT/alength xs)) + (clojure.lang.ArraySeq$ArraySeq_float. nil xs 0))) + ([xs t/doubles?] (when-not (zero? (clojure.lang.RT/alength xs)) + (clojure.lang.ArraySeq$ArraySeq_double. nil xs 0))) + ;; TODO fix + #_([xs t/array?] (when-not (zero? (clojure.lang.RT/alength xs)) + (clojure.lang.ArraySeq. xs 0))) + )) ) ;; ----- expanded code ----- ;; From 0df2b6e5bcd2c2b531cfef25f0c85e59ae9c674d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 2 Sep 2018 18:26:27 -0600 Subject: [PATCH 202/810] move `utpred/namespace?` --- src-dev/quantum/core/defnt_equivalences.cljc | 13 ++++---- src-untyped/quantum/untyped/core/analyze.cljc | 9 +++--- src-untyped/quantum/untyped/core/convert.cljc | 6 ++-- src-untyped/quantum/untyped/core/ns.cljc | 2 ++ src-untyped/quantum/untyped/core/qualify.cljc | 3 +- .../quantum/untyped/core/type/predicates.cljc | 32 ++++++++----------- src/quantum/core/core.cljc | 9 +++--- 7 files changed, 35 insertions(+), 39 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index a389f70e..bbd4fdd1 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -1,7 +1,8 @@ ;; See https://jsperf.com/js-property-access-comparison — all property accesses (at least of length 1) seem to be equal (ns quantum.core.test.defnt-equivalences - (:refer-clojure :exclude [* zero? count]) + (:refer-clojure :exclude + [* count get seq zero?]) (:require [quantum.untyped.core.type.defnt :refer [defnt fnt unsupported!]] @@ -1058,7 +1059,7 @@ #_(def ~'>long|__9|input-types (*<> t/ratio?)) #_(def ~'>long|__9|conditions - (*<> (-> long|__8|input-types (get 0) utr/and-type>args (get 1)))) + (*<> (-> long|__8|input-types (core/get 0) utr/and-type>args (core/get 1)))) (def ~'>long|__9 (reify Object>long (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] @@ -1364,17 +1365,17 @@ ; TODO CLJS version will come after #?(:clj (macroexpand ' -(defnt seq|test +(defnt seq "Taken from `clojure.lang.RT/seq`" > (t/? (t/isa? ISeq)) - ([xs t/nil? ] nil) - ([xs (t/isa? ASeq) ] xs) + ([xs t/nil?] nil) + ([xs (t/isa? ASeq)] xs) ([xs (t/or (t/isa? LazySeq) (t/isa? Seqable))] (.seq xs)) ([xs t/iterable?] (clojure.lang.RT/chunkIteratorSeq (.iterator xs))) ([xs t/char-seq?] (clojure.lang.StringSeq/create xs)) ;; TODO recursion - #_([xs (t/isa? java.util.Map)] (seq|test (.entrySet xs))) + #_([xs (t/isa? java.util.Map)] (seq (.entrySet xs))) ;; TODO for these, use `count` not `clojure.lang.RT/alength` ([xs t/booleans?] (when-not (zero? (clojure.lang.RT/alength xs)) (clojure.lang.ArraySeq$ArraySeq_boolean. nil xs 0))) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index a48d618f..7b55c8c2 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -475,9 +475,8 @@ :direct (-> dispatchable-overloads-seq first :output-type) :dynamic (->> dispatchable-overloads-seq (c/lmap :output-type) - ;; Technically we could do a complex - ;; conditional instead of a simple `t/or` - ;; but no need + ;; Technically we could do a complex conditional instead of a simple `t/or` but + ;; no need (apply t/or)))) (defns- call>input-nodes+out-type @@ -510,9 +509,9 @@ (>dispatch|out-type dispatch-type dispatchable-overloads-seq))))) (update ret :input-nodes conj input|analyzed))) - {:input-nodes [] + {:input-nodes [] ;; We could do a little smarter analysis here but we'll keep it simple for now - :out-type (when-not (= :fnt caller-kind) t/any?) + :out-type (when-not (= :fnt caller-kind) t/any?) :dispatch-type :direct :dispatchable-overloads-seq (when (= :fnt caller-kind) diff --git a/src-untyped/quantum/untyped/core/convert.cljc b/src-untyped/quantum/untyped/core/convert.cljc index f3e10741..55660bb7 100644 --- a/src-untyped/quantum/untyped/core/convert.cljc +++ b/src-untyped/quantum/untyped/core/convert.cljc @@ -4,10 +4,10 @@ [quantum.untyped.core.core :as ucore] [quantum.untyped.core.error :as uerr] [quantum.untyped.core.fn :as ufn] + [quantum.untyped.core.ns + #?@(:clj [:refer [namespace?]])] [quantum.untyped.core.qualify - :refer [#?(:cljs DelimitedIdent) delim-ident? named?]] - [quantum.untyped.core.type.predicates - :refer [namespace?]]) + :refer [#?(:cljs DelimitedIdent) delim-ident? named?]]) #?(:clj (:import quantum.untyped.core.qualify.DelimitedIdent))) (ucore/log-this-ns) diff --git a/src-untyped/quantum/untyped/core/ns.cljc b/src-untyped/quantum/untyped/core/ns.cljc index a6f93818..6a1477ab 100644 --- a/src-untyped/quantum/untyped/core/ns.cljc +++ b/src-untyped/quantum/untyped/core/ns.cljc @@ -14,6 +14,8 @@ [quantum.untyped.core.vars :as uvar :refer [defalias defaliases]])) +#?(:clj (defn namespace? [x] (instance? clojure.lang.Namespace x))) + #?(:clj (do (defaliases core ns the-ns find-ns ns-name ns-map) (defalias core/ns-unmap ) diff --git a/src-untyped/quantum/untyped/core/qualify.cljc b/src-untyped/quantum/untyped/core/qualify.cljc index d7f13198..2da7ac43 100644 --- a/src-untyped/quantum/untyped/core/qualify.cljc +++ b/src-untyped/quantum/untyped/core/qualify.cljc @@ -5,8 +5,7 @@ [clojure.string :as str] [fipp.ednize] [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.ns :as uns] - [quantum.untyped.core.type.predicates + [quantum.untyped.core.ns :as uns #?@(:clj [:refer [namespace?]])])) (ucore/log-this-ns) diff --git a/src-untyped/quantum/untyped/core/type/predicates.cljc b/src-untyped/quantum/untyped/core/type/predicates.cljc index 6d8932e2..55cb045c 100644 --- a/src-untyped/quantum/untyped/core/type/predicates.cljc +++ b/src-untyped/quantum/untyped/core/type/predicates.cljc @@ -4,12 +4,11 @@ (:refer-clojure :exclude [any? array? boolean? double? ident? pos-int? qualified-keyword? seqable? simple-symbol?]) (:require - [clojure.core :as core] -#?(:clj - [clojure.future :as fcore]) - [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.vars - :refer [defalias defaliases]])) + [clojure.core :as core] +#?(:clj [clojure.future :as fcore]) + [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.vars + :refer [defalias defaliases]])) (ucore/log-this-ns) @@ -51,8 +50,6 @@ `core/simple-symbol?))) :cljs (defalias core/simple-symbol?)) -#?(:clj (defn namespace? [x] (instance? clojure.lang.Namespace x))) - (def val? some?) (defn lookup? [x] @@ -66,6 +63,10 @@ (defn regex? [x] (instance? #?(:clj java.util.regex.Pattern :cljs js/RegExp) x)) +(defn array? [x] + #?(:clj (-> x class .isArray) ; must be reflective + :cljs (core/array? x))) + #?(:clj (defn seqable? "Returns true if (seq x) will succeed, false otherwise." {:from "clojure.contrib.core"} @@ -74,16 +75,14 @@ (instance? clojure.lang.Seqable x) (nil? x) (instance? Iterable x) - (-> x class .isArray) + (array? x) (string? x) (instance? java.util.Map x))) :cljs (def seqable? core/seqable?)) -(defn editable? [coll] - #?(:clj (instance? clojure.lang.IEditableCollection coll) - :cljs (satisfies? cljs.core.IEditableCollection coll))) - -#?(:clj (defn namespace? [x] (instance? clojure.lang.Namespace x))) +(defn editable? [x] + #?(:clj (instance? clojure.lang.IEditableCollection x) + :cljs (satisfies? cljs.core.IEditableCollection x))) (defaliases ucore metable? with-metable?) @@ -93,11 +92,6 @@ #?(:cljs (defn defined? [x] (not (undefined? x)))) -;; TODO move to type predicates -(defn array? [x] - #?(:clj (-> x class .isArray) ; must be reflective - :cljs (core/array? x))) - (defn transient? [x] #?(:clj (instance? clojure.lang.ITransientCollection x) :cljs (satisfies? cljs.core/ITransientCollection x))) diff --git a/src/quantum/core/core.cljc b/src/quantum/core/core.cljc index d90d31fe..a970fe99 100644 --- a/src/quantum/core/core.cljc +++ b/src/quantum/core/core.cljc @@ -1,16 +1,17 @@ (ns quantum.core.core - (:refer-clojure :exclude [get set]) + (:refer-clojure :exclude + [get set]) (:require [clojure.core :as core] [clojure.spec.alpha :as s] #?(:clj [clojure.core.specs.alpha :as ss]) [cuerdas.core :as str+] #?(:clj [environ.core :as env]) ;; TODO TYPED move to quantum.core.type - [quantum.core.defnt - :refer [defnt]] - #_[quantum.core.type :as t + #_[quantum.core.type :as t :refer [defnt defmacrot defprotocolt deft]] [quantum.untyped.core.core :as u] + [quantum.untyped.core.defnt + :refer [defnt]] ;; TODO TYPED move to quantum.core.type [quantum.untyped.core.type :as t :refer [?]] From 1080d4490c15e7d8114ddf1f5d359837d0d7f091 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 2 Sep 2018 18:33:56 -0600 Subject: [PATCH 203/810] Move `unbound?` and `array?` --- src-untyped/quantum/untyped/core/analyze.cljc | 2 +- .../quantum/untyped/core/collections.cljc | 4 +- .../quantum/untyped/core/data/array.cljc | 66 ++++++++++++------- .../quantum/untyped/core/type/predicates.cljc | 7 +- src-untyped/quantum/untyped/core/vars.cljc | 2 + src/quantum/core/vars.cljc | 6 +- 6 files changed, 52 insertions(+), 35 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 7b55c8c2..04dd2d20 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -628,7 +628,7 @@ (t/value resolved) (var? resolved) (or (-> resolved meta ::t/type) (t/value @resolved)) - (utpred/unbound? resolved) + (uvar/unbound? resolved) ;; Because the var could be anything and cannot have metadata (type or otherwise) t/any? (TODO "Unsure of what to do in this case" (kw-map env form resolved)))))) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index 85913871..35cdcfe5 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -6,6 +6,8 @@ [clojure.core :as core] [fast-zip.core :as zip] [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.data.array + :refer [array?]] [quantum.untyped.core.error :as uerr :refer [err!]] [quantum.untyped.core.fn :as ufn @@ -17,7 +19,7 @@ [quantum.untyped.core.reducers :as ur :refer [defeager def-transducer>eager transducer->transformer educe]] [quantum.untyped.core.type.predicates - :refer [array? val? transient?]])) + :refer [val? transient?]])) (ucore/log-this-ns) diff --git a/src-untyped/quantum/untyped/core/data/array.cljc b/src-untyped/quantum/untyped/core/data/array.cljc index e4ca4533..65b9cc37 100644 --- a/src-untyped/quantum/untyped/core/data/array.cljc +++ b/src-untyped/quantum/untyped/core/data/array.cljc @@ -1,33 +1,49 @@ (ns quantum.untyped.core.data.array (:refer-clojure :exclude - [array]) + [array array?]) (:require [clojure.core :as core]) #?(:clj (:import [quantum.core.data Array]))) +(defn array? [x] + #?(:clj (-> x class .isArray) ; must be reflective + :cljs (core/array? x))) + (defn ^"[Ljava.lang.Object;" *<> - ([] #?(:clj (Array/newUninitialized1dObjectArray 0) - :cljs #js [])) - ([a0] #?(:clj (Array/new1dObjectArray a0) - :cljs #js [a0])) - ([a0 a1] #?(:clj (Array/new1dObjectArray a0 a1) - :cljs #js [a0 a1])) - ([a0 a1 a2] #?(:clj (Array/new1dObjectArray a0 a1 a2) - :cljs #js [a0 a1 a2])) - ([a0 a1 a2 a3] #?(:clj (Array/new1dObjectArray a0 a1 a2 a3) - :cljs #js [a0 a1 a2 a3])) - ([a0 a1 a2 a3 a4] #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4) - :cljs #js [a0 a1 a2 a3 a4])) - ([a0 a1 a2 a3 a4 a5] #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5) - :cljs #js [a0 a1 a2 a3 a4 a5])) - ([a0 a1 a2 a3 a4 a5 a6] #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6) - :cljs #js [a0 a1 a2 a3 a4 a5 a6])) - ([a0 a1 a2 a3 a4 a5 a6 a7] #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6 a7) - :cljs #js [a0 a1 a2 a3 a4 a5 a6 a7])) - ([a0 a1 a2 a3 a4 a5 a6 a7 a8] #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6 a7 a8) - :cljs #js [a0 a1 a2 a3 a4 a5 a6 a7 a8])) - ([a0 a1 a2 a3 a4 a5 a6 a7 a8 a9] #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6 a7 a8 a9) - :cljs #js [a0 a1 a2 a3 a4 a5 a6 a7 a8 a9])) - ([a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10] #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) - :cljs #js [a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10]))) + ([] + #?(:clj (Array/newUninitialized1dObjectArray 0) + :cljs #js [])) + ([a0] + #?(:clj (Array/new1dObjectArray a0) + :cljs #js [a0])) + ([a0 a1] + #?(:clj (Array/new1dObjectArray a0 a1) + :cljs #js [a0 a1])) + ([a0 a1 a2] + #?(:clj (Array/new1dObjectArray a0 a1 a2) + :cljs #js [a0 a1 a2])) + ([a0 a1 a2 a3] + #?(:clj (Array/new1dObjectArray a0 a1 a2 a3) + :cljs #js [a0 a1 a2 a3])) + ([a0 a1 a2 a3 a4] + #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4) + :cljs #js [a0 a1 a2 a3 a4])) + ([a0 a1 a2 a3 a4 a5] + #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5) + :cljs #js [a0 a1 a2 a3 a4 a5])) + ([a0 a1 a2 a3 a4 a5 a6] + #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6) + :cljs #js [a0 a1 a2 a3 a4 a5 a6])) + ([a0 a1 a2 a3 a4 a5 a6 a7] + #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6 a7) + :cljs #js [a0 a1 a2 a3 a4 a5 a6 a7])) + ([a0 a1 a2 a3 a4 a5 a6 a7 a8] + #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6 a7 a8) + :cljs #js [a0 a1 a2 a3 a4 a5 a6 a7 a8])) + ([a0 a1 a2 a3 a4 a5 a6 a7 a8 a9] + #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6 a7 a8 a9) + :cljs #js [a0 a1 a2 a3 a4 a5 a6 a7 a8 a9])) + ([a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10] + #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) + :cljs #js [a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10]))) diff --git a/src-untyped/quantum/untyped/core/type/predicates.cljc b/src-untyped/quantum/untyped/core/type/predicates.cljc index 55cb045c..aa4bb349 100644 --- a/src-untyped/quantum/untyped/core/type/predicates.cljc +++ b/src-untyped/quantum/untyped/core/type/predicates.cljc @@ -63,10 +63,7 @@ (defn regex? [x] (instance? #?(:clj java.util.regex.Pattern :cljs js/RegExp) x)) -(defn array? [x] - #?(:clj (-> x class .isArray) ; must be reflective - :cljs (core/array? x))) - +;; TODO this references data.array #?(:clj (defn seqable? "Returns true if (seq x) will succeed, false otherwise." {:from "clojure.contrib.core"} @@ -95,5 +92,3 @@ (defn transient? [x] #?(:clj (instance? clojure.lang.ITransientCollection x) :cljs (satisfies? cljs.core/ITransientCollection x))) - -#?(:clj (defn unbound? [x] (instance? clojure.lang.Var$Unbound x))) diff --git a/src-untyped/quantum/untyped/core/vars.cljc b/src-untyped/quantum/untyped/core/vars.cljc index c1770f0e..825e7cf7 100644 --- a/src-untyped/quantum/untyped/core/vars.cljc +++ b/src-untyped/quantum/untyped/core/vars.cljc @@ -12,6 +12,8 @@ (ucore/log-this-ns) +#?(:clj (defn unbound? [x] (instance? clojure.lang.Var$Unbound x))) + ;; ===== Metadata ===== ;; (def update-meta ucore/update-meta) diff --git a/src/quantum/core/vars.cljc b/src/quantum/core/vars.cljc index 04deb8ad..b222bd18 100644 --- a/src/quantum/core/vars.cljc +++ b/src/quantum/core/vars.cljc @@ -5,7 +5,9 @@ (:require [clojure.core :as c] #?(:clj [quantum.core.ns :as ns]) [quantum.core.type :as t - :refer [? defnt fnt]] + :refer [?]] + [quantum.untyped.core.defnt + :refer [defnt fnt]] [quantum.untyped.core.form.evaluate :refer [case-env]] [quantum.untyped.core.qualify :as qual] @@ -16,7 +18,7 @@ ;; ===== Meta ===== ;; -(t/def meta? (? t/+map?)) +(def #_t/def meta? (? t/+map?)) (defnt meta "Returns the metadata of `x`, returns nil if there is no metadata." From 34e843b7f58e48ff55012a9d6b80b3d7ce6fd95f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 2 Sep 2018 18:37:00 -0600 Subject: [PATCH 204/810] Move `defined?` --- src-untyped/quantum/untyped/core/type/predicates.cljc | 2 -- src-untyped/quantum/untyped/core/vars.cljc | 2 ++ src-untyped/quantum/untyped/ui/features.cljc | 2 +- src-untyped/quantum/untyped/ui/style/fonts.cljc | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/predicates.cljc b/src-untyped/quantum/untyped/core/type/predicates.cljc index aa4bb349..3f9989e3 100644 --- a/src-untyped/quantum/untyped/core/type/predicates.cljc +++ b/src-untyped/quantum/untyped/core/type/predicates.cljc @@ -87,8 +87,6 @@ #?(:clj (instance? clojure.lang.IDeref x) :cljs (satisfies? cljs.core/IDeref x))) -#?(:cljs (defn defined? [x] (not (undefined? x)))) - (defn transient? [x] #?(:clj (instance? clojure.lang.ITransientCollection x) :cljs (satisfies? cljs.core/ITransientCollection x))) diff --git a/src-untyped/quantum/untyped/core/vars.cljc b/src-untyped/quantum/untyped/core/vars.cljc index 825e7cf7..37f6096a 100644 --- a/src-untyped/quantum/untyped/core/vars.cljc +++ b/src-untyped/quantum/untyped/core/vars.cljc @@ -14,6 +14,8 @@ #?(:clj (defn unbound? [x] (instance? clojure.lang.Var$Unbound x))) +#?(:cljs (defn defined? [x] (not (undefined? x)))) + ;; ===== Metadata ===== ;; (def update-meta ucore/update-meta) diff --git a/src-untyped/quantum/untyped/ui/features.cljc b/src-untyped/quantum/untyped/ui/features.cljc index 00c6c9df..c82b4498 100644 --- a/src-untyped/quantum/untyped/ui/features.cljc +++ b/src-untyped/quantum/untyped/ui/features.cljc @@ -6,7 +6,7 @@ [quantum.untyped.core.logic :refer [whenc fn=]] [quantum.untyped.core.system :as usys] - [quantum.untyped.core.type.predicates + [quantum.untyped.core.vars #?@(:cljs [:refer [defined?]])])) (ucore/log-this-ns) diff --git a/src-untyped/quantum/untyped/ui/style/fonts.cljc b/src-untyped/quantum/untyped/ui/style/fonts.cljc index bf52dcad..32302ff5 100644 --- a/src-untyped/quantum/untyped/ui/style/fonts.cljc +++ b/src-untyped/quantum/untyped/ui/style/fonts.cljc @@ -4,7 +4,7 @@ [quantum.untyped.core.error :refer [err! TODO]] [quantum.untyped.core.system :as usys] - [quantum.untyped.core.type.predicates + [quantum.untyped.core.vars #?@(:cljs [:refer [defined?]])] [quantum.untyped.ui.style.css :as ucss] [quantum.untyped.ui.style.css.dom :as ucss-dom])) From f9ced466103b52c93fb36cdc41a31658123b6dd9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 2 Sep 2018 18:40:11 -0600 Subject: [PATCH 205/810] move `metable?`, `with-metable?` --- src-untyped/quantum/untyped/core/core.cljc | 10 ---------- src-untyped/quantum/untyped/core/test.cljc | 8 ++++---- src-untyped/quantum/untyped/core/vars.cljc | 8 ++++++++ 3 files changed, 12 insertions(+), 14 deletions(-) diff --git a/src-untyped/quantum/untyped/core/core.cljc b/src-untyped/quantum/untyped/core/core.cljc index 67f84729..29e49207 100644 --- a/src-untyped/quantum/untyped/core/core.cljc +++ b/src-untyped/quantum/untyped/core/core.cljc @@ -33,16 +33,6 @@ (defn >sentinel [] #?(:clj (Object.) :cljs #js {})) (def >object >sentinel) -;; ===== quantum.untyped.core.type.predicates ===== ;; - -(defn metable? [x] - #?(:clj (instance? clojure.lang.IMeta x) - :cljs (satisfies? cljs.core/IMeta x))) - -(defn with-metable? [x] - #?(:clj (instance? clojure.lang.IObj x) - :cljs (satisfies? cljs.core/IWithMeta x))) - ; ===== COLLECTIONS ===== (defn seq= diff --git a/src-untyped/quantum/untyped/core/test.cljc b/src-untyped/quantum/untyped/core/test.cljc index c93cdb4a..758a8d57 100644 --- a/src-untyped/quantum/untyped/core/test.cljc +++ b/src-untyped/quantum/untyped/core/test.cljc @@ -11,7 +11,7 @@ [quantum.untyped.core.print :refer [ppr-meta]] [quantum.untyped.core.vars - :refer [defalias defmalias]])) + :refer [defalias defmalias metable?]])) #?(:clj (defmalias is clojure.test/is cljs.test/is )) #?(:clj (defmalias deftest clojure.test/deftest cljs.test/deftest)) @@ -27,8 +27,8 @@ (defn code= "`code=` but with helpful test-related logging" ([code0 code1] - (if (ucore/metable? code0) - (and (ucore/metable? code1) + (if (metable? code0) + (and (metable? code1) (let [meta0 (-> code0 meta (dissoc :line :column)) meta1 (-> code1 meta (dissoc :line :column))] (or (= meta0 meta1) @@ -50,7 +50,7 @@ (or (ucore/seq= (seq code0) (seq code1) code=) (pr! "FAIL: `(ucore/seq= code0 code1 code=)`" (pr-str code0) (pr-str code1))))))) - (and (not (ucore/metable? code1)) + (and (not (metable? code1)) (or (= code0 code1) (println "FAIL: should be `(= code0 code1)`" (pr-str code0) (pr-str code1)))))) ([code0 code1 & codes] (and (code= code0 code1) (every? #(code= code0 %) codes)))) diff --git a/src-untyped/quantum/untyped/core/vars.cljc b/src-untyped/quantum/untyped/core/vars.cljc index 37f6096a..0a4b4345 100644 --- a/src-untyped/quantum/untyped/core/vars.cljc +++ b/src-untyped/quantum/untyped/core/vars.cljc @@ -18,6 +18,14 @@ ;; ===== Metadata ===== ;; +(defn metable? [x] + #?(:clj (instance? clojure.lang.IMeta x) + :cljs (satisfies? cljs.core/IMeta x))) + +(defn with-metable? [x] + #?(:clj (instance? clojure.lang.IObj x) + :cljs (satisfies? cljs.core/IWithMeta x))) + (def update-meta ucore/update-meta) (def merge-meta-from ucore/merge-meta-from) (def replace-meta-from ucore/replace-meta-from) From 7bc47d7fa4023576a4fcb51d6a478ef45b5e870b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 2 Sep 2018 18:41:07 -0600 Subject: [PATCH 206/810] Move `regex?` --- src-untyped/quantum/untyped/core/string.cljc | 2 ++ src-untyped/quantum/untyped/core/type/predicates.cljc | 4 ---- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/string.cljc b/src-untyped/quantum/untyped/core/string.cljc index 6d677504..ade90685 100644 --- a/src-untyped/quantum/untyped/core/string.cljc +++ b/src-untyped/quantum/untyped/core/string.cljc @@ -10,6 +10,8 @@ (ucore/log-this-ns) +(defn regex? [x] (instance? #?(:clj java.util.regex.Pattern :cljs js/RegExp) x)) + (defn join-once "Like /clojure.string/join/ but ensures no double separators." {:attribution "taoensso.encore"} diff --git a/src-untyped/quantum/untyped/core/type/predicates.cljc b/src-untyped/quantum/untyped/core/type/predicates.cljc index 3f9989e3..5383d7d2 100644 --- a/src-untyped/quantum/untyped/core/type/predicates.cljc +++ b/src-untyped/quantum/untyped/core/type/predicates.cljc @@ -61,8 +61,6 @@ ;; Unfortunately there's no better check in CLJS, at least as of 03/18/2018 :cljs (and (fn? x) (= (str x) "function (){}")))) -(defn regex? [x] (instance? #?(:clj java.util.regex.Pattern :cljs js/RegExp) x)) - ;; TODO this references data.array #?(:clj (defn seqable? "Returns true if (seq x) will succeed, false otherwise." @@ -81,8 +79,6 @@ #?(:clj (instance? clojure.lang.IEditableCollection x) :cljs (satisfies? cljs.core.IEditableCollection x))) -(defaliases ucore metable? with-metable?) - (defn derefable? [x] #?(:clj (instance? clojure.lang.IDeref x) :cljs (satisfies? cljs.core/IDeref x))) From 78537f95e6b8ff8940f5e0188e56a7e6c7713fa0 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 2 Sep 2018 18:56:21 -0600 Subject: [PATCH 207/810] `boolean?`, `double?`, `val?` --- .../quantum/untyped/core/collections.cljc | 4 +- .../quantum/untyped/core/data/bits.cljc | 47 ++++++++++++++----- .../untyped/core/form/generate/deftype.cljc | 6 +-- src-untyped/quantum/untyped/core/specs.cljc | 6 +-- .../quantum/untyped/core/type/predicates.cljc | 12 ----- .../quantum/untyped/ui/components.cljc | 4 +- .../quantum/untyped/ui/style/css/dom.cljc | 4 +- .../core/analyze/clojure/predicates.cljc | 6 ++- 8 files changed, 53 insertions(+), 36 deletions(-) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index 35cdcfe5..cfdec4b4 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -8,6 +8,8 @@ [quantum.untyped.core.core :as ucore] [quantum.untyped.core.data.array :refer [array?]] + [quantum.untyped.core.data.bits + :refer [val?]] [quantum.untyped.core.error :as uerr :refer [err!]] [quantum.untyped.core.fn :as ufn @@ -19,7 +21,7 @@ [quantum.untyped.core.reducers :as ur :refer [defeager def-transducer>eager transducer->transformer educe]] [quantum.untyped.core.type.predicates - :refer [val? transient?]])) + :refer [transient?]])) (ucore/log-this-ns) diff --git a/src-untyped/quantum/untyped/core/data/bits.cljc b/src-untyped/quantum/untyped/core/data/bits.cljc index 0a777d72..76d8ba11 100644 --- a/src-untyped/quantum/untyped/core/data/bits.cljc +++ b/src-untyped/quantum/untyped/core/data/bits.cljc @@ -1,22 +1,35 @@ (ns - ^{:doc "Useful bit/binary operations." + ^{:doc "Useful bit/binary operations, at the primitive (boolean, byte, long, etc.) and + pre-primitive level." :attribution "alexandergunnarson"} quantum.untyped.core.data.bits - (:refer-clojure :exclude [not and or reverse contains? empty conj disj]) - (:require - [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.vars - :refer [defalias]]) - #?(:clj (:import quantum.core.Numeric))) + (:refer-clojure :exclude + [and not or, conj contains? disj empty reverse]) + (:require + [clojure.core :as core] + #?(:clj [clojure.future :as fcore]) + [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.vars + :refer [defalias]]) +#?(:clj (:import quantum.core.Numeric))) (ucore/log-this-ns) +;; ===== Valueness / nilness ===== ;; + +(def val? some?) + +;; ===== Bit logic ===== ;; + (defalias not bit-not) (defalias and bit-and) (defalias and-not bit-and-not) (defalias or bit-or) (defalias xor bit-xor) (defalias not! bit-flip) + +;; ===== Bit set operations ===== ;; + (defalias disj bit-clear) (def ^:const empty 0) @@ -29,13 +42,13 @@ (defalias contains? bit-test) -;; ===== SHIFTS ===== ;; +;; ===== Shifts ===== ;; (defalias << bit-shift-left) (defalias >> bit-shift-right) (defalias >>> unsigned-bit-shift-right) -;; ===== ROTATIONS ===== ;; +;; ===== Rotations ===== ;; (defn rotate-left|long {:adapted-from "http://hg.openjdk.java.net/jdk7u/jdk7u6/jdk/file/8c2c5d63a17e/src/share/classes/java/lang/Integer.java"} @@ -63,7 +76,7 @@ (declare bits) -; ===== BULK BIT OPERATIONS ===== ; +;; ===== Bulk bit operations ===== ;; (defn ?-coll "Returns true or false for the bit at the given index of the collection." @@ -83,8 +96,20 @@ #?(:clj ^long n :cljs n)] (and x (unchecked-dec (<< 1 n)))) -; ====== ENDIANNESS REVERSAL ======= +;; ===== Endianness reversal ===== ;; #?(:clj (defn reverse|short [x] (Numeric/reverseShort (short x)))) #?(:clj (defn reverse|int [x] (Numeric/reverseInt (int x)))) #?(:clj (defn reverse|long [^long x] (Numeric/reverseLong x))) + +;; ===== Primitives ===== ;; + +#?(:clj (eval `(defalias ~(if (resolve `fcore/boolean?) + `fcore/boolean? + `core/boolean?))) + :cljs (defalias core/boolean?)) + +#?(:clj (eval `(defalias ~(if (resolve `fcore/double?) + `fcore/double? + `core/double?))) + :cljs (defalias core/double?)) diff --git a/src-untyped/quantum/untyped/core/form/generate/deftype.cljc b/src-untyped/quantum/untyped/core/form/generate/deftype.cljc index d2fb14a8..9c0a28a8 100644 --- a/src-untyped/quantum/untyped/core/form/generate/deftype.cljc +++ b/src-untyped/quantum/untyped/core/form/generate/deftype.cljc @@ -6,6 +6,8 @@ [clojure.core :as core] [quantum.untyped.core.data :refer [kw-map]] + [quantum.untyped.core.data.bits + :refer [val?]] [quantum.untyped.core.form.evaluate :refer [case-env]] [quantum.untyped.core.form.generate :as ufgen] @@ -13,9 +15,7 @@ [quantum.untyped.core.form.type-hint :as uth :refer [type-hint with-type-hint un-type-hint]] [quantum.untyped.core.qualify :as uqual] - [quantum.untyped.core.string :as ustr] - [quantum.untyped.core.type.predicates - :refer [val?]])) + [quantum.untyped.core.string :as ustr])) (defn ?Associative [lang] (case lang :clj 'clojure.lang.Associative :cljs 'cljs.core/IAssociative)) (defn ?Collection [lang] (case lang :clj 'clojure.lang.IPersistentCollection :cljs 'cljs.core/ICollection )) diff --git a/src-untyped/quantum/untyped/core/specs.cljc b/src-untyped/quantum/untyped/core/specs.cljc index ce4fb144..3f6f6be9 100644 --- a/src-untyped/quantum/untyped/core/specs.cljc +++ b/src-untyped/quantum/untyped/core/specs.cljc @@ -5,11 +5,11 @@ (:require [clojure.core :as core] [clojure.set :as set] + [quantum.untyped.core.data.bits + :refer [val?]] [quantum.untyped.core.fn :refer [fn1 fnl]] - [quantum.untyped.core.spec :as s] - [quantum.untyped.core.type.predicates - :refer [val?]]) + [quantum.untyped.core.spec :as s]) #?(:cljs (:require-macros [quantum.untyped.core.specs :as this diff --git a/src-untyped/quantum/untyped/core/type/predicates.cljc b/src-untyped/quantum/untyped/core/type/predicates.cljc index 5383d7d2..289b8e5c 100644 --- a/src-untyped/quantum/untyped/core/type/predicates.cljc +++ b/src-untyped/quantum/untyped/core/type/predicates.cljc @@ -20,16 +20,6 @@ `core/any?))) :cljs (defalias core/any?)) -#?(:clj (eval `(defalias ~(if (resolve `fcore/boolean?) - `fcore/boolean? - `core/boolean?))) - :cljs (defalias core/boolean?)) - -#?(:clj (eval `(defalias ~(if (resolve `fcore/double?) - `fcore/double? - `core/double?))) - :cljs (defalias core/double?)) - #?(:clj (eval `(defalias ~(if (resolve `fcore/ident?) `fcore/ident? `core/ident?))) @@ -50,8 +40,6 @@ `core/simple-symbol?))) :cljs (defalias core/simple-symbol?)) -(def val? some?) - (defn lookup? [x] #?(:clj (instance? clojure.lang.ILookup x) :cljs (satisfies? ILookup x))) diff --git a/src-untyped/quantum/untyped/ui/components.cljc b/src-untyped/quantum/untyped/ui/components.cljc index 465b86cb..1b13f48a 100644 --- a/src-untyped/quantum/untyped/ui/components.cljc +++ b/src-untyped/quantum/untyped/ui/components.cljc @@ -10,11 +10,11 @@ :refer [react-class?]] [reagent.interop :refer [$ $!]]]) + [quantum.untyped.core.data.bits + :refer [val?]] [quantum.untyped.core.log :as log] [quantum.untyped.core.system :as usys :refer [#?@(:cljs [react-native])]] - [quantum.untyped.core.type.predicates - :refer [val?]] [quantum.untyped.reactive.core :as re])) (def id :testID) ; because camelCase is a little ugly in Clojure :) diff --git a/src-untyped/quantum/untyped/ui/style/css/dom.cljc b/src-untyped/quantum/untyped/ui/style/css/dom.cljc index 43f049fe..d9540ab6 100644 --- a/src-untyped/quantum/untyped/ui/style/css/dom.cljc +++ b/src-untyped/quantum/untyped/ui/style/css/dom.cljc @@ -1,11 +1,11 @@ (ns quantum.untyped.ui.style.css.dom (:require [clojure.string :as str] + [quantum.untyped.core.data.bits + :refer [val?]] [quantum.untyped.core.fn :refer [fn->]] [quantum.untyped.core.spec :as us] - [quantum.untyped.core.type.predicates - :refer [val?]] [quantum.untyped.ui.dom :as udom])) #?(:cljs diff --git a/src/quantum/core/analyze/clojure/predicates.cljc b/src/quantum/core/analyze/clojure/predicates.cljc index 1758a0ff..d67d968f 100644 --- a/src/quantum/core/analyze/clojure/predicates.cljc +++ b/src/quantum/core/analyze/clojure/predicates.cljc @@ -16,7 +16,8 @@ [quantum.core.type.core :as tcore] [quantum.core.vars :as var :refer [defalias]] - [quantum.untyped.core.type.predicates :as utpred])) + [quantum.untyped.core.data.bits :as ubit] + [quantum.untyped.core.string :as ustr])) (defn safe-mapcat "Like |mapcat|, but works if the returned values aren't sequences." @@ -49,7 +50,8 @@ (def possible-type-predicate? (fn-or keyword? (fn-and symbol? (fn-or (fn= 'default) (fn-> name (str-index-of "?") (not= -1)))))) -(def hinted-literal? (fn-or #?(:clj char?) number? string? vector? map? nil? keyword? utpred/boolean? utpred/regex?)) +(def hinted-literal? + (fn-or #?(:clj char?) number? string? vector? map? nil? keyword? ubit/boolean? ustr/regex?)) ; ===== SCOPE ===== (defn shadows-var? [bindings v] From 31d0a06a286a7017f2f543377c3dfb461969c53c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 2 Sep 2018 21:10:14 -0600 Subject: [PATCH 208/810] quantum.untyped.core.qualify -> identification --- .../quantum/untyped/core/analyze/expr.cljc | 4 +-- src-untyped/quantum/untyped/core/convert.cljc | 9 ++++--- src-untyped/quantum/untyped/core/defnt.cljc | 21 ++++++++------- .../untyped/core/form/generate/deftype.cljc | 6 ++--- .../{qualify.cljc => identification.cljc} | 27 +++++++++++++++---- src-untyped/quantum/untyped/core/log.cljc | 20 +++++++------- .../quantum/untyped/core/print/prettier.cljc | 14 +++++----- .../quantum/untyped/core/reducers.cljc | 18 ++++++------- src-untyped/quantum/untyped/core/spec.cljc | 19 +++++++------ src-untyped/quantum/untyped/core/type.cljc | 3 +-- .../quantum/untyped/core/type/defnt.cljc | 5 ++-- .../quantum/untyped/core/type/predicates.cljc | 23 +++------------- src/quantum/core/data/validated.cljc | 18 ++++++------- src/quantum/core/macros/defnt.cljc | 5 ++-- src/quantum/core/macros/optimization.cljc | 18 ++++++------- src/quantum/core/match.cljc | 18 ++++++------- src/quantum/core/reducers.cljc | 1 - src/quantum/core/refs.cljc | 16 +++++------ src/quantum/core/vars.cljc | 1 - test/quantum/test/untyped/core/convert.cljc | 4 +-- 20 files changed, 125 insertions(+), 125 deletions(-) rename src-untyped/quantum/untyped/core/{qualify.cljc => identification.cljc} (62%) diff --git a/src-untyped/quantum/untyped/core/analyze/expr.cljc b/src-untyped/quantum/untyped/core/analyze/expr.cljc index fafb1da9..b9a6ecf8 100644 --- a/src-untyped/quantum/untyped/core/analyze/expr.cljc +++ b/src-untyped/quantum/untyped/core/analyze/expr.cljc @@ -18,8 +18,8 @@ :refer [err! TODO]] [quantum.untyped.core.form :as uform :refer [>form]] + [quantum.untyped.core.identification :as uident] [quantum.untyped.core.print :as upr] - [quantum.untyped.core.qualify :as uqual] [quantum.untyped.core.reducers :as ur :refer [join]] [quantum.untyped.core.vars @@ -42,7 +42,7 @@ #?(:clj (defmacro def [sym x] - `(def ~sym (NamedExpr. '~(uqual/qualify sym) ~x)))) + `(def ~sym (NamedExpr. '~(uident/qualify sym) ~x)))) #?(:clj (defalias -def def)) diff --git a/src-untyped/quantum/untyped/core/convert.cljc b/src-untyped/quantum/untyped/core/convert.cljc index 55660bb7..ea8fc0f8 100644 --- a/src-untyped/quantum/untyped/core/convert.cljc +++ b/src-untyped/quantum/untyped/core/convert.cljc @@ -1,14 +1,15 @@ +;; TODO break out these fns to their respective namespaces (ns quantum.untyped.core.convert (:require [clojure.string :as str] [quantum.untyped.core.core :as ucore] [quantum.untyped.core.error :as uerr] [quantum.untyped.core.fn :as ufn] + [quantum.untyped.core.identification + :refer [#?(:cljs DelimitedIdent) delim-ident? named?]] [quantum.untyped.core.ns - #?@(:clj [:refer [namespace?]])] - [quantum.untyped.core.qualify - :refer [#?(:cljs DelimitedIdent) delim-ident? named?]]) - #?(:clj (:import quantum.untyped.core.qualify.DelimitedIdent))) + #?@(:clj [:refer [namespace?]])]) + #?(:clj (:import quantum.untyped.core.identification.DelimitedIdent))) (ucore/log-this-ns) diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index 079f3e75..47d92398 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -1,20 +1,23 @@ (ns quantum.untyped.core.defnt "Primarily for `(de)fns`." - (:refer-clojure :exclude [any? ident? qualified-keyword? seqable? simple-symbol?]) + (:refer-clojure :exclude + [any? ident? qualified-keyword? seqable? simple-symbol?]) (:require - [clojure.spec.alpha :as s] - [clojure.spec.gen.alpha :as gen] - [quantum.untyped.core.convert :as uconv] + [clojure.spec.alpha :as s] + [clojure.spec.gen.alpha :as gen] + [quantum.untyped.core.convert :as uconv] [quantum.untyped.core.data.map :refer [om]] - [quantum.untyped.core.form.evaluate :as ufeval] + [quantum.untyped.core.form.evaluate :as ufeval] + [quantum.untyped.core.identification + :refer [ident? qualified-keyword? simple-symbol?]] [quantum.untyped.core.loops :refer [reduce-2]] - [quantum.untyped.core.reducers :as ur] - [quantum.untyped.core.spec :as us] - [quantum.untyped.core.specs :as uss] + [quantum.untyped.core.reducers :as ur] + [quantum.untyped.core.spec :as us] + [quantum.untyped.core.specs :as uss] [quantum.untyped.core.type.predicates - :refer [any? ident? qualified-keyword? seqable? simple-symbol?]]) + :refer [any? seqable?]]) #?(:cljs (:require-macros [quantum.untyped.core.defnt :as this]))) diff --git a/src-untyped/quantum/untyped/core/form/generate/deftype.cljc b/src-untyped/quantum/untyped/core/form/generate/deftype.cljc index 9c0a28a8..ae7b06ad 100644 --- a/src-untyped/quantum/untyped/core/form/generate/deftype.cljc +++ b/src-untyped/quantum/untyped/core/form/generate/deftype.cljc @@ -14,7 +14,7 @@ [quantum.untyped.core.form.generate.definterface] [quantum.untyped.core.form.type-hint :as uth :refer [type-hint with-type-hint un-type-hint]] - [quantum.untyped.core.qualify :as uqual] + [quantum.untyped.core.identification :as uident] [quantum.untyped.core.string :as ustr])) (defn ?Associative [lang] (case lang :clj 'clojure.lang.Associative :cljs 'cljs.core/IAssociative)) @@ -309,7 +309,7 @@ {:methods-spec methods-spec} (let [interface-sym (symbol (str "I" (name type-sym) "__GEN")) - qualified-interface-sym (uqual/qualify|class interface-sym) + qualified-interface-sym (uident/qualify|class interface-sym) methods (->> fields (map (fn [field-sym] @@ -336,7 +336,7 @@ &env type-sym fields (apply concat (deftype-helper methods-spec lang)))] ; in order to help `deftype` recognize that there is an interface, when there is one `(do ~deftype-code - ~(when (= lang :clj) `(import (quote ~(uqual/qualify|class type-sym)))))))) ; TODO doesn't this already happen? + ~(when (= lang :clj) `(import (quote ~(uident/qualify|class type-sym)))))))) ; TODO doesn't this already happen? #?(:clj (defmacro deftype diff --git a/src-untyped/quantum/untyped/core/qualify.cljc b/src-untyped/quantum/untyped/core/identification.cljc similarity index 62% rename from src-untyped/quantum/untyped/core/qualify.cljc rename to src-untyped/quantum/untyped/core/identification.cljc index 2da7ac43..65dd30b1 100644 --- a/src-untyped/quantum/untyped/core/qualify.cljc +++ b/src-untyped/quantum/untyped/core/identification.cljc @@ -1,6 +1,8 @@ -(ns quantum.untyped.core.qualify - "Functions related to qualification (name, namespace, etc.) and unqualification - of nameables." +(ns quantum.untyped.core.identification + "Functions related to variable identification/naming (name, namespace, etc.) and + qualification/unqualification of nameables." + (:refer-clojure :exclude + [ident? qualified-keyword? simple-symbol?]) (:require [clojure.string :as str] [fipp.ednize] @@ -14,13 +16,28 @@ #?(:clj (instance? clojure.lang.Named x) :cljs (implements? cljs.core/INamed x))) +#?(:clj (eval `(defalias ~(if (resolve `fcore/ident?) + `fcore/ident? + `core/ident?))) + :cljs (defalias core/ident?)) + +#?(:clj (eval `(defalias ~(if (resolve `fcore/qualified-keyword?) + `fcore/qualified-keyword? + `core/qualified-keyword?))) + :cljs (defalias core/qualified-keyword?)) + +#?(:clj (eval `(defalias ~(if (resolve `fcore/simple-symbol?) + `fcore/simple-symbol? + `core/simple-symbol?))) + :cljs (defalias core/simple-symbol?)) + (defn ?ns->name [?ns] (name #?(:clj (if (namespace? ?ns) (ns-name ?ns) ?ns) :cljs ?ns))) -;; ===== QUALIFICATION ===== ;; +;; ===== Qualification ===== ;; (defn qualify #?(:clj ([sym] (qualify *ns* sym))) @@ -44,7 +61,7 @@ (str alias- (when extra-slash? "/")) n))) (name sym))))) -;; ===== IDENTS ===== ;; +;; ===== Idents ===== ;; (defrecord ^{:doc "A delimited identifier. diff --git a/src-untyped/quantum/untyped/core/log.cljc b/src-untyped/quantum/untyped/core/log.cljc index e93ed2ac..be4adf5c 100644 --- a/src-untyped/quantum/untyped/core/log.cljc +++ b/src-untyped/quantum/untyped/core/log.cljc @@ -2,24 +2,24 @@ (:refer-clojure :exclude [pr seqable?]) (:require - [com.stuartsierra.component :as component] - [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.error :as uerr] + [com.stuartsierra.component :as component] + [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.error :as uerr] [quantum.untyped.core.form :refer [$]] [quantum.untyped.core.form.evaluate :refer [compile-if]] - [quantum.untyped.core.form.generate :as ufgen] - [quantum.untyped.core.meta.debug :as udebug] - [quantum.untyped.core.print :as upr] - [quantum.untyped.core.qualify :as uqual] + [quantum.untyped.core.form.generate :as ufgen] + [quantum.untyped.core.identification :as uident] + [quantum.untyped.core.meta.debug :as udebug] + [quantum.untyped.core.print :as upr] [quantum.untyped.core.type.predicates :refer [seqable?]] [quantum.untyped.core.vars :refer [defalias]]) #?(:cljs (:require-macros - [quantum.untyped.core.log :as self + [quantum.untyped.core.log :as self :refer [-gen-from-levels with-log-errors]]))) (ucore/log-this-ns) @@ -123,8 +123,8 @@ #?(:clj (defmacro -def-with-always [sym & args] - (let [args-sym (gensym "args") - macro-sym (uqual/qualify sym)] + (let [args-sym (gensym "args") + macro-sym (uident/qualify sym)] `(do (defmacro ~sym ~@args) (defmacro ~(symbol (str (name sym) "!")) [& ~args-sym] `(~'~macro-sym :always ~@~args-sym)))))) diff --git a/src-untyped/quantum/untyped/core/print/prettier.cljc b/src-untyped/quantum/untyped/core/print/prettier.cljc index a05079eb..5c3059b5 100644 --- a/src-untyped/quantum/untyped/core/print/prettier.cljc +++ b/src-untyped/quantum/untyped/core/print/prettier.cljc @@ -3,13 +3,13 @@ [fipp.edn] [fipp.visit] [fipp.ednize] - [quantum.untyped.core.convert :as uconv] - [quantum.untyped.core.fn :as fn + [quantum.untyped.core.convert] + [quantum.untyped.core.fn :refer [rcomp]] - [quantum.untyped.core.ns :as ns] - [quantum.untyped.core.print :as pr] - [quantum.untyped.core.qualify :as qual] - [quantum.untyped.core.vars :as var])) + [quantum.untyped.core.ns] + [quantum.untyped.core.print] + [quantum.untyped.core.identification] + [quantum.untyped.core.vars])) #?(:clj (defmethod print-method fipp.ednize.IEdn [^fipp.ednize.IEdn v ^java.io.Writer w] @@ -52,7 +52,7 @@ (defn visit-symbol* [x] [:text (cond-> x quantum.untyped.core.print/*collapse-symbols?* - (quantum.untyped.core.qualify/collapse-symbol + (quantum.untyped.core.identification/collapse-symbol (not quantum.untyped.core.print/*print-as-code?*)))])) #?(:clj diff --git a/src-untyped/quantum/untyped/core/reducers.cljc b/src-untyped/quantum/untyped/core/reducers.cljc index f89e53c9..8443be74 100644 --- a/src-untyped/quantum/untyped/core/reducers.cljc +++ b/src-untyped/quantum/untyped/core/reducers.cljc @@ -1,24 +1,24 @@ (ns quantum.untyped.core.reducers (:refer-clojure :exclude [apply every? vec == for seqable?]) (:require - [clojure.core :as core] - [clojure.core.reducers :as r] - [fast-zip.core :as zip] - [quantum.untyped.core.compare :as comp + [clojure.core :as core] + [clojure.core.reducers :as r] + [fast-zip.core :as zip] + [quantum.untyped.core.compare :as comp :refer [== not==]] - [quantum.untyped.core.core :as ucore + [quantum.untyped.core.core :as ucore :refer [>sentinel]] [quantum.untyped.core.error :refer [err!]] [quantum.untyped.core.form.evaluate :refer [case-env]] - [quantum.untyped.core.qualify :as qual] + [quantum.untyped.core.identification :as uident] [quantum.untyped.core.type.predicates :refer [seqable?]] - [quantum.untyped.core.vars :as uvar + [quantum.untyped.core.vars :as uvar :refer [defalias]]) #?(:cljs (:require-macros - [quantum.untyped.core.reducers :as this]))) + [quantum.untyped.core.reducers :as this]))) (ucore/log-this-ns) @@ -134,7 +134,7 @@ (defmacro defeager [sym plus-sym max-args & [lazy-sym]] `(do ~(when (and (not lazy-sym) (resolve (symbol "clojure.core" (name sym)))) `(defalias ~(symbol (str "l" sym)) ~(symbol (case-env :cljs "cljs.core" "clojure.core") (name sym)))) - (defalias ~(qual/unqualify plus-sym) ~plus-sym) + (defalias ~(uident/unqualify plus-sym) ~plus-sym) ~(>eager|code sym plus-sym `join max-args (str "Like `core/" sym "`, but eager. Reduces into vector.")) ~(>eager|code (symbol (str sym "'")) plus-sym `join' max-args diff --git a/src-untyped/quantum/untyped/core/spec.cljc b/src-untyped/quantum/untyped/core/spec.cljc index 2116117a..eb62e375 100644 --- a/src-untyped/quantum/untyped/core/spec.cljc +++ b/src-untyped/quantum/untyped/core/spec.cljc @@ -3,22 +3,21 @@ [ident? string? keyword? set? number? any? assert keys merge + * cat and or constantly]) (:require - [clojure.core :as core] - [clojure.spec.alpha :as s] - [clojure.spec.test.alpha :as test] + [clojure.core :as core] + [clojure.spec.alpha :as s] + [clojure.spec.test.alpha :as test] [cljs.spec.alpha] - [clojure.spec.gen.alpha :as gen] + [clojure.spec.gen.alpha :as gen] [fipp.ednize] - [quantum.untyped.core.convert :as uconv] - [quantum.untyped.core.data :as udata] + [quantum.untyped.core.convert :as uconv] + [quantum.untyped.core.data :as udata] [quantum.untyped.core.error :refer [catch-all err! TODO]] [quantum.untyped.core.fn :refer [constantly with-do]] - [quantum.untyped.core.form.evaluate :as ufeval + [quantum.untyped.core.form.evaluate :as ufeval :refer [case-env]] - [quantum.untyped.core.qualify :as uqual] - [quantum.untyped.core.type.predicates + [quantum.untyped.core.identification :as uident :refer [ident?]] [quantum.untyped.core.vars :refer [defalias defmalias]]) @@ -154,7 +153,7 @@ #?(:clj (defmacro fdef! [sym & args] `(with-do (~(case-env :clj 'clojure.spec.alpha/fdef :cljs 'cljs.spec.alpha/fdef) ~sym ~@args) - (when (s/check-asserts?) (test/instrument '~(uqual/qualify *ns* sym)))))) + (when (s/check-asserts?) (test/instrument '~(uident/qualify *ns* sym)))))) #?(:clj (defmacro or-auto diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index ab7aa044..bfb99cda 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -46,7 +46,6 @@ :refer [fn-and ifs whenp->]] [quantum.untyped.core.numeric :as unum] [quantum.untyped.core.print :as upr] - [quantum.untyped.core.qualify :as qual] [quantum.untyped.core.reducers :as ur :refer [educe join]] [quantum.untyped.core.refs @@ -252,7 +251,7 @@ (defmacro define [sym t] `(~'def ~sym (let [t# ~t] (assert (utr/type? t#) t#) - #_(register-type! '~(qual/qualify sym) t#) + #_(register-type! '~(uident/qualify sym) t#) t#)))) ;; TODO clean up diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 5e3151dd..d9bc5bd6 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -30,14 +30,13 @@ [quantum.untyped.core.form.evaluate :as ufeval] [quantum.untyped.core.form.generate :as ufgen] [quantum.untyped.core.form.type-hint :as ufth] + [quantum.untyped.core.identification :as uident] [quantum.untyped.core.log :as ulog] [quantum.untyped.core.logic :as ul :refer [fn-or fn= ifs]] [quantum.untyped.core.loops :refer [reduce-2]] [quantum.untyped.core.numeric.combinatorics :as ucombo] - [quantum.untyped.core.qualify - :refer [qualify]] [quantum.untyped.core.reducers :as r :refer [reducei educe]] [quantum.untyped.core.spec :as s] @@ -562,7 +561,7 @@ [fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?), i|arg t/index?, body _] (if (-> body count (= 1)) (first body) - `(ifs ~@body (unsupported! (quote ~(qualify fn|name)) [~@arglist] ~i|arg)))) + `(ifs ~@body (unsupported! (quote ~(uident/qualify fn|name)) [~@arglist] ~i|arg)))) (defns >dynamic-dispatch|body-for-arity ([fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?) diff --git a/src-untyped/quantum/untyped/core/type/predicates.cljc b/src-untyped/quantum/untyped/core/type/predicates.cljc index 289b8e5c..d2c27e9e 100644 --- a/src-untyped/quantum/untyped/core/type/predicates.cljc +++ b/src-untyped/quantum/untyped/core/type/predicates.cljc @@ -2,7 +2,7 @@ "For type predicates that are not yet turned into specs. TODO excise and place in `quantum.untyped.core.type`." (:refer-clojure :exclude - [any? array? boolean? double? ident? pos-int? qualified-keyword? seqable? simple-symbol?]) + [any? pos-int? seqable?]) (:require [clojure.core :as core] #?(:clj [clojure.future :as fcore]) @@ -20,29 +20,14 @@ `core/any?))) :cljs (defalias core/any?)) -#?(:clj (eval `(defalias ~(if (resolve `fcore/ident?) - `fcore/ident? - `core/ident?))) - :cljs (defalias core/ident?)) - #?(:clj (eval `(defalias ~(if (resolve `fcore/pos-int?) `fcore/pos-int? `core/pos-int?))) :cljs (defalias core/pos-int?)) -#?(:clj (eval `(defalias ~(if (resolve `fcore/qualified-keyword?) - `fcore/qualified-keyword? - `core/qualified-keyword?))) - :cljs (defalias core/qualified-keyword?)) - -#?(:clj (eval `(defalias ~(if (resolve `fcore/simple-symbol?) - `fcore/simple-symbol? - `core/simple-symbol?))) - :cljs (defalias core/simple-symbol?)) - (defn lookup? [x] - #?(:clj (instance? clojure.lang.ILookup x) - :cljs (satisfies? ILookup x))) + #?(:clj (instance? clojure.lang.ILookup x) + :cljs (satisfies? cljs.core/ILookup x))) (defn protocol? [x] #?(:clj (and (lookup? x) (-> x (get :on-interface) class?)) @@ -65,7 +50,7 @@ (defn editable? [x] #?(:clj (instance? clojure.lang.IEditableCollection x) - :cljs (satisfies? cljs.core.IEditableCollection x))) + :cljs (satisfies? cljs.core/IEditableCollection x))) (defn derefable? [x] #?(:clj (instance? clojure.lang.IDeref x) diff --git a/src/quantum/core/data/validated.cljc b/src/quantum/core/data/validated.cljc index 8c190c77..49a5a2f1 100644 --- a/src/quantum/core/data/validated.cljc +++ b/src/quantum/core/data/validated.cljc @@ -1,28 +1,28 @@ (ns quantum.core.data.validated (:refer-clojure :exclude [contains?]) (:require - [clojure.core :as core] - [quantum.core.data.set :as set] - [quantum.core.error :as err + [clojure.core :as core] + [quantum.core.data.set :as set] + [quantum.core.error :as err :refer [>ex-info TODO catch-all]] [quantum.core.macros.deftype :as deftype] [quantum.core.fn :refer [fn-> fn->> fn1 fnl <- fn']] [quantum.core.logic :refer [fn= fn-and fn-or whenf1 whenf whenp default]] - [quantum.core.log :as log + [quantum.core.log :as log :refer [prl]] [quantum.core.macros.defrecord :refer [defrecord+]] [quantum.core.macros.optimization :refer [identity*]] - [quantum.core.spec :as s + [quantum.core.spec :as s :refer [validate]] - [quantum.untyped.core.collections :as ucoll + [quantum.untyped.core.collections :as ucoll :refer [contains?]] [quantum.untyped.core.collections.tree :as utree :refer [postwalk]] - [quantum.untyped.core.qualify :as uqual] + [quantum.untyped.core.identification :as uident] [quantum.untyped.core.form.evaluate :refer [case-env]]) #?(:cljs @@ -325,9 +325,9 @@ (concat req opt req-un opt-un) (s/coll-of qualified-keyword? :distinct true)) (let [{:keys [spec-name sym]} (sym->spec-name+sym sym-0 ns-name-str) schema (when db-mode? (spec->schema sym-0 nil)) ; TODO #4, #5 - qualified-sym (uqual/qualify|class sym) + qualified-sym (uident/qualify|class sym) req-record-sym (symbol (str (name sym) ":__required")) - qualified-record-sym (uqual/qualify|class req-record-sym) + qualified-record-sym (uident/qualify|class req-record-sym) un-record-sym (symbol (str (name sym) ":__un")) all-mod-record-sym (symbol (str (name sym) ":__all-mod")) all-record-sym (symbol (str (name sym) ":__all")) diff --git a/src/quantum/core/macros/defnt.cljc b/src/quantum/core/macros/defnt.cljc index 0d496db4..33ed4644 100644 --- a/src/quantum/core/macros/defnt.cljc +++ b/src/quantum/core/macros/defnt.cljc @@ -42,8 +42,8 @@ [quantum.untyped.core.form.evaluate :refer [case-env case-env*]] [quantum.untyped.core.form.type-hint :as ufth] + [quantum.untyped.core.identification :as uident] [quantum.untyped.core.numeric.combinatorics :as combo] - [quantum.untyped.core.qualify :as qual] [quantum.untyped.core.reducers :refer [reducei] :as ured] [quantum.untyped.core.string :as ustr] @@ -206,7 +206,7 @@ (-> sym name ustr/camelcase (str "Interface") munge symbol) ns-qualified-interface-name (-> genned-interface-name - #?(:clj (qual/qualify|dot (namespace-munge *ns*)))) + #?(:clj (uident/qualify|dot (namespace-munge *ns*)))) gen-interface-code-header (list 'gen-interface :name ns-qualified-interface-name :methods) gen-interface-code-body-unexpanded @@ -837,4 +837,3 @@ (let [lang :clj] (eval `(declare ~(th/with-sanitize-tag lang sym) ~(th/with-sanitize-tag lang (defnt-gen-protocol-name sym lang)))) ; To allow recursive analysis (defnt*-helper {:relaxed? true} lang *ns* sym nil nil nil body)))) - diff --git a/src/quantum/core/macros/optimization.cljc b/src/quantum/core/macros/optimization.cljc index e7aeb1e3..457d02bd 100644 --- a/src/quantum/core/macros/optimization.cljc +++ b/src/quantum/core/macros/optimization.cljc @@ -1,14 +1,14 @@ (ns ^{:doc "Helper functions for macros which provide optimization."} quantum.core.macros.optimization (:require - [quantum.core.core :as qcore] - [quantum.core.fn :as fn + [quantum.core.core :as qcore] + [quantum.core.fn :as fn :refer [fn->]] - [quantum.core.log :as log] - [quantum.core.logic :as logic + [quantum.core.log :as log] + [quantum.core.logic :as logic :refer [fn-and]] - [quantum.untyped.core.qualify :as qual] - [quantum.core.vars :as var])) + [quantum.core.vars :as var] + [quantum.untyped.core.identification :as uident])) ; ===== EXTERN ===== @@ -28,9 +28,9 @@ " because of error: |" e# "|")))))] (if (symbol? quoted-obj) quoted-obj - (do (intern ns- (qual/unqualify genned) obj-evaled) - (log/pr :macro-expand quoted-obj "EXTERNED AS" (qual/unqualify genned)) - (qual/unqualify genned))))) + (do (intern ns- (uident/unqualify genned) obj-evaled) + (log/pr :macro-expand quoted-obj "EXTERNED AS" (uident/unqualify genned)) + (uident/unqualify genned))))) quoted-obj))) #?(:clj diff --git a/src/quantum/core/match.cljc b/src/quantum/core/match.cljc index 6f25f653..7b667fbb 100644 --- a/src/quantum/core/match.cljc +++ b/src/quantum/core/match.cljc @@ -2,21 +2,21 @@ (:refer-clojure :exclude [+ * cat]) (:require #?@(:clj - [[net.cgrand.seqexp :as se] - [clojure.core.match :as match]]) - [quantum.core.fn :as fn + [[net.cgrand.seqexp :as se] + [clojure.core.match :as match]]) + [quantum.core.fn :as fn :refer [<- fn-> fnl]] - [quantum.untyped.core.qualify :as qual] - [quantum.core.vars :as var + [quantum.core.vars :as var :refer [defalias]] [quantum.core.logic :refer [fn-not fn-and fn-or whenf1 condf1]] - [quantum.core.collections :as coll + [quantum.core.collections :as coll :refer [postwalk map-vals+ join]] [quantum.core.macros :refer [macroexpand-all]] - [quantum.core.collections.tree :as tree] - [quantum.core.collections.zippers :as zip])) + [quantum.core.collections.tree :as tree] + [quantum.core.collections.zippers :as zip] + [quantum.untyped.core.identification :as uident])) ; Regex seq matching @@ -47,7 +47,7 @@ (def defs (let [defs-syms '#{#_& ? | + * ?= ?! _}] (->> (zipmap defs-syms - (mapv (fnl qual/qualify 'quantum.core.match) defs-syms)) + (mapv (fnl uident/qualify 'quantum.core.match) defs-syms)) (apply concat) vec))) #?(:clj diff --git a/src/quantum/core/reducers.cljc b/src/quantum/core/reducers.cljc index d4f77c64..cdc96da4 100644 --- a/src/quantum/core/reducers.cljc +++ b/src/quantum/core/reducers.cljc @@ -47,7 +47,6 @@ [quantum.core.vars :as var :refer [defalias def-]] [quantum.untyped.core.collections.logic :as ucoll&] - [quantum.untyped.core.qualify :as qual] [quantum.untyped.core.reducers :as ur] [quantum.untyped.core.form.generate :refer [arity-builder max-positional-arity unify-gensyms]]) diff --git a/src/quantum/core/refs.cljc b/src/quantum/core/refs.cljc index 77732a47..c9f2a476 100644 --- a/src/quantum/core/refs.cljc +++ b/src/quantum/core/refs.cljc @@ -9,19 +9,19 @@ set-error-mode! var-set]) (:require - [clojure.core :as core] - [clojure.string :as str] - [quantum.core.error :as err + [clojure.core :as core] + [clojure.string :as str] + [quantum.core.error :as err :refer [TODO]] [quantum.core.macros :refer [case-env defnt #?(:clj defnt') env-lang]] - [quantum.core.type :as t + [quantum.core.type :as t :refer [val?]] - [quantum.core.type.defs :as tdefs] - [quantum.untyped.core.qualify :as qual] + [quantum.core.type.defs :as tdefs] + [quantum.untyped.core.identification :as uident] [quantum.untyped.core.refs :refer [atom?]] - [quantum.core.vars :as var + [quantum.core.vars :as var :refer [defalias]]) #?(:clj (:import @@ -77,7 +77,7 @@ [~(with-meta 'x {:tag kind})] (new ~deftype-sym ~'x)) (defmacro ~(symbol (str "!" kind)) ([ ] `(new ~'~deftype-sym (~'~kind 0))) - ([~macro-param] `(~'~(qual/qualify *ns* defnt-sym) ~~macro-param)))))) + ([~macro-param] `(~'~(uident/qualify *ns* defnt-sym) ~~macro-param)))))) #?(:clj (defmacro gen-primitive-mutables [] diff --git a/src/quantum/core/vars.cljc b/src/quantum/core/vars.cljc index b222bd18..d248cd9b 100644 --- a/src/quantum/core/vars.cljc +++ b/src/quantum/core/vars.cljc @@ -10,7 +10,6 @@ :refer [defnt fnt]] [quantum.untyped.core.form.evaluate :refer [case-env]] - [quantum.untyped.core.qualify :as qual] [quantum.untyped.core.vars :as u]) #?(:cljs (:require-macros diff --git a/test/quantum/test/untyped/core/convert.cljc b/test/quantum/test/untyped/core/convert.cljc index 9aa7f730..230112c5 100644 --- a/test/quantum/test/untyped/core/convert.cljc +++ b/test/quantum/test/untyped/core/convert.cljc @@ -3,9 +3,9 @@ [quantum.core.test :as test :refer [deftest testing is is= throws]] [quantum.untyped.core.convert :as this] - [quantum.untyped.core.qualify + [quantum.untyped.core.identification #?@(:cljs [:refer [Ident]])]) - #?(:clj (:import quantum.untyped.core.qualify.Ident))) + #?(:clj (:import quantum.untyped.core.identification.Ident))) (deftest test|>ident (is= (this/>ident "a|b|c|d") (Ident. ["a" "b" "c" "d"])) From ad7cbcf9fecaaf0216b2f3a58bbef57fcc096bef Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 2 Sep 2018 21:20:00 -0600 Subject: [PATCH 209/810] move `pos-int?` --- .../quantum/untyped/core/identification.cljc | 18 +++++++------ src-untyped/quantum/untyped/core/numeric.cljc | 17 +++++++++--- src-untyped/quantum/untyped/core/type.cljc | 4 +-- .../quantum/untyped/core/type/predicates.cljc | 27 +++++++------------ 4 files changed, 36 insertions(+), 30 deletions(-) diff --git a/src-untyped/quantum/untyped/core/identification.cljc b/src-untyped/quantum/untyped/core/identification.cljc index 65dd30b1..ea34b87b 100644 --- a/src-untyped/quantum/untyped/core/identification.cljc +++ b/src-untyped/quantum/untyped/core/identification.cljc @@ -1,14 +1,16 @@ (ns quantum.untyped.core.identification "Functions related to variable identification/naming (name, namespace, etc.) and qualification/unqualification of nameables." - (:refer-clojure :exclude - [ident? qualified-keyword? simple-symbol?]) - (:require - [clojure.string :as str] - [fipp.ednize] - [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.ns :as uns - #?@(:clj [:refer [namespace?]])])) + (:refer-clojure :exclude + [ident? qualified-keyword? simple-symbol?]) + (:require + [clojure.core :as core] +#?(:clj [clojure.future :as fcore]) + [clojure.string :as str] + [fipp.ednize] + [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.ns :as uns + #?@(:clj [:refer [namespace?]])])) (ucore/log-this-ns) diff --git a/src-untyped/quantum/untyped/core/numeric.cljc b/src-untyped/quantum/untyped/core/numeric.cljc index 5b07098a..66ec6dfc 100644 --- a/src-untyped/quantum/untyped/core/numeric.cljc +++ b/src-untyped/quantum/untyped/core/numeric.cljc @@ -1,11 +1,22 @@ (ns quantum.untyped.core.numeric - (:require - [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.error :as err]) + (:refer-clojure :exclude + [pos-int?]) + (:require + [clojure.core :as core] + #?(:clj [clojure.future :as fcore]) + [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.error :as err] + [quantum.untyped.core.vars + :refer [defalias]]) #?(:clj (:import java.lang.Math java.math.BigDecimal))) (ucore/log-this-ns) +#?(:clj (eval `(defalias ~(if (resolve `fcore/pos-int?) + `fcore/pos-int? + `core/pos-int?))) + :cljs (defalias core/pos-int?)) + (defn integer-value? {:adapted-from '#{com.google.common.math.DoubleMath/isMathematicalInteger "https://stackoverflow.com/questions/1078953/check-if-bigdecimal-is-integer-value"}} diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index bfb99cda..820262dc 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -754,7 +754,7 @@ ;; dense integer values), not extensible #?(:clj -(defns >array-nd-type [kind c/symbol?, n utpred/pos-int? > utr/class-type?] +(defns >array-nd-type [kind c/symbol?, n unum/pos-int? > utr/class-type?] (let [prefix (apply str (repeat n \[)) letter (case kind boolean "Z" @@ -769,7 +769,7 @@ (isa? (Class/forName (str prefix letter)))))) #?(:clj -(defns >array-nd-types [n utpred/pos-int? > utr/type?] +(defns >array-nd-types [n unum/pos-int? > utr/type?] (->> '[boolean byte char short int long float double object] (map #(>array-nd-type % n)) (apply or)))) diff --git a/src-untyped/quantum/untyped/core/type/predicates.cljc b/src-untyped/quantum/untyped/core/type/predicates.cljc index d2c27e9e..b49ac411 100644 --- a/src-untyped/quantum/untyped/core/type/predicates.cljc +++ b/src-untyped/quantum/untyped/core/type/predicates.cljc @@ -2,7 +2,7 @@ "For type predicates that are not yet turned into specs. TODO excise and place in `quantum.untyped.core.type`." (:refer-clojure :exclude - [any? pos-int? seqable?]) + [any? seqable?]) (:require [clojure.core :as core] #?(:clj [clojure.future :as fcore]) @@ -12,28 +12,21 @@ (ucore/log-this-ns) -;; The reason we use `resolve` and `eval` here is that currently we need to prefer built-in impls -;; where possible in order to leverage their generators - #?(:clj (eval `(defalias ~(if (resolve `fcore/any?) `fcore/any? `core/any?))) :cljs (defalias core/any?)) -#?(:clj (eval `(defalias ~(if (resolve `fcore/pos-int?) - `fcore/pos-int? - `core/pos-int?))) - :cljs (defalias core/pos-int?)) - -(defn lookup? [x] - #?(:clj (instance? clojure.lang.ILookup x) - :cljs (satisfies? cljs.core/ILookup x))) - (defn protocol? [x] #?(:clj (and (lookup? x) (-> x (get :on-interface) class?)) ;; Unfortunately there's no better check in CLJS, at least as of 03/18/2018 :cljs (and (fn? x) (= (str x) "function (){}")))) +(defn derefable? [x] + #?(:clj (instance? clojure.lang.IDeref x) + :cljs (satisfies? cljs.core/IDeref x))) + + ;; TODO this references data.array #?(:clj (defn seqable? "Returns true if (seq x) will succeed, false otherwise." @@ -48,14 +41,14 @@ (instance? java.util.Map x))) :cljs (def seqable? core/seqable?)) +(defn lookup? [x] + #?(:clj (instance? clojure.lang.ILookup x) + :cljs (satisfies? cljs.core/ILookup x))) + (defn editable? [x] #?(:clj (instance? clojure.lang.IEditableCollection x) :cljs (satisfies? cljs.core/IEditableCollection x))) -(defn derefable? [x] - #?(:clj (instance? clojure.lang.IDeref x) - :cljs (satisfies? cljs.core/IDeref x))) - (defn transient? [x] #?(:clj (instance? clojure.lang.ITransientCollection x) :cljs (satisfies? cljs.core/ITransientCollection x))) From d82c035b835ed08a3c183bc9eb09f5508b994c27 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 2 Sep 2018 21:32:12 -0600 Subject: [PATCH 210/810] Move `any?`, `derefable?`, `protocol?` --- src-untyped/quantum/untyped/core/cache.cljc | 10 ++++---- src-untyped/quantum/untyped/core/core.cljc | 25 ++++++++++++++++--- src-untyped/quantum/untyped/core/defnt.cljc | 4 ++- src-untyped/quantum/untyped/core/refs.cljc | 11 +++++--- src-untyped/quantum/untyped/core/type.cljc | 6 ++--- .../quantum/untyped/core/type/predicates.cljc | 17 +------------ 6 files changed, 41 insertions(+), 32 deletions(-) diff --git a/src-untyped/quantum/untyped/core/cache.cljc b/src-untyped/quantum/untyped/core/cache.cljc index 377326f4..c6867be6 100644 --- a/src-untyped/quantum/untyped/core/cache.cljc +++ b/src-untyped/quantum/untyped/core/cache.cljc @@ -2,20 +2,20 @@ (:refer-clojure :exclude [memoize]) (:require - [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.error :as uerr + [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.error :as uerr :refer [err!]] - [quantum.untyped.core.fn :as ufn + [quantum.untyped.core.fn :as ufn :refer [fn1]] [quantum.untyped.core.logic :refer [whenc1]] - [quantum.untyped.core.type.predicates :as utpred + [quantum.untyped.core.refs :refer [derefable?]] [quantum.untyped.core.vars :refer [defmacro-]]) #?(:cljs (:require-macros - [quantum.untyped.core.cache :as self + [quantum.untyped.core.cache :as self :refer [memoize-form]])) #?(:clj (:import diff --git a/src-untyped/quantum/untyped/core/core.cljc b/src-untyped/quantum/untyped/core/core.cljc index 29e49207..2201d8b9 100644 --- a/src-untyped/quantum/untyped/core/core.cljc +++ b/src-untyped/quantum/untyped/core/core.cljc @@ -1,7 +1,9 @@ (ns quantum.untyped.core.core (:require - #?@(:clj [[environ.core :as env]]) - [cuerdas.core :as str+]) + [clojure.core :as core] + #?(:clj [clojure.future :as fcore]) + [cuerdas.core :as str+] + #?@(:clj [[environ.core :as env]])) #?(:cljs (:require-macros [quantum.untyped.core.core :as this]))) @@ -33,7 +35,24 @@ (defn >sentinel [] #?(:clj (Object.) :cljs #js {})) (def >object >sentinel) -; ===== COLLECTIONS ===== +;; ===== Fundamental type predicates ===== ;; + +#?(:clj (eval `(defalias ~(if (resolve `fcore/any?) + `fcore/any? + `core/any?))) + :cljs (defalias core/any?)) + +;; This is in here only because `protocol?` needs it +(defn lookup? [x] + #?(:clj (instance? clojure.lang.ILookup x) + :cljs (satisfies? cljs.core/ILookup x))) + +(defn protocol? [x] + #?(:clj (and (lookup? x) (-> x (get :on-interface) class?)) + ;; Unfortunately there's no better check in CLJS, at least as of 03/18/2018 + :cljs (and (fn? x) (= (str x) "function (){}")))) + +;; ===== Collections ===== ;; (defn seq= ([a b] (seq= a b =)) diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index 47d92398..f518b5f7 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -6,6 +6,8 @@ [clojure.spec.alpha :as s] [clojure.spec.gen.alpha :as gen] [quantum.untyped.core.convert :as uconv] + [quantum.untyped.core.core + :refer [any?]] [quantum.untyped.core.data.map :refer [om]] [quantum.untyped.core.form.evaluate :as ufeval] @@ -17,7 +19,7 @@ [quantum.untyped.core.spec :as us] [quantum.untyped.core.specs :as uss] [quantum.untyped.core.type.predicates - :refer [any? seqable?]]) + :refer [seqable?]]) #?(:cljs (:require-macros [quantum.untyped.core.defnt :as this]))) diff --git a/src-untyped/quantum/untyped/core/refs.cljc b/src-untyped/quantum/untyped/core/refs.cljc index 038a0076..2c286f4f 100644 --- a/src-untyped/quantum/untyped/core/refs.cljc +++ b/src-untyped/quantum/untyped/core/refs.cljc @@ -1,12 +1,15 @@ (ns quantum.untyped.core.refs (:require - [quantum.untyped.core.core :as ucore]) - #?(:clj (:import [clojure.lang IDeref IAtom]))) + [quantum.untyped.core.core :as ucore])) (ucore/log-this-ns) -(defn atom? [x] (#?(:clj instance? :cljs satisfies?) IAtom x)) +(defn atom? [x] + #?(:clj (instance? clojure.lang.IAtom x) + :cljs (satisfies? cljs.core/IAtom x))) -(defn derefable? [x] (#?(:clj instance? :cljs satisfies?) IDeref x)) +(defn derefable? [x] + #?(:clj (instance? clojure.lang.IDeref x) + :cljs (satisfies? cljs.core/IDeref x))) (defn ?deref [x] (if (derefable? x) @x x)) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 820262dc..b7feb0ee 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -152,7 +152,7 @@ ;; ----- ProtocolType ----- ;; -(defns- isa?|protocol [p utpred/protocol?] +(defns- isa?|protocol [p ucore/protocol?] (ProtocolType. uhash/default uhash/default nil p nil)) ;; ----- ClassType ----- ;; @@ -198,7 +198,7 @@ ([t0 utr/type?, t1 utr/type? & ts (us/seq-of utr/type?) > utr/type?] (reduce - (- t0 t1) ts))) (defn isa? [x] - (ifs (utpred/protocol? x) + (ifs (ucore/protocol? x) (isa?|protocol x) (#?(:clj c/class? :cljs c/fn?) x) @@ -236,7 +236,7 @@ (Expression. sym x)) (c/nil? x) nil? - (utpred/protocol? x) + (ucore/protocol? x) (ProtocolType. uhash/default uhash/default nil x name-sym) (value x)) :cljs nil))) diff --git a/src-untyped/quantum/untyped/core/type/predicates.cljc b/src-untyped/quantum/untyped/core/type/predicates.cljc index b49ac411..32fc1e22 100644 --- a/src-untyped/quantum/untyped/core/type/predicates.cljc +++ b/src-untyped/quantum/untyped/core/type/predicates.cljc @@ -2,7 +2,7 @@ "For type predicates that are not yet turned into specs. TODO excise and place in `quantum.untyped.core.type`." (:refer-clojure :exclude - [any? seqable?]) + [seqable?]) (:require [clojure.core :as core] #?(:clj [clojure.future :as fcore]) @@ -12,21 +12,6 @@ (ucore/log-this-ns) -#?(:clj (eval `(defalias ~(if (resolve `fcore/any?) - `fcore/any? - `core/any?))) - :cljs (defalias core/any?)) - -(defn protocol? [x] - #?(:clj (and (lookup? x) (-> x (get :on-interface) class?)) - ;; Unfortunately there's no better check in CLJS, at least as of 03/18/2018 - :cljs (and (fn? x) (= (str x) "function (){}")))) - -(defn derefable? [x] - #?(:clj (instance? clojure.lang.IDeref x) - :cljs (satisfies? cljs.core/IDeref x))) - - ;; TODO this references data.array #?(:clj (defn seqable? "Returns true if (seq x) will succeed, false otherwise." From 82e165d250e11fd5239e6fea79911cb0e5654b83 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 2 Sep 2018 22:11:51 -0600 Subject: [PATCH 211/810] Remove and redistribute `quantum.untyped.core.type.predicates` --- src-untyped/quantum/untyped/core/analyze.cljc | 1 - .../quantum/untyped/core/collections.cljc | 11 +++--- .../untyped/core/collections/diff.cljc | 8 +--- src-untyped/quantum/untyped/core/core.cljc | 3 +- src-untyped/quantum/untyped/core/data.cljc | 34 +++++++++++++++- .../quantum/untyped/core/data/bits.cljc | 4 -- src-untyped/quantum/untyped/core/defnt.cljc | 6 +-- .../untyped/core/form/generate/deftype.cljc | 4 +- src-untyped/quantum/untyped/core/log.cljc | 4 +- .../quantum/untyped/core/reducers.cljc | 4 +- src-untyped/quantum/untyped/core/specs.cljc | 2 +- src-untyped/quantum/untyped/core/type.cljc | 1 - .../quantum/untyped/core/type/predicates.cljc | 39 ------------------- src-untyped/quantum/untyped/core/vars.cljc | 3 +- .../quantum/untyped/ui/components.cljc | 2 +- .../quantum/untyped/ui/style/css/dom.cljc | 2 +- src/quantum/core/analyze/clojure/core.cljc | 6 +-- src/quantum/core/async.cljc | 2 +- src/quantum/core/macros/defnt.cljc | 6 +-- src/quantum/core/macros/protocol.cljc | 4 +- src/quantum/core/macros/transform.cljc | 6 +-- src/quantum/core/type.cljc | 6 +-- src/quantum/format/clojure/core.cljc | 3 +- 23 files changed, 68 insertions(+), 93 deletions(-) delete mode 100644 src-untyped/quantum/untyped/core/type/predicates.cljc diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 04dd2d20..87252d34 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -30,7 +30,6 @@ [quantum.untyped.core.spec :as s] [quantum.untyped.core.type :as t :refer [?]] - [quantum.untyped.core.type.predicates :as utpred] [quantum.untyped.core.type.reifications :as utr] [quantum.untyped.core.vars :as uvar :refer [update-meta]])) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index cfdec4b4..1a079469 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -1,4 +1,5 @@ (ns quantum.untyped.core.collections + "Operations on collections." (:refer-clojure :exclude [#?(:cljs array?) assoc-in cat contains? count distinct distinct? first get group-by filter flatten last map map-indexed mapcat partition-all pmap remove reverse zipmap]) @@ -6,10 +7,12 @@ [clojure.core :as core] [fast-zip.core :as zip] [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.data + :refer [transient?]] + [quantum.untyped.core.data + :refer [val?]] [quantum.untyped.core.data.array :refer [array?]] - [quantum.untyped.core.data.bits - :refer [val?]] [quantum.untyped.core.error :as uerr :refer [err!]] [quantum.untyped.core.fn :as ufn @@ -19,9 +22,7 @@ [quantum.untyped.core.loops :refer [reduce-2]] [quantum.untyped.core.reducers :as ur - :refer [defeager def-transducer>eager transducer->transformer educe]] - [quantum.untyped.core.type.predicates - :refer [transient?]])) + :refer [defeager def-transducer>eager transducer->transformer educe]])) (ucore/log-this-ns) diff --git a/src-untyped/quantum/untyped/core/collections/diff.cljc b/src-untyped/quantum/untyped/core/collections/diff.cljc index f46eb401..048f4027 100644 --- a/src-untyped/quantum/untyped/core/collections/diff.cljc +++ b/src-untyped/quantum/untyped/core/collections/diff.cljc @@ -8,11 +8,9 @@ [quantum.untyped.core.core :as ucore :refer [istr]] [quantum.untyped.core.data - :refer [kw-map]] + :refer [kw-map seqable?]] [quantum.untyped.core.error - :refer [err!]] - [quantum.untyped.core.type.predicates - :refer [seqable?]])) + :refer [err!]])) (ucore/log-this-ns) @@ -43,5 +41,3 @@ :- (istr "At position ~{position}, remove this number of items:")) x])) []))})) - - diff --git a/src-untyped/quantum/untyped/core/core.cljc b/src-untyped/quantum/untyped/core/core.cljc index 2201d8b9..2c0c7ed4 100644 --- a/src-untyped/quantum/untyped/core/core.cljc +++ b/src-untyped/quantum/untyped/core/core.cljc @@ -36,13 +36,14 @@ (def >object >sentinel) ;; ===== Fundamental type predicates ===== ;; +;; TODO maybe move to `quantum.untyped.core.data`? #?(:clj (eval `(defalias ~(if (resolve `fcore/any?) `fcore/any? `core/any?))) :cljs (defalias core/any?)) -;; This is in here only because `protocol?` needs it +;; This is in here only because `protocol?` needs it; it's aliased later (defn lookup? [x] #?(:clj (instance? clojure.lang.ILookup x) :cljs (satisfies? cljs.core/ILookup x))) diff --git a/src-untyped/quantum/untyped/core/data.cljc b/src-untyped/quantum/untyped/core/data.cljc index 7e820239..2c2346b4 100644 --- a/src-untyped/quantum/untyped/core/data.cljc +++ b/src-untyped/quantum/untyped/core/data.cljc @@ -1,11 +1,18 @@ (ns quantum.untyped.core.data + (:refer-clojure :exclude + [seqable?]) (:require - [quantum.untyped.core.convert :as uconv + [quantum.untyped.core.convert :as uconv :refer [>keyword]] - [quantum.untyped.core.core :as ucore])) + [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.data.array :as uarr] + [quantum.untyped.core.vars + :refer [defalias]])) (ucore/log-this-ns) +(def val? some?) + (defn quote-map-base [kw-modifier ks & [no-quote?]] (->> ks (map #(vector (cond->> (kw-modifier %) (not no-quote?) (list 'quote)) %)) @@ -13,3 +20,26 @@ #?(:clj (defmacro kw-map [& ks] (list* `hash-map (quote-map-base >keyword ks)))) #?(:clj (defmacro quote-map [& ks] (list* `hash-map (quote-map-base identity ks)))) + +#?(:clj (defn seqable? + "Returns true if (seq x) will succeed, false otherwise." + {:from "clojure.contrib.core"} + [x] + (or (seq? x) + (instance? clojure.lang.Seqable x) + (nil? x) + (instance? Iterable x) + (uarr/array? x) + (string? x) + (instance? java.util.Map x))) + :cljs (def seqable? core/seqable?)) + +(defalias ucore/lookup?) + +(defn editable? [x] + #?(:clj (instance? clojure.lang.IEditableCollection x) + :cljs (satisfies? cljs.core/IEditableCollection x))) + +(defn transient? [x] + #?(:clj (instance? clojure.lang.ITransientCollection x) + :cljs (satisfies? cljs.core/ITransientCollection x))) diff --git a/src-untyped/quantum/untyped/core/data/bits.cljc b/src-untyped/quantum/untyped/core/data/bits.cljc index 76d8ba11..c63d1dac 100644 --- a/src-untyped/quantum/untyped/core/data/bits.cljc +++ b/src-untyped/quantum/untyped/core/data/bits.cljc @@ -15,10 +15,6 @@ (ucore/log-this-ns) -;; ===== Valueness / nilness ===== ;; - -(def val? some?) - ;; ===== Bit logic ===== ;; (defalias not bit-not) diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index f518b5f7..cd1dae15 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -8,6 +8,8 @@ [quantum.untyped.core.convert :as uconv] [quantum.untyped.core.core :refer [any?]] + [quantum.untyped.core.data + :refer [seqable?]] [quantum.untyped.core.data.map :refer [om]] [quantum.untyped.core.form.evaluate :as ufeval] @@ -17,9 +19,7 @@ :refer [reduce-2]] [quantum.untyped.core.reducers :as ur] [quantum.untyped.core.spec :as us] - [quantum.untyped.core.specs :as uss] - [quantum.untyped.core.type.predicates - :refer [seqable?]]) + [quantum.untyped.core.specs :as uss]) #?(:cljs (:require-macros [quantum.untyped.core.defnt :as this]))) diff --git a/src-untyped/quantum/untyped/core/form/generate/deftype.cljc b/src-untyped/quantum/untyped/core/form/generate/deftype.cljc index ae7b06ad..ed647cd2 100644 --- a/src-untyped/quantum/untyped/core/form/generate/deftype.cljc +++ b/src-untyped/quantum/untyped/core/form/generate/deftype.cljc @@ -5,9 +5,7 @@ [cljs.core] [clojure.core :as core] [quantum.untyped.core.data - :refer [kw-map]] - [quantum.untyped.core.data.bits - :refer [val?]] + :refer [kw-map val?]] [quantum.untyped.core.form.evaluate :refer [case-env]] [quantum.untyped.core.form.generate :as ufgen] diff --git a/src-untyped/quantum/untyped/core/log.cljc b/src-untyped/quantum/untyped/core/log.cljc index be4adf5c..b8e8cd9c 100644 --- a/src-untyped/quantum/untyped/core/log.cljc +++ b/src-untyped/quantum/untyped/core/log.cljc @@ -4,6 +4,8 @@ (:require [com.stuartsierra.component :as component] [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.data + :refer [seqable?]] [quantum.untyped.core.error :as uerr] [quantum.untyped.core.form :refer [$]] @@ -13,8 +15,6 @@ [quantum.untyped.core.identification :as uident] [quantum.untyped.core.meta.debug :as udebug] [quantum.untyped.core.print :as upr] - [quantum.untyped.core.type.predicates - :refer [seqable?]] [quantum.untyped.core.vars :refer [defalias]]) #?(:cljs diff --git a/src-untyped/quantum/untyped/core/reducers.cljc b/src-untyped/quantum/untyped/core/reducers.cljc index 8443be74..46abafa0 100644 --- a/src-untyped/quantum/untyped/core/reducers.cljc +++ b/src-untyped/quantum/untyped/core/reducers.cljc @@ -8,13 +8,13 @@ :refer [== not==]] [quantum.untyped.core.core :as ucore :refer [>sentinel]] + [quantum.untyped.core.data + :refer [seqable?]] [quantum.untyped.core.error :refer [err!]] [quantum.untyped.core.form.evaluate :refer [case-env]] [quantum.untyped.core.identification :as uident] - [quantum.untyped.core.type.predicates - :refer [seqable?]] [quantum.untyped.core.vars :as uvar :refer [defalias]]) #?(:cljs (:require-macros diff --git a/src-untyped/quantum/untyped/core/specs.cljc b/src-untyped/quantum/untyped/core/specs.cljc index 3f6f6be9..a145de61 100644 --- a/src-untyped/quantum/untyped/core/specs.cljc +++ b/src-untyped/quantum/untyped/core/specs.cljc @@ -5,7 +5,7 @@ (:require [clojure.core :as core] [clojure.set :as set] - [quantum.untyped.core.data.bits + [quantum.untyped.core.data :refer [val?]] [quantum.untyped.core.fn :refer [fn1 fnl]] diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index b7feb0ee..1de6c95d 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -54,7 +54,6 @@ [quantum.untyped.core.type.compare :as utcomp] [quantum.untyped.core.type.core :as utcore] [quantum.untyped.core.type.defs :as utdef] - [quantum.untyped.core.type.predicates :as utpred] [quantum.untyped.core.type.reifications :as utr :refer [->AndType ->OrType PType #?@(:cljs [UniversalSetType EmptySetType diff --git a/src-untyped/quantum/untyped/core/type/predicates.cljc b/src-untyped/quantum/untyped/core/type/predicates.cljc deleted file mode 100644 index 32fc1e22..00000000 --- a/src-untyped/quantum/untyped/core/type/predicates.cljc +++ /dev/null @@ -1,39 +0,0 @@ -(ns quantum.untyped.core.type.predicates - "For type predicates that are not yet turned into specs. - TODO excise and place in `quantum.untyped.core.type`." - (:refer-clojure :exclude - [seqable?]) - (:require - [clojure.core :as core] -#?(:clj [clojure.future :as fcore]) - [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.vars - :refer [defalias defaliases]])) - -(ucore/log-this-ns) - -;; TODO this references data.array -#?(:clj (defn seqable? - "Returns true if (seq x) will succeed, false otherwise." - {:from "clojure.contrib.core"} - [x] - (or (seq? x) - (instance? clojure.lang.Seqable x) - (nil? x) - (instance? Iterable x) - (array? x) - (string? x) - (instance? java.util.Map x))) - :cljs (def seqable? core/seqable?)) - -(defn lookup? [x] - #?(:clj (instance? clojure.lang.ILookup x) - :cljs (satisfies? cljs.core/ILookup x))) - -(defn editable? [x] - #?(:clj (instance? clojure.lang.IEditableCollection x) - :cljs (satisfies? cljs.core/IEditableCollection x))) - -(defn transient? [x] - #?(:clj (instance? clojure.lang.ITransientCollection x) - :cljs (satisfies? cljs.core/ITransientCollection x))) diff --git a/src-untyped/quantum/untyped/core/vars.cljc b/src-untyped/quantum/untyped/core/vars.cljc index 0a4b4345..855499a5 100644 --- a/src-untyped/quantum/untyped/core/vars.cljc +++ b/src-untyped/quantum/untyped/core/vars.cljc @@ -12,8 +12,7 @@ (ucore/log-this-ns) -#?(:clj (defn unbound? [x] (instance? clojure.lang.Var$Unbound x))) - +#?(:clj (defn unbound? [x] (instance? clojure.lang.Var$Unbound x))) #?(:cljs (defn defined? [x] (not (undefined? x)))) ;; ===== Metadata ===== ;; diff --git a/src-untyped/quantum/untyped/ui/components.cljc b/src-untyped/quantum/untyped/ui/components.cljc index 1b13f48a..a5f24789 100644 --- a/src-untyped/quantum/untyped/ui/components.cljc +++ b/src-untyped/quantum/untyped/ui/components.cljc @@ -10,7 +10,7 @@ :refer [react-class?]] [reagent.interop :refer [$ $!]]]) - [quantum.untyped.core.data.bits + [quantum.untyped.core.data :refer [val?]] [quantum.untyped.core.log :as log] [quantum.untyped.core.system :as usys diff --git a/src-untyped/quantum/untyped/ui/style/css/dom.cljc b/src-untyped/quantum/untyped/ui/style/css/dom.cljc index d9540ab6..417ac160 100644 --- a/src-untyped/quantum/untyped/ui/style/css/dom.cljc +++ b/src-untyped/quantum/untyped/ui/style/css/dom.cljc @@ -1,7 +1,7 @@ (ns quantum.untyped.ui.style.css.dom (:require [clojure.string :as str] - [quantum.untyped.core.data.bits + [quantum.untyped.core.data :refer [val?]] [quantum.untyped.core.fn :refer [fn->]] diff --git a/src/quantum/core/analyze/clojure/core.cljc b/src/quantum/core/analyze/clojure/core.cljc index 0fb37b6b..e4f7bd44 100644 --- a/src/quantum/core/analyze/clojure/core.cljc +++ b/src/quantum/core/analyze/clojure/core.cljc @@ -14,10 +14,10 @@ :refer [defalias]] [quantum.untyped.core.data :refer [kw-map]] + [quantum.untyped.core.data.bits + :refer [val?]] [quantum.untyped.core.form.evaluate :as ufeval] - [quantum.untyped.core.form.type-hint :as ufth] - [quantum.untyped.core.type.predicates - :refer [val?]]) + [quantum.untyped.core.form.type-hint :as ufth]) #?(:clj (:import (clojure.lang RT Compiler)))) diff --git a/src/quantum/core/async.cljc b/src/quantum/core/async.cljc index 6997a922..5c60cd64 100644 --- a/src/quantum/core/async.cljc +++ b/src/quantum/core/async.cljc @@ -46,7 +46,7 @@ :refer [case-env]] [quantum.untyped.core.string :refer [istr]] - [quantum.untyped.core.type.predicates + [quantum.untyped.core.vars #?@(:cljs [:refer [defined?]])]) #?(:cljs (:require-macros diff --git a/src/quantum/core/macros/defnt.cljc b/src/quantum/core/macros/defnt.cljc index 33ed4644..60000cc1 100644 --- a/src/quantum/core/macros/defnt.cljc +++ b/src/quantum/core/macros/defnt.cljc @@ -38,7 +38,7 @@ [quantum.untyped.core.convert :as uconv :refer [>integer >name]] [quantum.untyped.core.data - :refer [kw-map]] + :refer [kw-map val?]] [quantum.untyped.core.form.evaluate :refer [case-env case-env*]] [quantum.untyped.core.form.type-hint :as ufth] @@ -47,9 +47,7 @@ [quantum.untyped.core.reducers :refer [reducei] :as ured] [quantum.untyped.core.string :as ustr] - [quantum.untyped.core.type :as t] - [quantum.untyped.core.type.predicates - :refer [val?]])) + [quantum.untyped.core.type :as t])) (defonce warn-on-strict-inexact-matches? (atom false)) (defonce warn-on-all-inexact-matches? (atom false)) diff --git a/src/quantum/core/macros/protocol.cljc b/src/quantum/core/macros/protocol.cljc index 662403e0..3ade0c4d 100644 --- a/src/quantum/core/macros/protocol.cljc +++ b/src/quantum/core/macros/protocol.cljc @@ -12,9 +12,7 @@ [quantum.untyped.core.collections :as ucoll :refer [contains? update-first]] [quantum.untyped.core.data - :refer [kw-map]] - [quantum.untyped.core.type.predicates - :refer [val?]])) + :refer [kw-map val?]])) (defn with-protocol-arglist-type-hint [sym lang arglist-ct] diff --git a/src/quantum/core/macros/transform.cljc b/src/quantum/core/macros/transform.cljc index edacca1e..d6f6603c 100644 --- a/src/quantum/core/macros/transform.cljc +++ b/src/quantum/core/macros/transform.cljc @@ -19,10 +19,10 @@ :refer [default-zipper]] [quantum.untyped.core.collections.tree :as utree :refer [postwalk]] + [quantum.untyped.core.data + :refer [val?]] [quantum.untyped.core.reducers :as ured - :refer [zip-reduce*]] - [quantum.untyped.core.type.predicates - :refer [val?]])) + :refer [zip-reduce*]])) ; TODO should move (some of) these functions to core.analyze.clojure/transform? diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index ee600850..d8551830 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -25,8 +25,8 @@ [quantum.core.type.core :as tcore] [quantum.core.vars :as var :refer [defalias]] - [quantum.untyped.core.refs :as uref] - [quantum.untyped.core.type.predicates :as utpred]) + [quantum.untyped.core.data :as udata] + [quantum.untyped.core.refs :as uref]) #?(:cljs (:require-macros [quantum.core.type :as self @@ -140,7 +140,7 @@ (defnt sequential? ([^sequential? x] true) ([^default x] false)) (defnt counted? ([^counted? x] true) ([^default x] false)) (defnt transformer? ([^transformer? x] true) ([^default x] false)) - (defalias seqable? utpred/seqable?) + (defalias seqable? udata/seqable?) #?(:clj (defnt file? ([^file? x] true) ([^default x] false))) (defnt regex? ([^regex? x] true) ([^default x] false)) diff --git a/src/quantum/format/clojure/core.cljc b/src/quantum/format/clojure/core.cljc index b661b32d..67be632f 100644 --- a/src/quantum/format/clojure/core.cljc +++ b/src/quantum/format/clojure/core.cljc @@ -11,7 +11,7 @@ :refer [fn-and fn-not fn-or whenf1]] [quantum.core.vars :as var :refer [def-]] - [quantum.untyped.core.type.predicates + [quantum.untyped.core.string :refer [regex?]])) ;(java/load-deps '[rewrite-clj "0.4.12"]) @@ -321,4 +321,3 @@ (-> (p/parse-string-all form-string) (reformat-form options) (n/string))) - From e7213700645bd2e8bbe72dbae17c23ec965d5fd0 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 2 Sep 2018 22:26:53 -0600 Subject: [PATCH 212/810] Compilation fixes; `seq=` and `code=` moved --- src-dev/quantum/core/defnt_equivalences.cljc | 4 +- .../quantum/untyped/core/collections.cljc | 11 +++ src-untyped/quantum/untyped/core/compare.cljc | 3 +- src-untyped/quantum/untyped/core/core.cljc | 78 +++++-------------- src-untyped/quantum/untyped/core/form.cljc | 33 +++++++- src-untyped/quantum/untyped/core/test.cljc | 6 +- src/quantum/core/data/finger_tree.cljc | 4 +- test/quantum/test/core/defnt.cljc | 4 +- 8 files changed, 71 insertions(+), 72 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index bbd4fdd1..02e55eac 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -6,12 +6,10 @@ (:require [quantum.untyped.core.type.defnt :refer [defnt fnt unsupported!]] - [quantum.untyped.core.core :as ucore - :refer [code=]] [quantum.untyped.core.data.array :refer [*<>]] [quantum.untyped.core.form - :refer [$]] + :refer [$ code=]] [quantum.untyped.core.form.evaluate :refer [case-env env-lang macroexpand-all]] [quantum.untyped.core.form.type-hint diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index 1a079469..6794c208 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -383,3 +383,14 @@ (lazy-seq (when (seq s) (cons (first s) (unchunk (rest s)))))) + +(defn seq= + ([a b] (seq= a b =)) + ([a b eq-f] + (boolean + (loop [a (seq a) b (seq b)] + (let [a-nil? (nil? a)] + (and (identical? a-nil? (nil? b)) + (or a-nil? + (and (eq-f (first a) (first b)) + (recur (next a) (next b)))))))))) diff --git a/src-untyped/quantum/untyped/core/compare.cljc b/src-untyped/quantum/untyped/core/compare.cljc index 427e1577..762016ee 100644 --- a/src-untyped/quantum/untyped/core/compare.cljc +++ b/src-untyped/quantum/untyped/core/compare.cljc @@ -1,4 +1,5 @@ (ns quantum.untyped.core.compare + "General comparison operators and constants" (:refer-clojure :exclude [==]) (:require [quantum.untyped.core.core :as ucore @@ -57,5 +58,3 @@ {#?@(:clj [Class (fn [^Class a ^Class b] (.compareTo (.getName a) (.getName b)))])}) - -(defaliases ucore seq= code=) diff --git a/src-untyped/quantum/untyped/core/core.cljc b/src-untyped/quantum/untyped/core/core.cljc index 2c0c7ed4..d7f965ae 100644 --- a/src-untyped/quantum/untyped/core/core.cljc +++ b/src-untyped/quantum/untyped/core/core.cljc @@ -35,65 +35,6 @@ (defn >sentinel [] #?(:clj (Object.) :cljs #js {})) (def >object >sentinel) -;; ===== Fundamental type predicates ===== ;; -;; TODO maybe move to `quantum.untyped.core.data`? - -#?(:clj (eval `(defalias ~(if (resolve `fcore/any?) - `fcore/any? - `core/any?))) - :cljs (defalias core/any?)) - -;; This is in here only because `protocol?` needs it; it's aliased later -(defn lookup? [x] - #?(:clj (instance? clojure.lang.ILookup x) - :cljs (satisfies? cljs.core/ILookup x))) - -(defn protocol? [x] - #?(:clj (and (lookup? x) (-> x (get :on-interface) class?)) - ;; Unfortunately there's no better check in CLJS, at least as of 03/18/2018 - :cljs (and (fn? x) (= (str x) "function (){}")))) - -;; ===== Collections ===== ;; - -(defn seq= - ([a b] (seq= a b =)) - ([a b eq-f] - (boolean - (loop [a (seq a) b (seq b)] - (let [a-nil? (nil? a)] - (and (identical? a-nil? (nil? b)) - (or a-nil? - (and (eq-f (first a) (first b)) - (recur (next a) (next b)))))))))) - -(defn code= - "Ensures that two pieces of code are equivalent. - This means ensuring that seqs, vectors, and maps are only allowed to be compared with - each other, and that metadata (minus line and column metadata) is equivalent." - ([code0 code1] - (if (metable? code0) - (and (metable? code1) - (= (-> code0 meta (dissoc :line :column)) - (-> code1 meta (dissoc :line :column))) - (let [similar-class? - (cond (seq? code0) (seq? code1) - (seq? code1) (seq? code0) - (vector? code0) (vector? code1) - (vector? code1) (vector? code0) - (map? code0) (map? code1) - (map? code1) (map? code0) - :else ::not-applicable)] - (if (= similar-class? ::not-applicable) - (= code0 code1) - (and similar-class? (seq= (seq code0) (seq code1) code=)))) - (cond (seq? code0) (and (seq? code1) (seq= code0 code1 code=)) - (vector? code0) (and (vector? code1) (seq= (seq code0) (seq code1) code=)) - (map? code0) (and (map? code1) (seq= (seq code0) (seq code1) code=)) - :else (= code0 code1))) - (and (not (metable? code1)) - (= code0 code1)))) - ([code0 code1 & codes] (and (code= code0 code1) (every? #(code= code0 %) codes)))) - ;; From `quantum.untyped.core.form.evaluate` — used below in `defalias` (defn cljs-env? @@ -184,6 +125,25 @@ alias-)] `(defaliases' ~ns-sym ~@names)))) +;; ===== Fundamental type predicates ===== ;; +;; TODO maybe move to `quantum.untyped.core.data`? + +#?(:clj (eval `(defalias ~(if (resolve `fcore/any?) + `fcore/any? + `core/any?))) + :cljs (defalias core/any?)) + +;; This is in here only because `protocol?` needs it; it's aliased later +(defn lookup? [x] + #?(:clj (instance? clojure.lang.ILookup x) + :cljs (satisfies? cljs.core/ILookup x))) + +(defn protocol? [x] + #?(:clj (and (lookup? x) (-> x (get :on-interface) class?)) + ;; Unfortunately there's no better check in CLJS, at least as of 03/18/2018 + :cljs (and (fn? x) (= (str x) "function (){}")))) + + ;; From `quantum.untyped.core.collections.tree` — used in `quantum.untyped.core.macros` (defn walk diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index 790e3db1..087ae7da 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -1,10 +1,13 @@ (ns quantum.untyped.core.form (:require + [quantum.untyped.core.collections + :refer [seq=]] [quantum.untyped.core.core :as ucore :refer [defalias]] [quantum.untyped.core.form.evaluate :refer [case-env*]] - [quantum.untyped.core.form.generate :as ufgen])) + [quantum.untyped.core.form.generate :as ufgen] + [quantum.untyped.core.vars :as uvar])) (ucore/log-this-ns) @@ -90,3 +93,31 @@ "Reproducibly, unifiedly syntax quote without messing up the format as a literal syntax quote might do." [body] `(ufgen/unify-gensyms (syntax-quote ~body) true))) + +(defn code= + "Ensures that two pieces of code are equivalent. + This means ensuring that seqs, vectors, and maps are only allowed to be compared with + each other, and that metadata (minus line and column metadata) is equivalent." + ([code0 code1] + (if (uvar/metable? code0) + (and (uvar/metable? code1) + (= (-> code0 meta (dissoc :line :column)) + (-> code1 meta (dissoc :line :column))) + (let [similar-class? + (cond (seq? code0) (seq? code1) + (seq? code1) (seq? code0) + (vector? code0) (vector? code1) + (vector? code1) (vector? code0) + (map? code0) (map? code1) + (map? code1) (map? code0) + :else ::not-applicable)] + (if (= similar-class? ::not-applicable) + (= code0 code1) + (and similar-class? (seq= (seq code0) (seq code1) code=)))) + (cond (seq? code0) (and (seq? code1) (seq= code0 code1 code=)) + (vector? code0) (and (vector? code1) (seq= (seq code0) (seq code1) code=)) + (map? code0) (and (map? code1) (seq= (seq code0) (seq code1) code=)) + :else (= code0 code1))) + (and (not (uvar/metable? code1)) + (= code0 code1)))) + ([code0 code1 & codes] (and (code= code0 code1) (every? #(code= code0 %) codes)))) diff --git a/src-untyped/quantum/untyped/core/test.cljc b/src-untyped/quantum/untyped/core/test.cljc index 758a8d57..b9b13e2d 100644 --- a/src-untyped/quantum/untyped/core/test.cljc +++ b/src-untyped/quantum/untyped/core/test.cljc @@ -4,6 +4,8 @@ [clojure.spec.test.alpha :as stest] [clojure.string :as str] [clojure.test :as test] + [quantum.untyped.core.collections + :refer [seq=]] [quantum.untyped.core.core :as ucore] [quantum.untyped.core.error :as uerr] [quantum.untyped.core.log @@ -47,8 +49,8 @@ (pr! "FAIL: should be `(= code0 code1)`" (pr-str code0) (pr-str code1))) (and (or similar-class? (pr! "FAIL: should be similar class" (pr-str code0) (pr-str code1))) - (or (ucore/seq= (seq code0) (seq code1) code=) - (pr! "FAIL: `(ucore/seq= code0 code1 code=)`" + (or (seq= (seq code0) (seq code1) code=) + (pr! "FAIL: `(seq= code0 code1 code=)`" (pr-str code0) (pr-str code1))))))) (and (not (metable? code1)) (or (= code0 code1) diff --git a/src/quantum/core/data/finger_tree.cljc b/src/quantum/core/data/finger_tree.cljc index f044aeca..095b9883 100644 --- a/src/quantum/core/data/finger_tree.cljc +++ b/src/quantum/core/data/finger_tree.cljc @@ -4,10 +4,10 @@ quantum.core.data.finger-tree (:refer-clojure :exclude [macroexpand-1]) (:require - [quantum.core.data.map :as map + [quantum.core.data.map :as map :refer [map-entry]] [quantum.core.macros.deftype :as deftype] - [quantum.core.core + [quantum.untyped.core.collections :refer [seq=]] #?@(:clj [[quantum.core.data.finger-tree.macros diff --git a/test/quantum/test/core/defnt.cljc b/test/quantum/test/core/defnt.cljc index 13567164..addaaeb9 100644 --- a/test/quantum/test/core/defnt.cljc +++ b/test/quantum/test/core/defnt.cljc @@ -12,10 +12,8 @@ [quantum.core.type.defs :as tdef] [quantum.untyped.core.analyze.ast :as ast] [quantum.untyped.core.analyze.expr :as xp] - [quantum.untyped.core.core - :refer [code=]] [quantum.untyped.core.form - :refer [$]] + :refer [$ code=]] [quantum.untyped.core.form.type-hint :refer [tag]] [quantum.untyped.core.spec :as s] From e36164a8f18b9615c0f99290481a408811d3ca9e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 2 Sep 2018 23:06:27 -0600 Subject: [PATCH 213/810] Compilation fixes --- src-untyped/quantum/untyped/core/core.cljc | 2 ++ src-untyped/quantum/untyped/core/identification.cljc | 4 +++- src-untyped/quantum/untyped/core/type/reifications.cljc | 2 +- src-untyped/quantum/untyped/core/vars.cljc | 1 - src/quantum/core/vars.cljc | 2 -- 5 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src-untyped/quantum/untyped/core/core.cljc b/src-untyped/quantum/untyped/core/core.cljc index d7f965ae..7a92d94d 100644 --- a/src-untyped/quantum/untyped/core/core.cljc +++ b/src-untyped/quantum/untyped/core/core.cljc @@ -1,4 +1,6 @@ (ns quantum.untyped.core.core + (:refer-clojure :exclude + [any?]) (:require [clojure.core :as core] #?(:clj [clojure.future :as fcore]) diff --git a/src-untyped/quantum/untyped/core/identification.cljc b/src-untyped/quantum/untyped/core/identification.cljc index ea34b87b..0af6506f 100644 --- a/src-untyped/quantum/untyped/core/identification.cljc +++ b/src-untyped/quantum/untyped/core/identification.cljc @@ -10,7 +10,9 @@ [fipp.ednize] [quantum.untyped.core.core :as ucore] [quantum.untyped.core.ns :as uns - #?@(:clj [:refer [namespace?]])])) + #?@(:clj [:refer [namespace?]])] + [quantum.untyped.core.vars + :refer [defalias]])) (ucore/log-this-ns) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 76a76fe6..6d4d564b 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -228,7 +228,7 @@ (udt/deftype FnType [name arities-form - arities #_(s/map-of non-zero-int? (s/seq-of ::t/fn-type|arity))] + arities #_(s/map-of non-zero-int? (s/seq-of :quantum.untyped.core.type/fn-type|arity))] {PType nil ;; Outputs whether the args match any input spec ?Fn {invoke ([this args] (TODO))} diff --git a/src-untyped/quantum/untyped/core/vars.cljc b/src-untyped/quantum/untyped/core/vars.cljc index 855499a5..d3d0e913 100644 --- a/src-untyped/quantum/untyped/core/vars.cljc +++ b/src-untyped/quantum/untyped/core/vars.cljc @@ -3,7 +3,6 @@ (:require [clojure.core :as core] [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.form :as uform] [quantum.untyped.core.form.evaluate :refer [case-env case-env*]] [quantum.untyped.core.form.generate :as ufgen]) diff --git a/src/quantum/core/vars.cljc b/src/quantum/core/vars.cljc index d248cd9b..3118e2ba 100644 --- a/src/quantum/core/vars.cljc +++ b/src/quantum/core/vars.cljc @@ -8,8 +8,6 @@ :refer [?]] [quantum.untyped.core.defnt :refer [defnt fnt]] - [quantum.untyped.core.form.evaluate - :refer [case-env]] [quantum.untyped.core.vars :as u]) #?(:cljs (:require-macros From d81be721e455f05af7d1d7a2d33102c36e343a93 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 3 Sep 2018 00:26:43 -0600 Subject: [PATCH 214/810] `*<>` is now variadic --- src-dev/quantum/core/defnt_equivalences.cljc | 22 +---- .../quantum/untyped/core/data/array.cljc | 85 +++++++++------- src-untyped/quantum/untyped/core/loops.cljc | 39 +++++++- src/quantum/core/collections.cljc | 98 +++++++++---------- src/quantum/core/collections/map_filter.cljc | 4 +- 5 files changed, 141 insertions(+), 107 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 02e55eac..89b0d245 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -1374,26 +1374,8 @@ ([xs t/char-seq?] (clojure.lang.StringSeq/create xs)) ;; TODO recursion #_([xs (t/isa? java.util.Map)] (seq (.entrySet xs))) - ;; TODO for these, use `count` not `clojure.lang.RT/alength` - ([xs t/booleans?] (when-not (zero? (clojure.lang.RT/alength xs)) - (clojure.lang.ArraySeq$ArraySeq_boolean. nil xs 0))) - ([xs t/bytes?] (when-not (zero? (clojure.lang.RT/alength xs)) - (clojure.lang.ArraySeq$ArraySeq_byte. nil xs 0))) - ([xs t/chars?] (when-not (zero? (clojure.lang.RT/alength xs)) - (clojure.lang.ArraySeq$ArraySeq_char. nil xs 0))) - ([xs t/shorts?] (when-not (zero? (clojure.lang.RT/alength xs)) - (clojure.lang.ArraySeq$ArraySeq_short. nil xs 0))) - ([xs t/ints?] (when-not (zero? (clojure.lang.RT/alength xs)) - (clojure.lang.ArraySeq$ArraySeq_int. nil xs 0))) - ([xs t/longs?] (when-not (zero? (clojure.lang.RT/alength xs)) - (clojure.lang.ArraySeq$ArraySeq_long. nil xs 0))) - ([xs t/floats?] (when-not (zero? (clojure.lang.RT/alength xs)) - (clojure.lang.ArraySeq$ArraySeq_float. nil xs 0))) - ([xs t/doubles?] (when-not (zero? (clojure.lang.RT/alength xs)) - (clojure.lang.ArraySeq$ArraySeq_double. nil xs 0))) - ;; TODO fix - #_([xs t/array?] (when-not (zero? (clojure.lang.RT/alength xs)) - (clojure.lang.ArraySeq. xs 0))) + ([xs t/array?] (when-not (zero? (Array/count xs)) ; TODO use `count` + (clojure.lang.ArraySeq. ^Object xs 0))) )) ) diff --git a/src-untyped/quantum/untyped/core/data/array.cljc b/src-untyped/quantum/untyped/core/data/array.cljc index 65b9cc37..effaca2c 100644 --- a/src-untyped/quantum/untyped/core/data/array.cljc +++ b/src-untyped/quantum/untyped/core/data/array.cljc @@ -2,7 +2,8 @@ (:refer-clojure :exclude [array array?]) (:require - [clojure.core :as core]) + [clojure.core :as core] + [quantum.untyped.core.loops :as uloop]) #?(:clj (:import [quantum.core.data Array]))) @@ -14,36 +15,52 @@ ([] #?(:clj (Array/newUninitialized1dObjectArray 0) :cljs #js [])) - ([a0] - #?(:clj (Array/new1dObjectArray a0) - :cljs #js [a0])) - ([a0 a1] - #?(:clj (Array/new1dObjectArray a0 a1) - :cljs #js [a0 a1])) - ([a0 a1 a2] - #?(:clj (Array/new1dObjectArray a0 a1 a2) - :cljs #js [a0 a1 a2])) - ([a0 a1 a2 a3] - #?(:clj (Array/new1dObjectArray a0 a1 a2 a3) - :cljs #js [a0 a1 a2 a3])) - ([a0 a1 a2 a3 a4] - #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4) - :cljs #js [a0 a1 a2 a3 a4])) - ([a0 a1 a2 a3 a4 a5] - #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5) - :cljs #js [a0 a1 a2 a3 a4 a5])) - ([a0 a1 a2 a3 a4 a5 a6] - #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6) - :cljs #js [a0 a1 a2 a3 a4 a5 a6])) - ([a0 a1 a2 a3 a4 a5 a6 a7] - #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6 a7) - :cljs #js [a0 a1 a2 a3 a4 a5 a6 a7])) - ([a0 a1 a2 a3 a4 a5 a6 a7 a8] - #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6 a7 a8) - :cljs #js [a0 a1 a2 a3 a4 a5 a6 a7 a8])) - ([a0 a1 a2 a3 a4 a5 a6 a7 a8 a9] - #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6 a7 a8 a9) - :cljs #js [a0 a1 a2 a3 a4 a5 a6 a7 a8 a9])) - ([a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10] - #?(:clj (Array/new1dObjectArray a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) - :cljs #js [a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10]))) + ([x0] + #?(:clj (Array/new1dObjectArray x0) + :cljs #js [x0])) + ([x0 x1] + #?(:clj (Array/new1dObjectArray x0 x1) + :cljs #js [x0 x1])) + ([x0 x1 x2] + #?(:clj (Array/new1dObjectArray x0 x1 x2) + :cljs #js [x0 x1 x2])) + ([x0 x1 x2 x3] + #?(:clj (Array/new1dObjectArray x0 x1 x2 x3) + :cljs #js [x0 x1 x2 x3])) + ([x0 x1 x2 x3 x4] + #?(:clj (Array/new1dObjectArray x0 x1 x2 x3 x4) + :cljs #js [x0 x1 x2 x3 x4])) + ([x0 x1 x2 x3 x4 x5] + #?(:clj (Array/new1dObjectArray x0 x1 x2 x3 x4 x5) + :cljs #js [x0 x1 x2 x3 x4 x5])) + ([x0 x1 x2 x3 x4 x5 x6] + #?(:clj (Array/new1dObjectArray x0 x1 x2 x3 x4 x5 x6) + :cljs #js [x0 x1 x2 x3 x4 x5 x6])) + ([x0 x1 x2 x3 x4 x5 x6 x7] + #?(:clj (Array/new1dObjectArray x0 x1 x2 x3 x4 x5 x6 x7) + :cljs #js [x0 x1 x2 x3 x4 x5 x6 x7])) + ([x0 x1 x2 x3 x4 x5 x6 x7 x8] + #?(:clj (Array/new1dObjectArray x0 x1 x2 x3 x4 x5 x6 x7 x8) + :cljs #js [x0 x1 x2 x3 x4 x5 x6 x7 x8])) + ([x0 x1 x2 x3 x4 x5 x6 x7 x8 x9] + #?(:clj (Array/new1dObjectArray x0 x1 x2 x3 x4 x5 x6 x7 x8 x9) + :cljs #js [x0 x1 x2 x3 x4 x5 x6 x7 x8 x9])) + ([x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10] + #?(:clj (Array/new1dObjectArray x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) + :cljs #js [x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10])) + ([x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 & xs] + #?(:clj (let [arr (Array/newUninitialized1dObjectArray (+ 11 (count xs)))] + (Array/set arr x0 0) + (Array/set arr x1 1) + (Array/set arr x2 2) + (Array/set arr x3 3) + (Array/set arr x4 4) + (Array/set arr x5 5) + (Array/set arr x6 6) + (Array/set arr x7 7) + (Array/set arr x8 8) + (Array/set arr x9 9) + (Array/set arr x10 10) + (uloop/doseqi [x xs i] (doto arr (Array/set x (+ 11 i))))) + :cljs (let [arr #js [x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10]] + (uloop/doseq [x xs] (doto arr (.push x))))))) diff --git a/src-untyped/quantum/untyped/core/loops.cljc b/src-untyped/quantum/untyped/core/loops.cljc index 0aa5aac4..ba5a82bd 100644 --- a/src-untyped/quantum/untyped/core/loops.cljc +++ b/src-untyped/quantum/untyped/core/loops.cljc @@ -1,7 +1,8 @@ (ns quantum.untyped.core.loops + (:refer-clojure :exclude + [doseq]) (:require - [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.reducers :as r])) + [quantum.untyped.core.core :as ucore])) (ucore/log-this-ns) @@ -23,3 +24,37 @@ :else (recur (f ret (first xs0') (first xs1')) (next xs0') (next xs1')))))) + + +;; TODO incorporate into `quantum.core.loops` +#?(:clj +(defmacro doseq + "Like `doseq` but: + - Indexed + - Returns the result + - Does not have `:let`, `:while` or `:when` semantics + - Much smaller code footprint" + [[x xs i] & body] + `(loop [xs# (seq ~xs) + ret# nil] + (if xs# + (let [~x (first xs#)] + (recur (next xs#) (do ~@body))) + ret#)))) + +;; TODO incorporate into `quantum.core.loops` +#?(:clj +(defmacro doseqi + "Like `doseq` but: + - Indexed + - Returns the result + - Does not have `:let`, `:while` or `:when` semantics + - Much smaller code footprint" + [[x xs i] & body] + `(loop [xs# (seq ~xs) + ~i 0 + ret# nil] + (if xs# + (let [~x (first xs#)] + (recur (next xs#) (inc ~i) (do ~@body))) + ret#)))) diff --git a/src/quantum/core/collections.cljc b/src/quantum/core/collections.cljc index f337acd5..63d46cf4 100644 --- a/src/quantum/core/collections.cljc +++ b/src/quantum/core/collections.cljc @@ -91,7 +91,7 @@ boolean? should-transientize? class]] [quantum.core.analyze.clojure.predicates :as anap] - [quantum.core.loops :as loops] + [quantum.core.loops :as loop] [quantum.core.vars :as var :refer [defalias defaliases]] [quantum.untyped.core.data :as udata]) @@ -260,7 +260,7 @@ (defnt into! ; TODO delete "Like into, but for mutable collections" - [^transient? x coll] (loops/doseq [elem coll] (conj! x elem)) x) + [^transient? x coll] (loop/doseq [elem coll] (conj! x elem)) x) ; `take` <~> `lodash/take` (defalias take diff/takel ) @@ -356,48 +356,48 @@ ; _______________________________________________________________ ; ============================ LOOPS ============================ ; ••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••• -#?(:clj (defalias dotimes loops/dotimes )) -#?(:clj (defalias fortimes loops/fortimes )) -#?(:clj (defalias fortimes:objects loops/fortimes:objects )) -#?(:clj (defalias fortimes:objects2 loops/fortimes:objects2)) -#?(:clj (defalias fortimes:doubles loops/fortimes:doubles )) -#?(:clj (defalias fortimes:doubles2 loops/fortimes:doubles2)) -#?(:clj (defalias fortimes:doubles3 loops/fortimes:doubles3)) +#?(:clj (defalias dotimes loop/dotimes )) +#?(:clj (defalias fortimes loop/fortimes )) +#?(:clj (defalias fortimes:objects loop/fortimes:objects )) +#?(:clj (defalias fortimes:objects2 loop/fortimes:objects2)) +#?(:clj (defalias fortimes:doubles loop/fortimes:doubles )) +#?(:clj (defalias fortimes:doubles2 loop/fortimes:doubles2)) +#?(:clj (defalias fortimes:doubles3 loop/fortimes:doubles3)) #?(:clj (defalias transduce red/transduce )) -#?(:clj (defalias reduce loops/reduce )) -#?(:clj (defalias reducei loops/reducei )) -#?(:clj (defalias reduce* loops/reduce* )) -#?(:clj (defalias reduce-multi loops/reduce-multi)) -#?(:clj (defalias red-for loops/red-for )) -#?(:clj (defalias red-fori loops/red-fori)) - (defalias reduce-pair loops/reduce-pair) - (defalias reduce-2 loops/reduce-2 ) - (defalias reducei-2 loops/reducei-2) -#?(:clj (defalias reduce-2:indexed loops/reduce-2:indexed)) -#?(:clj (defalias ifor loops/ifor )) -#?(:clj (defalias ifori loops/ifori )) +#?(:clj (defalias reduce loop/reduce )) +#?(:clj (defalias reducei loop/reducei )) +#?(:clj (defalias reduce* loop/reduce* )) +#?(:clj (defalias reduce-multi loop/reduce-multi)) +#?(:clj (defalias red-for loop/red-for )) +#?(:clj (defalias red-fori loop/red-fori)) + (defalias reduce-pair loop/reduce-pair) + (defalias reduce-2 loop/reduce-2 ) + (defalias reducei-2 loop/reducei-2) +#?(:clj (defalias reduce-2:indexed loop/reduce-2:indexed)) +#?(:clj (defalias ifor loop/ifor )) +#?(:clj (defalias ifori loop/ifori )) ; ===== COLLECTION COMPREHENSION ===== ; -#?(:clj (defalias for-join loops/for-join )) -#?(:clj (defalias for-join! loops/for-join! )) -#?(:clj (defalias for loops/for )) #?(:clj (alter-meta! (var for) c/assoc :macro true)) -#?(:clj (defalias for' loops/for' )) +#?(:clj (defalias for-join loop/for-join )) +#?(:clj (defalias for-join! loop/for-join! )) +#?(:clj (defalias for loop/for )) #?(:clj (alter-meta! (var for) c/assoc :macro true)) +#?(:clj (defalias for' loop/for' )) #?(:clj (defalias for+ red/for+ )) -#?(:clj (defalias fori loops/fori )) -#?(:clj (defalias fori' loops/fori' )) +#?(:clj (defalias fori loop/fori )) +#?(:clj (defalias fori' loop/fori' )) #?(:clj (defalias fori+ red/fori+ )) -#?(:clj (defalias fori-join loops/fori-join )) -#?(:clj (defalias fori-join! loops/fori-join!)) -#?(:clj (defmacro lfor [& args] `(loops/lfor ~@args))) - -#?(:clj (defmacro doseq [& args] `(loops/doseq ~@args))) -#?(:clj (defmacro doseqi [& args] `(loops/doseqi ~@args))) -#?(:clj (defalias until loops/until )) -#?(:clj (defalias while-let loops/while-let)) -#?(:clj (defalias doeach loops/doeach)) -#?(:clj (defalias each loops/each)) -#?(:clj (defalias eachi loops/eachi)) -#?(:clj (defalias doreduce loops/doreduce)) - (defalias mapfn loops/mapfn) +#?(:clj (defalias fori-join loop/fori-join )) +#?(:clj (defalias fori-join! loop/fori-join!)) +#?(:clj (defmacro lfor [& args] `(loop/lfor ~@args))) + +#?(:clj (defmacro doseq [& args] `(loop/doseq ~@args))) +#?(:clj (defmacro doseqi [& args] `(loop/doseqi ~@args))) +#?(:clj (defalias until loop/until )) +#?(:clj (defalias while-let loop/while-let)) +#?(:clj (defalias doeach loop/doeach)) +#?(:clj (defalias each loop/each)) +#?(:clj (defalias eachi loop/eachi)) +#?(:clj (defalias doreduce loop/doreduce)) + (defalias mapfn loop/mapfn) (defalias break reduced) ; _______________________________________________________________ ; ========================= GENERATIVE ========================== @@ -752,14 +752,14 @@ [coll elem-0] (if (should-transientize? coll) (persistent! - (loops/reducei + (loop/reducei (fn [ret elem-n n] (if (= elem-0 elem-n) (conj! ret n) ret)) (transient []) coll)) - (loops/reducei + (loop/reducei (fn [ret elem-n n] (if (= elem-0 elem-n) (conj ret n) @@ -892,7 +892,7 @@ {:todo ["Rename this function." "Possibly belongs in a different namespace"]} [coll compare-fn] - (loops/reducei + (loop/reducei (fn [ret elem n] (if (= n 0) elem (compare-fn ret elem))) nil @@ -951,7 +951,7 @@ (-> m (dissoc k)))) (defn rename-keys [m-0 rename-m] - (loops/reduce + (loop/reduce (fn [ret k-0 k-f] (-> ret (assoc k-f (get ret k-0)) @@ -1017,8 +1017,8 @@ merge2 (fn ([] {}) ([m1 m2] - (loops/reduce merge-entry (or m1 {}) (seq m2))))] - (loops/reduce merge2 maps)))) + (loop/reduce merge-entry (or m1 {}) (seq m2))))] + (loop/reduce merge2 maps)))) (defn merge-vals-left "Merges into the left map all elements of the right map whose @@ -1035,7 +1035,7 @@ :b {:aa 3}}} [left right f] (persistent! - (loops/reduce + (loop/reduce (fn [left-f k-right v-right] ;(if ((fn-not contains?) left-f k-right) ; can't call |contains?| on a transient, apparently... ; left-f) @@ -1067,7 +1067,7 @@ :attribution "alexandergunnarson" :out 'Map} ([coll kfs] - (->> (loops/reduce + (->> (loop/reduce (fn [ret k f] (assoc ret k (f coll))) {} @@ -1192,7 +1192,7 @@ (fn [grouped-elems] (if (single? grouped-elems) grouped-elems - (loops/reduce + (loop/reduce (fn [ret elem] (merge-with-k merge-with-f ret elem)) (first grouped-elems) diff --git a/src/quantum/core/collections/map_filter.cljc b/src/quantum/core/collections/map_filter.cljc index f897cda7..66155bf8 100644 --- a/src/quantum/core/collections/map_filter.cljc +++ b/src/quantum/core/collections/map_filter.cljc @@ -50,7 +50,7 @@ [quantum.core.reducers :as red :refer[indexed+ join' reduce defeager]] [quantum.core.type :as type] - [quantum.core.loops :as loops + [quantum.core.loops :as loop :refer [reducei doseqi lfor]] [quantum.core.vars :as var :refer [defalias defaliases]])) @@ -100,7 +100,7 @@ (->> xs rseq (ffilteri pred) (<- (update 0 (partial - (lasti xs)))))) ([xs pred] - (loops/reducei + (loop/reducei (fn [ret elem-n index-n] (if (pred elem-n) (map-entry index-n elem-n) From a62b24c2107ef1430913bda6474894a070754718 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 3 Sep 2018 00:26:54 -0600 Subject: [PATCH 215/810] Fix incorrect spec --- src-untyped/quantum/untyped/core/analyze.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 87252d34..37749545 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -351,7 +351,7 @@ method-or-field args-forms)))))) ;; TODO move this -(defns truthy-node? [{:as ast t [:type _]} _ > t/boolean?] +(defns truthy-node? [{:as ast t [:type _]} _ > (t/? t/boolean?)] (log/pr!) (ifs (or (t/= t t/nil?) (t/= t t/false?)) false From 0b186e64547b259e98f2dcd517a229d2d3669edc Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 3 Sep 2018 00:50:09 -0600 Subject: [PATCH 216/810] Make all type reifications metable --- src-dev/quantum/core/defnt_equivalences.cljc | 8 +++-- src-untyped/quantum/untyped/core/type.cljc | 15 ++++++---- .../untyped/core/type/reifications.cljc | 30 ++++++++++++++----- 3 files changed, 37 insertions(+), 16 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 89b0d245..2a6e59c8 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -1374,9 +1374,11 @@ ([xs t/char-seq?] (clojure.lang.StringSeq/create xs)) ;; TODO recursion #_([xs (t/isa? java.util.Map)] (seq (.entrySet xs))) - ([xs t/array?] (when-not (zero? (Array/count xs)) ; TODO use `count` - (clojure.lang.ArraySeq. ^Object xs 0))) - )) + ;; TODO use `t/assume` + ([xs t/array? > (t/* #_t/assume (t/? (t/isa? ISeq)))] + ;; We do this only because `clojure.lang.ArraySeq/createFromObject` is private but + ;; perhaps it would be wise from a performance perspective to fix that + (clojure.core/seq xs)))) ) ;; ----- expanded code ----- ;; diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 1de6c95d..15f5b0d1 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -119,7 +119,7 @@ (utr/or-type? t) (->> t utr/or-type>args (uc/lmap not) (apply and)) ;; DeMorgan's Law (utr/and-type? t) (->> t utr/and-type>args (uc/lmap not) (apply or )) - (NotType. uhash/default uhash/default t))) + (NotType. uhash/default uhash/default nil t))) (uvar/defalias ! not) @@ -163,7 +163,7 @@ (defns value "Creates a type whose extension is the singleton set containing only the value `v`." - [v _] (ValueType. uhash/default uhash/default v)) + [v _] (ValueType. uhash/default uhash/default nil v)) ;; ----- General ----- ;; @@ -185,15 +185,18 @@ (condp == c0 NotType (condp == (-> t0 utr/not-type>inner-type c/type) ClassType (condp == c1 - ClassType (AndType. uhash/default uhash/default [t0 (not t1)] (atom nil))) + ClassType (AndType. uhash/default uhash/default nil + [t0 (not t1)] (atom nil))) ValueType (condp == c1 - ValueType (AndType. uhash/default uhash/default [t0 (not t1)] (atom nil)))) + ValueType (AndType. uhash/default uhash/default nil + [t0 (not t1)] (atom nil)))) OrType (condp == c1 ClassType (let [args (->> t0 utr/or-type>args (uc/remove (fn1 = t1)))] (case (count args) 0 empty-set 1 (first args) - (OrType. uhash/default uhash/default args (atom nil)))))))))) + (OrType. uhash/default uhash/default nil args + (atom nil)))))))))) ([t0 utr/type?, t1 utr/type? & ts (us/seq-of utr/type?) > utr/type?] (reduce - (- t0 t1) ts))) (defn isa? [x] @@ -447,7 +450,7 @@ arities (->> arities-form (uc/map+ #(us/conform ::fn-type|arity %)) (uc/group-by #(-> % :input-types count)))] - (FnType. name- arities-form arities))) + (FnType. nil name- arities-form arities))) (defns compare|in [x0 utr/fn-type?, x1 utr/fn-type? > ucomp/comparison?] (let [ct->overloads|x0 (utr/fn-type>arities x0) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 6d4d564b..5ff0fe66 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -73,9 +73,12 @@ (udt/deftype NotType [^int ^:unsynchronized-mutable hash ^int ^:unsynchronized-mutable hash-code + meta #_(t/? ::meta) t #_t/type?] {PType nil ?Fn {invoke ([_ x] (not (t x)))} + ?Meta {meta ([this] meta) + with-meta ([this meta'] (NotType. hash hash-code meta' t))} ?Hash {hash ([this] (uhash/caching-set-ordered! hash NotType t))} ?Object {hash-code ([this] (uhash/caching-set-code! hash-code NotType t)) equals ([this that] @@ -95,6 +98,7 @@ (udt/deftype OrType [^int ^:unsynchronized-mutable hash ^int ^:unsynchronized-mutable hash-code + meta #_(t/? ::meta) args #_(t/and t/indexed? (t/seq t/type?)) *logical-complement] {PType nil @@ -104,6 +108,8 @@ (and satisfies-type? (reduced satisfies-type?)))) true ; vacuously args))} + ?Meta {meta ([this] meta) + with-meta ([this meta'] (OrType. hash hash-code meta' args *logical-complement))} ?Hash {hash ([this] (uhash/caching-set-ordered! hash OrType args))} ?Object {hash-code ([this] (uhash/caching-set-code! hash-code OrType args)) equals ([this that] @@ -123,12 +129,16 @@ (udt/deftype AndType [^int ^:unsynchronized-mutable hash ^int ^:unsynchronized-mutable hash-code + meta #_(t/? ::meta) args #_(t/and t/indexed? (t/seq t/type?)) *logical-complement] {PType nil ?Fn {invoke ([_ x] (reduce (fn [_ t] (or (t x) (reduced false))) true ; vacuously args))} + ?Meta {meta ([this] meta) + with-meta ([this meta'] (AndType. hash hash-code meta' args + *logical-complement))} ?Hash {hash ([this] (uhash/caching-set-ordered! hash AndType args))} ?Object {hash-code ([this] (uhash/caching-set-code! hash-code AndType args)) equals ([this that] @@ -180,9 +190,9 @@ (udt/deftype ClassType [^int ^:unsynchronized-mutable hash ^int ^:unsynchronized-mutable hash-code - meta #_(t/? ::meta) - ^Class c #_t/class? - name #_(t/? t/symbol?)] + meta #_(t/? ::meta) + ^Class c #_t/class? + name #_(t/? t/symbol?)] {PType nil ?Fn {invoke ([_ x] (instance? c x))} ?Meta {meta ([this] meta) @@ -207,9 +217,12 @@ (udt/deftype ValueType [^int ^:unsynchronized-mutable hash ^int ^:unsynchronized-mutable hash-code + meta #_(t/? ::meta) v #_any?] {PType nil ?Fn {invoke ([_ x] (= x v))} + ?Meta {meta ([this] meta) + with-meta ([this meta'] (ValueType. hash hash-code meta' v))} ?Hash {hash ([this] (uhash/caching-set-ordered! hash ValueType v))} ?Object {hash-code ([this] (uhash/caching-set-code! hash-code ValueType v)) equals ([this that #_any?] @@ -227,13 +240,16 @@ ;; ----- FnType ----- ;; (udt/deftype FnType - [name arities-form + [meta #_(t/? ::meta) + name arities-form arities #_(s/map-of non-zero-int? (s/seq-of :quantum.untyped.core.type/fn-type|arity))] - {PType nil + {PType nil ;; Outputs whether the args match any input spec - ?Fn {invoke ([this args] (TODO))} + ?Fn {invoke ([this args] (TODO))} + ?Meta {meta ([this] meta) + with-meta ([this meta'] (FnType. meta' name arities-form arities))} fipp.ednize/IOverride nil - fipp.ednize/IEdn {-edn ([this] (list 'quantum.untyped.core.type/fn arities-form))}}) + fipp.ednize/IEdn {-edn ([this] (list 'quantum.untyped.core.type/fn arities-form))}}) (defns fn-type? [x _ > boolean?] (instance? FnType x)) From 13e906e0131695d516a00561511994af4b76f93f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 3 Sep 2018 01:18:34 -0600 Subject: [PATCH 217/810] Allow `fn-wide-and-overload-specific-post` in `defns` --- src-dev/quantum/core/defnt_equivalences.cljc | 3 ++- src-untyped/quantum/untyped/core/data/set.cljc | 2 +- src-untyped/quantum/untyped/core/defnt.cljc | 7 +++++-- src-untyped/quantum/untyped/core/type.cljc | 2 +- test/quantum/test/untyped/core/defnt.cljc | 6 ++++++ test/quantum/test/untyped/core/type/compare.cljc | 6 ++++-- 6 files changed, 19 insertions(+), 7 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 2a6e59c8..82839df8 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -1377,7 +1377,8 @@ ;; TODO use `t/assume` ([xs t/array? > (t/* #_t/assume (t/? (t/isa? ISeq)))] ;; We do this only because `clojure.lang.ArraySeq/createFromObject` is private but - ;; perhaps it would be wise from a performance perspective to fix that + ;; perhaps it would be wise from a performance perspective to bypass that with e.g. a fast + ;; version of reflection (clojure.core/seq xs)))) ) diff --git a/src-untyped/quantum/untyped/core/data/set.cljc b/src-untyped/quantum/untyped/core/data/set.cljc index 41d532d1..101b13ad 100644 --- a/src-untyped/quantum/untyped/core/data/set.cljc +++ b/src-untyped/quantum/untyped/core/data/set.cljc @@ -1,5 +1,5 @@ (ns quantum.untyped.core.data.set - (:refer-clojure :exclude [- +, not < <= >= >]) + (:refer-clojure :exclude [- +, not, compare < <= >= >]) (:require #?@(:clj [[seqspert.hash-set]]) diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index cd1dae15..fe9f48dd 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -128,8 +128,11 @@ #(mapv (fn [overload] (let [overload' (update overload :body :body)] (if-let [output-spec (-> fn-form :quantum.core.defnt/output-spec :spec)] - (do (us/assert-conform nil? (-> overload' :arglist :post)) - (assoc-in overload' [:arglist :post] output-spec)) + (update-in overload' [:arglist :post] + (fn [{overload-output-spec :spec}] + (if (some? overload-output-spec) + (list `us/and overload-output-spec output-spec) + output-spec))) overload'))) %)) (dissoc :quantum.core.defnt/output-spec))))) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 15f5b0d1..fa65af6b 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -435,7 +435,7 @@ (assert (-> simplified count (c/>= 1))) ; for internal implementation correctness (if (-> simplified count (c/= 1)) (first simplified) - (construct-fn uhash/default uhash/default simplified (atom nil)))))) + (construct-fn uhash/default uhash/default nil simplified (atom nil)))))) ;; TODO do this? #_(udt/deftype SequentialType) diff --git a/test/quantum/test/untyped/core/defnt.cljc b/test/quantum/test/untyped/core/defnt.cljc index 94188af5..4d0c61e7 100644 --- a/test/quantum/test/untyped/core/defnt.cljc +++ b/test/quantum/test/untyped/core/defnt.cljc @@ -56,6 +56,12 @@ (defspec-test test|gen|seq|1 `gen|seq|1) +(this/defns fn-wide-and-overload-specific-post + > number? + [> integer?] 123) + +(defspec-test test|fn-wide-and-overload-specific-post `fn-wide-and-overload-specific-post) + ;; TODO assert that the below 2 things are equivalent #_(this/defns abcde "Documentation" {:metadata "abc"} diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 2bf4314d..8b6480a6 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -147,9 +147,11 @@ "To generate all commutative possibilities for a given type." [t t/type? > (s/seq-of t/type?)] (ifs (t/and-type? t) (->> t utr/and-type>args ucombo/permutations - (map #(utr/->AndType uhash/default uhash/default (vec %) (atom nil)))) + (map #(utr/->AndType uhash/default uhash/default nil (vec %) + (atom nil)))) (t/or-type? t) (->> t utr/or-type>args ucombo/permutations - (map #(utr/->OrType uhash/default uhash/default (vec %) (atom nil)))) + (map #(utr/->OrType uhash/default uhash/default nil (vec %) + (atom nil)))) [t])) #?(:clj From 63dddc6d38d8faeecfed188d93e09c834dd3cdf4 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 3 Sep 2018 01:41:22 -0600 Subject: [PATCH 218/810] Cleaner way of handling `:quantum.core.defnt/output-spec` --- src-untyped/quantum/untyped/core/defnt.cljc | 20 ++++++++----------- .../quantum/untyped/core/type/defnt.cljc | 1 + 2 files changed, 9 insertions(+), 12 deletions(-) diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index fe9f48dd..39bd26e6 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -125,16 +125,8 @@ (fn [fn-form] (-> fn-form (update :quantum.core.defnt/overloads - #(mapv (fn [overload] - (let [overload' (update overload :body :body)] - (if-let [output-spec (-> fn-form :quantum.core.defnt/output-spec :spec)] - (update-in overload' [:arglist :post] - (fn [{overload-output-spec :spec}] - (if (some? overload-output-spec) - (list `us/and overload-output-spec output-spec) - output-spec))) - overload'))) %)) - (dissoc :quantum.core.defnt/output-spec))))) + #(mapv (fn [overload] (update overload :body :body)) %)) + (update :quantum.core.defnt/output-spec :spec))))) (s/def :quantum.core.defnt/fnt (s/and (s/spec @@ -340,9 +332,11 @@ (when (= kind :fn) (println "WARNING: `fn` will ignore spec validation")) (let [{:keys [:quantum.core.specs/fn|name :quantum.core.defnt/overloads + :quantum.core.defnt/output-spec :quantum.core.specs/meta] :as args'} (us/assert-conform (case kind (:defn :defn-) :quantum.core.defnt/defns|code :fn :quantum.core.defnt/fns|code) args) + [_ output-spec] output-spec ret-sym (gensym "ret") arity-kind-sym (gensym "arity-kind") args-sym (gensym "args") {:keys [overload-forms spec-form|args spec-form|fn]} (reduce @@ -368,8 +362,10 @@ spec-form|arglist) spec-form|fn* (if (contains? arglist :post) `(let [~kw-args ~args-sym] - (us/spec ~post)) - `(us/spec any?))] + (us/spec ~(if output-spec + `(us/and ~post ~output-spec) + post))) + (list `us/spec (or output-spec `any?)))] (-> ret (update :overload-forms conj overload-form) (update :spec-form|args conj arity-ident spec-form|args*) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index d9bc5bd6..a14c65c6 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -243,6 +243,7 @@ ;; TODO this becomes an issue when `post-type|form` references local bindings post-type (eval post-type|form) post-type|runtime? (-> post-type meta :runtime?) + _ (println "POST TYPE" post-type|runtime? post-type) out-type (if post-type (if post-type|runtime? (case (t/compare post-type (:type analyzed)) From a5ea00517a9b6f39f72099ce08398b42beccd2ff Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 3 Sep 2018 02:03:04 -0600 Subject: [PATCH 219/810] Using an overload-specific spec is now compatible with overall spec --- .../quantum/untyped/core/type/defnt.cljc | 29 ++++++++++++------- 1 file changed, 19 insertions(+), 10 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index a14c65c6..4da8b16a 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -154,12 +154,14 @@ :non-primitivized ::expanded-overload :primitivized (s/nilable (s/seq-of ::expanded-overload))})) -(s/def ::expanded-overload-groups|arg-types|split (s/vec-of (s/vec-of t/type?))) -(s/def ::expanded-overload-groups|pre-type|form t/any?) -(s/def ::expanded-overload-groups|post-type|form t/any?) +(s/def ::expanded-overload-groups|arg-types|split (s/vec-of (s/vec-of t/type?))) +(s/def ::expanded-overload-groups|output-type t/any?) +(s/def ::expanded-overload-groups|pre-type|form t/any?) +(s/def ::expanded-overload-groups|post-type|form t/any?) (s/def ::expanded-overload-groups (s/kv {:arg-types|pre-split|form ::expanded-overload-group|arg-types|form + :fnt-output-type ::expanded-overload-groups|fnt-output-type :pre-type|form ::expanded-overload-groups|pre-type|form :post-type|form ::expanded-overload-groups|post-type|form :arg-types|split ::expanded-overload-groups|arg-types|split @@ -224,7 +226,7 @@ using (in part) these pieces of data, but does not use the possibly-updated `arg-types` as computed in the analysis. As a result, does not yet support type inference." [{:keys [arg-bindings _, arg-classes ::expanded-overload|arg-classes - post-type|form _ + fnt-output-type _, post-type|form _ arg-types ::expanded-overload|arg-types, body-codelist|pre-analyze _, lang ::lang varargs _, varargs-binding _]} _ > ::expanded-overload] @@ -241,9 +243,13 @@ (c/count arg-bindings) varargs))) ;; TODO this becomes an issue when `post-type|form` references local bindings - post-type (eval post-type|form) + overload-specific-post-type (some-> post-type|form eval) + _ (when (and overload-specific-post-type + (not (t/<= overload-specific-post-type fnt-output-type))) + (err! (str "Overload's specified output type does not satisfy function's overall " + "specified output type"))) + post-type (or overload-specific-post-type fnt-output-type) post-type|runtime? (-> post-type meta :runtime?) - _ (println "POST TYPE" post-type|runtime? post-type) out-type (if post-type (if post-type|runtime? (case (t/compare post-type (:type analyzed)) @@ -314,7 +320,7 @@ pre-type|form [:pre _] [_ _, post-type|form _] [:post _]} [:arglist _] body-codelist|pre-analyze [:body _]} _ - {:as opts :keys [::lang ::lang, symbolic-analysis? t/boolean?]} _ + {:as opts :keys [::lang ::lang, symbolic-analysis? t/boolean?, fnt-output-type _]} _ > ::expanded-overload-groups] (if symbolic-analysis? (err! "Symbolic analysis not supported yet") @@ -350,8 +356,8 @@ (>expanded-overload-group (kw-map arg-bindings arg-types body-codelist|pre-analyze lang arg-types|pre-split|form pre-type|form post-type|form - varargs varargs-binding)))))] - (kw-map arg-types|pre-split|form pre-type|form post-type|form + fnt-output-type varargs varargs-binding)))))] + (kw-map arg-types|pre-split|form pre-type|form post-type|form fnt-output-type arg-types|split arg-types|recombined expanded-overload-group-seq))))) @@ -615,10 +621,12 @@ (defns fnt|code [kind #{:fn :defn}, lang ::lang, args _] (let [{:keys [:quantum.core.specs/fn|name :quantum.core.defnt/overloads + :quantum.core.defnt/output-spec :quantum.core.specs/meta] :as args'} (s/validate args (case kind :defn :quantum.core.defnt/defnt :fn :quantum.core.defnt/fnt)) symbolic-analysis? false ; TODO parameterize this + fnt-output-type (or (some-> output-spec second eval) t/any?) gen-gensym-base (ufgen/>reproducible-gensym|generator) gen-gensym (fn [x] (symbol (str (gen-gensym-base x) "__"))) inline? (s/validate (-> fn|name core/meta :inline) (t/? t/boolean?)) @@ -628,7 +636,8 @@ fn|name) expanded-overload-groups-by-fnt-overload (->> overloads (mapv #(fnt|overload-data>expanded-overload-groups % - {::lang lang :symbolic-analysis? symbolic-analysis?}))) + {::lang lang :symbolic-analysis? symbolic-analysis? + :fnt-output-type fnt-output-type}))) args (assoc (kw-map expanded-overload-groups-by-fnt-overload gen-gensym lang) ::uss/fn|name fn|name) {:as direct-dispatch :keys [i-overload->direct-dispatch-data]} (>direct-dispatch args) From 5f0b0fe58a4a617f4703e178f0a113786f971927 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 3 Sep 2018 02:30:29 -0600 Subject: [PATCH 220/810] Distribute `quantum.untyped.core.convert` --- .../quantum/untyped/core/analyze/expr.cljc | 5 +- src-untyped/quantum/untyped/core/convert.cljc | 101 -------------- src-untyped/quantum/untyped/core/data.cljc | 4 +- .../quantum/untyped/core/data/map.cljc | 5 +- src-untyped/quantum/untyped/core/defnt.cljc | 7 +- .../quantum/untyped/core/form/type_hint.cljc | 4 +- .../quantum/untyped/core/identification.cljc | 131 +++++++++++++++--- src-untyped/quantum/untyped/core/numeric.cljc | 12 +- .../quantum/untyped/core/print/prettier.cljc | 3 +- src-untyped/quantum/untyped/core/spec.cljc | 9 +- src-untyped/quantum/untyped/core/type.cljc | 4 +- .../quantum/untyped/core/type/core.cljc | 4 +- .../quantum/untyped/core/type/defnt.cljc | 5 +- .../quantum/untyped/ui/style/core.cljc | 4 +- src/quantum/core/convert.cljc | 62 ++++----- src/quantum/core/core.cljc | 7 +- src/quantum/core/macros/defnt.cljc | 7 +- src/quantum/db/datomic/core.cljc | 2 +- test/quantum/test/untyped/core/convert.cljc | 37 ----- .../test/untyped/core/identification.cljc | 37 +++++ 20 files changed, 221 insertions(+), 229 deletions(-) delete mode 100644 src-untyped/quantum/untyped/core/convert.cljc delete mode 100644 test/quantum/test/untyped/core/convert.cljc create mode 100644 test/quantum/test/untyped/core/identification.cljc diff --git a/src-untyped/quantum/untyped/core/analyze/expr.cljc b/src-untyped/quantum/untyped/core/analyze/expr.cljc index b9a6ecf8..c85477c3 100644 --- a/src-untyped/quantum/untyped/core/analyze/expr.cljc +++ b/src-untyped/quantum/untyped/core/analyze/expr.cljc @@ -11,14 +11,13 @@ :refer [seq-or]] [quantum.untyped.core.compare :refer [== not==]] - [quantum.untyped.core.convert :as uconv - :refer [>symbol]] [quantum.untyped.core.core :as ucore] [quantum.untyped.core.error :as uerr :refer [err! TODO]] [quantum.untyped.core.form :as uform :refer [>form]] - [quantum.untyped.core.identification :as uident] + [quantum.untyped.core.identification :as uident + :refer [>symbol]] [quantum.untyped.core.print :as upr] [quantum.untyped.core.reducers :as ur :refer [join]] diff --git a/src-untyped/quantum/untyped/core/convert.cljc b/src-untyped/quantum/untyped/core/convert.cljc deleted file mode 100644 index ea8fc0f8..00000000 --- a/src-untyped/quantum/untyped/core/convert.cljc +++ /dev/null @@ -1,101 +0,0 @@ -;; TODO break out these fns to their respective namespaces -(ns quantum.untyped.core.convert - (:require - [clojure.string :as str] - [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.error :as uerr] - [quantum.untyped.core.fn :as ufn] - [quantum.untyped.core.identification - :refer [#?(:cljs DelimitedIdent) delim-ident? named?]] - [quantum.untyped.core.ns - #?@(:clj [:refer [namespace?]])]) - #?(:clj (:import quantum.untyped.core.identification.DelimitedIdent))) - -(ucore/log-this-ns) - -(defn demunged>namespace [^String s] (subs s 0 (.lastIndexOf s "/"))) -(defn demunged>name [^String s] (subs s (inc (.lastIndexOf s "/")))) - -(defn >name - "Computes the name (the unqualified string identifier) of `x`." - [x] - (cond (named? x) (name x) - (string? x) x -#?@(:clj [(class? x) (.getName ^Class x) - (namespace? x) (-> x ns-name name) - (var? x) (-> x meta :name name)]) - (fn? x) #?(:clj (or (some-> (-> x meta :name) >name) - (-> x class .getName clojure.lang.Compiler/demunge demunged>name)) - :cljs (when-not (-> x .-name str/blank?) - (-> x .-name demunge-str demunged>name))) - :else (uerr/not-supported! `>name x))) - -(def >?name (ufn/? >name)) - -(defn >?namespace - "Computes the nilable namespace (the string identifier-qualifier) of `x`." - [x] - (cond (named? x) (namespace x) - (or (nil? x) - (string? x) - #?(:clj (class? x)) - #?(:clj (namespace? x))) nil -#?@(:clj [(var? x) (-> x meta :ns >name)]) - (fn? x) #?(:clj (or (some-> (-> x meta :ns) >name) - (-> x class .getName clojure.lang.Compiler/demunge demunged>namespace)) - :cljs (when-not (-> x .-name str/blank?) - (-> x .-name demunge-str demunged>namespace))) - :else (uerr/not-supported! `>?namespace x))) - -(defn >delim-ident - "Computes the delimited identifier of `x`." - [x] - (cond (delim-ident? x) x - (string? x) (-> x (str/split #"\.|\||/") (DelimitedIdent.)) - (named? x) (DelimitedIdent. - (concat (some-> (namespace x) (str/split #"\.|\||/")) - (-> x >name (str/split #"\.|\||/")))) -#?@(:clj [(class? x) (>delim-ident (.getName ^Class x)) - (namespace? x) (-> x >name >delim-ident) - (var? x) (DelimitedIdent. - (concat (-> x >?namespace (str/split #"\.|\||/")) - (-> x >name (str/split #"\.|\||/"))))]) - (fn? x) (DelimitedIdent. - #?(:clj (or (some-> (-> x meta :name) >name (str/split #"\.|\||/")) - (-> x class .getName clojure.lang.Compiler/demunge (str/split #"\.|\||/"))) - :cljs (if (-> x .-name str/blank?) - [""] - (-> x .-name demunge-str (str/split #"\.|\||/"))))) - (nil? x) (uerr/not-supported! `>delim-ident x) - :else (-> x str recur))) - -(defn >keyword [x] - (cond (keyword? x) x - (symbol? x) (keyword (>?namespace x) (>name x)) - :else (-> x str keyword))) - -(defn >symbol - "Converts `x` to a symbol (possibly qualified, meta-able identifier)." - [x] - (cond (symbol? x) x - (string? x) (symbol x) - (or (keyword? x) #?(:clj (var? x))) - (symbol (>?namespace x) (>name x)) -#?@(:clj [(class? x) (-> x >name symbol) - (namespace? x) (ns-name x)]) - (fn? x) #?(:clj (or (when-let [ns- (-> x meta :ns)] - (symbol (>name ns-) (-> x meta :name >name))) - (-> x class .getName clojure.lang.Compiler/demunge recur)) - :cljs (when-not (-> x .-name str/blank?) - (-> x .-name demunge-str recur))) - :else (-> x str recur))) - -(defn >integer [x] - (cond (integer? x) x - (string? x) #?(:clj (Long/parseLong ^String x) - :cljs (js/parseInt x)) - :else (uerr/not-supported! `>integer x))) - -(defn >uuid [] - #?(:clj (java.util.UUID/randomUUID) - :cljs (cljs.core/random-uuid))) diff --git a/src-untyped/quantum/untyped/core/data.cljc b/src-untyped/quantum/untyped/core/data.cljc index 2c2346b4..9d2a5219 100644 --- a/src-untyped/quantum/untyped/core/data.cljc +++ b/src-untyped/quantum/untyped/core/data.cljc @@ -2,10 +2,10 @@ (:refer-clojure :exclude [seqable?]) (:require - [quantum.untyped.core.convert :as uconv - :refer [>keyword]] [quantum.untyped.core.core :as ucore] [quantum.untyped.core.data.array :as uarr] + [quantum.untyped.core.identification + :refer [>keyword]] [quantum.untyped.core.vars :refer [defalias]])) diff --git a/src-untyped/quantum/untyped/core/data/map.cljc b/src-untyped/quantum/untyped/core/data/map.cljc index 913ff887..047e0d33 100644 --- a/src-untyped/quantum/untyped/core/data/map.cljc +++ b/src-untyped/quantum/untyped/core/data/map.cljc @@ -12,8 +12,9 @@ #?@(:clj [[clojure.data.int-map :as imap] [seqspert.hash-map]]) - [quantum.untyped.core.convert :as uconv] [quantum.untyped.core.data :as udata] + [quantum.untyped.core.identification + :refer [>keyword]] [quantum.untyped.core.reducers :as ur :refer [reduce-pair]] [quantum.untyped.core.vars @@ -326,7 +327,7 @@ (defmacro kw-omap "Like `kw-map`, but preserves insertion order." [& ks] - (list* `om (udata/quote-map-base uconv/>keyword ks)))) + (list* `om (udata/quote-map-base >keyword ks)))) ;; TODO generate these functions via macros (defn #?(:clj ^LinkedHashMap !ordered-map :cljs !ordered-map) diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index 39bd26e6..b836d57d 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -5,7 +5,6 @@ (:require [clojure.spec.alpha :as s] [clojure.spec.gen.alpha :as gen] - [quantum.untyped.core.convert :as uconv] [quantum.untyped.core.core :refer [any?]] [quantum.untyped.core.data @@ -14,7 +13,7 @@ :refer [om]] [quantum.untyped.core.form.evaluate :as ufeval] [quantum.untyped.core.identification - :refer [ident? qualified-keyword? simple-symbol?]] + :refer [>keyword ident? qualified-keyword? simple-symbol?]] [quantum.untyped.core.loops :refer [reduce-2]] [quantum.untyped.core.reducers :as ur] @@ -264,7 +263,7 @@ (defn speced-binding>arg-ident [{[kind binding-] :binding-form} #_:quantum.core.defnt/speced-binding & [i|arg] #_(? nneg-integer?)] - (uconv/>keyword + (>keyword (case kind :sym binding- (:seq :map) @@ -290,7 +289,7 @@ (defn- keys||strs||syms>key-specs [kind #_#{:keys :strs :syms} speced-bindings] (let [binding-form>key - (case kind :keys uconv/>keyword :strs name :syms identity)] + (case kind :keys >keyword :strs name :syms identity)] (->> speced-bindings (filter (fn [{[spec-kind _] :spec}] (= spec-kind :spec))) (map (fn [{:keys [binding-form #_symbol?] [_ spec] :spec}] diff --git a/src-untyped/quantum/untyped/core/form/type_hint.cljc b/src-untyped/quantum/untyped/core/form/type_hint.cljc index e25cb8ba..9c8f83b8 100644 --- a/src-untyped/quantum/untyped/core/form/type_hint.cljc +++ b/src-untyped/quantum/untyped/core/form/type_hint.cljc @@ -1,10 +1,10 @@ (ns quantum.untyped.core.form.type-hint (:require [quantum.untyped.core.collections :as uc] - [quantum.untyped.core.convert - :refer [>name]] [quantum.untyped.core.error :refer [err!]] + [quantum.untyped.core.identification + :refer [>name]] [quantum.untyped.core.logic :refer [ifs]] [quantum.untyped.core.loops diff --git a/src-untyped/quantum/untyped/core/identification.cljc b/src-untyped/quantum/untyped/core/identification.cljc index 0af6506f..ba7b9110 100644 --- a/src-untyped/quantum/untyped/core/identification.cljc +++ b/src-untyped/quantum/untyped/core/identification.cljc @@ -4,36 +4,28 @@ (:refer-clojure :exclude [ident? qualified-keyword? simple-symbol?]) (:require - [clojure.core :as core] -#?(:clj [clojure.future :as fcore]) - [clojure.string :as str] + [clojure.core :as core] +#?(:clj [clojure.future :as fcore]) + [clojure.string :as str] [fipp.ednize] - [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.ns :as uns - #?@(:clj [:refer [namespace?]])] + [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.error :as uerr] + [quantum.untyped.core.fn :as ufn] + [quantum.untyped.core.ns :as uns +#?@(:clj [:refer [namespace?]])] [quantum.untyped.core.vars :refer [defalias]])) (ucore/log-this-ns) +;; ===== Nameability ===== ;; + (defn named? [x] #?(:clj (instance? clojure.lang.Named x) :cljs (implements? cljs.core/INamed x))) -#?(:clj (eval `(defalias ~(if (resolve `fcore/ident?) - `fcore/ident? - `core/ident?))) - :cljs (defalias core/ident?)) - -#?(:clj (eval `(defalias ~(if (resolve `fcore/qualified-keyword?) - `fcore/qualified-keyword? - `core/qualified-keyword?))) - :cljs (defalias core/qualified-keyword?)) - -#?(:clj (eval `(defalias ~(if (resolve `fcore/simple-symbol?) - `fcore/simple-symbol? - `core/simple-symbol?))) - :cljs (defalias core/simple-symbol?)) +(defn demunged>namespace [^String s] (subs s 0 (.lastIndexOf s "/"))) +(defn demunged>name [^String s] (subs s (inc (.lastIndexOf s "/")))) (defn ?ns->name [?ns] (name #?(:clj (if (namespace? ?ns) @@ -41,6 +33,37 @@ ?ns) :cljs ?ns))) +(defn >name + "Computes the name (the unqualified string identifier) of `x`." + [x] + (cond (named? x) (name x) + (string? x) x +#?@(:clj [(class? x) (.getName ^Class x) + (namespace? x) (-> x ns-name name) + (var? x) (-> x meta :name name)]) + (fn? x) #?(:clj (or (some-> (-> x meta :name) >name) + (-> x class .getName clojure.lang.Compiler/demunge demunged>name)) + :cljs (when-not (-> x .-name str/blank?) + (-> x .-name demunge-str demunged>name))) + :else (uerr/not-supported! `>name x))) + +(def >?name (ufn/? >name)) + +(defn >?namespace + "Computes the nilable namespace (the string identifier-qualifier) of `x`." + [x] + (cond (named? x) (namespace x) + (or (nil? x) + (string? x) + #?(:clj (class? x)) + #?(:clj (namespace? x))) nil +#?@(:clj [(var? x) (-> x meta :ns >name)]) + (fn? x) #?(:clj (or (some-> (-> x meta :ns) >name) + (-> x class .getName clojure.lang.Compiler/demunge demunged>namespace)) + :cljs (when-not (-> x .-name str/blank?) + (-> x .-name demunge-str demunged>namespace))) + :else (uerr/not-supported! `>?namespace x))) + ;; ===== Qualification ===== ;; (defn qualify @@ -65,7 +88,51 @@ (str alias- (when extra-slash? "/")) n))) (name sym))))) -;; ===== Idents ===== ;; +;; ===== Standard identifiers ===== ;; + +#?(:clj (eval `(defalias ~(if (resolve `fcore/qualified-keyword?) + `fcore/qualified-keyword? + `core/qualified-keyword?))) + :cljs (defalias core/qualified-keyword?)) + +(defn >keyword [x] + (cond (keyword? x) x + (symbol? x) (keyword (>?namespace x) (>name x)) + :else (-> x str keyword))) + +#?(:clj (eval `(defalias ~(if (resolve `fcore/simple-symbol?) + `fcore/simple-symbol? + `core/simple-symbol?))) + :cljs (defalias core/simple-symbol?)) + +(defn >symbol + "Converts `x` to a symbol (possibly qualified, meta-able identifier)." + [x] + (cond (symbol? x) x + (string? x) (symbol x) + (or (keyword? x) #?(:clj (var? x))) + (symbol (>?namespace x) (>name x)) +#?@(:clj [(class? x) (-> x >name symbol) + (namespace? x) (ns-name x)]) + (fn? x) #?(:clj (or (when-let [ns- (-> x meta :ns)] + (symbol (>name ns-) (-> x meta :name >name))) + (-> x class .getName clojure.lang.Compiler/demunge recur)) + :cljs (when-not (-> x .-name str/blank?) + (-> x .-name demunge-str recur))) + :else (-> x str recur))) + +#?(:clj (eval `(defalias ~(if (resolve `fcore/ident?) + `fcore/ident? + `core/ident?))) + :cljs (defalias core/ident?)) + +;; ===== UUIDs ===== ;; + +(defn >uuid [] + #?(:clj (java.util.UUID/randomUUID) + :cljs (cljs.core/random-uuid))) + +;; ===== Delimited identifiers ===== ;; (defrecord ^{:doc "A delimited identifier. @@ -76,3 +143,25 @@ (-edn [this] (tagged-literal '| (symbol (str/join "|" qualifiers))))) (defn delim-ident? [x] (instance? DelimitedIdent x)) + +(defn >delim-ident + "Computes the delimited identifier of `x`." + [x] + (cond (delim-ident? x) x + (string? x) (-> x (str/split #"\.|\||/") (DelimitedIdent.)) + (named? x) (DelimitedIdent. + (concat (some-> (namespace x) (str/split #"\.|\||/")) + (-> x >name (str/split #"\.|\||/")))) +#?@(:clj [(class? x) (>delim-ident (.getName ^Class x)) + (namespace? x) (-> x >name >delim-ident) + (var? x) (DelimitedIdent. + (concat (-> x >?namespace (str/split #"\.|\||/")) + (-> x >name (str/split #"\.|\||/"))))]) + (fn? x) (DelimitedIdent. + #?(:clj (or (some-> (-> x meta :name) >name (str/split #"\.|\||/")) + (-> x class .getName clojure.lang.Compiler/demunge (str/split #"\.|\||/"))) + :cljs (if (-> x .-name str/blank?) + [""] + (-> x .-name demunge-str (str/split #"\.|\||/"))))) + (nil? x) (uerr/not-supported! `>delim-ident x) + :else (-> x str recur))) diff --git a/src-untyped/quantum/untyped/core/numeric.cljc b/src-untyped/quantum/untyped/core/numeric.cljc index 66ec6dfc..d2a225e5 100644 --- a/src-untyped/quantum/untyped/core/numeric.cljc +++ b/src-untyped/quantum/untyped/core/numeric.cljc @@ -3,9 +3,9 @@ [pos-int?]) (:require [clojure.core :as core] - #?(:clj [clojure.future :as fcore]) + #?(:clj [clojure.future :as fcore]) [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.error :as err] + [quantum.untyped.core.error :as uerr] [quantum.untyped.core.vars :refer [defalias]]) #?(:clj (:import java.lang.Math java.math.BigDecimal))) @@ -35,7 +35,13 @@ false] :cljs [(number? x) (js/Number.isInteger x)]) - :else (err/not-supported! `integer-value? x))) + :else (uerr/not-supported! `integer-value? x))) + +(defn >integer [x] + (cond (integer? x) x + (string? x) #?(:clj (Long/parseLong ^String x) + :cljs (js/parseInt x)) + :else (uerr/not-supported! `>integer x))) (defn signum|long [^long x] diff --git a/src-untyped/quantum/untyped/core/print/prettier.cljc b/src-untyped/quantum/untyped/core/print/prettier.cljc index 5c3059b5..88437395 100644 --- a/src-untyped/quantum/untyped/core/print/prettier.cljc +++ b/src-untyped/quantum/untyped/core/print/prettier.cljc @@ -3,7 +3,6 @@ [fipp.edn] [fipp.visit] [fipp.ednize] - [quantum.untyped.core.convert] [quantum.untyped.core.fn :refer [rcomp]] [quantum.untyped.core.ns] @@ -57,7 +56,7 @@ #?(:clj (defn visit-fn [visitor x] - [:group "#" "fn" " " (-> x quantum.untyped.core.convert/>symbol visit-symbol*)])) + [:group "#" "fn" " " (-> x quantum.untyped.core.identification/>symbol visit-symbol*)])) #?(:clj (defn visit* diff --git a/src-untyped/quantum/untyped/core/spec.cljc b/src-untyped/quantum/untyped/core/spec.cljc index eb62e375..e080d4ee 100644 --- a/src-untyped/quantum/untyped/core/spec.cljc +++ b/src-untyped/quantum/untyped/core/spec.cljc @@ -9,7 +9,6 @@ [cljs.spec.alpha] [clojure.spec.gen.alpha :as gen] [fipp.ednize] - [quantum.untyped.core.convert :as uconv] [quantum.untyped.core.data :as udata] [quantum.untyped.core.error :refer [catch-all err! TODO]] @@ -18,7 +17,7 @@ [quantum.untyped.core.form.evaluate :as ufeval :refer [case-env]] [quantum.untyped.core.identification :as uident - :refer [ident?]] + :refer [>keyword ident?]] [quantum.untyped.core.vars :refer [defalias defmalias]]) #?(:cljs @@ -145,10 +144,12 @@ (defalias s/with-gen) #?(:clj (quantum.untyped.core.vars/defmalias cat clojure.spec.alpha/cat cljs.spec.alpha/cat)) -#?(:clj (defmacro cat* "`or` :`or*` :: `cat` : `cat*`" [& args] `(cat ~@(udata/quote-map-base uconv/>keyword args true)))) +#?(:clj (defmacro cat* "`or` :`or*` :: `cat` : `cat*`" [& args] + `(cat ~@(udata/quote-map-base >keyword args true)))) #?(:clj (quantum.untyped.core.vars/defmalias alt clojure.spec.alpha/alt cljs.spec.alpha/alt)) -#?(:clj (defmacro alt* "`or` :`or*` :: `alt` : `alt*`" [& args] `(alt ~@(udata/quote-map-base uconv/>keyword args true)))) +#?(:clj (defmacro alt* "`or` :`or*` :: `alt` : `alt*`" [& args] + `(alt ~@(udata/quote-map-base >keyword args true)))) #?(:clj (defmacro fdef! [sym & args] diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index fa65af6b..af1ec785 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -26,8 +26,6 @@ :refer [seq-and seq-or]] [quantum.untyped.core.compare :as ucomp :refer [== ident >ident]] - [quantum.untyped.core.convert - :refer [>symbol]] [quantum.untyped.core.core :as ucore] [quantum.untyped.core.data.bits :as ubit] [quantum.untyped.core.data.hash :as uhash] @@ -42,6 +40,8 @@ [quantum.untyped.core.fn :as ufn :refer [fn1 rcomp <- fn->]] [quantum.untyped.core.form.generate.deftype :as udt] + [quantum.untyped.core.identification + :refer [>symbol]] [quantum.untyped.core.logic :refer [fn-and ifs whenp->]] [quantum.untyped.core.numeric :as unum] diff --git a/src-untyped/quantum/untyped/core/type/core.cljc b/src-untyped/quantum/untyped/core/type/core.cljc index 22d1ff79..96ad7c6f 100644 --- a/src-untyped/quantum/untyped/core/type/core.cljc +++ b/src-untyped/quantum/untyped/core/type/core.cljc @@ -10,13 +10,13 @@ [clojure.tools.analyzer.jvm.utils :as ana]] :cljs [[cljs.core.async.impl.channels]]) - [quantum.untyped.core.convert :as uconv - :refer [>name]] [quantum.untyped.core.core :as ucore] [quantum.untyped.core.error :refer [>ex-info]] [quantum.untyped.core.fn :refer [<- fn->>]] + [quantum.untyped.core.identification + :refer [>name]] [quantum.untyped.core.vars :refer [defalias]] [quantum.untyped.core.type.defs :as utdef])) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 4da8b16a..2fed8c2e 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -14,8 +14,6 @@ :refer [defns defns- fns]] [quantum.untyped.core.collections :as c :refer [>set >vec]] - [quantum.untyped.core.convert - :refer [>name >symbol]] [quantum.untyped.core.data :refer [kw-map]] [quantum.untyped.core.data.array :as uarr] @@ -30,7 +28,8 @@ [quantum.untyped.core.form.evaluate :as ufeval] [quantum.untyped.core.form.generate :as ufgen] [quantum.untyped.core.form.type-hint :as ufth] - [quantum.untyped.core.identification :as uident] + [quantum.untyped.core.identification :as uident + :refer [>name >symbol]] [quantum.untyped.core.log :as ulog] [quantum.untyped.core.logic :as ul :refer [fn-or fn= ifs]] diff --git a/src-untyped/quantum/untyped/ui/style/core.cljc b/src-untyped/quantum/untyped/ui/style/core.cljc index 485adfe9..63945eee 100644 --- a/src-untyped/quantum/untyped/ui/style/core.cljc +++ b/src-untyped/quantum/untyped/ui/style/core.cljc @@ -4,9 +4,9 @@ (:require [clojure.string :as str] [quantum.untyped.core.collections :as uc] - [quantum.untyped.core.convert - :refer [>?name]] [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.identification + :refer [>?name]] [quantum.untyped.core.system :as usys])) (ucore/log-this-ns) diff --git a/src/quantum/core/convert.cljc b/src/quantum/core/convert.cljc index 291309c7..94a0d373 100644 --- a/src/quantum/core/convert.cljc +++ b/src/quantum/core/convert.cljc @@ -1,48 +1,48 @@ (ns quantum.core.convert ; perhaps coerce? (:require - [clojure.core :as core] - [cognitect.transit :as t] + [clojure.core :as core] + [cognitect.transit :as t] #?@(:clj [[clojure.tools.emitter.jvm] - [clojure.java.io :as io] - [manifold.stream :as s] - [manifold.deferred :as d] - [byte-streams :as streams] - [byte-streams.graph :as g] - [byte-streams.protocols :as proto] - [byte-streams.pushback-stream :as ps] - [byte-streams.char-sequence :as cs]] + [clojure.java.io :as io] + [manifold.stream :as s] + [manifold.deferred :as d] + [byte-streams :as streams] + [byte-streams.graph :as g] + [byte-streams.protocols :as proto] + [byte-streams.pushback-stream :as ps] + [byte-streams.char-sequence :as cs]] :cljs - [[cljs.reader :as core-r] - [goog.crypt.base64 :as base64]]) - [clojure.tools.reader :as r] - [clojure.tools.reader.edn :as r-edn] - [clojure.core.async :as async] - [datascript.transit :as dt] + [[cljs.reader :as core-r] + [goog.crypt.base64 :as base64]]) + [clojure.tools.reader :as r] + [clojure.tools.reader.edn :as r-edn] + [clojure.core.async :as async] + [datascript.transit :as dt] ; CompilerException java.lang.NoClassDefFoundError: IllegalName: compile__stub.gloss.data.bytes.core.gloss.data.bytes.core/MultiBufferSequence, compiling:(gloss/data/bytes/core.clj:78:1) ; [gloss.core.formats :as gforms] - [quantum.core.data.array :as arr] - [quantum.core.error :as err + [quantum.core.data.array :as arr] + [quantum.core.error :as err :refer [TODO]] - [quantum.core.numeric :as num] - [quantum.core.string :as str] + [quantum.core.numeric :as num] + [quantum.core.string :as str] [quantum.core.collections.core :refer [lasti]] - [quantum.core.convert.core :as conv] - [quantum.core.convert.primitive :as pconv] - [quantum.core.data.complex.json :as json] - [quantum.core.macros :as macros + [quantum.core.convert.core :as conv] + [quantum.core.convert.primitive :as pconv] + [quantum.core.data.complex.json :as json] + [quantum.core.macros :as macros :refer [defnt #?(:clj defnt')]] - [quantum.core.paths :as path] - [quantum.core.fn :as fn] - [quantum.core.vars :as var + [quantum.core.paths :as path] + [quantum.core.fn :as fn] + [quantum.core.vars :as var :refer [defalias defaliases]] - [quantum.core.log :as log] - [quantum.untyped.core.convert :as u] + [quantum.core.log :as log] [quantum.untyped.core.form.evaluate :refer [case-env]] [quantum.untyped.core.form.type-hint - :refer [static-cast]]) + :refer [static-cast]] + [quantum.untyped.core.identification :as uident]) #?(:cljs (:require-macros [quantum.core.convert :as self])) @@ -291,7 +291,7 @@ in protocol __GT_uuidProtocol must take at least one arg'" [& args] (if (empty? args) - `(u/>uuid) + `(uident/>uuid) `(->uuid* ~@args)))) #?(:clj (defalias ->file path/->file)) diff --git a/src/quantum/core/core.cljc b/src/quantum/core/core.cljc index a970fe99..3c69a4e5 100644 --- a/src/quantum/core/core.cljc +++ b/src/quantum/core/core.cljc @@ -8,7 +8,7 @@ #?(:clj [environ.core :as env]) ;; TODO TYPED move to quantum.core.type #_[quantum.core.type :as t - :refer [defnt defmacrot defprotocolt deft]] + :refer [declare-fnt defnt defmacrot deft]] [quantum.untyped.core.core :as u] [quantum.untyped.core.defnt :refer [defnt]] @@ -52,9 +52,8 @@ (get [this]) (set [this newv])) -#_(defprotocolt IValue - (get [this _]) - (set [this _, newv _])) +#_(do (declare-fnt get [this _]) + (declare-fnt set [this _, newv _])) ;; TODO TYPED ;; TODO move? diff --git a/src/quantum/core/macros/defnt.cljc b/src/quantum/core/macros/defnt.cljc index 60000cc1..4d181e68 100644 --- a/src/quantum/core/macros/defnt.cljc +++ b/src/quantum/core/macros/defnt.cljc @@ -35,14 +35,15 @@ [quantum.untyped.core.collections :as ucoll :refer [contains? merge-call update-first update-val]] [quantum.untyped.core.collections.tree :as utree] - [quantum.untyped.core.convert :as uconv - :refer [>integer >name]] [quantum.untyped.core.data :refer [kw-map val?]] [quantum.untyped.core.form.evaluate :refer [case-env case-env*]] [quantum.untyped.core.form.type-hint :as ufth] - [quantum.untyped.core.identification :as uident] + [quantum.untyped.core.identification :as uident + :refer [>name]] + [quantum.untyped.core.numeric + :refer [>integer]] [quantum.untyped.core.numeric.combinatorics :as combo] [quantum.untyped.core.reducers :refer [reducei] :as ured] diff --git a/src/quantum/db/datomic/core.cljc b/src/quantum/db/datomic/core.cljc index 0510dc74..3c6ee795 100644 --- a/src/quantum/db/datomic/core.cljc +++ b/src/quantum/db/datomic/core.cljc @@ -36,7 +36,7 @@ [quantum.core.spec :as s :refer [validate]] [quantum.core.type :as t] - [quantum.untyped.core.convert + [quantum.untyped.core.identification :refer [>?name]]) #?(:clj (:import diff --git a/test/quantum/test/untyped/core/convert.cljc b/test/quantum/test/untyped/core/convert.cljc deleted file mode 100644 index 230112c5..00000000 --- a/test/quantum/test/untyped/core/convert.cljc +++ /dev/null @@ -1,37 +0,0 @@ -(ns quantum.test.untyped.core.convert - (:require - [quantum.core.test :as test - :refer [deftest testing is is= throws]] - [quantum.untyped.core.convert :as this] - [quantum.untyped.core.identification - #?@(:cljs [:refer [Ident]])]) - #?(:clj (:import quantum.untyped.core.identification.Ident))) - -(deftest test|>ident - (is= (this/>ident "a|b|c|d") (Ident. ["a" "b" "c" "d"])) - - (is= (this/>ident String) (Ident. ["java" "lang" "String"])) - - (testing "Symbol" - (is= (this/>ident 'a) (Ident. ["a"])) - (is= (this/>ident 'a/b) (Ident. ["a" "b"])) - (is= (this/>ident 'a|b/c) (Ident. ["a" "b" "c"])) - (is= (this/>ident 'a|b|c) (Ident. ["a" "b" "c"])) - (is= (this/>ident 'a/b|c) (Ident. ["a" "b" "c"])) - (is= (this/>ident 'a|b/c|d) (Ident. ["a" "b" "c" "d"])) - (is= (this/>ident 'a.b/c.d) (Ident. ["a" "b" "c" "d"]))) - - (testing "Keyword" - (is= (this/>ident :a) (Ident. ["a"])) - (is= (this/>ident :a/b) (Ident. ["a" "b"])) - (is= (this/>ident :a|b/c) (Ident. ["a" "b" "c"])) - (is= (this/>ident :a|b|c) (Ident. ["a" "b" "c"])) - (is= (this/>ident :a/b|c) (Ident. ["a" "b" "c"])) - (is= (this/>ident :a|b/c|d) (Ident. ["a" "b" "c" "d"])) - (is= (this/>ident :a.b/c.d) (Ident. ["a" "b" "c" "d"]))) - - (is= (this/>ident (find-ns 'quantum.core.test)) (Ident. ["quantum" "core" "test"])) - - (is= (this/>ident #'count) (Ident. ["clojure" "core" "count"])) - - (is= (this/>ident count) (Ident. ["clojure" "core" "count"]))) diff --git a/test/quantum/test/untyped/core/identification.cljc b/test/quantum/test/untyped/core/identification.cljc new file mode 100644 index 00000000..e10c0286 --- /dev/null +++ b/test/quantum/test/untyped/core/identification.cljc @@ -0,0 +1,37 @@ +(ns quantum.test.untyped.core.identification + (:require + [quantum.untyped.core.identification :as this + #?@(:cljs [:refer [DelimitedIdent]])] + [quantum.untyped.core.test :as test + :refer [deftest testing is is= throws]]) + #?(:clj (:import quantum.untyped.core.identification.DelimitedIdent))) + +(deftest test|>ident + (is= (this/>delim-ident "a|b|c|d") (DelimitedIdent. ["a" "b" "c" "d"])) + + (is= (this/>delim-ident String) (DelimitedIdent. ["java" "lang" "String"])) + + (testing "Symbol" + (is= (this/>delim-ident 'a) (DelimitedIdent. ["a"])) + (is= (this/>delim-ident 'a/b) (DelimitedIdent. ["a" "b"])) + (is= (this/>delim-ident 'a|b/c) (DelimitedIdent. ["a" "b" "c"])) + (is= (this/>delim-ident 'a|b|c) (DelimitedIdent. ["a" "b" "c"])) + (is= (this/>delim-ident 'a/b|c) (DelimitedIdent. ["a" "b" "c"])) + (is= (this/>delim-ident 'a|b/c|d) (DelimitedIdent. ["a" "b" "c" "d"])) + (is= (this/>delim-ident 'a.b/c.d) (DelimitedIdent. ["a" "b" "c" "d"]))) + + (testing "Keyword" + (is= (this/>delim-ident :a) (DelimitedIdent. ["a"])) + (is= (this/>delim-ident :a/b) (DelimitedIdent. ["a" "b"])) + (is= (this/>delim-ident :a|b/c) (DelimitedIdent. ["a" "b" "c"])) + (is= (this/>delim-ident :a|b|c) (DelimitedIdent. ["a" "b" "c"])) + (is= (this/>delim-ident :a/b|c) (DelimitedIdent. ["a" "b" "c"])) + (is= (this/>delim-ident :a|b/c|d) (DelimitedIdent. ["a" "b" "c" "d"])) + (is= (this/>delim-ident :a.b/c.d) (DelimitedIdent. ["a" "b" "c" "d"]))) + + (is= (this/>delim-ident (find-ns 'quantum.untyped.core.test)) + (DelimitedIdent. ["quantum" "untyped" "core" "test"])) + (is= (this/>delim-ident #'count) + (DelimitedIdent. ["clojure" "core" "count"])) + (is= (this/>delim-ident count) + (DelimitedIdent. ["clojure" "core" "count"]))) From 282f0f6d80783bffc36778d0477c5255bbb64f1b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 3 Sep 2018 02:30:37 -0600 Subject: [PATCH 221/810] Update notes/todos --- resources-dev/defnt.cljc | 43 ++++++++++++++++++++++++++++++++-------- 1 file changed, 35 insertions(+), 8 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index c5806356..70bfd3a7 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -1,16 +1,43 @@ #_" -LEFT OFF LAST TIME (7/25/2018): -- handle calling of other `fnt`s from `fnt`s - - `(defnt >long ...)` : enable to refer to `>long*` and have that analyzed - - finish `>long` example - - quantum.core.data.map -- expressions (`quantum.untyped.core.analyze.expr`) -- `t/fn` -- handle `defnt` varargs +Note that `;; TODO TYPED` is the annotation we're using + +- TODO implement the following: + - t/... + - t/assume + - expressions (`quantum.untyped.core.analyze.expr`) + - deft + - fnt + - declare-fnt (a way to do protocols/interfaces) + - defnt + - recursion by adding the function's name and type to the local bindings (env) + - handle varargs + - defmacrot + - dotyped +- NOTE on namespace organization: + - [quantum.untyped.core.ns :refer [namespace?]] + instead of + [quantum.untyped.core.type.predicates :refer [namespace?]] + because not all predicates (type-related or otherwise) can be thought of ahead of time to be put + in one giant namespace + - Same with the `core.convert` namespace too + - Conversion functions belong in the namespace that their destination types belong in +- TODO transition the quantum.core.* namespaces: + - List of semi-approximately topologically ordered namespaces to make typed: + - quantum.core.core + - quantum.core.type.core + - quantum.core.ns + - quantum.core.logic + - quantum.core.fn + - quantum.core.data.map + - quantum.core.type + - quantum.core.vars + +LEFT OFF LAST TIME (7/25/2018): + - With `defnt`, protocols and interfaces aren't needed. You can just create `t/fn`s that you can then conform your fns to. - `dotyped`, `defnt`, and `fnt` create typed contexts in which their internal forms are analyzed From c1694ebb67212dc1965f3c13bb2c41fc3416232e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 3 Sep 2018 09:22:56 -0600 Subject: [PATCH 222/810] Set up recursion support --- .../quantum/untyped/core/type/defnt.cljc | 26 +++++++++++-------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 2fed8c2e..10269a68 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -224,14 +224,16 @@ "Is given `arg-classes` and `arg-types`. In order to determine the out-type, performs an analysis using (in part) these pieces of data, but does not use the possibly-updated `arg-types` as computed in the analysis. As a result, does not yet support type inference." - [{:keys [arg-bindings _, arg-classes ::expanded-overload|arg-classes - fnt-output-type _, post-type|form _ + [{:keys [fn|name _, arg-bindings _, arg-classes ::expanded-overload|arg-classes + fnt|output-type _, post-type|form _ arg-types ::expanded-overload|arg-types, body-codelist|pre-analyze _, lang ::lang varargs _, varargs-binding _]} _ > ::expanded-overload] (let [env (->> (zipmap arg-bindings arg-types) (c/map' (fn [[arg-binding arg-type]] - [arg-binding (uast/unbound nil arg-binding arg-type)]))) + [arg-binding (uast/unbound nil arg-binding arg-type)])) + ;; To support recursion + (<- (assoc fn|name fnt|type))) analyzed (uana/analyze env (ufgen/?wrap-do body-codelist|pre-analyze)) arg-classes|simplest (->> arg-classes (c/map class>simplest-class)) hint-arg|fn (fn [i arg-binding] @@ -244,10 +246,10 @@ ;; TODO this becomes an issue when `post-type|form` references local bindings overload-specific-post-type (some-> post-type|form eval) _ (when (and overload-specific-post-type - (not (t/<= overload-specific-post-type fnt-output-type))) + (not (t/<= overload-specific-post-type fnt|output-type))) (err! (str "Overload's specified output type does not satisfy function's overall " "specified output type"))) - post-type (or overload-specific-post-type fnt-output-type) + post-type (or overload-specific-post-type fnt|output-type) post-type|runtime? (-> post-type meta :runtime?) out-type (if post-type (if post-type|runtime? @@ -319,7 +321,8 @@ pre-type|form [:pre _] [_ _, post-type|form _] [:post _]} [:arglist _] body-codelist|pre-analyze [:body _]} _ - {:as opts :keys [::lang ::lang, symbolic-analysis? t/boolean?, fnt-output-type _]} _ + fn|name _, fnt|output-type _ + {:as opts :keys [::lang ::lang, symbolic-analysis? t/boolean?]} _ > ::expanded-overload-groups] (if symbolic-analysis? (err! "Symbolic analysis not supported yet") @@ -353,10 +356,10 @@ (->> arg-types|recombined (mapv (fn [arg-types] (>expanded-overload-group - (kw-map arg-bindings arg-types body-codelist|pre-analyze lang + (kw-map fn|name arg-bindings arg-types body-codelist|pre-analyze lang arg-types|pre-split|form pre-type|form post-type|form - fnt-output-type varargs varargs-binding)))))] - (kw-map arg-types|pre-split|form pre-type|form post-type|form fnt-output-type + fnt|output-type varargs varargs-binding)))))] + (kw-map arg-types|pre-split|form pre-type|form post-type|form fnt|output-type arg-types|split arg-types|recombined expanded-overload-group-seq))))) @@ -635,8 +638,9 @@ fn|name) expanded-overload-groups-by-fnt-overload (->> overloads (mapv #(fnt|overload-data>expanded-overload-groups % - {::lang lang :symbolic-analysis? symbolic-analysis? - :fnt-output-type fnt-output-type}))) + fn|name + fnt-output-type + {::lang lang :symbolic-analysis? symbolic-analysis?}))) args (assoc (kw-map expanded-overload-groups-by-fnt-overload gen-gensym lang) ::uss/fn|name fn|name) {:as direct-dispatch :keys [i-overload->direct-dispatch-data]} (>direct-dispatch args) From 6a7e8742661d805e1054942f0a5b667207da852c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 5 Sep 2018 00:34:44 -0600 Subject: [PATCH 223/810] Reorganize/clean up so many things in defnt namespace --- src-dev/quantum/core/defnt_equivalences.cljc | 2 +- src-untyped/quantum/untyped/core/defnt.cljc | 3 +- src-untyped/quantum/untyped/core/type.cljc | 4 +- .../quantum/untyped/core/type/defnt.cljc | 230 ++++++++++-------- .../untyped/core/type/reifications.cljc | 18 +- 5 files changed, 146 insertions(+), 111 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 82839df8..8540173e 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -46,7 +46,7 @@ ~'(->> (java.lang.management.ManagementFactory/getRuntimeMXBean) (.getName))))) (defn ~'pid|test - {::t/type (t/fn ~'[:> (? t/string?)])} + {::t/type (t/fn t/any? ~'[:> (? t/string?)])} ([] (.invoke ~(tag (str `>Object) 'pid|test|__0|0))))))] (testing "code equivalence" (is-code= actual expected)) diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index b836d57d..d4aab243 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -99,7 +99,8 @@ :spec (s/or :any-spec #{'_} :spec any?))) :post :quantum.core.defnt/output-spec)) (s/conformer - #(cond-> % (contains? % :varargs) (update :varargs :speced-binding) + #(cond-> % (nil? (:args %)) (assoc :args []) + (contains? % :varargs) (update :varargs :speced-binding) (contains? % :pre ) (update :pre :spec) (contains? % :post ) (update :post :spec))) (fn [{:keys [args varargs]}] diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index af1ec785..cb88dd83 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -444,13 +444,13 @@ "Creates a type that ... TODO" [pred (<= iterable?), t utr/type?] (TODO)) -(defn fn [arity & arities] ; TODO fix — & args should have been sufficient but `defnt` has a bug that way +(defn fn [out-type arity & arities] (let [name- nil arities-form (cons arity arities) arities (->> arities-form (uc/map+ #(us/conform ::fn-type|arity %)) (uc/group-by #(-> % :input-types count)))] - (FnType. nil name- arities-form arities))) + (FnType. nil name- out-type arities-form arities))) (defns compare|in [x0 utr/fn-type?, x1 utr/fn-type? > ucomp/comparison?] (let [ct->overloads|x0 (utr/fn-type>arities x0) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 10269a68..736d41bd 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -22,7 +22,7 @@ [quantum.untyped.core.error :as err :refer [TODO err!]] [quantum.untyped.core.fn - :refer [aritoid fn-> with-do]] + :refer [<- aritoid fn-> with-do]] [quantum.untyped.core.form :as uform :refer [>form]] [quantum.untyped.core.form.evaluate :as ufeval] @@ -131,6 +131,27 @@ (s/def ::lang #{:clj :cljs}) +;; "global" because they apply to the whole fnt +(s/def ::fnt-globals + (s/kv {:fn|name ::uss/fn|name + :fnt|type t/type?})) + +(s/def ::opts + (s/kv {:gen-gensym t/fn? + :lang ::lang + :symbolic-analysis? t/boolean?})) + +(s/def ::overload-data + (s/kv {:args (s/vec-of t/any?) + :varargs t/any? + :body-codelist|pre-analyze t/any? + :arg-types|form t/any? + :arg-types (s/vec-of t/type?) + :pre-type|form t/any? + :pre-type (? t/type?) + :post-type|form t/any? + :post-type t/type?})) + (s/def ::input-types-decl (s/kv {:form t/any? :name simple-symbol? @@ -146,26 +167,18 @@ (s/kv {:form t/any? :i-overload->direct-dispatch-data ::i-overload->direct-dispatch-data})) -(s/def ::expanded-overload-group|arg-types|form (s/vec-of t/any?)) - (s/def ::expanded-overload-group - (s/kv {:arg-types|form ::expanded-overload-group|arg-types|form - :non-primitivized ::expanded-overload - :primitivized (s/nilable (s/seq-of ::expanded-overload))})) + (s/kv {:arg-types|form|expanded (s/vec-of t/any?) + :non-primitivized ::expanded-overload + :primitivized (s/nilable (s/seq-of ::expanded-overload))})) -(s/def ::expanded-overload-groups|arg-types|split (s/vec-of (s/vec-of t/type?))) -(s/def ::expanded-overload-groups|output-type t/any?) -(s/def ::expanded-overload-groups|pre-type|form t/any?) -(s/def ::expanded-overload-groups|post-type|form t/any?) +(s/def ::expanded-overload-groups|arg-types|split (s/vec-of (s/vec-of t/type?))) (s/def ::expanded-overload-groups - (s/kv {:arg-types|pre-split|form ::expanded-overload-group|arg-types|form - :fnt-output-type ::expanded-overload-groups|fnt-output-type - :pre-type|form ::expanded-overload-groups|pre-type|form - :post-type|form ::expanded-overload-groups|post-type|form + (s/kv {:arg-types|recombined (s/vec-of (s/vec-of t/type?)) :arg-types|split ::expanded-overload-groups|arg-types|split - :arg-types|recombined (s/vec-of (s/vec-of t/type?)) - :expanded-overload-group-seq (s/seq-of ::expanded-overload-group)})) + :expanded-overload-group-seq (s/seq-of ::expanded-overload-group) + :overload-data ::overload-data})) #_(:clj (defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] @@ -218,18 +231,17 @@ (apply ucombo/cartesian-product) (c/lmap >vec)))) -;; TODO spec args #?(:clj (defns- >expanded-overload - "Is given `arg-classes` and `arg-types`. In order to determine the out-type, performs an analysis - using (in part) these pieces of data, but does not use the possibly-updated `arg-types` as - computed in the analysis. As a result, does not yet support type inference." - [{:keys [fn|name _, arg-bindings _, arg-classes ::expanded-overload|arg-classes - fnt|output-type _, post-type|form _ - arg-types ::expanded-overload|arg-types, body-codelist|pre-analyze _, lang ::lang - varargs _, varargs-binding _]} _ + [{:keys [varargs _, post-type|form _, post-type _, body-codelist|pre-analyze _]} ::overload-data + {:as fnt-globals :keys [fn|name _, fnt|type _]} ::fnt-globals + {:as opts :keys [lang _]} ::opts + arg-bindings _ + arg-types|satisfying-primitivization (s/vec-of t/type?) + arg-classes (s/vec-of t/class?) + varargs-binding _ > ::expanded-overload] - (let [env (->> (zipmap arg-bindings arg-types) + (let [env (->> (zipmap arg-bindings arg-types|satisfying-primitivization) (c/map' (fn [[arg-binding arg-type]] [arg-binding (uast/unbound nil arg-binding arg-type)])) ;; To support recursion @@ -243,13 +255,6 @@ lang (c/count arg-bindings) varargs))) - ;; TODO this becomes an issue when `post-type|form` references local bindings - overload-specific-post-type (some-> post-type|form eval) - _ (when (and overload-specific-post-type - (not (t/<= overload-specific-post-type fnt|output-type))) - (err! (str "Overload's specified output type does not satisfy function's overall " - "specified output type"))) - post-type (or overload-specific-post-type fnt|output-type) post-type|runtime? (-> post-type meta :runtime?) out-type (if post-type (if post-type|runtime? @@ -261,7 +266,7 @@ {:body analyzed :output-type post-type})) (if (t/<= (:type analyzed) post-type) (:type analyzed) - (err! "Body does not match output type" + (err! "Body type does not match declared output type" {:body analyzed :output-type post-type}))) (:type analyzed)) body-form @@ -271,9 +276,9 @@ (->> (c/zipmap-into (umap/om) arg-bindings arg-classes) (c/remove-vals' (fn-or nil? (fn= java.lang.Object) t/primitive-class?)))))] {:arg-classes arg-classes|simplest - :arg-types arg-types + :arg-types arg-types|satisfying-primitivization :arglist-code|fn|hinted (cond-> (->> arg-bindings (c/map-indexed hint-arg|fn)) - varargs-binding (conj '& varargs-binding)) ; TODO use `` + varargs-binding (conj '& varargs-binding)) ; TODO use `` :arglist-code|reify|unhinted (cond-> arg-bindings varargs-binding (conj varargs-binding)) :body-form body-form :positional-args-ct (count arg-bindings) @@ -282,9 +287,11 @@ :variadic? (boolean varargs)}))) (defns >expanded-overload-group - [{:as in :keys [arg-types ::expanded-overload-group|arg-types|form]} _ + [{:as overload-data :keys [arg-types _]} ::overload-data + fnt-globals ::fnt-globals, opts ::opts, arg-bindings _, varargs-binding _ > ::expanded-overload-group] - (let [arg-types|form (mapv >form arg-types) + (let [;; After `t/or`s etc. are expanded and simplified + arg-types|form|expanded (mapv >form arg-types) ;; `non-primitivized` is first because of class sorting [non-primitivized & primitivized :as overloads] (->> arg-types @@ -295,12 +302,11 @@ (fn [_ s #_t/type? c #_t/class?] (cond-> s (t/primitive-class? c) (t/and c))) arg-types arg-classes)] - (>expanded-overload - (assoc in :arg-classes arg-classes - :arg-types arg-types|satisfying-primitivization))))))] - (kw-map arg-types|form non-primitivized primitivized))) + (>expanded-overload overload-data fnt-globals opts + arg-bindings arg-types|satisfying-primitivization arg-classes + varargs-binding)))))] + (kw-map arg-types|form|expanded non-primitivized primitivized))) -;; TODO spec #?(:clj ; really, reserve for metalanguage (defns fnt|overload-data>expanded-overload-groups "Given an `fnt` overload, computes a seq of 'expanded-overload groups'. Each expanded-overload @@ -317,18 +323,15 @@ we decide instead to evaluate types in languages in which the metalanguage (compiler language) is the same as the object language (e.g. Clojure), and symbolically analyze types in the rest (e.g. vanilla ClojureScript), deferring code analyzed as functions to be enforced at runtime." - [{:as in {:keys [args _, varargs _] - pre-type|form [:pre _] - [_ _, post-type|form _] [:post _]} [:arglist _] - body-codelist|pre-analyze [:body _]} _ - fn|name _, fnt|output-type _ - {:as opts :keys [::lang ::lang, symbolic-analysis? t/boolean?]} _ + [{:as overload-data + :keys [args _, varargs _ + arg-types|form _, arg-types _, pre-type|form _, post-type|form _]} ::overload-data + {:as fnt-globals :keys [fn|name _, fnt|type _]} ::fnt-globals + {:as opts :keys [lang _, symbolic-analysis? _]} ::opts > ::expanded-overload-groups] (if symbolic-analysis? (err! "Symbolic analysis not supported yet") - (let [_ (when pre-type|form (TODO "Need to handle pre")) - _ (when varargs (TODO "Need to handle varargs")) - post-type|form (if (= post-type|form '_) `t/any? post-type|form) + (let [;; TODO support varargs varargs-binding (when varargs ;; TODO this assertion is purely temporary until destructuring is ;; supported @@ -340,14 +343,9 @@ ;; supported (assert kind :sym) binding-))) - arg-types|pre-split|form - (->> args - (mapv (fn [{[kind #_#{:any :spec}, t #_t/form?] :spec}] - (case kind :any `t/any? :spec t)))) - arg-types|pre-split (->> arg-types|pre-split|form (mapv (fn-> eval t/>type))) arg-types|split ;; NOTE Only `t/or`s are splittable for now - (->> arg-types|pre-split + (->> arg-types (c/map (fn [t] (if (utr/or-type? t) (utr/or-type>args t) [t])))) arg-types|recombined (->> arg-types|split (apply ucombo/cartesian-product) @@ -355,13 +353,9 @@ expanded-overload-group-seq (->> arg-types|recombined (mapv (fn [arg-types] - (>expanded-overload-group - (kw-map fn|name arg-bindings arg-types body-codelist|pre-analyze lang - arg-types|pre-split|form pre-type|form post-type|form - fnt|output-type varargs varargs-binding)))))] - (kw-map arg-types|pre-split|form pre-type|form post-type|form fnt|output-type - arg-types|split arg-types|recombined - expanded-overload-group-seq))))) + (>expanded-overload-group overload-data fnt-globals opts + arg-bindings varargs-binding))))] + (kw-map arg-types|recombined arg-types|split expanded-overload-group-seq overload-data))))) (def fnt-method-sym 'invoke) @@ -393,7 +387,7 @@ [{:as overload :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, out-class t/class?]} ::expanded-overload - gen-gensym fn? + {:as opts :keys [gen-gensym _]} ::opts > ::reify|overload] (let [interface-k {:out out-class :in arg-classes} interface @@ -424,10 +418,11 @@ [{:as in :keys [::uss/fn|name ::uss/fn|name, i|fnt-overload t/index?, i|expanded-overload-group t/index? expanded-overload-group ::expanded-overload-group]} _ - gen-gensym fn? > ::reify] + {:as opts :keys [gen-gensym _]} ::opts + > ::reify] (let [reify-overloads (->> (concat [(:non-primitivized expanded-overload-group)] (:primitivized expanded-overload-group)) - (c/map #(expanded-overload>reify-overload % gen-gensym))) + (c/map #(expanded-overload>reify-overload % opts))) reify-name (>reify|name in) form `(~'def ~reify-name ~(list* `reify* @@ -450,10 +445,8 @@ (defns >i-arg->input-types-decl "The evaluated `form` of each input-types-decl is an array of non-primitivized types that the dynamic dispatch uses to dispatch off input types." - [{:as in - :keys [arg-types|split ::expanded-overload-groups|arg-types|split - fn|name ::uss/fn|name - i|fnt-overload t/index?]} _ + [{:keys [fn|name _]} ::fnt-globals + arg-types|split ::expanded-overload-groups|arg-types|split, i|fnt-overload t/index? > (s/vec-of ::input-types-decl)] (->> arg-types|split (c/map-indexed @@ -518,10 +511,9 @@ (TODO)) (defns >direct-dispatch - [{:keys [::uss/fn|name ::uss/fn|name - expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups) - gen-gensym fn? - lang ::lang]} _ + [{:as fnt-globals :keys [fn|name _]} ::fnt-globals + {:as opts :keys [gen-gensym _, lang _]} ::opts + expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups) > ::direct-dispatch] (case lang :clj @@ -530,7 +522,7 @@ (c/map-indexed (fn [i|fnt-overload {:keys [arg-types|split expanded-overload-group-seq]}] {:i-arg->input-types-decl - (>i-arg->input-types-decl (kw-map arg-types|split fn|name i|fnt-overload)) + (>i-arg->input-types-decl fnt-globals arg-types|split i|fnt-overload) :reify-seq (->> expanded-overload-group-seq (c/map-indexed @@ -540,7 +532,7 @@ i|expanded-overload-group expanded-overload-group) ::uss/fn|name fn|name)] - (expanded-overload-group>reify in gen-gensym)))))}))) + (expanded-overload-group>reify in opts)))))}))) form (->> i-overload->direct-dispatch-data (c/map (fn [{:keys [i-arg->input-types-decl reify-seq]}] (concat (c/lmap :form i-arg->input-types-decl) @@ -550,13 +542,15 @@ :cljs (TODO))) (defns >dynamic-dispatch-fn|type-decl - [expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups)] - (list* `t/fn (->> expanded-overload-groups-by-fnt-overload - (map (fn [{:keys [arg-types|pre-split|form - pre-type|form post-type|form]}] - (cond-> (or arg-types|pre-split|form []) - pre-type|form (conj :| pre-type|form) - post-type|form (conj :> post-type|form))))))) + [{:keys [fnt|type _]} ::fnt-globals + expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups)] + (list* `t/fn + (-> fnt|type utr/fn-type>out-type >form) + (->> expanded-overload-groups-by-fnt-overload + (map (fn [{{:keys [arg-types|form pre-type|form post-type|form]} :overload-data}] + (cond-> (or arg-types|form []) + pre-type|form (conj :| pre-type|form) + post-type|form (conj :> post-type|form))))))) (defns >dynamic-dispatch|reify-call [reify- ::reify, arglist (s/vec-of simple-symbol?)] (let [dotted-reify-method-sym @@ -605,13 +599,13 @@ c/lcat)))) (defns >dynamic-dispatch-fn|form - [{:keys [::uss/fn|name ::uss/fn|name - expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups) - gen-gensym fn? - lang ::lang - i-overload->direct-dispatch-data ::i-overload->direct-dispatch-data]} _] + [{:as fnt-globals :keys [fn|name _]} ::fnt-globals + {:as opts :keys [gen-gensym _, lang _]} ::opts + expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups) + i-overload->direct-dispatch-data ::i-overload->direct-dispatch-data] `(defn ~fn|name - {::t/type ~(>dynamic-dispatch-fn|type-decl expanded-overload-groups-by-fnt-overload)} + {::t/type ~(>dynamic-dispatch-fn|type-decl fnt-globals + expanded-overload-groups-by-fnt-overload)} ~@(->> i-overload->direct-dispatch-data (group-by (fn-> :i-arg->input-types-decl count)) (map (fn [[arg-ct direct-dispatch-data-for-arity]] @@ -620,6 +614,40 @@ fn|name arglist direct-dispatch-data-for-arity)] (list arglist body))))))) +(defns fnt|overloads-data>type + [overloads-data (s/vec-of ::overload-data), fnt|output-type t/type? > t/type?] + (->> overloads-data + (c/lmap (fn [{:keys [arg-types pre-type post-type]}] + (cond-> arg-types + pre-type (conj :| pre-type) + post-type (conj :> post-type)))) + (apply t/fn fnt|output-type))) + +(defns fnt|parsed-overload>overload-data + [{:as in {:keys [args _, varargs _] + pre-type|form [:pre _] + [_ _, post-type|form _] [:post _]} [:arglist _] + body-codelist|pre-analyze [:body _]} _ + fnt|output-type t/type? + > ::overload-data] + (when pre-type|form (TODO "Need to handle pre")) + (when varargs (TODO "Need to handle varargs")) + (let [arg-types|form (->> args + (mapv (fn [{[kind #_#{:any :spec}, t #_t/form?] :spec}] + (case kind :any `t/any? :spec t)))) + arg-types (->> arg-types|form (mapv (fn-> eval t/>type))) + pre-type nil ; TODO fix + post-type|form (if (= post-type|form '_) `t/any? post-type|form) + ;; TODO this becomes an issue when `post-type|form` references local bindings + post-type|overload-specific (some-> post-type|form eval) + _ (when (and post-type|overload-specific + (not (t/<= post-type|overload-specific fnt|output-type))) + (err! (str "Overload's declared output type does not satisfy function's overall " + "declared output type"))) + post-type (or post-type|overload-specific fnt|output-type)] + (kw-map args varargs body-codelist|pre-analyze + arg-types|form arg-types, pre-type|form pre-type, post-type|form post-type))) + (defns fnt|code [kind #{:fn :defn}, lang ::lang, args _] (let [{:keys [:quantum.core.specs/fn|name :quantum.core.defnt/overloads @@ -628,7 +656,7 @@ (s/validate args (case kind :defn :quantum.core.defnt/defnt :fn :quantum.core.defnt/fnt)) symbolic-analysis? false ; TODO parameterize this - fnt-output-type (or (some-> output-spec second eval) t/any?) + fnt|output-type (or (some-> output-spec second eval) t/any?) gen-gensym-base (ufgen/>reproducible-gensym|generator) gen-gensym (fn [x] (symbol (str (gen-gensym-base x) "__"))) inline? (s/validate (-> fn|name core/meta :inline) (t/? t/boolean?)) @@ -636,19 +664,21 @@ (do (ulog/pr :warn "requested `:inline`; ignoring until feature is implemented") (update-meta fn|name dissoc :inline)) fn|name) + overloads-data (->> overloads (mapv #(fnt|parsed-overload>overload-data % fnt|output-type))) + fnt|type (fnt|overloads-data>type overloads-data fnt|output-type) + fnt-globals (kw-map fn|name fnt|type) + opts (kw-map gen-gensym lang symbolic-analysis?) expanded-overload-groups-by-fnt-overload - (->> overloads (mapv #(fnt|overload-data>expanded-overload-groups % - fn|name - fnt-output-type - {::lang lang :symbolic-analysis? symbolic-analysis?}))) - args (assoc (kw-map expanded-overload-groups-by-fnt-overload gen-gensym lang) - ::uss/fn|name fn|name) - {:as direct-dispatch :keys [i-overload->direct-dispatch-data]} (>direct-dispatch args) + (->> overloads-data + (mapv #(fnt|overload-data>expanded-overload-groups % fnt-globals opts))) + {:as direct-dispatch :keys [i-overload->direct-dispatch-data]} + (>direct-dispatch fnt-globals opts expanded-overload-groups-by-fnt-overload) fn-codelist (case lang :clj (->> `[~@(:form direct-dispatch) - ~(>dynamic-dispatch-fn|form - (merge args (kw-map i-overload->direct-dispatch-data)))] + ~(>dynamic-dispatch-fn|form fnt-globals opts + expanded-overload-groups-by-fnt-overload + i-overload->direct-dispatch-data)] (remove nil?)) :cljs (TODO)) code (case kind diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 5ff0fe66..b0b2dbe7 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -241,20 +241,24 @@ (udt/deftype FnType [meta #_(t/? ::meta) - name arities-form + name + out-type #_t/type? + arities-form arities #_(s/map-of non-zero-int? (s/seq-of :quantum.untyped.core.type/fn-type|arity))] - {PType nil + {PType nil ;; Outputs whether the args match any input spec - ?Fn {invoke ([this args] (TODO))} - ?Meta {meta ([this] meta) - with-meta ([this meta'] (FnType. meta' name arities-form arities))} - fipp.ednize/IOverride nil - fipp.ednize/IEdn {-edn ([this] (list 'quantum.untyped.core.type/fn arities-form))}}) + ?Fn {invoke ([this args] (TODO))} + ?Meta {meta ([this] meta) + with-meta ([this meta'] (FnType. meta' name out-type arities-form arities))} + fedn/IOverride nil + fedn/IEdn {-edn ([this] (list 'quantum.untyped.core.type/fn out-type arities-form))}}) (defns fn-type? [x _ > boolean?] (instance? FnType x)) (defns fn-type>arities [^FnType x fn-type?] (.-arities x)) +(defns fn-type>out-type [^FnType x fn-type?] (.-out-type x)) + (us/def :quantum.untyped.core.type/fn-type|arity (us/and (us/cat From af834d24fc841ff5df8ac3c50a9f531e1d353660 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 5 Sep 2018 00:35:03 -0600 Subject: [PATCH 224/810] Update tests --- .../test/untyped/core/type/compare.cljc | 74 +++++++++++-------- 1 file changed, 44 insertions(+), 30 deletions(-) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 8b6480a6..41386879 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -813,8 +813,8 @@ to compare the extension of their inputs and the extension of their outputs separately. That said, it's not clear how useful this sort of comparison is. - Furthermore, is it the case that `(t/< [[] t/any?] (t/fn []))`? Intuitively it doesn't seem - like it should be, but under the WHK model it nevertheless seems to be the case. + Furthermore, is it the case that `(t/< [[] t/any?] (t/fn t/any? []))`? Intuitively it doesn't + seem like it should be, but under the WHK model it nevertheless seems to be the case. So we opt to make `t/fn`s `t/compare`-able only with what its underlying function object is `t/compare`-able with, and introduce instead a `t/compare|input` and `t/compare|output`. @@ -858,33 +858,40 @@ (testing "input arities <" (testing "same-arity input types <" (testing "output <" - (test-comparison|fn [ t/boolean?]) - (t/fn [] [t/any? :> t/long?]))) + (test-comparison|fn [ t/boolean?]) + (t/fn t/any? [] [t/any? :> t/long?]))) (testing "output =") (testing "output >" - (test-comparison|fn [ ident] (t/fn [t/boolean?]) - (t/fn [:> t/boolean?] [t/any? :> t/boolean?]))) + (test-comparison|fn [ ident] + (t/fn t/any? [t/boolean?]) + (t/fn t/any? [:> t/boolean?] [t/any? :> t/boolean?]))) (testing "output ><") (testing "output <>")) (testing "same-arity input types =" (testing "output <" - (test-comparison|fn [ t/boolean?]) - (t/fn [] [t/any?]))) + (test-comparison|fn [ t/boolean?]) + (t/fn t/any? [] [t/any?]))) (testing "output =" - (test-comparison|fn [ " - (test-comparison|fn [ ident] (t/fn []) - (t/fn [:> t/boolean?] [t/any? :> t/long?]))) + (test-comparison|fn [ ident] + (t/fn t/any? []) + (t/fn t/any? [:> t/boolean?] [t/any? :> t/long?]))) (testing "output ><") (testing "output <>")) (testing "same-arity input types >" (testing "output <" - (test-comparison|fn [> t/boolean?]) - (t/fn [] [t/boolean?]))) + (test-comparison|fn [> t/boolean?]) + (t/fn t/any? [] [t/boolean?]))) (testing "output =" - (test-comparison|fn [>") (testing "output ><") (testing "output <>")) @@ -903,27 +910,34 @@ (testing "input arities =" (testing "same-arity input types <" (testing "output <" - (test-comparison|fn [ t/boolean?]) - (t/fn [t/any?]))) + (test-comparison|fn [ t/boolean?]) + (t/fn t/any? [t/any?]))) (testing "output =" - (test-comparison|fn [ " - (test-comparison|fn [ ident] (t/fn [t/boolean?]) - (t/fn [t/any? :> t/boolean?]))) + (test-comparison|fn [ ident] + (t/fn t/any? [t/boolean?]) + (t/fn t/any? [t/any? :> t/boolean?]))) (testing "output ><" - (test-comparison|fn [ i|><0]) - (t/fn [t/any? :> i|><1]))) + (test-comparison|fn [ i|><0]) + (t/fn t/any? [t/any? :> i|><1]))) (testing "output <>" - (test-comparison|fn [ ident] (t/fn [t/boolean? :> ><0]) - (t/fn [t/any? :> ><1])))) + (test-comparison|fn [ ident] + (t/fn t/any? [t/boolean? :> ><0]) + (t/fn t/any? [t/any? :> ><1])))) (testing "same-arity input types =" (testing "output <" - (test-comparison|fn [ =ident >ident] (t/fn []) - (t/fn [:> t/boolean?]))) + (test-comparison|fn [ =ident >ident] + (t/fn t/any? []) + (t/fn t/any? [:> t/boolean?]))) (testing "output =" - (test-comparison|fn [ =ident =ident] (t/fn []) - (t/fn []))) + (test-comparison|fn [ =ident =ident] + (t/fn t/any? []) + (t/fn t/any? []))) (testing "output >") (testing "output ><") (testing "output <>")) From fae854476ac23cf021dcb2c5da03ec7b7c879cac Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 5 Sep 2018 00:35:08 -0600 Subject: [PATCH 225/810] Add more notes --- resources-dev/defnt.cljc | 29 ++++++++++++++--------------- 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 70bfd3a7..48245e55 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -1,17 +1,23 @@ #_" +LEFT OFF LAST TIME (9/3/2018): Note that `;; TODO TYPED` is the annotation we're using - TODO implement the following: - t/... - t/assume + - t/numerically - expressions (`quantum.untyped.core.analyze.expr`) - deft - fnt - declare-fnt (a way to do protocols/interfaces) + - extend-fnt! - defnt - recursion by adding the function's name and type to the local bindings (env) - handle varargs + - do the defnt-equivalences + - a linting warning that you can narrow the type to whatever the deduced type is from whatever + wider declared type there is - defmacrot - dotyped - NOTE on namespace organization: @@ -33,11 +39,6 @@ Note that `;; TODO TYPED` is the annotation we're using - quantum.core.type - quantum.core.vars - - - -LEFT OFF LAST TIME (7/25/2018): - - With `defnt`, protocols and interfaces aren't needed. You can just create `t/fn`s that you can then conform your fns to. - `dotyped`, `defnt`, and `fnt` create typed contexts in which their internal forms are analyzed @@ -46,11 +47,11 @@ LEFT OFF LAST TIME (7/25/2018): types will very often have to be validated at runtime. [ ] Compile-Time (Direct) Dispatch - - Any argument, if it requires a non-nilable primitive-like value, will be marked as a - primitive. - - If nilable, there will be one overload for nil and one for primitive. - - When a `fnt` with type overloads is referenced outside of a typed context, then the overload - resolution will be done via Runtime Dispatch. + [x] Any argument, if it requires a non-nilable primitive-like value, will be marked as a + primitive. + [x] If nilable, there will be one overload for nil and one for primitive. + [x] When a `fnt` with type overloads is referenced outside of a typed context, then the overload + resolution will be done via Runtime Dispatch. - TODO Should we take into account 'actual' types (not just 'declared' types) when performing dispatch / overload resolution? - Let's take the example of `(defnt abcde [] (f (rand/int-between -10 -2)))`. @@ -99,10 +100,10 @@ LEFT OFF LAST TIME (7/25/2018): - For now we won't do it because we can very often find the correct overload at compile time. We will resort to using the `fn`. - It will be left as an optimization. - [ ] `fn` generation + [x] `fn` generation - Performs a worst-case linear check of the typedefs, `cond`-style. -[ ] Interface generation - - Even if the `defnt` is redefined, you won't have interface problems. +[x] Interface generation + [x] Even if the `defnt` is redefined, you won't have interface problems. [ ] `reify` generation - Which `reify`s get generated is mainly up to the inputs but partially up to the fn body — If any typed fns are called in the fn body then this can change what gets generated. @@ -128,6 +129,4 @@ LEFT OFF LAST TIME (7/25/2018): [—] Support for compilers in which the metalanguage differs from the object language (i.e. 'normal' non-CLJS-in-CLJS CLJS) - This will have to be approached later. We'll figure it out; maybe just not yet. -[—] `extend-defnt!` - - Not yet; probably complicated and we don't need it right now " From 50e1068cf72403e1e36113a7e5d307427b5e8b10 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 5 Sep 2018 21:53:24 -0600 Subject: [PATCH 226/810] Fix expanded types vs. non-expanded --- src-dev/quantum/core/defnt_equivalences.cljc | 82 ++++++++++++------- src-untyped/quantum/untyped/core/form.cljc | 6 +- src-untyped/quantum/untyped/core/test.cljc | 48 +++++------ src-untyped/quantum/untyped/core/type.cljc | 4 +- .../quantum/untyped/core/type/defnt.cljc | 43 +++++----- .../untyped/core/type/reifications.cljc | 2 +- 6 files changed, 105 insertions(+), 80 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 8540173e..679f4680 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -17,7 +17,7 @@ [quantum.untyped.core.logic :refer [ifs]] [quantum.untyped.core.spec :as s] - [quantum.untyped.core.test :as test + [quantum.untyped.core.test :as utest :refer [deftest is is= is-code= testing throws]] [quantum.untyped.core.type :as t :refer [? *]] @@ -92,14 +92,14 @@ [~'_8__ ~(tag "double" 'x)] ~'x))) (defn ~'identity|uninlined - {::t/type (t/fn ~'[t/any?])} + {::t/type (t/fn t/any? ~'[t/any?])} ([~'x00__] ;; TODO elide check because `t/any?` doesn't require a check ;; and all args are `t/=` `t/any?` (ifs ((Array/get ~'identity|uninlined|__0|input0|types 0) ~'x00__) (.invoke ~(tag (str `Object>Object) 'identity|uninlined|__0|0) ~'x00__) - (unsupported! `name|test [~'x00__] 0)))))) + (unsupported! `identity|uninlined [~'x00__] 0)))))) :cljs ;; Direct dispatch will be simple functions, not `reify`s ($ (do (defn ~'identity|uninlined [~'x] ~'x))))] @@ -144,7 +144,8 @@ (defn ~'name|test {::t/type - (t/fn ~'[t/string? :> t/string?] + (t/fn t/any? + ~'[t/string? :> t/string?] ~'[(t/isa? Named) :> (* t/string?)])} ([~'x00__] (ifs ((Array/get ~'name|test|__0|input0|types 0) ~'x00__) @@ -208,7 +209,8 @@ (~(tag "boolean" 'invoke) [~'_9__ ~(tag "double" 'x)] true))) (defn ~'some?|test - {::t/type (t/fn ~'[t/nil?] + {::t/type (t/fn t/any? + ~'[t/nil?] ~'[t/any?])} ([~'x00__] (ifs ((Array/get ~'some?|test|__0|input0|types 0) ~'x00__) @@ -268,7 +270,8 @@ (~(tag "boolean" 'invoke) [~'_9__ ~(tag "double" 'x)] false))) (defn ~'reduced?|test - {::t/type (t/fn ~'[(t/isa? Reduced)] + {::t/type (t/fn t/any? + ~'[(t/isa? Reduced)] ~'[t/any?])} ([~'x00__] (ifs ((Array/get ~'reduced?|test|__0|input0|types 0) ~'x00__) @@ -337,7 +340,8 @@ (~(tag "boolean" 'invoke) [~'_10__ ~(tag "double" 'x)] true))) (defn ~'>boolean - {::t/type (t/fn ~'[t/boolean?] + {::t/type (t/fn t/any? + ~'[t/boolean?] ~'[t/nil?] ~'[t/any?])} ([~'x00__] @@ -432,8 +436,9 @@ (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(.intValue x))))) (defn ~'>int* - {::t/type (t/fn ~'[(t/- t/primitive? t/boolean?) :> t/int?] - ~'[(t/ref (t/isa? Number)) :> t/int?])} + {::t/type (t/fn ~'t/int? + ~'[(t/- t/primitive? t/boolean?)] + ~'[(t/ref (t/isa? Number))])} ([~'x00__] (ifs ((Array/get ~'>int*|__0|input0|types 0) ~'x00__) (.invoke ~(tag (str `byte>int) '>int*|__0|0) ~'x00__) @@ -698,7 +703,8 @@ ;; Unindented for greater vertical brevity (defn ~'>|test {::t/type - (t/fn #?(:clj ~'[t/comparable-primitive? t/comparable-primitive? + (t/fn t/any? + #?(:clj ~'[t/comparable-primitive? t/comparable-primitive? :> t/boolean?] :cljs ~'[t/double? t/double? :> (t/assume t/boolean?)]))} @@ -864,12 +870,12 @@ (~(tag "long" 'invoke) [~'_0__ ~(tag "byte" 'x)] ~'(Primitive/uncheckedLongCast x)))) (def ~'>long*|__0|1 - (reify* [char>long] - (~(tag "long" 'invoke) [~'_1__ ~(tag "char" 'x)] + (reify* [short>long] + (~(tag "long" 'invoke) [~'_1__ ~(tag "short" 'x)] ~'(Primitive/uncheckedLongCast x)))) (def ~'>long*|__0|2 - (reify* [short>long] - (~(tag "long" 'invoke) [~'_2__ ~(tag "short" 'x)] + (reify* [char>long] + (~(tag "long" 'invoke) [~'_2__ ~(tag "char" 'x)] ~'(Primitive/uncheckedLongCast x)))) (def ~'>long*|__0|3 (reify* [int>long] @@ -898,8 +904,10 @@ (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(.longValue x))))) (defn ~'>long* - {::t/type (t/fn ~'[(t/- t/primitive? t/boolean?) :> t/long?] - ~'[(t/ref (t/isa? Number)) :> t/long?])} + {:source "clojure.lang.RT.uncheckedLongCast" + ::t/type (t/fn ~'t/long? + ~'[(t/- t/primitive? t/boolean?)] + ~'[(t/ref (t/isa? Number))])} ([~'x00__] (ifs ((Array/get ~'>long*|__0|input0|types 0) x00__) @@ -934,11 +942,22 @@ (is (identical? (>long* -1.1) (clojure.lang.RT/uncheckedLongCast -1.1))) (is (identical? (>long* (byte 1)) (clojure.lang.RT/uncheckedLongCast (byte 1))))))))) - (deftest defnt-reference-test - (defnt defnt-reference - ([] (>long* 1))) - (is (identical? (defnt-reference) 1))) + (let [actual + (macroexpand ' + (defnt defnt-reference + ([] (>long* 1)))) + expected + (case (env-lang) + :clj ($ (do (def ~'defnt-reference|__0|0 + (reify* [>long] (~'invoke [~'_0__] ~'(>long* 1)))) + (defn ~'defnt-reference + {::t/type (t/fn t/any? [])} + ([] (.invoke ~'defnt-reference|__0|0))))))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do (is (identical? (defnt-reference) 1))))))) ;; NOTE would use `>long` but that's already an interface (deftest test|>long-checked @@ -1175,14 +1194,14 @@ (~(tag "java.lang.Object" 'invoke) [~'_0__] ~'(StringBuilder.)))) - (def ~'!str|__1|input0|types + (def ~(tag "[Ljava.lang.Object;" '!str|__1|input0|types) (*<> (t/isa? java.lang.String))) (def ~'!str|__1|0 (reify* [Object>Object] (~(tag "java.lang.Object" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] (let* [~(tag "java.lang.String" 'x) ~'x] ~'(StringBuilder. x))))) - (def ~'!str|__2|input0|types + (def ~(tag "[Ljava.lang.Object;" '!str|__2|input0|types) (*<> (t/isa? java.lang.CharSequence) (t/isa? java.lang.Integer))) (def ~'!str|__2|0 @@ -1196,18 +1215,23 @@ ~'(StringBuilder. x)))) (defn ~'!str - {::t/type (t/fn ~'[ :> (t/isa? StringBuilder)] - ~'[t/string? :> (t/isa? StringBuilder)] - ~'[(t/or t/char-seq? t/int?) :> (t/isa? StringBuilder)])} - ([] (.invoke ~'!str|__0|0)) + {::t/type (t/fn ~'(t/isa? StringBuilder) + ~'[] + ~'[t/string?] + ~'[(t/or t/char-seq? t/int?)])} + ([] (.invoke ~(tag "quantum.core.test.defnt_equivalences.>Object" + '!str|__0|0))) ([~'x00__] (ifs ((Array/get ~'!str|__1|input0|types 0) ~'x00__) - (.invoke !str|__1|0 ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" + '!str|__1|0) ~'x00__) ((Array/get ~'!str|__2|input0|types 0) ~'x00__) - (.invoke !str|__2|0 ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" + '!str|__2|0) ~'x00__) ((Array/get ~'!str|__2|input0|types 1) ~'x00__) - (.invoke !str|__2|1 ~'x00__) + (.invoke ~(tag "quantum.core.test.defnt_equivalences.int>Object" + '!str|__2|1) ~'x00__) (unsupported! `!str [~'x00__] 0)))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index 087ae7da..a89d763a 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -113,11 +113,7 @@ :else ::not-applicable)] (if (= similar-class? ::not-applicable) (= code0 code1) - (and similar-class? (seq= (seq code0) (seq code1) code=)))) - (cond (seq? code0) (and (seq? code1) (seq= code0 code1 code=)) - (vector? code0) (and (vector? code1) (seq= (seq code0) (seq code1) code=)) - (map? code0) (and (map? code1) (seq= (seq code0) (seq code1) code=)) - :else (= code0 code1))) + (and similar-class? (seq= (seq code0) (seq code1) code=))))) (and (not (uvar/metable? code1)) (= code0 code1)))) ([code0 code1 & codes] (and (code= code0 code1) (every? #(code= code0 %) codes)))) diff --git a/src-untyped/quantum/untyped/core/test.cljc b/src-untyped/quantum/untyped/core/test.cljc index b9b13e2d..a70a2af7 100644 --- a/src-untyped/quantum/untyped/core/test.cljc +++ b/src-untyped/quantum/untyped/core/test.cljc @@ -28,34 +28,36 @@ (defn code= "`code=` but with helpful test-related logging" - ([code0 code1] - (if (metable? code0) - (and (metable? code1) - (let [meta0 (-> code0 meta (dissoc :line :column)) - meta1 (-> code1 meta (dissoc :line :column))] + ([c0 c1] + (if (metable? c0) + (and (metable? c1) + (let [meta0 (-> c0 meta (dissoc :line :column)) + meta1 (-> c1 meta (dissoc :line :column))] (or (= meta0 meta1) - (pr! "FAIL: meta should be match for" (pr-str meta0) (pr-str meta1) - "on code" (pr-str code0) (pr-str code1)))) + (do (pr! "FAIL: meta should be match for" (pr-str meta0) (pr-str meta1) + "on code" (pr-str c0) (pr-str c1)) + false))) (let [similar-class? - (cond (seq? code0) (seq? code1) - (seq? code1) (seq? code0) - (vector? code0) (vector? code1) - (vector? code1) (vector? code0) - (map? code0) (map? code1) - (map? code1) (map? code0) + (cond (seq? c0) (seq? c1) + (seq? c1) (seq? c0) + (vector? c0) (vector? c1) + (vector? c1) (vector? c0) + (map? c0) (map? c1) + (map? c1) (map? c0) :else ::not-applicable)] (if (= similar-class? ::not-applicable) - (or (= code0 code1) - (pr! "FAIL: should be `(= code0 code1)`" (pr-str code0) (pr-str code1))) + (or (= c0 c1) + (do (pr! "FAIL: should be `(= code0 code1)`" (pr-str c0) (pr-str c1)) false)) (and (or similar-class? - (pr! "FAIL: should be similar class" (pr-str code0) (pr-str code1))) - (or (seq= (seq code0) (seq code1) code=) - (pr! "FAIL: `(seq= code0 code1 code=)`" - (pr-str code0) (pr-str code1))))))) - (and (not (metable? code1)) - (or (= code0 code1) - (println "FAIL: should be `(= code0 code1)`" (pr-str code0) (pr-str code1)))))) - ([code0 code1 & codes] (and (code= code0 code1) (every? #(code= code0 %) codes)))) + (do (pr! "FAIL: should be similar class" (pr-str c0) (pr-str c1)) + false)) + (or (seq= (seq c0) (seq c1) code=) + (do (pr! "FAIL: `(seq= code0 code1 code=)`" (pr-str c0) (pr-str c1)) + false)))))) + (and (not (metable? c1)) + (or (= c0 c1) + (println "FAIL: should be `(= code0 code1)`" (pr-str c0) (pr-str c1)))))) + ([c0 c1 & codes] (and (code= c0 c1) (every? #(code= c0 %) codes)))) (defn is-code= [& args] (is (apply code= args))) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index cb88dd83..6169e7fd 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -448,7 +448,9 @@ (let [name- nil arities-form (cons arity arities) arities (->> arities-form - (uc/map+ #(us/conform ::fn-type|arity %)) + (uc/map+ (c/fn [arity-form] + (-> (us/conform ::fn-type|arity arity-form) + (update :output-type #(c/or % out-type universal-set))))) (uc/group-by #(-> % :input-types count)))] (FnType. nil name- out-type arities-form arities))) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 736d41bd..7344cf27 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -133,8 +133,9 @@ ;; "global" because they apply to the whole fnt (s/def ::fnt-globals - (s/kv {:fn|name ::uss/fn|name - :fnt|type t/type?})) + (s/kv {:fn|name ::uss/fn|name + :fnt|output-type|form t/any? + :fnt|type t/type?})) (s/def ::opts (s/kv {:gen-gensym t/fn? @@ -175,7 +176,7 @@ (s/def ::expanded-overload-groups|arg-types|split (s/vec-of (s/vec-of t/type?))) (s/def ::expanded-overload-groups - (s/kv {:arg-types|recombined (s/vec-of (s/vec-of t/type?)) + (s/kv {:arg-types|expanded-seq (s/vec-of (s/vec-of t/type?)) :arg-types|split ::expanded-overload-groups|arg-types|split :expanded-overload-group-seq (s/seq-of ::expanded-overload-group) :overload-data ::overload-data})) @@ -287,21 +288,20 @@ :variadic? (boolean varargs)}))) (defns >expanded-overload-group - [{:as overload-data :keys [arg-types _]} ::overload-data - fnt-globals ::fnt-globals, opts ::opts, arg-bindings _, varargs-binding _ + [overload-data ::overload-data + fnt-globals ::fnt-globals, opts ::opts, arg-bindings _, varargs-binding _, arg-types|expanded _ > ::expanded-overload-group] - (let [;; After `t/or`s etc. are expanded and simplified - arg-types|form|expanded (mapv >form arg-types) + (let [arg-types|form|expanded (mapv >form arg-types|expanded) ;; `non-primitivized` is first because of class sorting [non-primitivized & primitivized :as overloads] - (->> arg-types + (->> arg-types|expanded arg-types>arg-classes-seq|primitivized (mapv (fn [arg-classes #_::expanded-overload|arg-classes] (let [arg-types|satisfying-primitivization (c/mergev-with (fn [_ s #_t/type? c #_t/class?] (cond-> s (t/primitive-class? c) (t/and c))) - arg-types arg-classes)] + arg-types|expanded arg-classes)] (>expanded-overload overload-data fnt-globals opts arg-bindings arg-types|satisfying-primitivization arg-classes varargs-binding)))))] @@ -347,15 +347,16 @@ ;; NOTE Only `t/or`s are splittable for now (->> arg-types (c/map (fn [t] (if (utr/or-type? t) (utr/or-type>args t) [t])))) - arg-types|recombined (->> arg-types|split - (apply ucombo/cartesian-product) - (c/map vec)) + arg-types|expanded-seq (->> arg-types|split + (apply ucombo/cartesian-product) + (c/map vec)) expanded-overload-group-seq - (->> arg-types|recombined - (mapv (fn [arg-types] + (->> arg-types|expanded-seq + (mapv (fn [arg-types|expanded] ; TODO use this (>expanded-overload-group overload-data fnt-globals opts - arg-bindings varargs-binding))))] - (kw-map arg-types|recombined arg-types|split expanded-overload-group-seq overload-data))))) + arg-bindings varargs-binding arg-types|expanded))))] + (kw-map arg-types|expanded-seq arg-types|split expanded-overload-group-seq + overload-data))))) (def fnt-method-sym 'invoke) @@ -542,10 +543,9 @@ :cljs (TODO))) (defns >dynamic-dispatch-fn|type-decl - [{:keys [fnt|type _]} ::fnt-globals + [{:keys [fnt|output-type|form _, fnt|type _]} ::fnt-globals expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups)] - (list* `t/fn - (-> fnt|type utr/fn-type>out-type >form) + (list* `t/fn fnt|output-type|form (->> expanded-overload-groups-by-fnt-overload (map (fn [{{:keys [arg-types|form pre-type|form post-type|form]} :overload-data}] (cond-> (or arg-types|form []) @@ -656,7 +656,8 @@ (s/validate args (case kind :defn :quantum.core.defnt/defnt :fn :quantum.core.defnt/fnt)) symbolic-analysis? false ; TODO parameterize this - fnt|output-type (or (some-> output-spec second eval) t/any?) + fnt|output-type|form (or (second output-spec) `t/any?) + fnt|output-type (eval fnt|output-type|form) gen-gensym-base (ufgen/>reproducible-gensym|generator) gen-gensym (fn [x] (symbol (str (gen-gensym-base x) "__"))) inline? (s/validate (-> fn|name core/meta :inline) (t/? t/boolean?)) @@ -666,7 +667,7 @@ fn|name) overloads-data (->> overloads (mapv #(fnt|parsed-overload>overload-data % fnt|output-type))) fnt|type (fnt|overloads-data>type overloads-data fnt|output-type) - fnt-globals (kw-map fn|name fnt|type) + fnt-globals (kw-map fn|name fnt|output-type|form fnt|type) opts (kw-map gen-gensym lang symbolic-analysis?) expanded-overload-groups-by-fnt-overload (->> overloads-data diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index b0b2dbe7..38723cc7 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -265,6 +265,6 @@ :input-types (us/* type?) :output-type-pair (us/? (us/cat :ident #{:>} :type type?))) (us/conformer - (fn [x] (-> x (update :output-type-pair #(or (:type %) universal-set)) + (fn [x] (-> x (update :output-type-pair :type) (update :input-types vec) (set/rename-keys {:output-type-pair :output-type})))))) From d544dcfc8aed1590ba7c54a438675f6e42c2f93d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 5 Sep 2018 22:38:09 -0600 Subject: [PATCH 227/810] Proper placement of metadata --- src-dev/quantum/core/defnt_equivalences.cljc | 39 +++++++++---------- src-untyped/quantum/untyped/core/defnt.cljc | 14 ++++--- src-untyped/quantum/untyped/core/specs.cljc | 9 +++-- .../quantum/untyped/core/type/defnt.cljc | 26 +++++++------ 4 files changed, 46 insertions(+), 42 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 679f4680..5b825641 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -346,13 +346,12 @@ ~'[t/any?])} ([~'x00__] (ifs ((Array/get ~'>boolean|__0|input0|types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.boolean>boolean" - '>boolean|__0|0) ~'x00__) + (.invoke ~(tag (str `boolean>boolean) '>boolean|__0|0) ~'x00__) ((Array/get ~'>boolean|__1|input0|types 0) ~'x00__) - (.invoke ~(tag (str `Object>boolean) '>boolean|__1|0) ~'x00__) + (.invoke ~(tag (str `Object>boolean) '>boolean|__1|0) ~'x00__) ;; TODO eliminate this check because it's not needed (`t/any?`) ((Array/get ~'>boolean|__2|input0|types 0) ~'x00__) - (.invoke ~(tag (str `Object>boolean) '>boolean|__2|0) ~'x00__) + (.invoke ~(tag (str `Object>boolean) '>boolean|__2|0) ~'x00__) (unsupported! `>boolean [~'x00__] 0)))))) :cljs ($ (do (defn ~'>boolean [~'x] @@ -910,22 +909,22 @@ ~'[(t/ref (t/isa? Number))])} ([~'x00__] (ifs - ((Array/get ~'>long*|__0|input0|types 0) x00__) - (.invoke >long*|__0|0 x00__) - ((Array/get ~'>long*|__0|input0|types 1) x00__) - (.invoke >long*|__0|1 x00__) - ((Array/get ~'>long*|__0|input0|types 2) x00__) - (.invoke >long*|__0|2 x00__) - ((Array/get ~'>long*|__0|input0|types 3) x00__) - (.invoke >long*|__0|3 x00__) - ((Array/get ~'>long*|__0|input0|types 4) x00__) - (.invoke >long*|__0|4 x00__) - ((Array/get ~'>long*|__0|input0|types 5) x00__) - (.invoke >long*|__0|5 x00__) - ((Array/get ~'>long*|__0|input0|types 6) x00__) - (.invoke >long*|__0|6 x00__) - ((Array/get ~'>long*|__1|input0|types 0) x00__) - (.invoke >long*|__1|0 x00__) + ((Array/get ~'>long*|__0|input0|types 0) ~'x00__) + (.invoke ~(tag (str `byte>long) '>long*|__0|0) ~'x00__) + ((Array/get ~'>long*|__0|input0|types 1) ~'x00__) + (.invoke ~(tag (str `short>long) '>long*|__0|1) ~'x00__) + ((Array/get ~'>long*|__0|input0|types 2) ~'x00__) + (.invoke ~(tag (str `char>long) '>long*|__0|2) ~'x00__) + ((Array/get ~'>long*|__0|input0|types 3) ~'x00__) + (.invoke ~(tag (str `int>long) '>long*|__0|3) ~'x00__) + ((Array/get ~'>long*|__0|input0|types 4) ~'x00__) + (.invoke ~(tag (str `long>long) '>long*|__0|4) ~'x00__) + ((Array/get ~'>long*|__0|input0|types 5) ~'x00__) + (.invoke ~(tag (str `float>long) '>long*|__0|5) ~'x00__) + ((Array/get ~'>long*|__0|input0|types 6) ~'x00__) + (.invoke ~(tag (str `double>long) '>long*|__0|6) ~'x00__) + ((Array/get ~'>long*|__1|input0|types 0) ~'x00__) + (.invoke ~(tag (str `Object>long) '>long*|__1|0) ~'x00__) (unsupported! `>long* [~'x00__] 0)))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index d4aab243..8cd4f2a7 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -330,10 +330,11 @@ (defn fns|code [kind lang args] (assert (= lang #?(:clj :clj :cljs :cljs)) lang) (when (= kind :fn) (println "WARNING: `fn` will ignore spec validation")) - (let [{:keys [:quantum.core.specs/fn|name + (let [{:as args' + :keys [:quantum.core.specs/fn|name :quantum.core.defnt/overloads - :quantum.core.defnt/output-spec - :quantum.core.specs/meta] :as args'} + :quantum.core.defnt/output-spec] + fn|meta :quantum.core.specs/meta} (us/assert-conform (case kind (:defn :defn-) :quantum.core.defnt/defns|code :fn :quantum.core.defnt/fns|code) args) [_ output-spec] output-spec @@ -380,12 +381,13 @@ :fn (us/with-gen-spec (fn [{~ret-sym :ret}] ~ret-sym) (fn [{[~arity-kind-sym ~args-sym] :args}] (case ~arity-kind-sym ~@spec-form|fn))))) + fn|name|with-meta (with-meta fn|name fn|meta) fn-form (case kind :fn (list* 'fn (concat (when (contains? args' :quantum.core.specs/fn|name) - [fn|name]) + [fn|name|with-meta]) overload-forms)) - :defn (list* 'defn fn|name overload-forms) - :defn- (list* 'defn- fn|name overload-forms)) + :defn (list* 'defn fn|name|with-meta overload-forms) + :defn- (list* 'defn- fn|name|with-meta overload-forms)) code `(do ~spec-form ~fn-form)] code)) diff --git a/src-untyped/quantum/untyped/core/specs.cljc b/src-untyped/quantum/untyped/core/specs.cljc index a145de61..521d1439 100644 --- a/src-untyped/quantum/untyped/core/specs.cljc +++ b/src-untyped/quantum/untyped/core/specs.cljc @@ -136,10 +136,11 @@ (dissoc :quantum.core.specs/docstring :quantum.core.specs/pre-meta :quantum.core.specs/post-meta) - (cond-> fn|name - (update :quantum.core.specs/fn|name with-meta - (-> (merge (meta fn|name) pre-meta post-meta) ; TODO use `merge-unique` instead of `:quantum.core.specs/defn|unique-meta` - (cond-> docstring (assoc :doc docstring))))))))) + (update :quantum.core.specs/fn|name with-meta nil) + (assoc :quantum.core.specs/meta + (-> ;; TODO use `merge-unique` instead of `:quantum.core.specs/fn|unique-meta` + (merge (meta fn|name) pre-meta post-meta) + (cond-> docstring (assoc :doc docstring)))))))) (defn fn-like|postchecks|gen [overloads-ident] (s/and (s/conformer diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 7344cf27..1faabc92 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -133,7 +133,8 @@ ;; "global" because they apply to the whole fnt (s/def ::fnt-globals - (s/kv {:fn|name ::uss/fn|name + (s/kv {:fn|meta ::uss/meta + :fn|name ::uss/fn|name :fnt|output-type|form t/any? :fnt|type t/type?})) @@ -599,13 +600,13 @@ c/lcat)))) (defns >dynamic-dispatch-fn|form - [{:as fnt-globals :keys [fn|name _]} ::fnt-globals + [{:as fnt-globals :keys [fn|meta _, fn|name _]} ::fnt-globals {:as opts :keys [gen-gensym _, lang _]} ::opts expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups) i-overload->direct-dispatch-data ::i-overload->direct-dispatch-data] `(defn ~fn|name - {::t/type ~(>dynamic-dispatch-fn|type-decl fnt-globals - expanded-overload-groups-by-fnt-overload)} + ~(assoc fn|meta ::t/type + (>dynamic-dispatch-fn|type-decl fnt-globals expanded-overload-groups-by-fnt-overload)) ~@(->> i-overload->direct-dispatch-data (group-by (fn-> :i-arg->input-types-decl count)) (map (fn [[arg-ct direct-dispatch-data-for-arity]] @@ -649,10 +650,11 @@ arg-types|form arg-types, pre-type|form pre-type, post-type|form post-type))) (defns fnt|code [kind #{:fn :defn}, lang ::lang, args _] - (let [{:keys [:quantum.core.specs/fn|name + (let [{:as args' + :keys [:quantum.core.specs/fn|name :quantum.core.defnt/overloads - :quantum.core.defnt/output-spec - :quantum.core.specs/meta] :as args'} + :quantum.core.defnt/output-spec] + fn|meta :quantum.core.specs/meta} (s/validate args (case kind :defn :quantum.core.defnt/defnt :fn :quantum.core.defnt/fnt)) symbolic-analysis? false ; TODO parameterize this @@ -660,14 +662,14 @@ fnt|output-type (eval fnt|output-type|form) gen-gensym-base (ufgen/>reproducible-gensym|generator) gen-gensym (fn [x] (symbol (str (gen-gensym-base x) "__"))) - inline? (s/validate (-> fn|name core/meta :inline) (t/? t/boolean?)) - fn|name (if inline? + inline? (s/validate (:inline fn|meta) (t/? t/boolean?)) + fn|meta (if inline? (do (ulog/pr :warn "requested `:inline`; ignoring until feature is implemented") - (update-meta fn|name dissoc :inline)) - fn|name) + (dissoc fn|meta :inline)) + fn|meta) overloads-data (->> overloads (mapv #(fnt|parsed-overload>overload-data % fnt|output-type))) fnt|type (fnt|overloads-data>type overloads-data fnt|output-type) - fnt-globals (kw-map fn|name fnt|output-type|form fnt|type) + fnt-globals (kw-map fn|meta fn|name fnt|output-type|form fnt|type) opts (kw-map gen-gensym lang symbolic-analysis?) expanded-overload-groups-by-fnt-overload (->> overloads-data From e19d77ab94136da36a90759b57ba3f41e2134d4a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 5 Sep 2018 22:39:22 -0600 Subject: [PATCH 228/810] Fixed up test --- src-dev/quantum/core/defnt_equivalences.cljc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 5b825641..e51badd4 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -949,10 +949,10 @@ expected (case (env-lang) :clj ($ (do (def ~'defnt-reference|__0|0 - (reify* [>long] (~'invoke [~'_0__] ~'(>long* 1)))) + (reify* [>long] (~(tag "long" 'invoke) [~'_0__] ~'(>long* 1)))) (defn ~'defnt-reference {::t/type (t/fn t/any? [])} - ([] (.invoke ~'defnt-reference|__0|0))))))] + ([] (.invoke ~(tag (str `>long) 'defnt-reference|__0|0)))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) From 0f019edb8c86a1b035a13014f5c3dd4513845d0b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 5 Sep 2018 22:41:22 -0600 Subject: [PATCH 229/810] Recursion works :D --- src-dev/quantum/core/defnt_equivalences.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index e51badd4..b5a8bc24 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -1398,7 +1398,7 @@ ;; TODO recursion #_([xs (t/isa? java.util.Map)] (seq (.entrySet xs))) ;; TODO use `t/assume` - ([xs t/array? > (t/* #_t/assume (t/? (t/isa? ISeq)))] + ([xs t/array? > (t/* (t/? (t/isa? ISeq)))] ;; We do this only because `clojure.lang.ArraySeq/createFromObject` is private but ;; perhaps it would be wise from a performance perspective to bypass that with e.g. a fast ;; version of reflection From 3d134d68c8689528a74fbbcb53aeff4e4f341574 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 5 Sep 2018 22:41:51 -0600 Subject: [PATCH 230/810] A little premature but still! Close! --- src-dev/quantum/core/defnt_equivalences.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index b5a8bc24..16a1210f 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -1396,7 +1396,7 @@ ([xs t/iterable?] (clojure.lang.RT/chunkIteratorSeq (.iterator xs))) ([xs t/char-seq?] (clojure.lang.StringSeq/create xs)) ;; TODO recursion - #_([xs (t/isa? java.util.Map)] (seq (.entrySet xs))) + ([xs (t/isa? java.util.Map)] (seq (.entrySet xs))) ;; TODO use `t/assume` ([xs t/array? > (t/* (t/? (t/isa? ISeq)))] ;; We do this only because `clojure.lang.ArraySeq/createFromObject` is private but From 6a7ca7ce299ee14cfd3cada1b64ea71773bfab7a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 5 Sep 2018 22:47:54 -0600 Subject: [PATCH 231/810] Okay but *now* recursion works! :D --- src-dev/quantum/core/defnt_equivalences.cljc | 3 ++- src-untyped/quantum/untyped/core/type/defnt.cljc | 6 ++++-- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 16a1210f..166dd707 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -1395,7 +1395,6 @@ (t/isa? Seqable))] (.seq xs)) ([xs t/iterable?] (clojure.lang.RT/chunkIteratorSeq (.iterator xs))) ([xs t/char-seq?] (clojure.lang.StringSeq/create xs)) - ;; TODO recursion ([xs (t/isa? java.util.Map)] (seq (.entrySet xs))) ;; TODO use `t/assume` ([xs t/array? > (t/* (t/? (t/isa? ISeq)))] @@ -1405,6 +1404,8 @@ (clojure.core/seq xs)))) ) +(seq (quantum.untyped.core.data.map/!hash-map 1 2)) + ;; ----- expanded code ----- ;; #?(:clj diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 1faabc92..8ff43f60 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -243,11 +243,13 @@ arg-classes (s/vec-of t/class?) varargs-binding _ > ::expanded-overload] - (let [env (->> (zipmap arg-bindings arg-types|satisfying-primitivization) + (let [;; Not sure if `nil` is the right approach for the value + recursive-ast-node-reference (uast/symbol {} fn|name nil fnt|type) + env (->> (zipmap arg-bindings arg-types|satisfying-primitivization) (c/map' (fn [[arg-binding arg-type]] [arg-binding (uast/unbound nil arg-binding arg-type)])) ;; To support recursion - (<- (assoc fn|name fnt|type))) + (<- (assoc fn|name recursive-ast-node-reference))) analyzed (uana/analyze env (ufgen/?wrap-do body-codelist|pre-analyze)) arg-classes|simplest (->> arg-classes (c/map class>simplest-class)) hint-arg|fn (fn [i arg-binding] From 84b0e860eb24e2e3d1cd39f770332fae0dbae4dc Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 5 Sep 2018 23:07:33 -0600 Subject: [PATCH 232/810] More recursion tests work! --- resources-dev/defnt.cljc | 1 - src-dev/quantum/core/defnt_equivalences.cljc | 24 ++++++++++--------- src-untyped/quantum/untyped/core/analyze.cljc | 5 ++-- 3 files changed, 16 insertions(+), 14 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 48245e55..5c163762 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -13,7 +13,6 @@ Note that `;; TODO TYPED` is the annotation we're using - declare-fnt (a way to do protocols/interfaces) - extend-fnt! - defnt - - recursion by adding the function's name and type to the local bindings (env) - handle varargs - do the defnt-equivalences - a linting warning that you can narrow the type to whatever the deduced type is from whatever diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 166dd707..da5effb3 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -112,8 +112,8 @@ (deftest test|name (let [actual (macroexpand ' - (defnt #_:inline name|test - ([x t/string? > t/string?] x) + (defnt #_:inline name|test > t/string? + ([x t/string?] x) #?(:clj ([x (t/isa? Named) > (* t/string?)] (.getName x)) :cljs ([x (t/isa? INamed) > (* t/string?)] (-name x))))) expected @@ -144,8 +144,8 @@ (defn ~'name|test {::t/type - (t/fn t/any? - ~'[t/string? :> t/string?] + (t/fn ~'t/string? + ~'[t/string?] ~'[(t/isa? Named) :> (* t/string?)])} ([~'x00__] (ifs ((Array/get ~'name|test|__0|input0|types 0) ~'x00__) @@ -958,6 +958,9 @@ (eval actual) (eval '(do (is (identical? (defnt-reference) 1))))))) +(defnt >big-integer > (t/isa? java.math.BigInteger) + ([x t/ratio? > (* (t/isa? java.math.BigInteger))] (.bigIntegerValue x))) + ;; NOTE would use `>long` but that's already an interface (deftest test|>long-checked (let [actual @@ -979,8 +982,7 @@ ;; TODO add this back in #_(fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] (.longValue x)) - ;; TODO support recursion - #_([x t/ratio?] (>long-checked (.bigIntegerValue x))) + ([x t/ratio?] (-> x >big-integer >long-checked)) ([x (t/value true)] 1) ([x (t/value false)] 0) ([x t/string?] (Long/parseLong x)) @@ -1364,8 +1366,9 @@ (macroexpand ' (defnt #_:inline get - ([xs t/array? , k (t/numerically t/int?)] (#?(:clj Array/get :cljs aget) xs k)) - ([xs t/string?, k (t/numerically t/int?)] (.charAt xs k)) + ;; TODO `t/numerically + ([xs t/array? , k #_(t/numerically t/int?)] (#?(:clj Array/get :cljs aget) xs k)) + ([xs t/string?, k #_(t/numerically t/int?)] (.charAt xs k)) ([xs !+vector?, k t/any?] #?(:clj (.valAt xs k) :cljs (TODO)))) ) ;; ----- expanded code ----- ;; @@ -1391,12 +1394,10 @@ > (t/? (t/isa? ISeq)) ([xs t/nil?] nil) ([xs (t/isa? ASeq)] xs) - ([xs (t/or (t/isa? LazySeq) - (t/isa? Seqable))] (.seq xs)) + ([xs (t/or (t/isa? LazySeq) (t/isa? Seqable))] (.seq xs)) ([xs t/iterable?] (clojure.lang.RT/chunkIteratorSeq (.iterator xs))) ([xs t/char-seq?] (clojure.lang.StringSeq/create xs)) ([xs (t/isa? java.util.Map)] (seq (.entrySet xs))) - ;; TODO use `t/assume` ([xs t/array? > (t/* (t/? (t/isa? ISeq)))] ;; We do this only because `clojure.lang.ArraySeq/createFromObject` is private but ;; perhaps it would be wise from a performance perspective to bypass that with e.g. a fast @@ -1404,6 +1405,7 @@ (clojure.core/seq xs)))) ) +;; Works! (seq (quantum.untyped.core.data.map/!hash-map 1 2)) ;; ----- expanded code ----- ;; diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 37749545..6e2bfc6a 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -451,8 +451,9 @@ (if (or (empty? dispatchable-overloads-seq') (c/contains? non-dispatchable-or-types)) (err! "No overloads satisfy the inputs, whether direct or dynamic" - {:caller caller|node - :inputs body}) + {:caller caller|node :inputs body + :failing-input-form (:form input|analyzed) + :failing-input-type (:type input|analyzed)}) (assoc ret :dispatchable-overloads-seq dispatchable-overloads-seq' :dispatch-type :dynamic))) (err! "Cannot currently do a dynamic dispatch on a non-`t/or` input type" From 4fc17390f5e1a4e1b31a8ad1840b10bd9e1b60b5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 5 Sep 2018 23:20:35 -0600 Subject: [PATCH 233/810] quantum.core.type -> quantum.core.type-old --- resources-dev/defnt.cljc | 2 +- src-dev/quantum/core/defnt_equivalences.cljc | 6 +- src/quantum/ai/ml/classification.cljc | 2 +- src/quantum/ai/ml/core.cljc | 2 +- src/quantum/ai/ml/validation.cljc | 2 +- src/quantum/apis/amazon/cloud_drive/core.cljc | 2 +- src/quantum/apis/google/contacts.cljc | 2 +- src/quantum/apis/google/drive/core.cljc | 3 +- src/quantum/apis/quip/core.cljc | 6 +- src/quantum/audio/midi.clj | 3 +- src/quantum/browser/core.cljc | 2 +- src/quantum/compile/transpile/from/java.cljc | 3 +- src/quantum/compile/transpile/to/core.cljc | 8 +- src/quantum/core/async.cljc | 2 +- src/quantum/core/async/pool.cljc | 3 +- src/quantum/core/collections.cljc | 4 +- src/quantum/core/collections/core.cljc | 2 +- .../core/collections/differential.cljc | 2 +- src/quantum/core/collections/generative.cljc | 2 +- src/quantum/core/collections/map_filter.cljc | 2 +- src/quantum/core/collections/sociative.cljc | 2 +- src/quantum/core/convert/primitive.cljc | 2 +- src/quantum/core/data/bytes.cljc | 2 +- src/quantum/core/data/complex/json.cljc | 2 +- src/quantum/core/io/core.cljc | 2 +- src/quantum/core/loops.cljc | 2 +- src/quantum/core/meta/dev.cljc | 2 +- src/quantum/core/meta/profile.cljc | 2 +- src/quantum/core/nondeterministic.cljc | 2 +- src/quantum/core/numeric/operators.cljc | 2 +- src/quantum/core/reducers.cljc | 2 +- src/quantum/core/reducers/fold.cljc | 2 +- src/quantum/core/reducers/reduce.cljc | 2 +- src/quantum/core/refs.cljc | 2 +- src/quantum/core/resources.cljc | 2 +- src/quantum/core/string.cljc | 2 +- src/quantum/core/telemetry.cljc | 2 +- src/quantum/core/thread.cljc | 4 +- src/quantum/core/type.cljc | 265 +----------------- src/quantum/core/type_old.cljc | 264 +++++++++++++++++ src/quantum/db/datomic.cljc | 2 +- src/quantum/db/datomic/core.cljc | 2 +- src/quantum/location/climate.cljc | 2 +- src/quantum/net/websocket.cljc | 2 +- src/quantum/numeric/core.cljc | 2 +- src/quantum/numeric/tensors.cljc | 2 +- src/quantum/security/cryptography.cljc | 3 +- src/quantum/ui/components.cljc | 2 +- test-dev/incremental.clj | 4 +- test/quantum/test/core/collections.cljc | 2 +- test/quantum/test/core/type.cljc | 70 ----- 51 files changed, 321 insertions(+), 399 deletions(-) create mode 100644 src/quantum/core/type_old.cljc diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 5c163762..b2895ce7 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -35,7 +35,7 @@ Note that `;; TODO TYPED` is the annotation we're using - quantum.core.logic - quantum.core.fn - quantum.core.data.map - - quantum.core.type + - quantum.core.type-old - quantum.core.vars - With `defnt`, protocols and interfaces aren't needed. You can just create `t/fn`s that you can diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index da5effb3..32e95230 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -1399,9 +1399,9 @@ ([xs t/char-seq?] (clojure.lang.StringSeq/create xs)) ([xs (t/isa? java.util.Map)] (seq (.entrySet xs))) ([xs t/array? > (t/* (t/? (t/isa? ISeq)))] - ;; We do this only because `clojure.lang.ArraySeq/createFromObject` is private but - ;; perhaps it would be wise from a performance perspective to bypass that with e.g. a fast - ;; version of reflection + ;; We do this only because `clojure.lang.ArraySeq/createFromObject` is private but perhaps it + ;; would be wise from a performance perspective to bypass that with e.g. a fast version of + ;; reflection (clojure.core/seq xs)))) ) diff --git a/src/quantum/ai/ml/classification.cljc b/src/quantum/ai/ml/classification.cljc index 1abd816b..8f66fce2 100644 --- a/src/quantum/ai/ml/classification.cljc +++ b/src/quantum/ai/ml/classification.cljc @@ -27,7 +27,7 @@ [quantum.core.nondeterministic :as rand] [quantum.core.thread :as thread :refer [async]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [val?]] [quantum.core.vars :as var :refer [defalias]] diff --git a/src/quantum/ai/ml/core.cljc b/src/quantum/ai/ml/core.cljc index b8d2e275..a2b45fd4 100644 --- a/src/quantum/ai/ml/core.cljc +++ b/src/quantum/ai/ml/core.cljc @@ -12,7 +12,7 @@ :refer [fn1]] [quantum.core.macros :refer [defnt]] - [quantum.core.type :as t])) + [quantum.core.type-old :as t])) (dv/def instances (fn1 t/sequential?)) ; TODO better validation (dv/def targets (fn1 t/sequential?)) ; TODO better validation diff --git a/src/quantum/ai/ml/validation.cljc b/src/quantum/ai/ml/validation.cljc index a1871412..7477dcda 100644 --- a/src/quantum/ai/ml/validation.cljc +++ b/src/quantum/ai/ml/validation.cljc @@ -23,7 +23,7 @@ [quantum.core.nondeterministic :as rand] [quantum.core.numeric :as num] [quantum.core.spec :as s] - [quantum.core.type :as t] + [quantum.core.type-old :as t] [quantum.core.vars :as var :refer [defalias]] [quantum.numeric.statistics.core :as stat])) diff --git a/src/quantum/apis/amazon/cloud_drive/core.cljc b/src/quantum/apis/amazon/cloud_drive/core.cljc index 5179c9c7..de70370c 100644 --- a/src/quantum/apis/amazon/cloud_drive/core.cljc +++ b/src/quantum/apis/amazon/cloud_drive/core.cljc @@ -21,7 +21,7 @@ :include-macros true] [quantum.core.spec :as s :refer [validate]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [val?]]) #?(:cljs (:require-macros diff --git a/src/quantum/apis/google/contacts.cljc b/src/quantum/apis/google/contacts.cljc index ad7bef29..31c5e3d2 100644 --- a/src/quantum/apis/google/contacts.cljc +++ b/src/quantum/apis/google/contacts.cljc @@ -6,7 +6,7 @@ [quantum.core.collections :as coll :refer [#?@(:clj [assoc!])] #?@(:cljs [:refer-macros [assoc!]])] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [val?]] [quantum.apis.google.auth :as gauth])) diff --git a/src/quantum/apis/google/drive/core.cljc b/src/quantum/apis/google/drive/core.cljc index 2dec03a1..225be08d 100644 --- a/src/quantum/apis/google/drive/core.cljc +++ b/src/quantum/apis/google/drive/core.cljc @@ -21,7 +21,7 @@ [quantum.core.paths :as path] [quantum.core.spec :as s :refer [validate]] - [quantum.core.type :as t] + [quantum.core.type-old :as t] [quantum.core.vars :as var] [quantum.apis.google.auth :as gauth])) @@ -529,4 +529,3 @@ ; :maxApertureValue ; The smallest f-number of the lens at the focal length used to create the photo (APEX value). ; :subjectDistance ; The distance to the subject of the photo, in meters. ; :lens ""}}) ; The lens used to create the photo. - diff --git a/src/quantum/apis/quip/core.cljc b/src/quantum/apis/quip/core.cljc index b2de2df8..79953589 100644 --- a/src/quantum/apis/quip/core.cljc +++ b/src/quantum/apis/quip/core.cljc @@ -1,8 +1,8 @@ (ns quantum.apis.quip.core #_(:require-quantum [:lib http auth]) - #_(:require [hickory.core :as hp] - [hickory.select :as hs] - [quantum.core.type :as t])) + #_(:require [hickory.core :as hp] + [hickory.select :as hs] + [quantum.core.type-old :as t])) #_(defn request! [req] (http/request! diff --git a/src/quantum/audio/midi.clj b/src/quantum/audio/midi.clj index 722f65da..f54a34be 100644 --- a/src/quantum/audio/midi.clj +++ b/src/quantum/audio/midi.clj @@ -28,7 +28,7 @@ [quantum.core.convert :as conv] [quantum.measure.convert :refer [convert]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [val?]] [quantum.core.async.pool :as pool] [quantum.db.datomic.core :as dbc]) ; TODO just for the spec @@ -490,4 +490,3 @@ join)) (apply (partial mapv (partial apply str))) (str/join "\n"))) - diff --git a/src/quantum/browser/core.cljc b/src/quantum/browser/core.cljc index e1037b49..094eabee 100644 --- a/src/quantum/browser/core.cljc +++ b/src/quantum/browser/core.cljc @@ -24,7 +24,7 @@ :refer [join map+]] [quantum.core.macros :refer [defnt]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [val?]]) #?(:clj (:import ;(com.teamdev.jxbrowser.chromium.javafx BrowserView) diff --git a/src/quantum/compile/transpile/from/java.cljc b/src/quantum/compile/transpile/from/java.cljc index 1b0ebad1..e648beaf 100644 --- a/src/quantum/compile/transpile/from/java.cljc +++ b/src/quantum/compile/transpile/from/java.cljc @@ -19,7 +19,7 @@ :refer [fn' fn-> fn->> fn1 rcomp]] [quantum.core.logic :as logic :refer [fn= fn-or fn-and whenf whenf1 ifn1 condf1 if-let cond-let]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [val?]] [quantum.core.type.core :as tcore] [quantum.core.match :as m @@ -515,4 +515,3 @@ first (map (ifn1 (fn-and seq? (fn-> first (= 'do)) (fn-> count (= 2))) rest list)) (apply concat)))) - diff --git a/src/quantum/compile/transpile/to/core.cljc b/src/quantum/compile/transpile/to/core.cljc index 5445abf7..a0e3c551 100644 --- a/src/quantum/compile/transpile/to/core.cljc +++ b/src/quantum/compile/transpile/to/core.cljc @@ -20,7 +20,7 @@ whenf1 whenc ifn condfc condpc coll-or]] [quantum.core.macros :as macros :refer [defnt]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [val?]])) ; special-symbol? is a clojure thing @@ -97,10 +97,10 @@ (declare obj-class) -; TODO insert in quantum.core.type +; TODO insert in quantum.core.type-old (def primitive? (partial (fn-not coll?))) ; TODO this is definitely not right -; TODO use quantum.core.type +; TODO use quantum.core.type-old (def primitives-map {(type (long 0)) "long" (type (int 0)) "int" @@ -762,5 +762,3 @@ (map (partial eval-form)) (interpose (if whitespace? ", " ",")) (apply str)))) - - diff --git a/src/quantum/core/async.cljc b/src/quantum/core/async.cljc index 5c60cd64..2f422b1b 100644 --- a/src/quantum/core/async.cljc +++ b/src/quantum/core/async.cljc @@ -38,7 +38,7 @@ [quantum.core.spec :as s :refer [validate]] [quantum.core.system :as sys] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [val?]] [quantum.core.vars :as var :refer [defalias defmalias]] diff --git a/src/quantum/core/async/pool.cljc b/src/quantum/core/async/pool.cljc index 0db40f7f..aa920a83 100644 --- a/src/quantum/core/async/pool.cljc +++ b/src/quantum/core/async/pool.cljc @@ -32,7 +32,7 @@ [quantum.core.resources :as res] [quantum.core.time.core :as time] [quantum.measure.convert :as uconv] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [atom?]] [quantum.core.vars :as var]) #?(:cljs @@ -588,4 +588,3 @@ (if apply? (apply distribute! distributor inputs) (distribute! distributor inputs))))) - diff --git a/src/quantum/core/collections.cljc b/src/quantum/core/collections.cljc index 63d46cf4..eb236efb 100644 --- a/src/quantum/core/collections.cljc +++ b/src/quantum/core/collections.cljc @@ -86,7 +86,7 @@ :refer [setm! swapm! deref !ref]] [quantum.core.string :as str ] [quantum.core.string.format :as sform ] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [lseq? transient? editable? boolean? should-transientize? class]] @@ -109,7 +109,7 @@ #?(:clj (:import java.util.Comparator quantum.core.refs.MutableReference) :cljs (:import goog.string.StringBuffer))) -(defalias val? quantum.core.type/val?) +(defalias val? quantum.core.type-old/val?) #?(:clj (defmacro getf diff --git a/src/quantum/core/collections/core.cljc b/src/quantum/core/collections/core.cljc index 1f2c655f..35680934 100644 --- a/src/quantum/core/collections/core.cljc +++ b/src/quantum/core/collections/core.cljc @@ -44,7 +44,7 @@ :refer [identity*]] [quantum.core.reducers.reduce :as r :refer [reduce reducei]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [class defnt fnt regex? val?]] [quantum.core.type.defs :as tdef] [quantum.core.type.core :as tcore] diff --git a/src/quantum/core/collections/differential.cljc b/src/quantum/core/collections/differential.cljc index f64dda2d..449f4a6b 100644 --- a/src/quantum/core/collections/differential.cljc +++ b/src/quantum/core/collections/differential.cljc @@ -57,7 +57,7 @@ :refer [map+ reduce indexed+]] [quantum.core.vars :as var :refer [defalias]] - [quantum.core.type :as t] + [quantum.core.type-old :as t] [quantum.core.collections.map-filter :refer [ffilteri last-filteri]] [quantum.untyped.core.data diff --git a/src/quantum/core/collections/generative.cljc b/src/quantum/core/collections/generative.cljc index 25c4ef72..059904ac 100644 --- a/src/quantum/core/collections/generative.cljc +++ b/src/quantum/core/collections/generative.cljc @@ -45,7 +45,7 @@ :refer [join]] [quantum.core.logic :refer [whenc->]] - [quantum.core.type :as type + [quantum.core.type-old :as type :refer [should-transientize?]] [quantum.core.loops :as loops :refer [for fortimes]] diff --git a/src/quantum/core/collections/map_filter.cljc b/src/quantum/core/collections/map_filter.cljc index 66155bf8..05485816 100644 --- a/src/quantum/core/collections/map_filter.cljc +++ b/src/quantum/core/collections/map_filter.cljc @@ -49,7 +49,7 @@ :refer[defnt]] [quantum.core.reducers :as red :refer[indexed+ join' reduce defeager]] - [quantum.core.type :as type] + [quantum.core.type-old :as type] [quantum.core.loops :as loop :refer [reducei doseqi lfor]] [quantum.core.vars :as var diff --git a/src/quantum/core/collections/sociative.cljc b/src/quantum/core/collections/sociative.cljc index 37238ca3..331b3886 100644 --- a/src/quantum/core/collections/sociative.cljc +++ b/src/quantum/core/collections/sociative.cljc @@ -54,7 +54,7 @@ :refer [defnt]] [quantum.core.reducers :as red :refer [join partition-all+]] - [quantum.core.type :as type + [quantum.core.type-old :as type :refer [transient? editable?]] [quantum.core.loops :as loops :refer [reduce-pair reduce]])) diff --git a/src/quantum/core/convert/primitive.cljc b/src/quantum/core/convert/primitive.cljc index 1b592d99..c0479c9a 100644 --- a/src/quantum/core/convert/primitive.cljc +++ b/src/quantum/core/convert/primitive.cljc @@ -6,7 +6,7 @@ :refer [&&]] [quantum.core.error :as err :refer [>ex-info]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [defnt]] [quantum.core.vars :as var :refer [defalias]]) diff --git a/src/quantum/core/data/bytes.cljc b/src/quantum/core/data/bytes.cljc index ffd025b6..89c0d4cf 100644 --- a/src/quantum/core/data/bytes.cljc +++ b/src/quantum/core/data/bytes.cljc @@ -14,7 +14,7 @@ :refer [&& >>>]] [quantum.core.fn :as fn :refer [fn1]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [val?]]) #?(:clj (:import java.util.Arrays))) diff --git a/src/quantum/core/data/complex/json.cljc b/src/quantum/core/data/complex/json.cljc index 8e851804..c89f4bcb 100644 --- a/src/quantum/core/data/complex/json.cljc +++ b/src/quantum/core/data/complex/json.cljc @@ -12,7 +12,7 @@ :refer [<- fn1]] [quantum.core.logic :refer [whenp]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [val?]])) ; 2.888831 ms for Cheshire (on what?) vs. clojure.data.json : 7.036831 ms diff --git a/src/quantum/core/io/core.cljc b/src/quantum/core/io/core.cljc index 5f71f104..5e5e1b95 100644 --- a/src/quantum/core/io/core.cljc +++ b/src/quantum/core/io/core.cljc @@ -24,7 +24,7 @@ [quantum.core.paths :as p :refer [path]] [quantum.core.resources :as res] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [svector?]] [quantum.core.vars :as var :refer [defalias]] diff --git a/src/quantum/core/loops.cljc b/src/quantum/core/loops.cljc index af090c16..28bd2253 100644 --- a/src/quantum/core/loops.cljc +++ b/src/quantum/core/loops.cljc @@ -25,7 +25,7 @@ :refer [map+]] [quantum.core.refs :as refs :refer [deref reset! !long]] - [quantum.core.type :as type] + [quantum.core.type-old :as type] [quantum.untyped.core.reducers :as ured] [quantum.core.vars :as var :refer [defalias]]) diff --git a/src/quantum/core/meta/dev.cljc b/src/quantum/core/meta/dev.cljc index 6ccf43d2..ea058205 100644 --- a/src/quantum/core/meta/dev.cljc +++ b/src/quantum/core/meta/dev.cljc @@ -10,7 +10,7 @@ :refer [catch-all]] [quantum.core.macros :refer [defnt]] - [quantum.core.type :as t] + [quantum.core.type-old :as t] [quantum.core.collections :as coll :refer [map+ map-vals+ cat+ contains? filter+ filter-keys+ filter-vals+ remove+ keys+ join seq-and]])) diff --git a/src/quantum/core/meta/profile.cljc b/src/quantum/core/meta/profile.cljc index 47c9f337..c6bfd2cc 100644 --- a/src/quantum/core/meta/profile.cljc +++ b/src/quantum/core/meta/profile.cljc @@ -15,7 +15,7 @@ :refer [fn-or fn-and]] [quantum.core.vars :as var :refer [defalias]] - [quantum.core.type :as t]) + [quantum.core.type-old :as t]) #?(:clj (:import com.carrotsearch.sizeof.RamUsageEstimator quanta.ClassIntrospector))) diff --git a/src/quantum/core/nondeterministic.cljc b/src/quantum/core/nondeterministic.cljc index 57ac6f27..590b4b10 100644 --- a/src/quantum/core/nondeterministic.cljc +++ b/src/quantum/core/nondeterministic.cljc @@ -27,7 +27,7 @@ :refer [>ex-info TODO throw-unless]] [quantum.core.macros :as macros :refer [defnt]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [regex?]] [quantum.core.logic :as logic :refer [splice-or condf1 whenc default]] diff --git a/src/quantum/core/numeric/operators.cljc b/src/quantum/core/numeric/operators.cljc index 378808c9..c5781d63 100644 --- a/src/quantum/core/numeric/operators.cljc +++ b/src/quantum/core/numeric/operators.cljc @@ -16,7 +16,7 @@ :refer [numerator denominator]] [quantum.core.numeric.convert :as conv :refer [->bigint #?@(:clj [->big-integer])]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [val?]] [quantum.core.vars :refer [defalias #?@(:clj [defmalias])]] diff --git a/src/quantum/core/reducers.cljc b/src/quantum/core/reducers.cljc index cdc96da4..7fdb9468 100644 --- a/src/quantum/core/reducers.cljc +++ b/src/quantum/core/reducers.cljc @@ -39,7 +39,7 @@ [quantum.core.numeric :as num] [quantum.core.refs :as refs :refer [! deref reset! volatile atom*]] - [quantum.core.type :as type + [quantum.core.type-old :as type :refer [instance+? lseq?]] [quantum.core.reducers.reduce :as red :refer [transformer]] diff --git a/src/quantum/core/reducers/fold.cljc b/src/quantum/core/reducers/fold.cljc index 91eb6309..e5241301 100644 --- a/src/quantum/core/reducers/fold.cljc +++ b/src/quantum/core/reducers/fold.cljc @@ -32,7 +32,7 @@ :refer [defnt]] [quantum.core.reducers.reduce :as red :refer [reduce]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [lseq? editable? ->joinable]] [quantum.untyped.core.reducers #?@(:cljs [:refer [Transformer]])]) diff --git a/src/quantum/core/reducers/reduce.cljc b/src/quantum/core/reducers/reduce.cljc index 16ab063d..349cc1f7 100644 --- a/src/quantum/core/reducers/reduce.cljc +++ b/src/quantum/core/reducers/reduce.cljc @@ -30,7 +30,7 @@ :refer [defnt]] [quantum.core.refs :as refs :refer [deref !boolean !long ! reset!]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [editable? val?]] [quantum.core.type.defs #?@(:cljs [:refer [Transformer]])] diff --git a/src/quantum/core/refs.cljc b/src/quantum/core/refs.cljc index c9f2a476..28e73cae 100644 --- a/src/quantum/core/refs.cljc +++ b/src/quantum/core/refs.cljc @@ -15,7 +15,7 @@ :refer [TODO]] [quantum.core.macros :refer [case-env defnt #?(:clj defnt') env-lang]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [val?]] [quantum.core.type.defs :as tdefs] [quantum.untyped.core.identification :as uident] diff --git a/src/quantum/core/resources.cljc b/src/quantum/core/resources.cljc index 643e98a8..7b7fff7d 100644 --- a/src/quantum/core/resources.cljc +++ b/src/quantum/core/resources.cljc @@ -22,7 +22,7 @@ [quantum.core.macros :as macros :refer [defnt]] [quantum.core.async :as async] - [quantum.core.type :as type + [quantum.core.type-old :as type :refer [atom? val?]] [quantum.core.spec :as s :refer [validate]]) diff --git a/src/quantum/core/string.cljc b/src/quantum/core/string.cljc index cdee7f8a..e0d58c52 100644 --- a/src/quantum/core/string.cljc +++ b/src/quantum/core/string.cljc @@ -34,7 +34,7 @@ [quantum.core.string.regex :as regex] [quantum.core.vars :as var :refer [defalias]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [val?]]) #?(:cljs (:require-macros diff --git a/src/quantum/core/telemetry.cljc b/src/quantum/core/telemetry.cljc index a5a6394e..74632aae 100644 --- a/src/quantum/core/telemetry.cljc +++ b/src/quantum/core/telemetry.cljc @@ -11,7 +11,7 @@ :refer [whenf]] [quantum.core.resources :as res] [quantum.core.system :as sys] - [quantum.core.type :as t])) + [quantum.core.type-old :as t])) #_(t/def ::offloader keyword? "The offloader implementation to use") diff --git a/src/quantum/core/thread.cljc b/src/quantum/core/thread.cljc index 074566ef..de20a5ef 100644 --- a/src/quantum/core/thread.cljc +++ b/src/quantum/core/thread.cljc @@ -28,7 +28,7 @@ :refer [defnt]] [quantum.core.spec :as s :refer [validate]] - [quantum.core.type :as type + [quantum.core.type-old :as type :refer [boolean? val?]] [quantum.core.time.core :as time] [quantum.core.cache @@ -685,5 +685,3 @@ ; (whenf ~millis nil? (fn' 500)) ; (whenf ~n-times nil? (fn' 6)) ; #(update-out-str-with! ~out-str baos#))))) - - diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index d8551830..44628396 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -1,264 +1 @@ -(ns - ^{:doc "Type-checking predicates, 'transientization' checks, class aliases, etc." - :attribution "alexandergunnarson"} - quantum.core.type - (:refer-clojure :exclude - [vector? map? set? associative? seq? seqable? string? fn? map-entry? boolean? - double? decimal? - nil? char? number? integer? float? - sequential? indexed? list? coll? - symbol? keyword?, array?, record?, var?, counted?, bytes? - identity - class type - ancestors descendants, supers bases, isa? instance?, derive underive]) - (:require - [clojure.core :as core] - [quantum.core.analyze.clojure.core :as ana] - [quantum.core.classes :as classes] - [quantum.core.data.vector :as vec] - [quantum.core.fn :as fn - :refer [fn1 fnl mfn fn->]] - [quantum.core.logic :as logic - :refer [fn-and whenf1]] - [quantum.core.macros :as macros - :refer [defnt #?(:clj defnt')]] - [quantum.core.type.core :as tcore] - [quantum.core.vars :as var - :refer [defalias]] - [quantum.untyped.core.data :as udata] - [quantum.untyped.core.refs :as uref]) -#?(:cljs - (:require-macros - [quantum.core.type :as self - :refer [should-transientize? boolean?]]))) - -; TODO: Should include typecasting? (/cast/) - -; ===== HIERARCHY ===== ; - -#?(:clj (defalias ancestors core/ancestors)) -#?(:clj (defalias descendants core/descendants)) - -#?(:clj (defalias supers core/supers )) -#?(:clj (defalias bases core/bases )) - - (defalias isa? core/isa? ) - (defalias instance? core/instance?) - -#?(:clj (defalias derive core/derive )) -#?(:clj (defalias underive core/underive )) - -(def class #?(:clj core/class :cljs core/type)) -(defalias type core/type) - -#?(:clj (def instance+? instance?) - :cljs - (defn instance+? - {:todo #{"try-catch in something this basic is a performance issue"}} - [c x] ; inline this? - (try - (instance? c x) - (catch js/TypeError _ - (try (satisfies? c x)))))) - -#?(:clj (defalias static-cast-depth ana/static-cast-depth)) - - (def val? some?) - - ; TODO for JS, primitives (function, array, number, string) aren't covered by these - -#?(:clj (defnt' prim-long? ([^long x] true) - ([#{boolean byte char int float double Object} x] false))) ; TODO #{(- prim? long) Object} - - (defnt integer? - "Whether x is integer-like (primitive/boxed integer, BigInteger, etc.)." - ([^integer? obj] true) ([^default obj] false)) -#?(:clj (defnt double? ([^double x] true) ([^default x] false)) - :cljs (do (defalias double? core/number?) ; TODO fix - (defalias double?-protocol double?))) -#?(:clj (defnt float? ([^float x] true) ([^default x] false)) - :cljs (do (defalias float? core/number?) ; TODO fix - (defalias float?-protocol float?))) - (defnt number? ([^number? x] true) ([^default x] false)) - - (defnt boolean? ([^boolean x] true) ([^default x] false)) - - (defnt bigint? ([^bigint? x] true) ([^default x] false)) - - (defnt byte-array? ([^byte-array? x] true) ([^default x] false)) - (defnt bytes? ([^bytes? x] true) ([^default x] false)) - (defnt double-array? ([^double-array? x] true) ([^default x] false)) - (defnt doubles? ([^doubles? x] true) ([^default x] false)) -#?(:clj (defnt array-2d? ([^array-2d? x] true) ([^default x] false))) - (defnt array? - ([^array? x] true) - ([x] #?(:clj (-> x class .isArray) ; Have to use reflection here because we can't check *ALL* possible array types in a `defnt` - :cljs (-> x core/array?)))) - - (defnt svector? ([^svector? x] true) ([^default x] false)) - (defnt +vector? ([^+vector? x] true) ([^default x] false)) - (defnt !+vector? ([^!+vector? x] true) ([^default x] false)) - (defnt ?!+vector? ([^?!+vector? x] true) ([^default x] false)) - (defnt !vector? ([^!vector? x] true) ([^default x] false)) - (defnt vector? ([^vector? x] true) ([^default x] false)) - - (defnt +array-map? ([^+array-map? x] true) ([^default x] false)) - (defnt !+array-map? ([^!+array-map? x] true) ([^default x] false)) - (defnt ?!+array-map? ([^?!+array-map? x] true) ([^default x] false)) - - (defnt +hash-map? ([^+hash-map? x] true) ([^default x] false)) - (defnt !+hash-map? ([^!+hash-map? x] true) ([^default x] false)) - (defnt ?!+hash-map? ([^?!+hash-map? x] true) ([^default x] false)) - (defnt !hash-map? ([^!hash-map? x] true) ([^default x] false)) -#?(:clj (defnt !!hash-map? ([^!!hash-map? x] true) ([^default x] false))) - - (defnt +unsorted-map? ([^+unsorted-map? x] true) ([^default x] false)) - (defnt unsorted-map? ([^unsorted-map? x] true) ([^default x] false)) - (defnt +sorted-map? ([^+sorted-map? x] true) ([^default x] false)) - (defnt sorted-map? ([^sorted-map? x] true) ([^default x] false)) - (defnt +insertion-ordered-map? ([^+insertion-ordered-map? x] true) ([^default x] false)) - (defnt !insertion-ordered-map? ([^!insertion-ordered-map? x] true) ([^default x] false)) - (defnt insertion-ordered-map? ([^insertion-ordered-map? x] true) ([^default x] false)) - (defnt +map? ([^+map? x] true) ([^default x] false)) - (defnt !map? ([^!map? x] true) ([^default x] false)) - (defnt map? ([^map? x] true) ([^default x] false)) - - (defnt +unsorted-set? ([^+unsorted-set? x] true) ([^default x] false)) - (defnt unsorted-set? ([^unsorted-set? x] true) ([^default x] false)) - (defnt +sorted-set? ([^+sorted-set? x] true) ([^default x] false)) - (defnt sorted-set? ([^sorted-set? x] true) ([^default x] false)) - (defnt +set? ([^+set? x] true) ([^default x] false)) - (defnt !set? ([^!set? x] true) ([^default x] false)) - (defnt set? ([^set? x] true) ([^default x] false)) - - (defnt !array-list? ([^!array-list? x] true) ([^default x] false)) - (defnt list? ([^list? x] true) ([^default x] false)) - (defnt +list? ([^+list? x] true) ([^default x] false)) - (defnt +queue? ([^+queue? x] true) ([^default x] false)) - (defnt queue? ([^queue? x] true) ([^default x] false)) - (defnt lseq? ([^lseq? x] true) ([^default x] false)) - (defnt sequential? ([^sequential? x] true) ([^default x] false)) - (defnt counted? ([^counted? x] true) ([^default x] false)) - (defnt transformer? ([^transformer? x] true) ([^default x] false)) - (defalias seqable? udata/seqable?) - -#?(:clj (defnt file? ([^file? x] true) ([^default x] false))) - (defnt regex? ([^regex? x] true) ([^default x] false)) - (defnt editable? ([^editable? x] true) ([^default x] false)) - (defnt transient? ([^transient? x] true) ([^default x] false)) - (defnt indexed? ([^indexed? x] true) ([^default x] false)) - (defnt m2m-chan? ([^m2m-chan? x] true) ([^default x] false)) - -; #?(:cljs (defnt typed-array? ...)) - - (def map-entry? #?(:clj core/map-entry? - :cljs (fn-and vector? (fn-> count (= 2))))) - (defalias atom? uref/atom?) -#?(:clj (defalias var? core/var?)) - ; TODO `ref?`, `future?` - - (defn derefable? [obj] - #?(:clj (instance? clojure.lang.IDeref obj) - :cljs (satisfies? cljs.core/IDeref obj))) - -#?(:clj (def throwable? (partial instance+? java.lang.Throwable ))) - (defnt error? ([#{#?(:clj Throwable - :cljs js/Error)} obj] true) ([obj] false)) -#?(:clj -(defnt interface? - [^java.lang.Class class-] - (.isInterface class-))) - -#?(:clj -(defnt abstract? - [^java.lang.Class class-] - (java.lang.reflect.Modifier/isAbstract (.getModifiers class-)))) - - -#?(:clj (def multimethod? (fnl instance? clojure.lang.MultiFn))) -#?(:clj (def unbound? (fnl instance? clojure.lang.Var$Unbound))) -#?(:clj (def thread? (fnl instance? Thread))) - -#?(:clj -(defn protocol? - "Returns true if an argument is a protocol" - [x] (and (map? x) (-> x :on-interface class?)))) - -#?(:clj (defn namespace? [x] (instance? clojure.lang.Namespace x))) - -#?(:clj -(defn promise? - {:source 'zcaudate/hara.class.checks} - [^Object obj] - (let [^String s (.getName ^Class (type obj))] - (.startsWith s "clojure.core$promise$")))) - -; ===== JAVA ===== - -#?(:clj -(defn enum? - {:source "zcaudate/hara.object.enum"} - [type] - (-> (classes/class->ancestors type) - (get java.lang.Enum)))) - -; ; ======= TRANSIENTS ======= - -; ; TODO this is just intuition. Better to |bench| it -; ; TODO move these vars -(def transient-threshold 3) - -; macro because it will probably be heavily used -#?(:clj -(defmacro should-transientize? [coll] - `(and (editable? ~coll) - (counted? ~coll) - (-> ~coll count (> transient-threshold))))) - -; (def primitive-records -; [{:raw "Z" :symbol 'boolean :string "boolean" :class Boolean/TYPE :container Boolean} -; {:raw "B" :symbol 'byte :string "byte" :class Byte/TYPE :container Byte} -; {:raw "C" :symbol 'char :string "char" :class Character/TYPE :container Character} -; {:raw "I" :symbol 'int :string "int" :class Integer/TYPE :container Integer} -; {:raw "J" :symbol 'long :string "long" :class Long/TYPE :container Long} -; {:raw "F" :symbol 'float :string "float" :class Float/TYPE :container Float} -; {:raw "D" :symbol 'double :string "double" :class Double/TYPE :container Double} -; {:raw "V" :symbol 'void :string "void" :class Void/TYPE :container Void}]) - -#?(:clj (def ^:runtime-eval construct (mfn new))) - -(defnt identity - "Type identity function." - {:todo ["Fix so only immmutable data stuctures have immutable identity fns."]} - ([^+vector? x] vector) - ([^+map? x] hash-map) - ([^+set? x] hash-set)) - -(def +vector?-fn (fn1 +vector?)) -(def +set?-fn (fn1 +set?)) -(def +map?-fn (fn1 +map?)) - -(defnt ->pred - "Gets the type predicate associated with the value passed." - ([^+vector? x] +vector?-fn) - ([^+set? x] +set?-fn) - ([^+map? x] +map?-fn)) - -(defnt ->literal - "Gets the literal value associated with the value passed." - ([^+vector? x] []) - ([^+set? x] #{}) - ([^+map? x] {})) - -(defnt ->base - "Gets the base value associated with the value passed." - ([^+vector? x] (vector)) - ([^+unsorted-set? x] (hash-set)) - ([^+hash-map? x] #?(:clj clojure.lang.PersistentHashMap/EMPTY - :cljs cljs.core.PersistentHashMap.EMPTY)) - ([^default x] (empty x))) - -(defnt ->joinable - ([#{+vector? +hash-map? +unsorted-set?} x] x) - ([#{+array-map?} x] (into (->base x) x)) - ([^default x] x)) +(ns quantum.core.type) diff --git a/src/quantum/core/type_old.cljc b/src/quantum/core/type_old.cljc new file mode 100644 index 00000000..2ac99a44 --- /dev/null +++ b/src/quantum/core/type_old.cljc @@ -0,0 +1,264 @@ +(ns + ^{:doc "Type-checking predicates, 'transientization' checks, class aliases, etc." + :attribution "alexandergunnarson"} + quantum.core.type-old + (:refer-clojure :exclude + [vector? map? set? associative? seq? seqable? string? fn? map-entry? boolean? + double? decimal? + nil? char? number? integer? float? + sequential? indexed? list? coll? + symbol? keyword?, array?, record?, var?, counted?, bytes? + identity + class type + ancestors descendants, supers bases, isa? instance?, derive underive]) + (:require + [clojure.core :as core] + [quantum.core.analyze.clojure.core :as ana] + [quantum.core.classes :as classes] + [quantum.core.data.vector :as vec] + [quantum.core.fn :as fn + :refer [fn1 fnl mfn fn->]] + [quantum.core.logic :as logic + :refer [fn-and whenf1]] + [quantum.core.macros :as macros + :refer [defnt #?(:clj defnt')]] + [quantum.core.type.core :as tcore] + [quantum.core.vars :as var + :refer [defalias]] + [quantum.untyped.core.data :as udata] + [quantum.untyped.core.refs :as uref]) +#?(:cljs + (:require-macros + [quantum.core.type-old :as self + :refer [should-transientize? boolean?]]))) + +; TODO: Should include typecasting? (/cast/) + +; ===== HIERARCHY ===== ; + +#?(:clj (defalias ancestors core/ancestors)) +#?(:clj (defalias descendants core/descendants)) + +#?(:clj (defalias supers core/supers )) +#?(:clj (defalias bases core/bases )) + + (defalias isa? core/isa? ) + (defalias instance? core/instance?) + +#?(:clj (defalias derive core/derive )) +#?(:clj (defalias underive core/underive )) + +(def class #?(:clj core/class :cljs core/type)) +(defalias type core/type) + +#?(:clj (def instance+? instance?) + :cljs + (defn instance+? + {:todo #{"try-catch in something this basic is a performance issue"}} + [c x] ; inline this? + (try + (instance? c x) + (catch js/TypeError _ + (try (satisfies? c x)))))) + +#?(:clj (defalias static-cast-depth ana/static-cast-depth)) + + (def val? some?) + + ; TODO for JS, primitives (function, array, number, string) aren't covered by these + +#?(:clj (defnt' prim-long? ([^long x] true) + ([#{boolean byte char int float double Object} x] false))) ; TODO #{(- prim? long) Object} + + (defnt integer? + "Whether x is integer-like (primitive/boxed integer, BigInteger, etc.)." + ([^integer? obj] true) ([^default obj] false)) +#?(:clj (defnt double? ([^double x] true) ([^default x] false)) + :cljs (do (defalias double? core/number?) ; TODO fix + (defalias double?-protocol double?))) +#?(:clj (defnt float? ([^float x] true) ([^default x] false)) + :cljs (do (defalias float? core/number?) ; TODO fix + (defalias float?-protocol float?))) + (defnt number? ([^number? x] true) ([^default x] false)) + + (defnt boolean? ([^boolean x] true) ([^default x] false)) + + (defnt bigint? ([^bigint? x] true) ([^default x] false)) + + (defnt byte-array? ([^byte-array? x] true) ([^default x] false)) + (defnt bytes? ([^bytes? x] true) ([^default x] false)) + (defnt double-array? ([^double-array? x] true) ([^default x] false)) + (defnt doubles? ([^doubles? x] true) ([^default x] false)) +#?(:clj (defnt array-2d? ([^array-2d? x] true) ([^default x] false))) + (defnt array? + ([^array? x] true) + ([x] #?(:clj (-> x class .isArray) ; Have to use reflection here because we can't check *ALL* possible array types in a `defnt` + :cljs (-> x core/array?)))) + + (defnt svector? ([^svector? x] true) ([^default x] false)) + (defnt +vector? ([^+vector? x] true) ([^default x] false)) + (defnt !+vector? ([^!+vector? x] true) ([^default x] false)) + (defnt ?!+vector? ([^?!+vector? x] true) ([^default x] false)) + (defnt !vector? ([^!vector? x] true) ([^default x] false)) + (defnt vector? ([^vector? x] true) ([^default x] false)) + + (defnt +array-map? ([^+array-map? x] true) ([^default x] false)) + (defnt !+array-map? ([^!+array-map? x] true) ([^default x] false)) + (defnt ?!+array-map? ([^?!+array-map? x] true) ([^default x] false)) + + (defnt +hash-map? ([^+hash-map? x] true) ([^default x] false)) + (defnt !+hash-map? ([^!+hash-map? x] true) ([^default x] false)) + (defnt ?!+hash-map? ([^?!+hash-map? x] true) ([^default x] false)) + (defnt !hash-map? ([^!hash-map? x] true) ([^default x] false)) +#?(:clj (defnt !!hash-map? ([^!!hash-map? x] true) ([^default x] false))) + + (defnt +unsorted-map? ([^+unsorted-map? x] true) ([^default x] false)) + (defnt unsorted-map? ([^unsorted-map? x] true) ([^default x] false)) + (defnt +sorted-map? ([^+sorted-map? x] true) ([^default x] false)) + (defnt sorted-map? ([^sorted-map? x] true) ([^default x] false)) + (defnt +insertion-ordered-map? ([^+insertion-ordered-map? x] true) ([^default x] false)) + (defnt !insertion-ordered-map? ([^!insertion-ordered-map? x] true) ([^default x] false)) + (defnt insertion-ordered-map? ([^insertion-ordered-map? x] true) ([^default x] false)) + (defnt +map? ([^+map? x] true) ([^default x] false)) + (defnt !map? ([^!map? x] true) ([^default x] false)) + (defnt map? ([^map? x] true) ([^default x] false)) + + (defnt +unsorted-set? ([^+unsorted-set? x] true) ([^default x] false)) + (defnt unsorted-set? ([^unsorted-set? x] true) ([^default x] false)) + (defnt +sorted-set? ([^+sorted-set? x] true) ([^default x] false)) + (defnt sorted-set? ([^sorted-set? x] true) ([^default x] false)) + (defnt +set? ([^+set? x] true) ([^default x] false)) + (defnt !set? ([^!set? x] true) ([^default x] false)) + (defnt set? ([^set? x] true) ([^default x] false)) + + (defnt !array-list? ([^!array-list? x] true) ([^default x] false)) + (defnt list? ([^list? x] true) ([^default x] false)) + (defnt +list? ([^+list? x] true) ([^default x] false)) + (defnt +queue? ([^+queue? x] true) ([^default x] false)) + (defnt queue? ([^queue? x] true) ([^default x] false)) + (defnt lseq? ([^lseq? x] true) ([^default x] false)) + (defnt sequential? ([^sequential? x] true) ([^default x] false)) + (defnt counted? ([^counted? x] true) ([^default x] false)) + (defnt transformer? ([^transformer? x] true) ([^default x] false)) + (defalias seqable? udata/seqable?) + +#?(:clj (defnt file? ([^file? x] true) ([^default x] false))) + (defnt regex? ([^regex? x] true) ([^default x] false)) + (defnt editable? ([^editable? x] true) ([^default x] false)) + (defnt transient? ([^transient? x] true) ([^default x] false)) + (defnt indexed? ([^indexed? x] true) ([^default x] false)) + (defnt m2m-chan? ([^m2m-chan? x] true) ([^default x] false)) + +; #?(:cljs (defnt typed-array? ...)) + + (def map-entry? #?(:clj core/map-entry? + :cljs (fn-and vector? (fn-> count (= 2))))) + (defalias atom? uref/atom?) +#?(:clj (defalias var? core/var?)) + ; TODO `ref?`, `future?` + + (defn derefable? [obj] + #?(:clj (instance? clojure.lang.IDeref obj) + :cljs (satisfies? cljs.core/IDeref obj))) + +#?(:clj (def throwable? (partial instance+? java.lang.Throwable ))) + (defnt error? ([#{#?(:clj Throwable + :cljs js/Error)} obj] true) ([obj] false)) +#?(:clj +(defnt interface? + [^java.lang.Class class-] + (.isInterface class-))) + +#?(:clj +(defnt abstract? + [^java.lang.Class class-] + (java.lang.reflect.Modifier/isAbstract (.getModifiers class-)))) + + +#?(:clj (def multimethod? (fnl instance? clojure.lang.MultiFn))) +#?(:clj (def unbound? (fnl instance? clojure.lang.Var$Unbound))) +#?(:clj (def thread? (fnl instance? Thread))) + +#?(:clj +(defn protocol? + "Returns true if an argument is a protocol" + [x] (and (map? x) (-> x :on-interface class?)))) + +#?(:clj (defn namespace? [x] (instance? clojure.lang.Namespace x))) + +#?(:clj +(defn promise? + {:source 'zcaudate/hara.class.checks} + [^Object obj] + (let [^String s (.getName ^Class (type obj))] + (.startsWith s "clojure.core$promise$")))) + +; ===== JAVA ===== + +#?(:clj +(defn enum? + {:source "zcaudate/hara.object.enum"} + [type] + (-> (classes/class->ancestors type) + (get java.lang.Enum)))) + +; ; ======= TRANSIENTS ======= + +; ; TODO this is just intuition. Better to |bench| it +; ; TODO move these vars +(def transient-threshold 3) + +; macro because it will probably be heavily used +#?(:clj +(defmacro should-transientize? [coll] + `(and (editable? ~coll) + (counted? ~coll) + (-> ~coll count (> transient-threshold))))) + +; (def primitive-records +; [{:raw "Z" :symbol 'boolean :string "boolean" :class Boolean/TYPE :container Boolean} +; {:raw "B" :symbol 'byte :string "byte" :class Byte/TYPE :container Byte} +; {:raw "C" :symbol 'char :string "char" :class Character/TYPE :container Character} +; {:raw "I" :symbol 'int :string "int" :class Integer/TYPE :container Integer} +; {:raw "J" :symbol 'long :string "long" :class Long/TYPE :container Long} +; {:raw "F" :symbol 'float :string "float" :class Float/TYPE :container Float} +; {:raw "D" :symbol 'double :string "double" :class Double/TYPE :container Double} +; {:raw "V" :symbol 'void :string "void" :class Void/TYPE :container Void}]) + +#?(:clj (def ^:runtime-eval construct (mfn new))) + +(defnt identity + "Type identity function." + {:todo ["Fix so only immmutable data stuctures have immutable identity fns."]} + ([^+vector? x] vector) + ([^+map? x] hash-map) + ([^+set? x] hash-set)) + +(def +vector?-fn (fn1 +vector?)) +(def +set?-fn (fn1 +set?)) +(def +map?-fn (fn1 +map?)) + +(defnt ->pred + "Gets the type predicate associated with the value passed." + ([^+vector? x] +vector?-fn) + ([^+set? x] +set?-fn) + ([^+map? x] +map?-fn)) + +(defnt ->literal + "Gets the literal value associated with the value passed." + ([^+vector? x] []) + ([^+set? x] #{}) + ([^+map? x] {})) + +(defnt ->base + "Gets the base value associated with the value passed." + ([^+vector? x] (vector)) + ([^+unsorted-set? x] (hash-set)) + ([^+hash-map? x] #?(:clj clojure.lang.PersistentHashMap/EMPTY + :cljs cljs.core.PersistentHashMap.EMPTY)) + ([^default x] (empty x))) + +(defnt ->joinable + ([#{+vector? +hash-map? +unsorted-set?} x] x) + ([#{+array-map?} x] (into (->base x) x)) + ([^default x] x)) diff --git a/src/quantum/db/datomic.cljc b/src/quantum/db/datomic.cljc index 5dc150d6..8db82b18 100644 --- a/src/quantum/db/datomic.cljc +++ b/src/quantum/db/datomic.cljc @@ -31,7 +31,7 @@ [quantum.core.string :as str] [quantum.core.async :as async :refer [go]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [val?]] [quantum.core.vars :as var :refer [defalias defaliases]] diff --git a/src/quantum/db/datomic/core.cljc b/src/quantum/db/datomic/core.cljc index 3c6ee795..44f0ac6a 100644 --- a/src/quantum/db/datomic/core.cljc +++ b/src/quantum/db/datomic/core.cljc @@ -35,7 +35,7 @@ [quantum.core.data.validated :as dv] [quantum.core.spec :as s :refer [validate]] - [quantum.core.type :as t] + [quantum.core.type-old :as t] [quantum.untyped.core.identification :refer [>?name]]) #?(:clj diff --git a/src/quantum/location/climate.cljc b/src/quantum/location/climate.cljc index 463493bb..b29571db 100644 --- a/src/quantum/location/climate.cljc +++ b/src/quantum/location/climate.cljc @@ -33,7 +33,7 @@ [quantum.core.numeric :as num] [quantum.core.reducers :as r] [quantum.core.reflect :as refl] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [val?]] [quantum.measure.convert :as unit]) (:import diff --git a/src/quantum/net/websocket.cljc b/src/quantum/net/websocket.cljc index 011febf1..7981b7cb 100644 --- a/src/quantum/net/websocket.cljc +++ b/src/quantum/net/websocket.cljc @@ -17,7 +17,7 @@ :refer [promise offer! go]] [quantum.core.spec :as s :refer [validate]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [val?]] [quantum.core.resources :as res] #?(:clj [quantum.net.server.router :as router]))) diff --git a/src/quantum/numeric/core.cljc b/src/quantum/numeric/core.cljc index 08766585..a425c2bf 100644 --- a/src/quantum/numeric/core.cljc +++ b/src/quantum/numeric/core.cljc @@ -21,7 +21,7 @@ #?@(:cljs [:refer-macros [*']])] [quantum.core.reducers :refer [multiplex]] - [quantum.core.type :as t] + [quantum.core.type-old :as t] [quantum.core.vars :refer [defalias]] [quantum.core.macros diff --git a/src/quantum/numeric/tensors.cljc b/src/quantum/numeric/tensors.cljc index 5721466c..8420404c 100644 --- a/src/quantum/numeric/tensors.cljc +++ b/src/quantum/numeric/tensors.cljc @@ -39,7 +39,7 @@ :refer [defalias]] [quantum.core.spec :as s :refer [validate]] - [quantum.core.type :as t]) + [quantum.core.type-old :as t]) #?(:clj (:import [org.apache.spark.mllib.linalg BLAS DenseVector] diff --git a/src/quantum/security/cryptography.cljc b/src/quantum/security/cryptography.cljc index b53739e9..fe99bb4c 100644 --- a/src/quantum/security/cryptography.cljc +++ b/src/quantum/security/cryptography.cljc @@ -33,7 +33,7 @@ [quantum.core.string :as str] [quantum.core.spec :as s :refer [validate]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [val?]] [quantum.core.vars :as var :refer [defalias]]) @@ -637,4 +637,3 @@ :aes (aes obj :decrypt password opts) :threefish #?(:clj (threefish obj :decrypt opts) :cljs (throw (>ex-info :unsupported "Threefish unsupported as of yet in CLJS."))))) - diff --git a/src/quantum/ui/components.cljc b/src/quantum/ui/components.cljc index 39646962..26f2e28b 100644 --- a/src/quantum/ui/components.cljc +++ b/src/quantum/ui/components.cljc @@ -22,7 +22,7 @@ [quantum.core.log :as log] [quantum.core.system :as sys :refer [#?@(:cljs [react-native])]] - [quantum.core.type :as t + [quantum.core.type-old :as t :refer [val?]] [quantum.core.async :as async :refer [go]] diff --git a/test-dev/incremental.clj b/test-dev/incremental.clj index e3135879..ce0e1d08 100644 --- a/test-dev/incremental.clj +++ b/test-dev/incremental.clj @@ -8,7 +8,7 @@ ; (require '[quantum.core.error]) ; (require '[quantum.core.function]) ; (require '[quantum.core.logic]) -; (require '[quantum.core.type]) +; (require '[quantum.core.type-old]) ; (require '[quantum.core.numeric]) ; (require '[quantum.core.data.vector]) ; (require '[quantum.core.macros]) @@ -51,4 +51,4 @@ ; (require '[quantum.google.core]) ; (require '[quantum.google.drive.auth]) ; ; 3RD TIER -; (require '[quantum.google.drive.core]) \ No newline at end of file +; (require '[quantum.google.drive.core]) diff --git a/test/quantum/test/core/collections.cljc b/test/quantum/test/core/collections.cljc index 49b2b5ef..11c0b5c6 100644 --- a/test/quantum/test/core/collections.cljc +++ b/test/quantum/test/core/collections.cljc @@ -12,7 +12,7 @@ :refer [fn-or fn-and whenf1]] [quantum.core.refs :refer [!ref]] - [quantum.core.type :as t] + [quantum.core.type-old :as t] [quantum.core.meta.profile :refer [p profile]])) diff --git a/test/quantum/test/core/type.cljc b/test/quantum/test/core/type.cljc index ce052e8f..a94994c0 100644 --- a/test/quantum/test/core/type.cljc +++ b/test/quantum/test/core/type.cljc @@ -1,72 +1,2 @@ (ns quantum.test.core.type (:require [quantum.core.type :as ns])) - -(defn test:instance+? [x]) - - (defn test:byte-array? [x]) -#?(:clj (defn test:bigint? [x])) -#?(:clj (defn test:file? [x])) - (defn test:hash-map? [x]) - (defn test:sorted-map? [x]) - (defn test:boolean? [x]) - (defn test:listy? [x]) - (defn test:vector? [x]) - (defn test:set? [x]) - (defn test:hash-set? [x]) - (defn test:map? [x]) - (defn test:array-list? [x]) - (defn test:queue? [x]) - (defn test:lseq? [x]) - (defn test:pattern? [x]) - (defn test:regex? [x]) - (defn test:editable? [x]) - (defn test:transient? [x]) - (defn test:array? [x]) -#?(:clj (defn test:prim-long? [x])) - (defn test:double? [x]) -#?(:clj (defn test:indexed? [x])) -#?(:clj (defn test:throwable? [x])) - (defn test:error? [x]) -#?(:clj -(defn test:interface? - [^java.lang.Class class-])) - -#?(:clj -(defn test:abstract? - [^java.lang.Class class-])) - -#?(:clj (defn test:multimethod? [x])) - -#?(:clj -(defn test:protocol? - [obj])) - -#?(:clj -(defn test:promise? - [^Object obj])) -; ===== JAVA ===== - -#?(:clj -(defn test:enum? - [type])) - -; ; ======= TRANSIENTS ======= - -(defn test:should-transientize? [coll]) - -(defn test:identity [x]) - -(defn test:->pred [x]) - -(defn test:->literal [x]) - -(defn test:->base [x]) - -(defn test:transient!* [x]) -(defn test:persistent!* [x]) - -(defn test:transient-fns [coll]) - -(defn test:recommended-transient-fns [coll]) - -(defn test:->joinable [x]) \ No newline at end of file From 32cad24cd587899c4391323d669584fe5497b41b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 5 Sep 2018 23:41:37 -0600 Subject: [PATCH 234/810] Type meta key changed --- src-dev/quantum/core/defnt_equivalences.cljc | 62 ++++++++++--------- .../quantum/untyped/core/type/defnt.cljc | 2 +- 2 files changed, 35 insertions(+), 29 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 32e95230..cbe11fbf 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -46,7 +46,7 @@ ~'(->> (java.lang.management.ManagementFactory/getRuntimeMXBean) (.getName))))) (defn ~'pid|test - {::t/type (t/fn t/any? ~'[:> (? t/string?)])} + {:quantum.core.type/type (t/fn t/any? ~'[:> (? t/string?)])} ([] (.invoke ~(tag (str `>Object) 'pid|test|__0|0))))))] (testing "code equivalence" (is-code= actual expected)) @@ -92,7 +92,7 @@ [~'_8__ ~(tag "double" 'x)] ~'x))) (defn ~'identity|uninlined - {::t/type (t/fn t/any? ~'[t/any?])} + {:quantum.core.type/type (t/fn t/any? ~'[t/any?])} ([~'x00__] ;; TODO elide check because `t/any?` doesn't require a check ;; and all args are `t/=` `t/any?` @@ -143,7 +143,7 @@ (t/validate ~'(.getName x) ~'(* t/string?)))))) (defn ~'name|test - {::t/type + {:quantum.core.type/type (t/fn ~'t/string? ~'[t/string?] ~'[(t/isa? Named) :> (* t/string?)])} @@ -209,9 +209,10 @@ (~(tag "boolean" 'invoke) [~'_9__ ~(tag "double" 'x)] true))) (defn ~'some?|test - {::t/type (t/fn t/any? - ~'[t/nil?] - ~'[t/any?])} + {:quantum.core.type/type + (t/fn t/any? + ~'[t/nil?] + ~'[t/any?])} ([~'x00__] (ifs ((Array/get ~'some?|test|__0|input0|types 0) ~'x00__) (.invoke ~(tag (str `Object>boolean) 'some?|test|__0|0) ~'x00__) @@ -270,9 +271,10 @@ (~(tag "boolean" 'invoke) [~'_9__ ~(tag "double" 'x)] false))) (defn ~'reduced?|test - {::t/type (t/fn t/any? - ~'[(t/isa? Reduced)] - ~'[t/any?])} + {:quantum.core.type/type + (t/fn t/any? + ~'[(t/isa? Reduced)] + ~'[t/any?])} ([~'x00__] (ifs ((Array/get ~'reduced?|test|__0|input0|types 0) ~'x00__) (.invoke ~(tag (str `Object>boolean) 'reduced?|test|__0|0) ~'x00__) @@ -340,10 +342,11 @@ (~(tag "boolean" 'invoke) [~'_10__ ~(tag "double" 'x)] true))) (defn ~'>boolean - {::t/type (t/fn t/any? - ~'[t/boolean?] - ~'[t/nil?] - ~'[t/any?])} + {:quantum.core.type/type + (t/fn t/any? + ~'[t/boolean?] + ~'[t/nil?] + ~'[t/any?])} ([~'x00__] (ifs ((Array/get ~'>boolean|__0|input0|types 0) ~'x00__) (.invoke ~(tag (str `boolean>boolean) '>boolean|__0|0) ~'x00__) @@ -435,9 +438,10 @@ (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(.intValue x))))) (defn ~'>int* - {::t/type (t/fn ~'t/int? - ~'[(t/- t/primitive? t/boolean?)] - ~'[(t/ref (t/isa? Number))])} + {:quantum.core.type/type + (t/fn ~'t/int? + ~'[(t/- t/primitive? t/boolean?)] + ~'[(t/ref (t/isa? Number))])} ([~'x00__] (ifs ((Array/get ~'>int*|__0|input0|types 0) ~'x00__) (.invoke ~(tag (str `byte>int) '>int*|__0|0) ~'x00__) @@ -701,7 +705,7 @@ ;; Unindented for greater vertical brevity (defn ~'>|test - {::t/type + {:quantum.core.type/type (t/fn t/any? #?(:clj ~'[t/comparable-primitive? t/comparable-primitive? :> t/boolean?] @@ -904,9 +908,10 @@ (defn ~'>long* {:source "clojure.lang.RT.uncheckedLongCast" - ::t/type (t/fn ~'t/long? - ~'[(t/- t/primitive? t/boolean?)] - ~'[(t/ref (t/isa? Number))])} + :quantum.core.type/type + (t/fn ~'t/long? + ~'[(t/- t/primitive? t/boolean?)] + ~'[(t/ref (t/isa? Number))])} ([~'x00__] (ifs ((Array/get ~'>long*|__0|input0|types 0) ~'x00__) @@ -951,7 +956,7 @@ :clj ($ (do (def ~'defnt-reference|__0|0 (reify* [>long] (~(tag "long" 'invoke) [~'_0__] ~'(>long* 1)))) (defn ~'defnt-reference - {::t/type (t/fn t/any? [])} + {:quantum.core.type/type (t/fn t/any? [])} ([] (.invoke ~(tag (str `>long) 'defnt-reference|__0|0)))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" @@ -1138,7 +1143,7 @@ ~'(Long/parseLong x radix)))) #_(defn >long - {::t/type + {:quantum.core.type/type (t/fn [(t/- t/primitive? t/boolean? t/float? t/double?)] [(t/and (t/or t/double? t/float?) @@ -1216,10 +1221,11 @@ ~'(StringBuilder. x)))) (defn ~'!str - {::t/type (t/fn ~'(t/isa? StringBuilder) - ~'[] - ~'[t/string?] - ~'[(t/or t/char-seq? t/int?)])} + {:quantum.core.type/type + (t/fn ~'(t/isa? StringBuilder) + ~'[] + ~'[t/string?] + ~'[(t/or t/char-seq? t/int?)])} ([] (.invoke ~(tag "quantum.core.test.defnt_equivalences.>Object" '!str|__0|0))) ([~'x00__] @@ -1314,7 +1320,7 @@ (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'x] (.toString x)))) (defn str - {::t/type + {:quantum.core.type/type (t/fn :> t/string? [] [t/nil?] @@ -1490,7 +1496,7 @@ (defn seq "Taken from `clojure.lang.RT/seq`" - {::t/type + {:quantum.core.type/type (t/fn > (t/? (t/isa? ISeq)) [t/nil?] [(t/isa? ASeq)] diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 8ff43f60..4dfd5e5a 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -607,7 +607,7 @@ expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups) i-overload->direct-dispatch-data ::i-overload->direct-dispatch-data] `(defn ~fn|name - ~(assoc fn|meta ::t/type + ~(assoc fn|meta :quantum.core.type/type (>dynamic-dispatch-fn|type-decl fnt-globals expanded-overload-groups-by-fnt-overload)) ~@(->> i-overload->direct-dispatch-data (group-by (fn-> :i-arg->input-types-decl count)) From 21ec9071321ad21c6cecbfff1fa5dbc7da1a2c42 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 6 Sep 2018 01:40:12 -0600 Subject: [PATCH 235/810] More notes --- resources-dev/defnt.cljc | 19 +++++++++++++- resources-dev/to-move.cljc | 54 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 72 insertions(+), 1 deletion(-) create mode 100644 resources-dev/to-move.cljc diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index b2895ce7..a0067757 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -1,22 +1,31 @@ #_" LEFT OFF LAST TIME (9/3/2018): -Note that `;; TODO TYPED` is the annotation we're using +Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - t/... - t/assume - t/numerically + - t/of + - (t/of t/+map? t/symbol? t/string?) + - (t/of t/seq? namespace?) + - t/map-of + - t/seq-of + - t/unqualified-symbol? - expressions (`quantum.untyped.core.analyze.expr`) - deft - fnt + - declaret - declare-fnt (a way to do protocols/interfaces) - extend-fnt! - defnt - handle varargs + - [& args _] shouldn't result in `t/any?` but rather like `t/seqable?` or whatever - do the defnt-equivalences - a linting warning that you can narrow the type to whatever the deduced type is from whatever wider declared type there is + - the option of creating a `defnt` that isn't extensible? - defmacrot - dotyped - NOTE on namespace organization: @@ -30,6 +39,7 @@ Note that `;; TODO TYPED` is the annotation we're using - TODO transition the quantum.core.* namespaces: - List of semi-approximately topologically ordered namespaces to make typed: - quantum.core.core + - TODO delete this namespace? - quantum.core.type.core - quantum.core.ns - quantum.core.logic @@ -37,6 +47,13 @@ Note that `;; TODO TYPED` is the annotation we're using - quantum.core.data.map - quantum.core.type-old - quantum.core.vars + - List of corresponding untyped namespaces to incorporate: + - quantum.untyped.core.core + - quantum.untyped.core.vars + - Standard metadata + - e.g. `{:alternate-implementations #{'cljs.tools.reader/merge-meta}}` + - Instead of e.g. `ns-` or `var-` we can do `ns-val` and `var-val` + - Should we type `when`, `let`? - With `defnt`, protocols and interfaces aren't needed. You can just create `t/fn`s that you can then conform your fns to. diff --git a/resources-dev/to-move.cljc b/resources-dev/to-move.cljc new file mode 100644 index 00000000..df02baa2 --- /dev/null +++ b/resources-dev/to-move.cljc @@ -0,0 +1,54 @@ +;; TO MOVE + +;; ===== quantum.core.form + +(t/def langs #{:clj :cljs :clr}) + +(t/def lang "The language this code is compiled under" #?(:clj :clj :cljs :cljs)) + +;; ===== quantum.core.form.generate + +;; TODO TYPED +(defalias u/externs?) + +;; ===== quantum.core.system + +#?(:clj +(defnt pid [> (? t/string?)] + (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) + (.getName)))) + +;; TODO TYPED +(defalias u/*registered-components) + + +;; ===== UNKNOWN ===== ;; + +;; ----- Mutability/Effects + +;; TODO TYPED +(defprotocol IValue + (get [this]) + (set [this newv])) +#_(do (declare-fnt get [this _]) + (declare-fnt set [this _, newv _])) + +;; ----- Really unknown + +(defnt >sentinel [> t/object?] #?(:clj (Object.) :cljs #js {})) +(defalias >object >sentinel) + +;; TODO TYPED +#?(:clj +(defmacro with + "Evaluates @expr, then @body, then returns @expr. + For (side) effects." + [expr & body] + `(let [expr# ~expr] ~@body expr#))) + +#_(:clj +(defmacrot with + "Evaluates @expr, then @body, then returns @expr. + For (side) effects." + [expr t/form? & body (? (t/seq-of t/form?))] + `(let [expr# ~expr] ~@body expr#))) From 9b9b04acae5812da8137eed4a86dcb2f0ea502ff Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 6 Sep 2018 01:40:22 -0600 Subject: [PATCH 236/810] Fix bug --- src-untyped/quantum/untyped/core/analyze.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 6e2bfc6a..8884d2da 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -627,7 +627,7 @@ (or (t/literal? resolved) (t/class? resolved)) (t/value resolved) (var? resolved) - (or (-> resolved meta ::t/type) (t/value @resolved)) + (or (-> resolved meta :quantum.core.type/type) (t/value @resolved)) (uvar/unbound? resolved) ;; Because the var could be anything and cannot have metadata (type or otherwise) t/any? From 25079b4139d01ec6ceb37a116d140bce5122196b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 6 Sep 2018 01:40:48 -0600 Subject: [PATCH 237/810] quantum.core.core, ns, type, vars all being typed!! :D --- src-untyped/quantum/untyped/core/type.cljc | 10 +- src/quantum/core/core.cljc | 73 +------------ src/quantum/core/ns.cljc | 69 ++++++++++-- src/quantum/core/type.cljc | 28 ++++- src/quantum/core/vars.cljc | 117 +++++++++++---------- 5 files changed, 159 insertions(+), 138 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 6169e7fd..b60e4feb 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -13,6 +13,7 @@ array? associative? coll? counted? indexed? iterable? list? map? map-entry? record? seq? seqable? sequential? set? sorted? vector? fn? ifn? + var? meta ref volatile? fn]) @@ -730,6 +731,7 @@ ;; ===== Sequences ===== ;; Sequential (generally not efficient Lookup / RandomAccess) + (-def seq? (isa? #?(:clj clojure.lang.ISeq :cljs cljs.core/ISeq))) (-def cons? (isa? #?(:clj clojure.lang.Cons :cljs cljs.core/Cons))) (-def lseq? (isa? #?(:clj clojure.lang.LazySeq :cljs cljs.core/LazySeq))) (-def misc-seq? (or (isa? #?(:clj clojure.lang.APersistentMap$KeySeq :cljs cljs.core/KeySeq)) @@ -1697,8 +1699,8 @@ (-def multimethod? (isa? #?(:clj clojure.lang.MultiFn :cljs cljs.core/IMultiFn))) - ;; I.e., can you call/invoke it by being in functor position (first element of an unquoted list) - ;; within a typed context? + ;; I.e., can you call/invoke it by being in functor position (first element of an unquoted + ;; list) within a typed context? ;; TODO should we allow java.lang.Runnable, java.util.concurrent.Callable, and other ;; functional interfaces to be `callable?`? (-def callable? (or ifn? fnt?)) @@ -1748,6 +1750,10 @@ (-def keyword? (isa? #?(:clj clojure.lang.Keyword :cljs cljs.core/Keyword))) (-def symbol? (isa? #?(:clj clojure.lang.Symbol :cljs cljs.core/Symbol))) +#?(:clj (-def namespace? (isa? clojure.lang.Namespace))) + +#?(:clj (-def var? (isa? clojure.lang.Var))) + ;; `js/File` isn't always available! Use an abstraction #?(:clj (-def file? (isa? java.io.File))) diff --git a/src/quantum/core/core.cljc b/src/quantum/core/core.cljc index 3c69a4e5..e075db6b 100644 --- a/src/quantum/core/core.cljc +++ b/src/quantum/core/core.cljc @@ -1,72 +1 @@ -(ns quantum.core.core - (:refer-clojure :exclude - [get set]) - (:require [clojure.core :as core] - [clojure.spec.alpha :as s] - #?(:clj [clojure.core.specs.alpha :as ss]) - [cuerdas.core :as str+] - #?(:clj [environ.core :as env]) - ;; TODO TYPED move to quantum.core.type - #_[quantum.core.type :as t - :refer [declare-fnt defnt defmacrot deft]] - [quantum.untyped.core.core :as u] - [quantum.untyped.core.defnt - :refer [defnt]] - ;; TODO TYPED move to quantum.core.type - [quantum.untyped.core.type :as t - :refer [?]] - [quantum.untyped.core.vars - :refer [defalias defaliases]])) - -;; ===== Environment ===== ;; - -(deft lang t/keyword? "The language this code is compiled under" u/lang) - -#?(:clj -(defnt pid [> (? t/string?)] - (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) - (.getName)))) - -;; ===== Compilation ===== ;; - -;; TODO TYPED -(defalias u/externs?) - -;; ===== quantum.core.system ===== ;; - -;; TODO TYPED -;; TODO move -(defalias u/*registered-components) - -;; ===== Miscellaneous ===== ;; - -;; TODO move -(defnt >sentinel [> t/object?] #?(:clj (Object.) :cljs #js {})) -(defalias >object >sentinel) - -;; ===== Mutability/Effects ===== ;; - -;; TODO TYPED -;; TODO move? -(defprotocol IValue - (get [this]) - (set [this newv])) - -#_(do (declare-fnt get [this _]) - (declare-fnt set [this _, newv _])) - -;; TODO TYPED -;; TODO move? -#?(:clj -(defmacro with - "Evaluates @expr, then @body, then returns @expr. - For (side) effects." - [expr & body] - `(let [expr# ~expr] ~@body expr#))) - -#_(:clj -(defmacrot with - "Evaluates @expr, then @body, then returns @expr. - For (side) effects." - [expr t/form? & body (? (t/seq-of t/form?))] - `(let [expr# ~expr] ~@body expr#))) +(ns quantum.core.core) diff --git a/src/quantum/core/ns.cljc b/src/quantum/core/ns.cljc index cbfc581b..fa59ba2d 100644 --- a/src/quantum/core/ns.cljc +++ b/src/quantum/core/ns.cljc @@ -1,22 +1,71 @@ (ns - ^{:doc "Useful namespace and var-related functions." + ^{:doc "Functions related to namespace access and manipulation." :attribution "alexandergunnarson"} quantum.core.ns (:refer-clojure :exclude - [ns in-ns all-ns create-ns the-ns find-ns ns-name ns-map - alias ns-aliases require import ns-imports use - ns-interns ns-publics refer ns-refers refer-clojure ns-unalias ns-unmap loaded-libs - remove-ns]) + [alias import loaded-libs ns ns-aliases ns-imports ns-interns ns-publics + ns-refers ns-unalias refer refer-clojure remove-ns require use]) (:require + ;; TODO TYPED remove reference to `clojure.core` + [clojure.core :as core] + [quantum.core.type :as t + :refer [defnt]] + ;; TODO TYPED remove reference to `quantum.untyped.core.ns` [quantum.untyped.core.ns :as uns] + ;; TODO TYPED remove reference to `quantum.untyped.core.vars` [quantum.untyped.core.vars :as uvar - :refer [defaliases]])) + :refer [defalias]])) +(def namespace? (t/isa? clojure.lang.Namespace)) + +;; TODO TYPED +(defalias core/ns) + +#?(:clj +(defnt >?ns + "Supersedes `clojure.core/find-ns`." + [x t/symbol? > (t/? namespace?)] (clojure.lang.Namespace/find x))) + +#?(:clj +(defnt >ns + "Supersedes `clojure.core/the-ns`." + ([x namespace? > namespace?] x) + ([x t/symbol? > (t/* namespace?)] (>?ns x)))) + +;; TODO TYPED finish `t/assume`, `t/of`, `t/unqualified-symbol?` +#_(:clj +(defnt ns>var-map + "Outputs a map of all the symbol->var mappings for the namespace. + Supersedes `clojure.core/ns-map`." + [x namespace? > (t/assume (t/of t/+map? t/unqualified-symbol? t/var?))] + (.getMappings x))) + +;; TODO TYPED finish `t/unqualified-symbol?` +#_(:clj +(defnt unmap! + "Removes the var mapping for the symbol from the namespace and outputs the namespace. + Supersedes `clojure.core/ns-unmap`." + [ns-val namespace?, sym t/unqualified-symbol? > namespace?] + (.unmap ns-val sym) + ns-val)) + +(def in in-ns) + +;; TODO TYPED finish `t/of`, `t/assume` +#_(:clj +(defnt all + "Returns a sequence of all namespaces." + [> (t/assume (t/of t/seq? namespace?))] (clojure.lang.Namespace/all))) + +(defnt create! + "Creates a new namespace named by the symbol if one doesn't already exist. Returns it or the + already-existing namespace of the same name. + + Supersedes `clojure.core/create-ns`." + [x t/symbol? > (t/* namespace?)] (clojure.lang.Namespace/findOrCreate x)) + +;; TODO TYPED (defaliases uns - ns the-ns find-ns ns-name ns-map - ns-map ns-unmap ns-unmap! - in-ns all-ns - create-ns create-ns! alias alias! ns-unalias ns-unalias! ns-aliases diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index 44628396..5810c1dd 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -1 +1,27 @@ -(ns quantum.core.type) +(ns quantum.core.type + "This is this the namespace upon which all other fully-typed namespaces rest." + (:refer-clojure :exclude + [* and any? fn isa? or seq? symbol? var?]) + (:require + [quantum.untyped.core.type.defnt :as udefnt] + [quantum.untyped.core.type :as ut] + ;; TODO TYPED prefer e.g. `deft-alias` + [quantum.untyped.core.vars + :refer [defaliases]])) + +(defalias udefnt/fnt) +(defalias udefnt/defnt) + +(defaliases ut + ;; Generators + ? * isa? fn + ;; Combinators + and or + ;; Predicates + any? + +map? + metable? + seq? + symbol? + var? + with-metable?) diff --git a/src/quantum/core/vars.cljc b/src/quantum/core/vars.cljc index 3118e2ba..94b4d6d9 100644 --- a/src/quantum/core/vars.cljc +++ b/src/quantum/core/vars.cljc @@ -1,76 +1,87 @@ (ns quantum.core.vars - "Var- and namespace-related functions." - (:refer-clojure :exclude - [defonce, intern, binding with-local-vars, meta, reset-meta!]) - (:require [clojure.core :as c] - #?(:clj [quantum.core.ns :as ns]) - [quantum.core.type :as t - :refer [?]] - [quantum.untyped.core.defnt - :refer [defnt fnt]] - [quantum.untyped.core.vars :as u]) -#?(:cljs - (:require-macros - [quantum.core.vars :as this]))) + "Functions related to vars and metadata." + (:refer-clojure :exclude + [binding defonce intern meta reset-meta! var? with-local-vars with-meta]) + (:require + ;; TODO TYPED remove reference to `clojure.core` + [clojure.core :as c] + [quantum.core.ns :as ns] + [quantum.core.type :as t + :refer [defnt]] + ;; TODO TYPED remove reference to `quantum.untyped.core.vars` + [quantum.untyped.core.vars :as uvar]) +#?(:cljs (:require-macros + [quantum.core.vars :as this]))) + +#?(:clj (def var? t/var?)) ;; ===== Meta ===== ;; -(def #_t/def meta? (? t/+map?)) +(def meta? (t/? t/+map?)) (defnt meta - "Returns the metadata of `x`, returns nil if there is no metadata." - [x t/metable? > meta?] (.meta x)) + "Returns the (possibly nil) metadata of ->`x`." + > meta? + [x t/metable?] (#?(:clj .meta :cljs cljs.core/-meta) x)) (defnt with-meta - "Returns an object of the same type and value as `x`, with map `meta-` as its metadata." - [x t/with-metable?, meta- meta? > (t/spec-of meta-)] (.withMeta x meta-)) + "Returns an object of the same type and value as ->`x`, with ->`meta'` as its metadata." + > t/with-metable? + ([x t/with-metable?, meta' meta? > (t/* t/with-metable?) #_(TODO TYPED (t/value-of x))] + (#?(:clj .withMeta :cljs cljs.core/-with-meta) x meta')) + #?(:cljs ([x goog/isFunction, meta' meta?] + (cljs.core/MetaFn. x meta')))) (defnt reset-meta! - "Atomically resets the metadata for a namespace/var/ref/agent/atom" - [iref (t/isa? #?(:clj clojure.lang.IReference :cljs (TODO))) meta- meta? > (t/spec-of meta-)] - (.resetMeta iref meta-)) - -(defnt update-meta - "Returns an object of the same type and value as `x`, with `(apply f (meta x) args)` as its - metadata." - ;; TODO `f` should more specifically be able to handle the args arity and specs - [x (t/and t/with-metable? t/metable?) f t/fn? & args] - (with-meta x (apply f (meta x) args))) - -(defnt merge-meta - "See also `cljs.tools.reader/merge-meta`." + "Atomically resets ->`x`'s metadata to be ->`meta'`." + > meta? + [x (t/isa? #?(:clj clojure.lang.IReference :cljs (TODO))) meta' meta?] + (#?(:clj .resetMeta :cljs (set! (.-meta x) m)) x meta')) + +;; TODO TYPED +#_(defnt update-meta + "Returns an object of the same type and value as ->`x`, with its metadata updated by ->`f`." + ;; TODO `f` should more specifically be able to handle the args arity and specs + [x (t/and t/with-metable? t/metable?) f (t/fn meta? [& (t/type-of %args)]) & args _] + (with-meta x (apply f (meta x) args))) + +;; TODO TYPED +#_(defnt merge-meta + {:alternate-implementations #{'cljs.tools.reader/merge-meta}} [x (t/and t/with-metable? t/metable?) meta- meta? > (t/spec-of x)] (update-meta x merge meta-)) -(defnt merge-meta-from [to (t/and t/with-metable? t/metable?), from t/metable?] +;; TODO TYPED +#_(defnt merge-meta-from [to (t/and t/with-metable? t/metable?), from t/metable?] (update-meta to merge (meta from))) -(defnt replace-meta-from [to t/with-metable?, from t/metable?] +(defnt replace-meta-from > t/with-metable? [to t/with-metable?, from t/metable?] (with-meta to (meta from))) ;; ===== Declaration/Interning ===== ;; -(defnt intern - "Finds or creates a var named by the symbol name in the namespace `ns`, setting its root binding - to `v` if supplied. The namespace must exist. The var will adopt any metadata from `name`. +#?(:clj +(defnt intern > t/var? + "Finds or creates a var named by the symbol name in ->`ns-val`, setting its root binding to ->`v` + if supplied. The namespace must exist. The var will adopt any metadata from ->`name-val`. Returns the var." - ([ns- (t/or t/symbol? t/namespace?), name- symbol?] - (let [var- (clojure.lang.Var/intern (the-ns ns-) name-)] - (when (meta name-) (.setMeta var- (meta name-))) - var-)) - ([ns- (t/or t/symbol? t/namespace?), name- symbol?, v _] - (let [v (clojure.lang.Var/intern (the-ns ns-) name- v)] - (when (meta name-) (.setMeta var- (meta name-))) - var-))) - -;; TODO typed -#?(:clj (defalias u/def)) - -;; TODO typed -#?(:clj (u/defalias u/defalias)) - -;; TODO typed -#?(:clj (u/defaliases u defaliases defaliases')) + ([ns-val (t/or t/symbol? t/namespace?), var-name t/symbol?] + (let [var-ref (clojure.lang.Var/intern (ns/symbol>ns ns-val) var-name)] + (when (meta var-name) (.setMeta var- (meta var-name))) + var-ref)) + ([ns-val (t/or t/symbol? t/namespace?), var-name t/symbol?, var-val t/any?] + (let [var-ref (clojure.lang.Var/intern (ns/symbol>ns ns-val) var-name var-val)] + (when (meta var-name) (.setMeta var-ref (meta var-name))) + var-ref)))) + +;; TODO TYPED +#?(:clj (defalias uvar/def)) + +;; TODO TYPED +#?(:clj (uvar/defalias uvar/defalias)) + +;; TODO TYPED +#?(:clj (uvar/defaliases uvar defaliases defaliases')) #?(:clj (defnt defined? [x t/var?] (.hasRoot x))) From aaa9445e7b5f41a00f8f1bc5de9458882ce9d598 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 6 Sep 2018 09:42:57 -0600 Subject: [PATCH 238/810] `quantum.core.ns` is as done as we can right now --- resources-dev/defnt.cljc | 3 +- src/quantum/core/ns.cljc | 153 +++++++++++++++++++++++++++++---------- 2 files changed, 117 insertions(+), 39 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index a0067757..527bfd80 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -25,7 +25,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - do the defnt-equivalences - a linting warning that you can narrow the type to whatever the deduced type is from whatever wider declared type there is - - the option of creating a `defnt` that isn't extensible? + - the option of creating a `defnt` that isn't extensible? Or at least in which the input types are limited in the same way per-overload output types are limited by the per-fn output type? + - dealing with `apply`... - defmacrot - dotyped - NOTE on namespace organization: diff --git a/src/quantum/core/ns.cljc b/src/quantum/core/ns.cljc index fa59ba2d..a7219fad 100644 --- a/src/quantum/core/ns.cljc +++ b/src/quantum/core/ns.cljc @@ -3,8 +3,7 @@ :attribution "alexandergunnarson"} quantum.core.ns (:refer-clojure :exclude - [alias import loaded-libs ns ns-aliases ns-imports ns-interns ns-publics - ns-refers ns-unalias refer refer-clojure remove-ns require use]) + [ns loaded-libs]) (:require ;; TODO TYPED remove reference to `clojure.core` [clojure.core :as core] @@ -16,10 +15,10 @@ [quantum.untyped.core.vars :as uvar :refer [defalias]])) -(def namespace? (t/isa? clojure.lang.Namespace)) +#?(:clj (def namespace? (t/isa? clojure.lang.Namespace))) ;; TODO TYPED -(defalias core/ns) +#?(:clj (defalias core/ns)) #?(:clj (defnt >?ns @@ -32,24 +31,17 @@ ([x namespace? > namespace?] x) ([x t/symbol? > (t/* namespace?)] (>?ns x)))) -;; TODO TYPED finish `t/assume`, `t/of`, `t/unqualified-symbol?` -#_(:clj -(defnt ns>var-map - "Outputs a map of all the symbol->var mappings for the namespace. - Supersedes `clojure.core/ns-map`." - [x namespace? > (t/assume (t/of t/+map? t/unqualified-symbol? t/var?))] - (.getMappings x))) - ;; TODO TYPED finish `t/unqualified-symbol?` #_(:clj (defnt unmap! - "Removes the var mapping for the symbol from the namespace and outputs the namespace. + "Removes the mapping for the symbol from the namespace and outputs the namespace. + Supersedes `clojure.core/ns-unmap`." [ns-val namespace?, sym t/unqualified-symbol? > namespace?] (.unmap ns-val sym) ns-val)) -(def in in-ns) +#?(:clj (def in in-ns)) ;; TODO TYPED finish `t/of`, `t/assume` #_(:clj @@ -57,37 +49,122 @@ "Returns a sequence of all namespaces." [> (t/assume (t/of t/seq? namespace?))] (clojure.lang.Namespace/all))) +;; ===== Creation/Destruction ===== ;; + +#?(:clj (defnt create! "Creates a new namespace named by the symbol if one doesn't already exist. Returns it or the already-existing namespace of the same name. Supersedes `clojure.core/create-ns`." - [x t/symbol? > (t/* namespace?)] (clojure.lang.Namespace/findOrCreate x)) + [x t/symbol? > (t/* namespace?)] (clojure.lang.Namespace/findOrCreate x))) + +#?(:clj +(defnt remove! + "Removes the namespace named by the symbol. Use with caution. Cannot be used to remove the + `clojure.core` namespace." + [x t/symbol? > (t/* namespace?)] (clojure.lang.Namespace/remove x))) + +;; ===== Modification ===== ;; + +#?(:clj +(defnt alias! + "Add an alias to another namespace in the destination namespace. Returns the destination + namespace. This corresponds roughly to the `:as` directive in the ns macro. + + Supersedes `clojure.core/alias`." + [dest-ns namespace?, alias-sym t/symbol?, ns-to-alias namespace?] + (.addAlias dest-ns alias-sym ns-to-alias) + dest-ns)) + +#?(:clj +(defnt unalias! + "Removes the alias as designated by `alias-sym` from the namespace." + [ns-val namespace?, alias-sym t/symbol?] + (.removeAlias ns-val alias-sym) + ns-val)) + +;; TODO TYPED +#?(:clj (defalias require! core/require)) + +;; TODO TYPED +#?(:clj (defalias import! core/import)) + +;; TODO TYPED +#?(:clj (defalias refer! core/refer)) ;; TODO TYPED +#?(:clj (defalias refer-clojure! core/refer-clojure)) + +;; ===== Mappings ===== ;; + +;; TODO TYPED finish `t/assume`, `t/of`, `t/unqualified-symbol?` +#_(:clj +(defnt ns>mappings + "Supersedes `clojure.core/ns-map`." + [x namespace? > (t/assume (t/of t/+map? t/unqualified-symbol? (t/or t/var? t/class?)))] + (.getMappings x))) + +;; TODO TYPED finish `t/assume`, `t/of`, `t/unqualified-symbol?` +#_(:clj +(defnt ns>alias-map + "Outputs the alias->namespace mappings for the namespace. + + Supersedes `clojure.core/ns-aliases`." + [x namespace? > (t/assume (t/of t/+map? t/unqualified-symbol? namespace?))] + (.getAliases x))) + +;; TODO TYPED finish `t/assume`, `t/of`, `t/unqualified-symbol?`, decide on `filter-vals'`? +#_(:clj +(defnt ns>imports + "Outputs the import-mappings for the namespace. + + Supersedes `clojure.core/ns-imports`." + [x namespace? > (t/assume (t/of t/+map? t/unqualified-symbol? t/class?))] + (->> x (filter-vals' t/class?)))) + +;; TODO TYPED finish `t/assume`, `t/of`, `t/unqualified-symbol?`, decide on `filter-vals'`? +#_(:clj +(defnt ns>interns + "Outputs the intern-mappings for the namespace. + + Supersedes `clojure.core/ns-interns`." + [ns-val namespace? > (t/assume (t/of t/+map? t/unqualified-symbol? t/var?))] + (->> ns-val + ns>mappings + (filter-vals' (fn [^clojure.lang.Var v] (and (t/var? v) (= ns-val (.ns v)))))))) + +#_(:clj +(defnt ns>publics + "Outputs the public intern-mappings for the namespace. + + Supersedes `clojure.core/ns-publics`." + [ns-val namespace? > (t/assume (t/of t/+map? t/unqualified-symbol? t/var?))] + (->> ns-val + ns>interns + (filter-vals' (fn [^clojure.lang.Var v] (.isPublic v)))))) + +;; TODO TYPED finish `t/assume`, `t/of`, `t/unqualified-symbol?`, decide on `remove-vals'`? +#_(:clj +(defnt ns>refers + "Outputs the refer-mappings for the namespace. + + Supersedes `clojure.core/ns-refers`." + [ns-val namespace? > (t/assume (t/of t/+map? t/unqualified-symbol? t/var?))] + (->> ns-val + ns>mappings + (remove-vals' (fn [^clojure.lang.Var v] (and (t/var? v) (= ns-val (.ns v)))))))) + +#?(:clj +(defnt alias>?ns [src-ns namespace?, sym t/symbol? > (t/? namespace?)] (.lookupAlias src-ns sym))) + +;; TODO TYPED +#?(:clj (defaliases uns - alias alias! - ns-unalias ns-unalias! - ns-aliases - require require! - import import! - ns-imports - use use! - ns-interns - ns-publics - refer refer! - refer-clojure refer-clojure! - ns-refers - remove-ns remove-ns! - ;; - the-alias ns>alias ns-name>alias - clear-ns-interns! search-var ns-exclude - with-ns with-temp-ns - import-static load-ns load-nss - loaded-libs load-lib! load-package! load-dep! - assert-ns-aliased) - -;; TODO type and enable + ns>alias ns-name>alias clear-ns-interns! search-var ns-exclude with-ns with-temp-ns import-static + load-ns load-nss loaded-libs load-lib! load-package! load-dep! assert-ns-aliased)) + +;; TODO TYPED — enable #_(:clj (defn alias-ns "Create vars in the current namespace to alias each of the public vars in @@ -96,5 +173,5 @@ {:attribution "flatland.useful.ns"} [ns-name-] (require ns-name-) - (doseq [[name var] (ns-publics (the-ns ns-name-))] + (doseq [[name var] (ns>publics (the-ns ns-name-))] (uvar/alias-var name var)))) From a446baf292841ee6f617ae5d84b997ea5cc26aa7 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 6 Sep 2018 22:13:04 -0600 Subject: [PATCH 239/810] Update notes --- resources-dev/defnt.cljc | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 527bfd80..f0498212 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -39,17 +39,19 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - Conversion functions belong in the namespace that their destination types belong in - TODO transition the quantum.core.* namespaces: - List of semi-approximately topologically ordered namespaces to make typed: - - quantum.core.core - - TODO delete this namespace? - quantum.core.type.core - - quantum.core.ns - quantum.core.logic - quantum.core.fn - quantum.core.data.map - quantum.core.type-old - quantum.core.vars + - Worked through all we can for now: + - quantum.core.core + - TODO delete this namespace? + - quantum.core.ns - List of corresponding untyped namespaces to incorporate: - quantum.untyped.core.core + - quantum.untyped.core.ns - quantum.untyped.core.vars - Standard metadata - e.g. `{:alternate-implementations #{'cljs.tools.reader/merge-meta}}` From 428a1aae6e736fdc3dc7a5cc6177f9d0ec3784c8 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 6 Sep 2018 22:14:04 -0600 Subject: [PATCH 240/810] Prefer expanded form to unexpanded --- src-dev/quantum/core/defnt_equivalences.cljc | 3 +- src-untyped/quantum/untyped/core/analyze.cljc | 275 +++++++++--------- .../quantum/untyped/core/analyze/ast.cljc | 90 ++++-- .../quantum/untyped/core/analyze/expr.cljc | 2 + src-untyped/quantum/untyped/core/type.cljc | 4 +- .../quantum/untyped/core/type/defnt.cljc | 6 +- 6 files changed, 208 insertions(+), 172 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index cbe11fbf..e4d2357a 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -43,8 +43,7 @@ ($ (do (def ~'pid|test|__0|0 (reify* [>Object] (~(tag "java.lang.Object" 'invoke) [~'_0__] - ~'(->> (java.lang.management.ManagementFactory/getRuntimeMXBean) - (.getName))))) + ~'(. (java.lang.management.ManagementFactory/getRuntimeMXBean) getName)))) (defn ~'pid|test {:quantum.core.type/type (t/fn t/any? ~'[:> (? t/string?)])} ([] (.invoke ~(tag (str `>Object) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 8884d2da..5dbfa9c5 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -82,17 +82,12 @@ (def class->fields|with-cache (memoize (fn [c] (class->fields c)))) -(def ^:dynamic *conditional-branch-pruning?* true) - (defonce *analyze-depth (atom 0)) -(defn add-file-context [to from] +(defn add-file-context-from [to from] (let [from-meta (meta from)] (update-meta to assoc :line (:line from-meta) :column (:column from-meta)))) -(defn persistent!-and-add-file-context [form ast-data] - (update ast-data :form (fn-> persistent! (add-file-context form)))) - (def special-symbols '#{do let* deftype* fn* def . if quote new throw}) ; TODO make more complete ;; TODO move @@ -130,11 +125,12 @@ overall AST node; the second is the deduced type of the current sub-AST-node."}} [env ::env, form _, empty-form _, rf _] - (->> form - (reducei (fn [accum form' i] (rf accum (analyze* (:env accum) form') i)) - {:env env :form (transient empty-form) :body (transient [])}) - (persistent!-and-add-file-context form) - (<- (update :body persistent!)))) + (-> (reducei + (fn [accum form' i] (rf accum (analyze* (:env accum) form') i)) + {:env env :form (transient empty-form) :body (transient [])} + form) + (update :form (fn-> persistent! (add-file-context-from form))) + (update :body persistent!))) (defns- analyze-map {:todo #{"If the map is bound to a variable, preserve type info for it such that lookups @@ -150,31 +146,30 @@ ;; TODO fix; we want the types of the keys and vals to be deduced :type-info nil}))) (->expr-info {:env env :form (transient {})})) - (persistent!-and-add-file-context form))) + (persistent!-and-add-file-context-from form))) -(defns- analyze-seq|do [env ::env, [_ _ & body|form _ :as form] _] +(defns- analyze-seq|do [env ::env, [_ _ & body|form _ :as form] _ > uast/do?] (if (empty? body|form) - (uast/do {:env env - :form form - :expanded-form form - :body [] - :type t/nil?}) + (uast/do {:env env + :unexpanded-form form + :form form + :body [] + :type t/nil?}) (let [{expanded-form :form body :body} (analyze-non-map-seqable env body|form [] (fn [accum ast-data _] - (assoc ast-data - ;; The env should be the same as whatever it was originally - ;; because no new scopes are created - :env (:env accum) - :form (conj! (:form accum) (:form ast-data)) - :body (conj! (:body accum) ast-data))))] - (uast/do {:env env - :form form - :expanded-form (with-meta (list* 'do expanded-form) (meta expanded-form)) - :body body - ;; To types, only the last sub-AST-node ever matters, as each is independent - ;; from the others - :type (-> body c/last :type)})))) + ;; The env should be the same as whatever it was originally because no new scopes + ;; are created + (-> accum + (update :form conj! (:form ast-data)) + (update :body conj! ast-data))))] + (uast/do {:env env + :unexpanded-form form + :form (with-meta (list* 'do expanded-form) (meta expanded-form)) + :body body + ;; To types, only the last sub-AST-node ever matters, as each is independent from + ;; the others + :type (-> body c/last :type)})))) (defns analyze-seq|let*|bindings [env ::env, bindings|form _] (->> bindings|form @@ -185,20 +180,21 @@ :form (conj! (conj! !bindings sym) (:form node)) :bindings-map (assoc bindings-map sym node)})) {:env env :form (transient []) :bindings-map {}}) - (persistent!-and-add-file-context bindings|form))) + (<- (update :form (fn-> persistent! (add-file-context-from bindings|form)))))) -(defns analyze-seq|let* [env ::env, [_ _, bindings|form _ & body|form _ :as form] _] +(defns analyze-seq|let* [env ::env, [_ _, bindings|form _ & body|form _ :as form] _ > uast/let*?] (let [{env' :env bindings|form' :form :keys [bindings-map]} (analyze-seq|let*|bindings env bindings|form) - {body|form' :expanded-form body|type :type body :body} + {body|form' :form body|type :type body :body} (analyze-seq|do env' (list* 'do body|form))] - (uast/let* {:env env - :form form - :expanded-form (list* 'let* bindings|form' (rest body|form')) - :bindings bindings-map - :body body - :type body|type}))) - + (uast/let* {:env env + :unexpanded-form form + :form (list* 'let* bindings|form' (rest body|form')) + :bindings bindings-map + :body body + :type body|type}))) + +;; TODO enhance this to use `t/fn` (defns methods->type "Creates a type given ->`methods`." [methods (s/seq-of t/any? #_method?) #_> #_t/type?] @@ -265,47 +261,50 @@ "A note will be made of what methods match the argument types. If only one method is found, that is noted too. If no matching method is found, an exception is thrown." - [env ::env, form _, target _, target-class t/class?, static? t/boolean?, method-form simple-symbol?, args-forms _ #_(seq-of form?)] - (log/pr!) + [env ::env, form _, target _, target-class t/class?, static? t/boolean? + method-form simple-symbol?, args-forms _ #_(seq-of form?) > uast/method-call?] ;; TODO cache type by method - (if-not-let [methods-for-name (-> target-class class->methods|with-cache (c/get (name method-form)))] + (if-not-let [methods-for-name (-> target-class class->methods|with-cache + (c/get (name method-form)))] (if (empty? args-forms) (err! "No such method or field in class" {:class target-class :method-or-field method-form}) - (err! "No such method in class" {:class target-class :methods method-form})) + (err! "No such method in class" {:class target-class :methods method-form})) (if-not-let [methods-for-count (c/get methods-for-name (c/count args-forms))] (err! "Incorrect number of arguments for method" - {:class target-class :method method-form :possible-counts (set (keys methods-for-name))}) + {:class target-class + :method method-form + :possible-counts (set (keys methods-for-name))}) (let [static?>kind (fn [static?] (if static? :static :instance))] (if-not-let [methods (c/get methods-for-count (static?>kind static?))] (err! (istr "Method found for arg-count, but was ~(static?>kind (not static?)), not ~(static?>kind static?)") {:class target-class :method method-form :args args-forms}) (let [args-ct (c/count args-forms) - call (uast/method-call - {:env env - :form form - :target target - :method method-form - :args [] - :type (methods->type methods #_(count arg-forms))}) - with-arg-types - (r/fori [arg-form args-forms - call' call + call-data + {:env env + :form form + :target target + :method method-form + :args [] + :type (methods->type methods #_(count arg-forms))} + call-data-with-arg-types + (r/fori [arg-form args-forms + call-data' call-data i|arg] (let [arg-node (analyze* env arg-form)] ;; TODO can incrementally calculate return value, but possibly not worth it - (update call' :args conj arg-node))) - with-ret-type - (update with-arg-types :type - (fn [ret-type] (->> with-arg-types :args (mapv :type) ret-type))) + (update call-data' :args conj arg-node))) + call-data-with-ret-type + (update call-data-with-arg-types :type + (fn [ret-type] (->> call-data-with-arg-types :args (mapv :type) ret-type))) ?cast-type (?cast-call->type target-class method-form) _ (when ?cast-type (log/ppr :warn "Not yet able to statically validate whether primitive cast will succeed at runtime" {:form form}) #_(s/validate (-> with-ret-type :args first :type) #(t/>= % (t/numerically ?cast-type))))] - with-ret-type)))))) + (uast/method-call call-data-with-ret-type))))))) (defns- analyze-seq|dot|field-access - [env ::env, form _, target _, field-form simple-symbol?, field (t/isa? Field)] - (log/pr!) + [env ::env, form _, target _, field-form simple-symbol?, field (t/isa? Field) + > uast/field-access?] (uast/field-access {:env env :form form @@ -317,7 +316,6 @@ "Ensure that given a set of classes, that set consists of at most a class C and nil. If so, returns C. Otherwise, throws." [cs (s/set-of (? t/class?)) > t/class?] - (log/pr!) (let [cs' (disj cs nil)] (if (-> cs' count (= 1)) (first cs') @@ -325,7 +323,6 @@ ;; TODO type these arguments; e.g. check that ?method||field, if present, is an unqualified symbol (defns- analyze-seq|dot [env ::env, [_ _, target-form _, ?method-or-field _ & ?args _ :as form] _] - (log/pr!) (let [target (analyze* env target-form) method-or-field (if (symbol? ?method-or-field) ?method-or-field (first ?method-or-field)) args-forms (if (symbol? ?method-or-field) ?args (rest ?method-or-field))] @@ -333,7 +330,9 @@ (err! "Cannot use the dot operator on nil." {:form form}) (let [;; `nilable?` because technically any non-primitive in Java is nilable and we can't ;; necessarily rely on all e.g. "@nonNull" annotations - {:as ?target-static-class-map target-static-class :class target-static-class-nilable? :nilable?} + {:as ?target-static-class-map + target-static-class :class + target-static-class-nilable? :nilable?} (-> target :type t/type>?class-value) target-classes (if ?target-static-class-map @@ -341,89 +340,80 @@ (-> target :type t/type>classes)) target-class-nilable? (contains? target-classes nil) target-class (classes>class target-classes)] - ;; TODO determine how to handle `target-class-nilable?`; for now we will just let it slip through - ;; to `NullPointerException` at runtime rather than create a potentially more helpful custom - ;; exception + ;; TODO determine how to handle `target-class-nilable?`; for now we will just let it slip + ;; through to `NullPointerException` at runtime rather than create a potentially more + ;; helpful custom exception (if-let [field (and (empty? args-forms) - (-> target-class class->fields|with-cache (c/get (name method-or-field))))] + (-> target-class class->fields|with-cache + (c/get (name method-or-field))))] (analyze-seq|dot|field-access env form target method-or-field field) - (analyze-seq|dot|method-call env form target target-class (boolean ?target-static-class-map) - method-or-field args-forms)))))) + (analyze-seq|dot|method-call env form target target-class + (boolean ?target-static-class-map) method-or-field args-forms)))))) ;; TODO move this (defns truthy-node? [{:as ast t [:type _]} _ > (t/? t/boolean?)] - (log/pr!) - (ifs (or (t/= t t/nil?) - (t/= t t/false?)) false - (or (t/> t t/nil?) - (t/> t t/false?)) nil ; representing "unknown" + (ifs (or (t/= t t/nil?) (t/= t t/false?)) false + (or (t/> t t/nil?) (t/> t t/false?)) nil ; representing "unknown" true)) (defns- analyze-seq|if - "If `*conditional-branch-pruning?*` is falsey, the dead branch's original form will be - retained, but it will not be type-analyzed." - [env ::env, [_ _ & [pred-form _, true-form _, false-form _ :as body] _ :as form] _] - (log/pr!) - (if (-> body count (not= 3)) - (err! "`if` accepts exactly 3 arguments: one predicate test and two branches; received" - {:body body}) - (let [pred-node (analyze* env pred-form) - true-node (delay (analyze* env true-form)) - false-node (delay (analyze* env false-form)) - whole-node - (delay - (uast/if-node - {:env env - :form (list 'if (:form pred-node) (:form @true-node) (:form @false-node)) - :pred-node pred-node - :true-node @true-node - :false-node @false-node - :type (apply t/or (->> [(:type @true-node) (:type @false-node)] - (remove nil?)))}))] - (case (truthy-node? pred-node) - true (do (log/ppr :warn "Predicate in `if` node is always true" {:pred pred-form}) - (-> @true-node - (assoc :env env) - (cond-> (not *conditional-branch-pruning?*) - (assoc :form (list 'if pred-form (:form @true-node) false-form))))) - false (do (log/ppr :warn "Predicate in `if` node is always false" {:pred pred-form}) - (-> @false-node - (assoc :env env) - (cond-> (not *conditional-branch-pruning?*) - (assoc :form (list 'if pred-form true-form (:form @false-node)))))) - nil @whole-node)))) - -(defns- analyze-seq|quote [env ::env, [_ _ & body _ :as form] _] - (log/pr!) + "Performs conditional branch pruning." + [env ::env, [_ _ & [pred-form _, true-form _, false-form _ :as body] _ :as form] _ + > uast/node?] + (if-not (<= 2 (count body) 3) + (err! "`if` accepts exactly 3 arguments: one predicate test and two branches; received" + {:body body}) + (let [pred-node (analyze* env pred-form) + true-node (delay (analyze* env true-form)) + false-node (delay (analyze* env false-form)) + whole-node + (delay + (uast/if-node + {:env env + :form (list 'if (:form pred-node) (:form @true-node) (:form @false-node)) + :pred-node pred-node + :true-node @true-node + :false-node @false-node + :type (apply t/or (->> [(:type @true-node) (:type @false-node)] + (remove nil?)))}))] + (case (truthy-node? pred-node) + true (do (log/ppr :warn "Predicate in `if` node is always true" {:pred pred-form}) + (assoc @true-node :env env)) + false (do (log/ppr :warn "Predicate in `if` node is always false" {:pred pred-form}) + (assoc @false-node :env env)) + nil @whole-node)))) + +(defns- analyze-seq|quote [env ::env, [_ _ & body _ :as form] _ > uast/quoted?] (uast/quoted env form (tcore/most-primitive-class-of body))) -(defns- analyze-seq|new [env ::env, [_ _ & [c|form _ #_t/class? & args _ :as body] _ :as form] _] - (log/pr!) +(defns- analyze-seq|new + [env ::env, [_ _ & [c|form _ #_t/class? & args _ :as body] _ :as form] _ > uast/new-node?] (let [c|analyzed (analyze* env c|form)] (if-not (and (-> c|analyzed :type t/value-type?) (-> c|analyzed :type utr/value-type>value class?)) - (err! "Supplied non-class to `new` form" {:x c|form}) - (let [c (-> c|analyzed :type utr/value-type>value) - args|analyzed (mapv #(analyze* env %) args)] - (uast/new-node {:env env - :form (list* 'new c|form (map :form args|analyzed)) - :class c - :args args|analyzed - :type (t/isa? c)}))))) - -(defns- analyze-seq|throw [env ::env, form _ [arg _ :as body] _] - (log/pr!) + (err! "Supplied non-class to `new` form" {:x c|form}) + (let [c (-> c|analyzed :type utr/value-type>value) + args|analyzed (mapv #(analyze* env %) args)] + (uast/new-node + {:env env + :form (list* 'new c|form (map :form args|analyzed)) + :class c + :args args|analyzed + :type (t/isa? c)}))))) + +(defns- analyze-seq|throw [env ::env, form _ [arg _ :as body] _ > uast/throw-node?] (if (-> body count (not= 1)) (err! "Must supply exactly one input to `throw`; supplied" {:body body}) (let [arg|analyzed (analyze* env arg)] ;; TODO this is not quite true for CLJS but it's nice at least (if-not (-> arg|analyzed :type (t/<= t/throwable?)) (err! "`throw` requires a throwable; received" {:arg arg :type (:type arg|analyzed)}) - (uast/throw-node {:env env - :form (list 'throw (:form arg|analyzed)) - :arg arg|analyzed - ;; `t/none?` because nothing is actually returned - :type t/none?}))))) + (uast/throw-node + {:env env + :form (list 'throw (:form arg|analyzed)) + :arg arg|analyzed + ;; `t/none?` because nothing is actually returned + :type t/none?}))))) (defn- filter-dynamic-dispatchable-overloads "An example of dynamic dispatch: @@ -451,7 +441,8 @@ (if (or (empty? dispatchable-overloads-seq') (c/contains? non-dispatchable-or-types)) (err! "No overloads satisfy the inputs, whether direct or dynamic" - {:caller caller|node :inputs body + {:caller caller|node + :inputs body :failing-input-form (:form input|analyzed) :failing-input-type (:type input|analyzed)}) (assoc ret :dispatchable-overloads-seq dispatchable-overloads-seq' @@ -523,8 +514,7 @@ (defns- analyze-seq* "Analyze a seq after it has been macro-expanded. The ->`form` is post- incremental macroexpansion." - [env ::env, [caller|form _ & body _ :as form] _] - (log/pr!) + [env ::env, [caller|form _ & body _ :as form] _ > uast/node?] (ifs (special-symbols caller|form) (case caller|form do (analyze-seq|do env form) @@ -537,7 +527,6 @@ quote (analyze-seq|quote env form) new (analyze-seq|new env form) throw (analyze-seq|throw env form)) - ;; TODO support recursion (let [caller|node (analyze* env caller|form) caller|type (:type caller|node) inputs-ct (count body)] @@ -594,16 +583,16 @@ :type out-type})))))) (defns- analyze-seq [env ::env, form _] - (log/pr!) (let [expanded-form (ufeval/macroexpand form)] (if (ucomp/== form expanded-form) (analyze-seq* env expanded-form) (let [expanded (analyze-seq* env expanded-form)] (uast/macro-call - {:env env - :form form - :expanded-form (:form expanded) - :expanded expanded}))))) + {:env env + :unexpanded-form form + :form (:form expanded) + :expanded expanded + :type (:type expanded)}))))) (defns ?resolve-with-env [sym t/symbol?, env ::env] (if-let [[_ local] (find env sym)] @@ -617,8 +606,7 @@ {:value (analyze-seq|dot env (list '. (-> sym namespace symbol) (-> sym name symbol)))} nil)))) -(defns- analyze-symbol [env ::env, form t/symbol?] - (log/pr!) +(defns- analyze-symbol [env ::env, form t/symbol? > uast/symbol?] (if-not-let [{resolved :value} (?resolve-with-env form env)] (err! "Could not resolve symbol" {:sym form}) (uast/symbol env form resolved @@ -633,8 +621,7 @@ t/any? (TODO "Unsure of what to do in this case" (kw-map env form resolved)))))) -(defns- analyze* [env ::env, form _] - (log/pr! form) +(defns- analyze* [env ::env, form _ > uast/node?] (when (> (swap! *analyze-depth inc) 100) (throw (ex-info "Stack too deep" {:form form}))) (ifs (symbol? form) (analyze-symbol env form) @@ -649,7 +636,7 @@ (analyze-seq env form) (throw (ex-info "Unrecognized form" {:form form})))) -(defns analyze +(defns analyze > uast/node? ([form _] (analyze {} form)) ([env ::env, form _] (log/pr! form) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 5d0c6a52..9a0d1ab1 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -6,14 +6,36 @@ == unbound?]) (:require - [quantum.untyped.core.compare :as comp + [quantum.untyped.core.analyze.expr :as uxp] + [quantum.untyped.core.compare :as comp :refer [==]] - [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.type :as t])) + [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.form.type-hint :as ufth] + [quantum.untyped.core.type :as t] + [quantum.untyped.core.type.reifications :as utr])) (ucore/log-this-ns) -(do +(defn >type-hint + "Applied on every `form` of every AST node created in order to avoid reflection wherever + possible." + [form t] + (if (or (not (t/with-metable? form)) + (utr/fn-type? t) + ;; TODO for now + (uxp/iexpr? t)) + nil + (let [cs (t/type>classes t) + c (when (-> cs count (= 1)) (first cs))] + (ufth/>body-embeddable-tag c)))) + +(defn with-type-hint [node] + (if-let [type-hint (>type-hint (:form node) (:type node))] + (-> node + (update :form ufth/with-type-hint type-hint) + (cond-> (contains? node :unexpanded-form) + (update :unexpanded-form ufth/with-type-hint type-hint))) + node)) ;; ===== Constituent types ===== ;; @@ -36,7 +58,8 @@ (defn unbound ([form t] (unbound nil form t)) - ([env form t] (Unbound. env form t t))) ; TODO should wrap second `t` in `t/deducible` + ;; TODO should wrap second `t` in `t/deducible` + ([env form t] (Unbound. env (ufth/with-type-hint form (>type-hint form t)) t t))) (defn unbound? [x] (instance? Unbound x)) @@ -48,7 +71,9 @@ (defn literal ([form t] (literal nil form t)) - ([env form t] (Literal. env form t))) + ([env form t] (Literal. env (ufth/with-type-hint form (>type-hint form t)) t))) + +(defn literal? [x] (instance? Literal x)) (defrecord Symbol [env #_::env @@ -62,7 +87,7 @@ (defn symbol ([form value t] (symbol nil form value t)) - ([env form value t] (Symbol. env form value t))) + ([env form value t] (Symbol. env (ufth/with-type-hint form (>type-hint form t)) value t))) (defn symbol? [x] (instance? Symbol x)) @@ -75,7 +100,9 @@ fipp.ednize/IEdn (-edn [this] (list `quoted form type))) -(defn quoted [form t] (Quoted. nil form t)) +(defn quoted [form t] (Quoted. nil (ufth/with-type-hint form (>type-hint form t)) t)) + +(defn quoted? [x] (instance? Quoted x)) (defrecord Let* [env #_::env @@ -88,12 +115,14 @@ fipp.ednize/IEdn (-edn [this] (list `let* (into (array-map) this)))) -(defn let* [m] (map->Let* m)) +(defn let* [m] (-> m map->Let* with-type-hint)) + +(defn let*? [x] (instance? Let* x)) (defrecord Do [env #_::env form #_::t/form - expanded-form #_::t/form + unexpanded-form #_::t/form body #_(t/and t/sequential? t/indexed? (t/every? ::node)) type #_t/type?] INode @@ -101,20 +130,24 @@ fipp.ednize/IEdn (-edn [this] (list `do (into (array-map) this)))) -(defn do [m] (map->Do m)) +(defn do [m] (-> m map->Do with-type-hint)) + +(defn do? [x] (instance? Do x)) (defrecord MacroCall - [env #_::env - form #_::t/form - expanded-form #_::t/form ; the *fully* expanded form - expanded #_::node - type #_t/type?] + [env #_::env + unexpanded-form #_::t/form + form #_::t/form ; the *fully* expanded form + expanded #_::node + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn (-edn [this] (list `macro-call (into (array-map) this)))) -(defn macro-call [m] (-> m map->MacroCall (assoc :type (-> m :expanded :type)))) +(defn macro-call [m] (-> m map->MacroCall with-type-hint)) + +(defn macro-call? [x] (instance? MacroCall x)) (defrecord IfNode [env #_::env @@ -128,7 +161,9 @@ fipp.ednize/IEdn (-edn [this] (list `if-node (into (array-map) this)))) -(defn if-node [m] (map->IfNode m)) +(defn if-node [m] (-> m map->IfNode with-type-hint)) + +(defn if-node? [x] (instance? IfNode x)) ;; ===== RUNTIME CALLS ===== ;; @@ -143,7 +178,9 @@ fipp.ednize/IEdn (-edn [this] (list `field-access (into (array-map) this)))) -(defn field-access [m] (map->FieldAccess m)) +(defn field-access [m] (-> m map->FieldAccess with-type-hint)) + +(defn field-access? [x] (instance? FieldAccess x)) (defrecord MethodCall [env #_::env @@ -157,7 +194,9 @@ fipp.ednize/IEdn (-edn [this] (list `method-call (into (array-map) this)))) -(defn method-call [m] (map->MethodCall m)) +(defn method-call [m] (-> m map->MethodCall with-type-hint)) + +(defn method-call? [x] (instance? MethodCall x)) (defrecord CallNode ; by a `t/callable?` [env #_::env @@ -170,7 +209,9 @@ fipp.ednize/IEdn (-edn [this] (list `call-node (into (array-map) this)))) -(defn call-node [m] (map->CallNode m)) +(defn call-node [m] (-> m map->CallNode with-type-hint)) + +(defn call-node? [x] (instance? CallNode x)) (defrecord NewNode [env #_::env @@ -183,7 +224,9 @@ fipp.ednize/IEdn (-edn [this] (list `new-node (into (array-map) this)))) -(defn new-node [m] (map->NewNode m)) +(defn new-node [m] (-> m map->NewNode with-type-hint)) + +(defn new-node? [x] (instance? NewNode x)) (defrecord ThrowNode [env #_::env @@ -195,6 +238,7 @@ fipp.ednize/IEdn (-edn [this] (list `throw-node (into (array-map) this)))) +;; Not type hinted because there's no point (defn throw-node [m] (map->ThrowNode m)) -) +(defn throw-node? [x] (instance? ThrowNode x)) diff --git a/src-untyped/quantum/untyped/core/analyze/expr.cljc b/src-untyped/quantum/untyped/core/analyze/expr.cljc index c85477c3..5d638d93 100644 --- a/src-untyped/quantum/untyped/core/analyze/expr.cljc +++ b/src-untyped/quantum/untyped/core/analyze/expr.cljc @@ -30,6 +30,8 @@ (#?(:clj definterface :cljs defprotocol) IExpr) +(defn iexpr? [x] (#?(:clj instance? :cljs satisfies?) IExpr x)) + (defprotocol PExpr (with-form [this form']) (update-form [this f]) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index b60e4feb..ef870108 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -15,7 +15,7 @@ fn? ifn? var? meta - ref volatile? + delay? ref volatile? fn]) (:require [clojure.core :as c] @@ -1765,6 +1765,8 @@ (-def transformer? (isa? quantum.untyped.core.reducers.Transformer)) + (-def delay? (isa? #?(:clj clojure.lang.Delay :cljs cljs.core/Delay))) + ;; ----- Collections ----- ;; (-def sorted? (or (isa? #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 4dfd5e5a..06a217a2 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -133,7 +133,7 @@ ;; "global" because they apply to the whole fnt (s/def ::fnt-globals - (s/kv {:fn|meta ::uss/meta + (s/kv {:fn|meta (s/nilable :quantum.core.specs/meta) :fn|name ::uss/fn|name :fnt|output-type|form t/any? :fnt|type t/type?})) @@ -271,7 +271,9 @@ (if (t/<= (:type analyzed) post-type) (:type analyzed) (err! "Body type does not match declared output type" - {:body analyzed :output-type post-type}))) + {:form (:form analyzed) + :type (:type analyzed) + :declared-output-type post-type}))) (:type analyzed)) body-form (-> (:form analyzed) From 20c2eb2b6bccbcdd102b2ef01692e346c72052ec Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 6 Sep 2018 22:14:11 -0600 Subject: [PATCH 241/810] Fix error in `code=` --- src-untyped/quantum/untyped/core/form.cljc | 4 ++-- src-untyped/quantum/untyped/core/test.cljc | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index a89d763a..8bdd6f35 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -101,8 +101,8 @@ ([code0 code1] (if (uvar/metable? code0) (and (uvar/metable? code1) - (= (-> code0 meta (dissoc :line :column)) - (-> code1 meta (dissoc :line :column))) + (= (-> code0 meta (or {}) (dissoc :line :column)) + (-> code1 meta (or {}) (dissoc :line :column))) (let [similar-class? (cond (seq? code0) (seq? code1) (seq? code1) (seq? code0) diff --git a/src-untyped/quantum/untyped/core/test.cljc b/src-untyped/quantum/untyped/core/test.cljc index a70a2af7..457ce686 100644 --- a/src-untyped/quantum/untyped/core/test.cljc +++ b/src-untyped/quantum/untyped/core/test.cljc @@ -31,8 +31,8 @@ ([c0 c1] (if (metable? c0) (and (metable? c1) - (let [meta0 (-> c0 meta (dissoc :line :column)) - meta1 (-> c1 meta (dissoc :line :column))] + (let [meta0 (-> c0 meta (or {}) (dissoc :line :column)) + meta1 (-> c1 meta (or {}) (dissoc :line :column))] (or (= meta0 meta1) (do (pr! "FAIL: meta should be match for" (pr-str meta0) (pr-str meta1) "on code" (pr-str c0) (pr-str c1)) From 8cdeea282f4b0947e4a8940e93b9fdc7e34dcfc8 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 6 Sep 2018 22:25:59 -0600 Subject: [PATCH 242/810] Don't tag primitive forms --- src-dev/quantum/core/defnt_equivalences.cljc | 7 +++++-- src-untyped/quantum/untyped/core/analyze/ast.cljc | 11 ++++++++--- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index e4d2357a..e47b5474 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -32,6 +32,8 @@ (do (require '[orchestra.spec.test :as st]) (orchestra.spec.test/instrument)) +(defn O [form] (tag "java.lang.Object" form)) + #?(:clj (deftest test|pid (let [actual @@ -42,8 +44,9 @@ expected ($ (do (def ~'pid|test|__0|0 (reify* [>Object] - (~(tag "java.lang.Object" 'invoke) [~'_0__] - ~'(. (java.lang.management.ManagementFactory/getRuntimeMXBean) getName)))) + (~(O 'invoke) [~'_0__] + ~(tag "java.lang.String" + '(. (java.lang.management.ManagementFactory/getRuntimeMXBean) getName))))) (defn ~'pid|test {:quantum.core.type/type (t/fn t/any? ~'[:> (? t/string?)])} ([] (.invoke ~(tag (str `>Object) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 9a0d1ab1..7f15ccb6 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -25,9 +25,14 @@ ;; TODO for now (uxp/iexpr? t)) nil - (let [cs (t/type>classes t) - c (when (-> cs count (= 1)) (first cs))] - (ufth/>body-embeddable-tag c)))) + (let [cs (t/type>classes t)] + (case (count cs) + 1 (let [c (first cs)] + (when-let [not-primitive? (not (contains? t/boxed-class->unboxed-symbol c))] + (ufth/>body-embeddable-tag c))) + 2 (when (contains? cs nil) + (-> cs (disj nil) first ufth/>body-embeddable-tag)) + nil)))) (defn with-type-hint [node] (if-let [type-hint (>type-hint (:form node) (:type node))] From 5f07ea4299ae9289be4f3630e5ecab041004ac44 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 6 Sep 2018 22:44:08 -0600 Subject: [PATCH 243/810] Fix a few type hints in defnt equivalences --- src-dev/quantum/core/defnt_equivalences.cljc | 158 +++++++++--------- .../quantum/untyped/core/analyze/ast.cljc | 3 +- 2 files changed, 84 insertions(+), 77 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index e47b5474..fa9bbdd0 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -32,7 +32,8 @@ (do (require '[orchestra.spec.test :as st]) (orchestra.spec.test/instrument)) -(defn O [form] (tag "java.lang.Object" form)) +(defn O [form] (tag "java.lang.Object" form)) +(defn STR [form] (tag "java.lang.String" form)) #?(:clj (deftest test|pid @@ -44,9 +45,9 @@ expected ($ (do (def ~'pid|test|__0|0 (reify* [>Object] - (~(O 'invoke) [~'_0__] - ~(tag "java.lang.String" - '(. (java.lang.management.ManagementFactory/getRuntimeMXBean) getName))))) + (~(tag "java.lang.Object" 'invoke) [~'_0__] + ~(STR '(. (java.lang.management.ManagementFactory/getRuntimeMXBean) + getName))))) (defn ~'pid|test {:quantum.core.type/type (t/fn t/any? ~'[:> (? t/string?)])} ([] (.invoke ~(tag (str `>Object) @@ -75,7 +76,7 @@ (reify* [Object>Object boolean>boolean byte>byte short>short char>char int>int long>long float>float double>double] (~(tag "java.lang.Object" 'invoke) - [~'_0__ ~(tag "java.lang.Object" 'x)] ~'x) + [~'_0__ ~(tag "java.lang.Object" 'x)] ~(O 'x)) (~(tag "boolean" 'invoke) [~'_1__ ~(tag "boolean" 'x)] ~'x) (~(tag "byte" 'invoke) @@ -132,7 +133,7 @@ (def ~'name|test|__0|0 (reify* [Object>Object] (~(tag "java.lang.Object" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "java.lang.String" 'x) ~'x] ~'x)))) + (let* [~(STR 'x) ~'x] ~(STR 'x))))) ;; [(t/isa? Named)] @@ -142,7 +143,8 @@ (reify* [Object>Object] (~(tag "java.lang.Object" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] (let* [~(tag "clojure.lang.Named" 'x) ~'x] - (t/validate ~'(.getName x) ~'(* t/string?)))))) + (t/validate ~(STR '(. x getName)) + ~'(* t/string?)))))) (defn ~'name|test {:quantum.core.type/type @@ -403,31 +405,31 @@ (def ~'>int*|__0|0 (reify* [byte>int] (~(tag "int" 'invoke) [~'_0__ ~(tag "byte" 'x)] - ~'(Primitive/uncheckedIntCast x)))) + ~'(. Primitive uncheckedIntCast x)))) (def ~'>int*|__0|1 (reify* [short>int] (~(tag "int" 'invoke) [~'_1__ ~(tag "short" 'x)] - ~'(Primitive/uncheckedIntCast x)))) + ~'(. Primitive uncheckedIntCast x)))) (def ~'>int*|__0|2 (reify* [char>int] (~(tag "int" 'invoke) [~'_2__ ~(tag "char" 'x)] - ~'(Primitive/uncheckedIntCast x)))) + ~'(. Primitive uncheckedIntCast x)))) (def ~'>int*|__0|3 (reify* [int>int] (~(tag "int" 'invoke) [~'_3__ ~(tag "int" 'x)] - ~'(Primitive/uncheckedIntCast x)))) + ~'(. Primitive uncheckedIntCast x)))) (def ~'>int*|__0|4 (reify* [long>int] (~(tag "int" 'invoke) [~'_4__ ~(tag "long" 'x)] - ~'(Primitive/uncheckedIntCast x)))) + ~'(. Primitive uncheckedIntCast x)))) (def ~'>int*|__0|5 (reify* [float>int] (~(tag "int" 'invoke) [~'_5__ ~(tag "float" 'x)] - ~'(Primitive/uncheckedIntCast x)))) + ~'(. Primitive uncheckedIntCast x)))) (def ~'>int*|__0|6 (reify* [double>int] (~(tag "int" 'invoke) [~'_6__ ~(tag "double" 'x)] - ~'(Primitive/uncheckedIntCast x)))) + ~'(. Primitive uncheckedIntCast x)))) ;; [x (t/ref (t/isa? Number)) ;; -> (t/- (t/ref (t/isa? Number)) (t/- t/primitive? t/boolean?))] @@ -437,7 +439,7 @@ (def ~'>int*|__1|0 (reify* [Object>int] (~(tag "int" 'invoke) [~'_7__ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(.intValue x))))) + (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(. x intValue))))) (defn ~'>int* {:quantum.core.type/type @@ -511,199 +513,199 @@ (def ~'>|test|__0|0 (reify* [byte+byte>boolean] (~(tag "boolean" 'invoke) [~'_0__ ~(tag "byte" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|1 (reify* [byte+short>boolean] (~(tag "boolean" 'invoke) [~'_1__ ~(tag "byte" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|2 (reify* [byte+char>boolean] (~(tag "boolean" 'invoke) [~'_2__ ~(tag "byte" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|3 (reify* [byte+int>boolean] (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|4 (reify* [byte+long>boolean] (~(tag "boolean" 'invoke) [~'_4__ ~(tag "byte" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|5 (reify* [byte+float>boolean] (~(tag "boolean" 'invoke) [~'_5__ ~(tag "byte" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|6 (reify* [byte+double>boolean] (~(tag "boolean" 'invoke) [~'_6__ ~(tag "byte" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|7 (reify* [short+byte>boolean] (~(tag "boolean" 'invoke) [~'_7__ ~(tag "short" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|8 (reify* [short+short>boolean] (~(tag "boolean" 'invoke) [~'_8__ ~(tag "short" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|9 (reify* [short+char>boolean] (~(tag "boolean" 'invoke) [~'_9__ ~(tag "short" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|10 (reify* [short+int>boolean] (~(tag "boolean" 'invoke) [~'_10__ ~(tag "short" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|11 (reify* [short+long>boolean] (~(tag "boolean" 'invoke) [~'_11__ ~(tag "short" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|12 (reify* [short+float>boolean] (~(tag "boolean" 'invoke) [~'_12__ ~(tag "short" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|13 (reify* [short+double>boolean] (~(tag "boolean" 'invoke) [~'_13__ ~(tag "short" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|14 (reify* [char+byte>boolean] (~(tag "boolean" 'invoke) [~'_14__ ~(tag "char" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|15 (reify* [char+short>boolean] (~(tag "boolean" 'invoke) [~'_15__ ~(tag "char" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|16 (reify* [char+char>boolean] (~(tag "boolean" 'invoke) [~'_16__ ~(tag "char" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|17 (reify* [char+int>boolean] (~(tag "boolean" 'invoke) [~'_17__ ~(tag "char" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|18 (reify* [char+long>boolean] (~(tag "boolean" 'invoke) [~'_18__ ~(tag "char" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|19 (reify* [char+float>boolean] (~(tag "boolean" 'invoke) [~'_19__ ~(tag "char" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|20 (reify* [char+double>boolean] (~(tag "boolean" 'invoke) [~'_20__ ~(tag "char" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|21 (reify* [int+byte>boolean] (~(tag "boolean" 'invoke) [~'_21__ ~(tag "int" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|22 (reify* [int+short>boolean] (~(tag "boolean" 'invoke) [~'_22__ ~(tag "int" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|23 (reify* [int+char>boolean] (~(tag "boolean" 'invoke) [~'_23__ ~(tag "int" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|24 (reify* [int+int>boolean] (~(tag "boolean" 'invoke) [~'_24__ ~(tag "int" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|25 (reify* [int+long>boolean] (~(tag "boolean" 'invoke) [~'_25__ ~(tag "int" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|26 (reify* [int+float>boolean] (~(tag "boolean" 'invoke) [~'_26__ ~(tag "int" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|27 (reify* [int+double>boolean] (~(tag "boolean" 'invoke) [~'_27__ ~(tag "int" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|28 (reify* [long+byte>boolean] (~(tag "boolean" 'invoke) [~'_28__ ~(tag "long" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|29 (reify* [long+short>boolean] (~(tag "boolean" 'invoke) [~'_29__ ~(tag "long" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|30 (reify* [long+char>boolean] (~(tag "boolean" 'invoke) [~'_30__ ~(tag "long" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|31 (reify* [long+int>boolean] (~(tag "boolean" 'invoke) [~'_31__ ~(tag "long" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|32 (reify* [long+long>boolean] (~(tag "boolean" 'invoke) [~'_32__ ~(tag "long" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|33 (reify* [long+float>boolean] (~(tag "boolean" 'invoke) [~'_33__ ~(tag "long" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|34 (reify* [long+double>boolean] (~(tag "boolean" 'invoke) [~'_34__ ~(tag "long" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|35 (reify* [float+byte>boolean] (~(tag "boolean" 'invoke) [~'_35__ ~(tag "float" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|36 (reify* [float+short>boolean] (~(tag "boolean" 'invoke) [~'_36__ ~(tag "float" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|37 (reify* [float+char>boolean] (~(tag "boolean" 'invoke) [~'_37__ ~(tag "float" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|38 (reify* [float+int>boolean] (~(tag "boolean" 'invoke) [~'_38__ ~(tag "float" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|39 (reify* [float+long>boolean] (~(tag "boolean" 'invoke) [~'_39__ ~(tag "float" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|40 (reify* [float+float>boolean] (~(tag "boolean" 'invoke) [~'_40__ ~(tag "float" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|41 (reify* [float+double>boolean] (~(tag "boolean" 'invoke) [~'_41__ ~(tag "float" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|42 (reify* [double+byte>boolean] (~(tag "boolean" 'invoke) [~'_42__ ~(tag "double" 'a) ~(tag "byte" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|43 (reify* [double+short>boolean] (~(tag "boolean" 'invoke) [~'_43__ ~(tag "double" 'a) ~(tag "short" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|44 (reify* [double+char>boolean] (~(tag "boolean" 'invoke) [~'_44__ ~(tag "double" 'a) ~(tag "char" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|45 (reify* [double+int>boolean] (~(tag "boolean" 'invoke) [~'_45__ ~(tag "double" 'a) ~(tag "int" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|46 (reify* [double+long>boolean] (~(tag "boolean" 'invoke) [~'_46__ ~(tag "double" 'a) ~(tag "long" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|47 (reify* [double+float>boolean] (~(tag "boolean" 'invoke) [~'_47__ ~(tag "double" 'a) ~(tag "float" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) (def ~'>|test|__0|48 (reify* [double+double>boolean] (~(tag "boolean" 'invoke) [~'_48__ ~(tag "double" 'a) ~(tag "double" 'b)] - ~'(Numeric/gt a b)))) + ~'(. Numeric gt a b)))) ;; Unindented for greater vertical brevity (defn ~'>|test @@ -873,31 +875,31 @@ (def ~'>long*|__0|0 (reify* [byte>long] (~(tag "long" 'invoke) [~'_0__ ~(tag "byte" 'x)] - ~'(Primitive/uncheckedLongCast x)))) + ~'(. Primitive uncheckedLongCast x)))) (def ~'>long*|__0|1 (reify* [short>long] (~(tag "long" 'invoke) [~'_1__ ~(tag "short" 'x)] - ~'(Primitive/uncheckedLongCast x)))) + ~'(. Primitive uncheckedLongCast x)))) (def ~'>long*|__0|2 (reify* [char>long] (~(tag "long" 'invoke) [~'_2__ ~(tag "char" 'x)] - ~'(Primitive/uncheckedLongCast x)))) + ~'(. Primitive uncheckedLongCast x)))) (def ~'>long*|__0|3 (reify* [int>long] (~(tag "long" 'invoke) [~'_3__ ~(tag "int" 'x)] - ~'(Primitive/uncheckedLongCast x)))) + ~'(. Primitive uncheckedLongCast x)))) (def ~'>long*|__0|4 (reify* [long>long] (~(tag "long" 'invoke) [~'_4__ ~(tag "long" 'x)] - ~'(Primitive/uncheckedLongCast x)))) + ~'(. Primitive uncheckedLongCast x)))) (def ~'>long*|__0|5 (reify* [float>long] (~(tag "long" 'invoke) [~'_5__ ~(tag "float" 'x)] - ~'(Primitive/uncheckedLongCast x)))) + ~'(. Primitive uncheckedLongCast x)))) (def ~'>long*|__0|6 (reify* [double>long] (~(tag "long" 'invoke) [~'_6__ ~(tag "double" 'x)] - ~'(Primitive/uncheckedLongCast x)))) + ~'(. Primitive uncheckedLongCast x)))) ;; [x (t/ref (t/isa? Number))] @@ -906,7 +908,7 @@ (def ~'>long*|__1|0 (reify* [Object>long] (~(tag "long" 'invoke) [~'_7__ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(.longValue x))))) + (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(. x longValue))))) (defn ~'>long* {:source "clojure.lang.RT.uncheckedLongCast" @@ -1200,14 +1202,16 @@ :clj ($ (do (def ~'!str|__0|0 (reify* [>Object] (~(tag "java.lang.Object" 'invoke) [~'_0__] - ~'(StringBuilder.)))) + ~(tag "java.lang.StringBuilder" '(new StringBuilder))))) (def ~(tag "[Ljava.lang.Object;" '!str|__1|input0|types) (*<> (t/isa? java.lang.String))) (def ~'!str|__1|0 (reify* [Object>Object] (~(tag "java.lang.Object" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "java.lang.String" 'x) ~'x] ~'(StringBuilder. x))))) + (let* [~(Str 'x) ~'x] + ~(tag "java.lang.StringBuilder" + (list 'new 'StringBuilder (STR 'x))))))) (def ~(tag "[Ljava.lang.Object;" '!str|__2|input0|types) (*<> (t/isa? java.lang.CharSequence) @@ -1216,11 +1220,13 @@ (reify* [Object>Object] (~(tag "java.lang.Object" 'invoke) [~'_2__ ~(tag "java.lang.Object" 'x)] (let* [~(tag "java.lang.CharSequence" 'x) ~'x] - ~'(StringBuilder. x))))) + ~(tag "java.lang.StringBuilder" + (list 'new 'StringBuilder + (tag "java.lang.CharSequence" 'x))))))) (def ~'!str|__2|1 (reify* [int>Object] (~(tag "java.lang.Object" 'invoke) [~'_3__ ~(tag "int" 'x)] - ~'(StringBuilder. x)))) + ~(tag "java.lang.StringBuilder" '(new StringBuilder x))))) (defn ~'!str {:quantum.core.type/type diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 7f15ccb6..93b2ae62 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -229,7 +229,8 @@ fipp.ednize/IEdn (-edn [this] (list `new-node (into (array-map) this)))) -(defn new-node [m] (-> m map->NewNode with-type-hint)) +;; Not type hinted because it's inferred +(defn new-node [m] (map->NewNode m)) (defn new-node? [x] (instance? NewNode x)) From 1f8b5524449b16c4fb740086b6ee5000a44f4d9a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 7 Sep 2018 00:05:17 -0600 Subject: [PATCH 244/810] Clean up --- src-dev/quantum/core/defnt_equivalences.cljc | 2 +- src-untyped/quantum/untyped/core/analyze.cljc | 48 +++++++++++-------- .../quantum/untyped/core/analyze/ast.cljc | 6 ++- .../core/analyze/clojure/predicates.cljc | 1 - src/quantum/core/macros/fn.cljc | 4 +- src/quantum/core/type.cljc | 4 +- 6 files changed, 37 insertions(+), 28 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index fa9bbdd0..236567fc 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -46,7 +46,7 @@ ($ (do (def ~'pid|test|__0|0 (reify* [>Object] (~(tag "java.lang.Object" 'invoke) [~'_0__] - ~(STR '(. (java.lang.management.ManagementFactory/getRuntimeMXBean) + ~(STR '(. (. java.lang.management.ManagementFactory getRuntimeMXBean) getName))))) (defn ~'pid|test {:quantum.core.type/type (t/fn t/any? ~'[:> (? t/string?)])} diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 5dbfa9c5..620bb8a8 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -19,6 +19,9 @@ [quantum.untyped.core.fn :refer [<- fn-> fn->>]] [quantum.untyped.core.form.evaluate :as ufeval] + [quantum.untyped.core.form.type-hint :as ufth] + [quantum.untyped.core.identification :as uident + :refer [>symbol]] [quantum.untyped.core.log :as log :refer [prl!]] [quantum.untyped.core.logic :as l @@ -85,8 +88,10 @@ (defonce *analyze-depth (atom 0)) (defn add-file-context-from [to from] - (let [from-meta (meta from)] - (update-meta to assoc :line (:line from-meta) :column (:column from-meta)))) + (let [{:keys [line column]} (meta from)] + (update-meta to + #(cond-> % line (assoc :line line) + column (assoc :column column))))) (def special-symbols '#{do let* deftype* fn* def . if quote new throw}) ; TODO make more complete @@ -261,7 +266,7 @@ "A note will be made of what methods match the argument types. If only one method is found, that is noted too. If no matching method is found, an exception is thrown." - [env ::env, form _, target _, target-class t/class?, static? t/boolean? + [env ::env, form _, target uast/node?, target-class t/class?, static? t/boolean? method-form simple-symbol?, args-forms _ #_(seq-of form?) > uast/method-call?] ;; TODO cache type by method (if-not-let [methods-for-name (-> target-class class->methods|with-cache @@ -281,18 +286,22 @@ (let [args-ct (c/count args-forms) call-data {:env env - :form form + :form ['. (-> target :form ufth/un-type-hint) method-form] :target target :method method-form :args [] :type (methods->type methods #_(count arg-forms))} call-data-with-arg-types - (r/fori [arg-form args-forms - call-data' call-data - i|arg] - (let [arg-node (analyze* env arg-form)] - ;; TODO can incrementally calculate return value, but possibly not worth it - (update call-data' :args conj arg-node))) + (-> (r/fori [arg-form args-forms + call-data' call-data + i|arg] + (let [arg-node (analyze* env arg-form)] + ;; TODO can incrementally calculate return value, but possibly not + ;; worth it + (-> call-data' + (update :form conj (:form arg-node)) + (update :args conj arg-node)))) + (update :form seq)) call-data-with-ret-type (update call-data-with-arg-types :type (fn [ret-type] (->> call-data-with-arg-types :args (mapv :type) ret-type))) @@ -574,13 +583,15 @@ :fn nil) {:keys [input-nodes out-type]} (call>input-nodes+out-type - env caller|node caller|type caller-kind inputs-ct body)] - (uast/call-node - {:env env - :form form - :caller caller|node - :args input-nodes - :type out-type})))))) + env caller|node caller|type caller-kind inputs-ct body) + call-node + (uast/call-node + {:env env + :form form + :caller caller|node + :args input-nodes + :type out-type})] + call-node))))) (defns- analyze-seq [env ::env, form _] (let [expanded-form (ufeval/macroexpand form)] @@ -598,8 +609,6 @@ (if-let [[_ local] (find env sym)] {:value local} (let [resolved (ns-resolve *ns* sym)] - (log/ppr :warn "Not sure how to handle non-local symbol; resolved it for now" - (kw-map sym resolved)) (ifs resolved {:value resolved} (some-> sym namespace symbol resolve class?) @@ -639,6 +648,5 @@ (defns analyze > uast/node? ([form _] (analyze {} form)) ([env ::env, form _] - (log/pr! form) (reset! *analyze-depth 0) (analyze* env form))) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 93b2ae62..2c9ae00a 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -183,7 +183,8 @@ fipp.ednize/IEdn (-edn [this] (list `field-access (into (array-map) this)))) -(defn field-access [m] (-> m map->FieldAccess with-type-hint)) +;; Not type hinted because it's inferred +(defn field-access [m] (map->FieldAccess m)) (defn field-access? [x] (instance? FieldAccess x)) @@ -199,7 +200,8 @@ fipp.ednize/IEdn (-edn [this] (list `method-call (into (array-map) this)))) -(defn method-call [m] (-> m map->MethodCall with-type-hint)) +;; Not type hinted because it's inferred +(defn method-call [m] (map->MethodCall m)) (defn method-call? [x] (instance? MethodCall x)) diff --git a/src/quantum/core/analyze/clojure/predicates.cljc b/src/quantum/core/analyze/clojure/predicates.cljc index d67d968f..029c2e30 100644 --- a/src/quantum/core/analyze/clojure/predicates.cljc +++ b/src/quantum/core/analyze/clojure/predicates.cljc @@ -7,7 +7,6 @@ #?(:clj [clojure.jvm.tools.analyzer :as tana]) [quantum.core.analyze.clojure.core :as ana] - [quantum.core.core :as qcore] [quantum.core.fn :as fn :refer [fnl <- fn-> fn->> fn']] [quantum.core.logic :as logic diff --git a/src/quantum/core/macros/fn.cljc b/src/quantum/core/macros/fn.cljc index 96e78835..dc1fec96 100644 --- a/src/quantum/core/macros/fn.cljc +++ b/src/quantum/core/macros/fn.cljc @@ -15,10 +15,10 @@ :refer [fn-or whenf1]] [quantum.core.macros.optimization :as opt :refer [extern?]] - [quantum.untyped.core.collections.tree :as utree - :refer [postwalk]] [quantum.core.vars :refer [defalias]] + [quantum.untyped.core.collections.tree :as utree + :refer [postwalk]] [quantum.untyped.core.form.evaluate :refer [case-env]] [quantum.untyped.core.form.generate :as ufgen])) diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index 5810c1dd..96a52efc 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -1,7 +1,7 @@ (ns quantum.core.type "This is this the namespace upon which all other fully-typed namespaces rest." (:refer-clojure :exclude - [* and any? fn isa? or seq? symbol? var?]) + [* and any? fn isa? or ref seq? symbol? var?]) (:require [quantum.untyped.core.type.defnt :as udefnt] [quantum.untyped.core.type :as ut] @@ -14,7 +14,7 @@ (defaliases ut ;; Generators - ? * isa? fn + ? * isa? fn ref ;; Combinators and or ;; Predicates From 623a095f6c53d6a312444197e42650cfb05d5ae0 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 7 Sep 2018 00:05:25 -0600 Subject: [PATCH 245/810] Get as far as we can in quantum.core.vars --- src/quantum/core/vars.cljc | 50 ++++++++++++++++++++------------------ 1 file changed, 26 insertions(+), 24 deletions(-) diff --git a/src/quantum/core/vars.cljc b/src/quantum/core/vars.cljc index 94b4d6d9..0ee00300 100644 --- a/src/quantum/core/vars.cljc +++ b/src/quantum/core/vars.cljc @@ -61,16 +61,17 @@ ;; ===== Declaration/Interning ===== ;; #?(:clj -(defnt intern > t/var? +(defnt intern "Finds or creates a var named by the symbol name in ->`ns-val`, setting its root binding to ->`v` if supplied. The namespace must exist. The var will adopt any metadata from ->`name-val`. Returns the var." - ([ns-val (t/or t/symbol? t/namespace?), var-name t/symbol?] - (let [var-ref (clojure.lang.Var/intern (ns/symbol>ns ns-val) var-name)] - (when (meta var-name) (.setMeta var- (meta var-name))) + > t/var? + ([ns-val (t/or t/symbol? t/namespace?), var-name t/symbol? > (t/* t/var?)] + (let [var-ref (clojure.lang.Var/intern (ns/>ns ns-val) var-name)] + (when (meta var-name) (.setMeta var-ref (meta var-name))) var-ref)) - ([ns-val (t/or t/symbol? t/namespace?), var-name t/symbol?, var-val t/any?] - (let [var-ref (clojure.lang.Var/intern (ns/symbol>ns ns-val) var-name var-val)] + ([ns-val (t/or t/symbol? t/namespace?), var-name t/symbol?, var-val (t/ref t/any?) > (t/* t/var?)] + (let [var-ref (clojure.lang.Var/intern (ns/>ns ns-val) var-name var-val)] (when (meta var-name) (.setMeta var-ref (meta var-name))) var-ref)))) @@ -78,45 +79,45 @@ #?(:clj (defalias uvar/def)) ;; TODO TYPED -#?(:clj (uvar/defalias uvar/defalias)) - -;; TODO TYPED -#?(:clj (uvar/defaliases uvar defaliases defaliases')) +#?(:clj (uvar/defaliases uvar defalias defaliases defaliases')) #?(:clj (defnt defined? [x t/var?] (.hasRoot x))) -#?(:clj +;; TODO TYPED — need to do `apply`, and `apply` with defnt; also `merge`, `str`, `deref` +#_(:clj (defnt alias-var "Create a var with the supplied name in the current namespace, having the same metadata and root-binding as the supplied var." {:attribution "flatland.useful.ns" :contributors ["Alex Gunnarson"]} - [sym t/symbol?, var- t/var?] + [sym t/symbol?, var-val t/var?] (apply intern *ns* (with-meta sym (merge {:dont-test - (str "Alias of " (-> var- meta :name))} + (str "Alias of " (-> var-val meta :name))} (meta var-0) (meta sym))) - (when (defined? var-) [(deref var-)])))) + (when (defined? var-) [(deref var-val)])))) -;; TODO typed +;; TODO TYPED #?(:clj (quantum.untyped.core.vars/defmalias defmalias quantum.untyped.core.vars/defmalias)) -;; TODO typed -#?(:clj (defaliases u defonce def- defmacro-)) +;; TODO TYPED +#?(:clj (defaliases uvar defonce def- defmacro-)) ;; ===== Modification ===== ;; -#?(:clj +;; TODO TYPED — need to do `fnt` +#_(:clj (defnt reset-var! "Like `reset!` but for vars. Atomically sets the root binding of ->`var-` to ->`v`." {:attribution "alexandergunnarson"} - [var- t/var?, v _ > t/var?] - (.alterRoot var- (fnt [_] v)))) + [var-val t/var?, v (t/ref t/any?) > t/var?] + (.alterRoot var-val (fnt [_] v)))) -#?(:clj +;; TODO TYPED — need to do `fnt`, `apply` +#_(:clj (defnt update-var! {:attribution "alexandergunnarson"} ([var- t/var?, f (t/fn [_]) > t/var?] @@ -127,7 +128,8 @@ (do (.alterRoot var- (fnt [v' _] (apply f v' args))) var-)))) -#?(:clj +;; TODO TYPED — `doseq` +#_(:clj (defnt clear-vars! "Sets each var in ->`vars` to nil." {:attribution "alexandergunnarson"} @@ -136,7 +138,7 @@ ;; ===== Thread-local ===== ;; -;; TODO typed +;; TODO TYPED #?(:clj (defalias binding c/binding)) -;; TODO typed +;; TODO TYPED #?(:clj (defalias with-local-vars c/with-local-vars)) From 1baa07e98f7fe91f27c0036399c8a4e12474b74f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 7 Sep 2018 00:05:29 -0600 Subject: [PATCH 246/810] Add notes --- resources-dev/defnt.cljc | 37 +++++++++++++++++++++++++++++++++++-- 1 file changed, 35 insertions(+), 2 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index f0498212..ce9f13e6 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -29,6 +29,11 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - dealing with `apply`... - defmacrot - dotyped + - typed core fns + - `apply` + - especially with `defnt` as the caller + - `merge` + - `str` - NOTE on namespace organization: - [quantum.untyped.core.ns :refer [namespace?]] instead of @@ -40,15 +45,43 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO transition the quantum.core.* namespaces: - List of semi-approximately topologically ordered namespaces to make typed: - quantum.core.type.core + - quantum.core.type.defs + - quantum.core.data.map - quantum.core.logic - quantum.core.fn - - quantum.core.data.map + - quantum.core.cache - quantum.core.type-old - - quantum.core.vars + - quantum.core.data.string + - quantum.core.print + - quantum.core.log + - quantum.core.data.vector + - quantum.core.spec + - quantum.core.error + - quantum.core.data.bits + + - quantum.core.convert.primitive + - quantum.core.string.regex + - quantum.core.data.set + - quantum.core.macros.type-hint + - quantum.core.analyze.clojure.core + - quantum.core.analyze.clojure.predicates + - quantum.core.macros.optimization + - quantum.core.macros.fn + - quantum.core.macros.transform + - quantum.core.macros.protocol + - quantum.core.macros.reify + - quantum.core.macros.defnt + - quantum.core.macros + + - quantum.core.refs + - quantum.core.reducers.reduce + - quantum.core.collections.logic + - quantum.core.collections.core - Worked through all we can for now: - quantum.core.core - TODO delete this namespace? - quantum.core.ns + - quantum.core.vars - List of corresponding untyped namespaces to incorporate: - quantum.untyped.core.core - quantum.untyped.core.ns From 6f52e4b78c38735f36615c1d8b79ff12bead41d0 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 7 Sep 2018 19:33:59 -0600 Subject: [PATCH 247/810] `quantum.core.data.primitive` --- resources-dev/defnt.cljc | 1 + src-untyped/quantum/untyped/core/form.cljc | 4 +- src/quantum/core/data/primitive.cljc | 72 +++++++++++++--------- 3 files changed, 47 insertions(+), 30 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index ce9f13e6..eac9b1c1 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -80,6 +80,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - Worked through all we can for now: - quantum.core.core - TODO delete this namespace? + - quantum.core.data.primitive - quantum.core.ns - quantum.core.vars - List of corresponding untyped namespaces to incorporate: diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index 8bdd6f35..082ae424 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -36,7 +36,9 @@ nil (>form [x] nil) #?(:clj java.lang.Boolean :cljs boolean) (>form [x] x) - java.lang.Long (>form [x] x) + #?@(:clj [java.lang.Long (>form [x] x)]) + #?(:clj java.lang.Double + :cljs number) (>form [x] x) #?(:clj clojure.lang.Symbol :cljs cljs.core.Symbol) (>form [x] (list 'quote x)) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index ef7bc432..e08329e5 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -1,35 +1,49 @@ (ns quantum.core.data.primitive + (:refer-clojure :exclude + [char? double? float? int?]) (:require - [quantum.core.macros :refer [defnt]])) + [quantum.core.type :as t + :refer [defnt]])) -(defnt ->min-magnitude - #?(:clj ([^byte x] (byte 0))) - #?(:clj ([^char x] (char 0))) - #?(:clj ([^short x] (short 0))) - #?(:clj ([^int x] (int 0))) - #?(:clj ([^long x] (long 0))) - #?(:clj ([^float x] Float/MIN_VALUE )) - ([^double x] #?(:clj Double/MIN_VALUE - :cljs js/Number.MIN_VALUE))) +;; TODO TYPED type coercion/casts should go in here -#?(:clj (def ^:const min-float (- Float/MAX_VALUE))) - (def ^:const min-double (- #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) +#?(:clj (def byte? (t/isa? Byte))) +#?(:clj (def short? (t/isa? Short))) +#?(:clj (def char? (t/isa? Character))) +#?(:clj (def int? (t/isa? Integer))) +#?(:clj (def long? (t/isa? Long))) +#?(:clj (def float? (t/isa? Float))) + (def double? (t/isa? #?(:clj Double :cljs js/Number))) -(defnt ->min-value - #?(:clj ([^byte x] Byte/MIN_VALUE )) - #?(:clj ([^char x] Character/MIN_VALUE)) - #?(:clj ([^short x] Short/MIN_VALUE )) - #?(:clj ([^int x] Integer/MIN_VALUE )) - #?(:clj ([^long x] Long/MIN_VALUE )) - #?(:clj ([^float x] min-float )) - ([^double x] min-double )) +(defnt >min-magnitude + #?(:clj ([x byte? > byte?] (byte 0))) + #?(:clj ([x short? > short?] (short 0))) + #?(:clj ([x char? > char?] (char 0))) + #?(:clj ([x int? > int?] (int 0))) + #?(:clj ([x long? > long?] (long 0))) + #?(:clj ([x float? > float?] Float/MIN_VALUE)) + ([x double? > double?] #?(:clj Double/MIN_VALUE + :cljs js/Number.MIN_VALUE))) -(defnt ->max-value - #?(:clj ([^byte x] Byte/MAX_VALUE )) - #?(:clj ([^char x] Character/MAX_VALUE)) - #?(:clj ([^short x] Short/MAX_VALUE )) - #?(:clj ([^int x] Integer/MAX_VALUE )) - #?(:clj ([^long x] Long/MAX_VALUE )) - #?(:clj ([^float x] Float/MAX_VALUE )) - ([^double x] #?(:clj Double/MAX_VALUE - :cljs js/Number.MAX_VALUE))) +#?(:clj (def min-float (- Float/MAX_VALUE))) + (def min-double (- #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) + +;; TODO TYPED for some reason it's not figuring out the type of `min-float` and `min-double` +#_(defnt >min-value + #?(:clj ([x byte? > byte?] Byte/MIN_VALUE)) + #?(:clj ([x short? > short?] Short/MIN_VALUE)) + #?(:clj ([x char? > char?] Character/MIN_VALUE)) + #?(:clj ([x int? > int?] Integer/MIN_VALUE)) + #?(:clj ([x long? > long?] Long/MIN_VALUE)) + #?(:clj ([x float? > float?] min-float)) + ([x double? > double?] min-double)) + +(defnt >max-value + #?(:clj ([x byte? > byte?] Byte/MAX_VALUE)) + #?(:clj ([x short? > short?] Short/MAX_VALUE)) + #?(:clj ([x char? > char?] Character/MAX_VALUE)) + #?(:clj ([x int? > int?] Integer/MAX_VALUE)) + #?(:clj ([x long? > long?] Long/MAX_VALUE)) + #?(:clj ([x float? > float?] Float/MAX_VALUE)) + ([x double? > double?] #?(:clj Double/MAX_VALUE + :cljs js/Number.MAX_VALUE))) From 58038b6e821eb565b0bd6d68c2faef2706c56335 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 14 Sep 2018 23:24:59 -0600 Subject: [PATCH 248/810] quantum.core.data.map --- resources-dev/defnt.cljc | 17 +- src-dev/quantum/core/defnt_equivalences.cljc | 6 +- .../quantum/untyped/core/data/map.cljc | 392 +---- src-untyped/quantum/untyped/core/specs.cljc | 2 +- src-untyped/quantum/untyped/core/type.cljc | 665 +------ src-untyped/quantum/untyped/ui/features.cljc | 4 +- src/quantum/ai/ml/instance/selection.cljc | 12 +- src/quantum/apis/google/drive/core.cljc | 2 +- src/quantum/apis/quip/core.cljc | 5 +- src/quantum/audio/midi.clj | 7 +- src/quantum/compile/transpile/to/core.cljc | 16 +- src/quantum/core/async/pool.cljc | 2 +- src/quantum/core/collections.cljc | 14 +- src/quantum/core/data/map.cljc | 1541 ++++++++++++++++- src/quantum/core/data/primitive.cljc | 37 +- src/quantum/core/ns.cljc | 14 +- src/quantum/core/type.cljc | 6 +- src/quantum/core/vars.cljc | 9 +- src/quantum/numeric/statistics/core.cljc | 10 +- test/quantum/test/core/collections.cljc | 4 - 20 files changed, 1618 insertions(+), 1147 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index eac9b1c1..495a1c2e 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -8,18 +8,19 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - t/assume - t/numerically - t/of - - (t/of t/+map? t/symbol? t/string?) + - (t/of map/+map? t/symbol? str/string?) - (t/of t/seq? namespace?) - t/map-of - t/seq-of - t/unqualified-symbol? - expressions (`quantum.untyped.core.analyze.expr`) + - comparison of `t/fn`s is probably possible? - deft - - fnt + - fnt (t/fn; current t/fn might transition to t/fn-spec or whatever?) - declaret - declare-fnt (a way to do protocols/interfaces) - extend-fnt! - - defnt + - defnt (t/defn) - handle varargs - [& args _] shouldn't result in `t/any?` but rather like `t/seqable?` or whatever - do the defnt-equivalences @@ -27,13 +28,16 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative wider declared type there is - the option of creating a `defnt` that isn't extensible? Or at least in which the input types are limited in the same way per-overload output types are limited by the per-fn output type? - dealing with `apply`... - - defmacrot + - t/defmacro + - t/deftype - dotyped - typed core fns - `apply` - especially with `defnt` as the caller - `merge` - `str` + - `compare` + - `get` - NOTE on namespace organization: - [quantum.untyped.core.ns :refer [namespace?]] instead of @@ -46,7 +50,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - List of semi-approximately topologically ordered namespaces to make typed: - quantum.core.type.core - quantum.core.type.defs - - quantum.core.data.map - quantum.core.logic - quantum.core.fn - quantum.core.cache @@ -83,10 +86,14 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - quantum.core.data.primitive - quantum.core.ns - quantum.core.vars + - quantum.core.data.map - List of corresponding untyped namespaces to incorporate: - quantum.untyped.core.core - quantum.untyped.core.ns - quantum.untyped.core.vars + - quantum.untyped.core.data.map + - quantum.untyped.core.type.defs + - quantum.untyped.core.data - Standard metadata - e.g. `{:alternate-implementations #{'cljs.tools.reader/merge-meta}}` - Instead of e.g. `ns-` or `var-` we can do `ns-val` and `var-val` diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 236567fc..92b9a1f2 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -1633,10 +1633,10 @@ (let [rf ((.-xf x) f)] (rf (reduce rf init (.-prev x))))) ([f rf?, init _, x t/chan?] (async/reduce f init x)) ; TODO spec `async/reduce` -#?(:cljs ([f rf?, init _, xs t/+map?] (#_(:clj clojure.core.protocols/kv-reduce - :cljs -kv-reduce) ; in order to use transducers... +#?(:cljs ([f rf?, init _, xs map/+map?] (#_(:clj clojure.core.protocols/kv-reduce + :cljs -kv-reduce) ; in order to use transducers... -reduce-seq xs f init))) -#?(:cljs ([f rf?, init _, xs t/+set?] (-reduce-seq xs f init))) +#?(:cljs ([f rf?, init _, xs set/+set?] (-reduce-seq xs f init))) ([f rf?, init _, n (t/numerically t/int?)] (loop [i 0 v init] (if (< i n) diff --git a/src-untyped/quantum/untyped/core/data/map.cljc b/src-untyped/quantum/untyped/core/data/map.cljc index 047e0d33..82e34bb9 100644 --- a/src-untyped/quantum/untyped/core/data/map.cljc +++ b/src-untyped/quantum/untyped/core/data/map.cljc @@ -28,38 +28,8 @@ [it.unimi.dsi.fastutil.objects Reference2LongOpenHashMap]] :cljs [[goog.structs AvlTree LinkedMap]]))) -;; TO EXPLORE -;; - Optimizing Hash-Array Mapped Tries for Fast and Lean Immutable JVM Collections -;; - Actual usable implementation: https://github.com/usethesource/capsule -;; - http://michael.steindorfer.name/publications/oopsla15.pdf -;; - Overall significantly faster on what they've chosen to measure. -;; - Alex Miller: "We have seen it and will probably investigate some of these ideas after 1.8." -;; ======================= - ;; ===== Map entries ===== ;; -(defn map-entry - "A performant replacement for creating 2-tuples (vectors), e.g., as return values - in a |kv-reduce| function. - - Now overshadowed by ztellman's unrolled vectors in 1.8.0. - - Time to create 100000000 2-tuples: - new tuple-vector 55.816415 ms - map-entry 37.542442 ms - - However, insertion into maps is faster with map-entry: - - (def vs [[1 2] [3 4]]) - (def ms [(map-entry 1 2) (map-entry 3 4)]) - (def m0 {}) - 508.122831 ms (dotimes [n 1000000] (into m0 vs)) - 310.335998 ms (dotimes [n 1000000] (into m0 ms))" - {:attribution "alexandergunnarson"} - [k v] - #?(:clj (clojure.lang.MapEntry. k v) - :cljs (cljs.core.MapEntry. k v nil))) - ;; TODO excise? (defn map-entry-seq [args] (loop [[k v :as args-n] args @@ -69,64 +39,6 @@ (recur (-> args-n rest rest) (conj accum (map-entry k v)))))) -;; ===== Unordered identity-semantic maps ===== ;; - -;; TODO generate these functions via macros -(defn #?(:clj ^IdentityHashMap !identity-map :cljs !identity-map) - "Creates a single-threaded, mutable identity map. - On the JVM, this is a `java.util.IdentityHashMap`. - On JS, this is a `js/Map` (ECMAScript 6 Map)." - ([] #?(:clj (IdentityHashMap.) :cljs (js/Map.))) - ([k0 v0] - (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) - (#?(:clj .put :cljs .set) k0 v0))) - ([k0 v0 k1 v1] - (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) - (#?(:clj .put :cljs .set) k0 v0) - (#?(:clj .put :cljs .set) k1 v1))) - ([k0 v0 k1 v1 k2 v2] - (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) - (#?(:clj .put :cljs .set) k0 v0) - (#?(:clj .put :cljs .set) k1 v1) - (#?(:clj .put :cljs .set) k2 v2))) - ([k0 v0 k1 v1 k2 v2 k3 v3] - (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) - (#?(:clj .put :cljs .set) k0 v0) - (#?(:clj .put :cljs .set) k1 v1) - (#?(:clj .put :cljs .set) k2 v2) - (#?(:clj .put :cljs .set) k3 v3))) - ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4] - (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) - (#?(:clj .put :cljs .set) k0 v0) - (#?(:clj .put :cljs .set) k1 v1) - (#?(:clj .put :cljs .set) k2 v2) - (#?(:clj .put :cljs .set) k3 v3) - (#?(:clj .put :cljs .set) k4 v4))) - ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5] - (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) - (#?(:clj .put :cljs .set) k0 v0) - (#?(:clj .put :cljs .set) k1 v1) - (#?(:clj .put :cljs .set) k2 v2) - (#?(:clj .put :cljs .set) k3 v3) - (#?(:clj .put :cljs .set) k4 v4) - (#?(:clj .put :cljs .set) k5 v5))) - ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 & kvs] - (reduce-pair - (fn [#?(:clj ^IdentityHashMap m :cljs m) k v] (doto m (#?(:clj .put :cljs .set) k v))) - (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) - (#?(:clj .put :cljs .set) k0 v0) - (#?(:clj .put :cljs .set) k1 v1) - (#?(:clj .put :cljs .set) k2 v2) - (#?(:clj .put :cljs .set) k3 v3) - (#?(:clj .put :cljs .set) k4 v4) - (#?(:clj .put :cljs .set) k5 v5) - (#?(:clj .put :cljs .set) k6 v6)) - kvs))) - -;; ===== Unordered value-semantic maps ===== ;; - -(defalias array-map core/array-map) - ;; ----- Hash maps ----- ;; #?(:clj (def hash-map? (partial instance? clojure.lang.PersistentHashMap))) @@ -136,186 +48,6 @@ #?(:clj (defalias hash-map|long->ref imap/int-map)) #?(:clj (defalias int-map hash-map|long->ref)) -#?(:cljs -(deftype MutableHashMap ; There can be no `undefined` values - [meta ^:mutable ct ^js/Map m #_"Keys are int hashes; vals are map entries from k to v" - ^:mutable ^boolean has-nil? ^:mutable nil-val ^:mutable __hash] - Object - (toString [this] (str (into {} (es6-iterator-seq (.values m))))) - (equiv [this other] (-equiv this other)) - (keys [this] (es6-iterator (cljs.core/keys this))) - (entries [this] (es6-entries-iterator (seq this))) - (values [this] (es6-iterator (vals this))) - (has [this k] (contains? this k)) - (get [this k not-found] (-lookup this k not-found)) - (forEach [this f] (doseq [[k v] this] (f v k))) - ICloneable - (-clone [_] (MutableHashMap. meta ct m has-nil? nil-val __hash)) - IIterable - (-iterator [this] (-iterator (vals this))) - IWithMeta - (-with-meta [this meta-] (MutableHashMap. meta- ct m has-nil? nil-val __hash)) - IMeta - (-meta [this] meta) - IEmptyableCollection - (-empty [this] (MutableHashMap. meta 0 (js/Map.) false nil 0)) - IEquiv - (-equiv [this that] (equiv-map this that)) - IHash - (-hash [this] (caching-hash this hash-unordered-coll __hash)) - ISeqable - (-seq [this] - (when (pos? ct) - (let [s (es6-iterator-seq (.values m))] - (if has-nil? - (cons (map-entry nil nil-val) s) - s)))) - ICounted - (-count [this] ct) - ILookup - (-lookup [this k] (-lookup this k nil)) - (-lookup [this k not-found] - (if (nil? k) - (if has-nil? nil-val not-found) - (let [kv (.get m (hash k))] - (if (undefined? kv) not-found (-val kv))))) - IAssociative - (-contains-key? [this k] - (if (nil? k) - has-nil? - (.has m (hash k)))) - IFind - (-find [this k] - (if (nil? k) - (when has-nil? (map-entry nil nil-val)) - (let [kv (.get m (hash k))] - (if (undefined? kv) nil kv)))) - ITransientCollection - (-conj! [this entry] - (if (vector? entry) - (-assoc! this (-nth entry 0) (-nth entry 1)) - (loop [ret this es (seq entry)] - (if (nil? es) - ret - (let [e (first es)] - (if (vector? e) - (recur (-assoc! ret (-nth e 0) (-nth e 1)) - (next es)) - (throw (ex-info "conj on a map takes map entries or seqables of map entries" {})))))))) - ITransientAssociative - (-assoc! [this k v] - (cond - (undefined? v) - (throw (ex-info "Cannot `assoc` undefined value to `MutableHashMap`" {})) - (nil? k) - (if (and has-nil? (identical? v nil-val)) - this - (do (when-not has-nil? (set! ct (inc ct))) - (set! has-nil? true) - (set! nil-val v) - (set! __hash nil) ; TODO recalculate incrementally? - this)) - :else - (let [hash-k (hash k)] - (if (.has m hash-k) - this - (do (.set m (hash k) (map-entry k v)) - (set! ct (inc ct)) - (set! __hash nil) ; TODO recalculate incrementally? - this))))) - ITransientMap - (-dissoc! [this k] - (if (nil? k) - (if has-nil? - (do (set! ct (dec ct)) - (set! has-nil? false) - (set! nil-val nil) - (set! __hash nil) ; TODO recalculate incrementally? - this) - this) - (if (.delete m (hash k)) - (do (set! ct (dec ct)) - (set! __hash nil) ; TODO recalculate incrementally? - this) - this))) - IKVReduce - (-kv-reduce [this f init] - (let [init (if has-nil? (f init nil nil-val) init)] - (if (reduced? init) - @init - (unreduced (reduce (fn [ret kv] (f ret (-key kv) (-val kv))) init m))))) - IFn - (-invoke [this k] (-lookup this k)) - (-invoke [this k not-found] (-lookup this k not-found)))) - -;; TODO generate these functions via macros -(defn #?(:clj ^HashMap !hash-map :cljs !hash-map) - "Creates a single-threaded, mutable hash map. - On the JVM, this is a `java.util.HashMap`. - On JS, this is a `quantum.untyped.core.data.map.HashMap`." - ([] #?(:clj (HashMap.) :cljs (MutableHashMap. nil 0 (js/Map.) false nil nil))) - ([k0 v0] - (doto #?(:clj (HashMap.) :cljs (!hash-map)) - (#?(:clj .put :cljs assoc!) k0 v0))) - ([k0 v0 k1 v1] - (doto #?(:clj (HashMap.) :cljs (!hash-map)) - (#?(:clj .put :cljs assoc!) k0 v0) - (#?(:clj .put :cljs assoc!) k1 v1))) - ([k0 v0 k1 v1 k2 v2] - (doto #?(:clj (HashMap.) :cljs (!hash-map)) - (#?(:clj .put :cljs assoc!) k0 v0) - (#?(:clj .put :cljs assoc!) k1 v1) - (#?(:clj .put :cljs assoc!) k2 v2))) - ([k0 v0 k1 v1 k2 v2 k3 v3] - (doto #?(:clj (HashMap.) :cljs (!hash-map)) - (#?(:clj .put :cljs assoc!) k0 v0) - (#?(:clj .put :cljs assoc!) k1 v1) - (#?(:clj .put :cljs assoc!) k2 v2) - (#?(:clj .put :cljs assoc!) k3 v3))) - ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4] - (doto #?(:clj (HashMap.) :cljs (!hash-map)) - (#?(:clj .put :cljs assoc!) k0 v0) - (#?(:clj .put :cljs assoc!) k1 v1) - (#?(:clj .put :cljs assoc!) k2 v2) - (#?(:clj .put :cljs assoc!) k3 v3) - (#?(:clj .put :cljs assoc!) k4 v4))) - ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5] - (doto #?(:clj (HashMap.) :cljs (!hash-map)) - (#?(:clj .put :cljs assoc!) k0 v0) - (#?(:clj .put :cljs assoc!) k1 v1) - (#?(:clj .put :cljs assoc!) k2 v2) - (#?(:clj .put :cljs assoc!) k3 v3) - (#?(:clj .put :cljs assoc!) k4 v4) - (#?(:clj .put :cljs assoc!) k5 v5))) - ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 & kvs] - (reduce-pair - (fn [^HashMap m k v] (doto m (#?(:clj .put :cljs assoc!) k v))) - (doto #?(:clj (HashMap.) :cljs (!hash-map)) - (#?(:clj .put :cljs assoc!) k0 v0) - (#?(:clj .put :cljs assoc!) k1 v1) - (#?(:clj .put :cljs assoc!) k2 v2) - (#?(:clj .put :cljs assoc!) k3 v3) - (#?(:clj .put :cljs assoc!) k4 v4) - (#?(:clj .put :cljs assoc!) k5 v5) - (#?(:clj .put :cljs assoc!) k6 v6)) - kvs))) - -; TODO generate these functions via macros -#?(:clj (defn ^Int2ReferenceOpenHashMap !hash-map|int->ref [] (Int2ReferenceOpenHashMap.))) -#?(:clj (defalias !hash-map|int->object !hash-map|int->ref)) - -#?(:clj (defn ^Long2LongOpenHashMap !hash-map|long->long [] (Long2LongOpenHashMap.))) -#?(:clj (defalias !hash-map|long !hash-map|long->long)) - -#?(:clj (defn ^Long2ReferenceOpenHashMap !hash-map|long->ref [] (Long2ReferenceOpenHashMap.))) -#?(:clj (defalias !hash-map|long->object !hash-map|long->ref)) - -#?(:clj (defn ^Double2ReferenceOpenHashMap !hash-map|double->ref [] (Double2ReferenceOpenHashMap.))) -#?(:clj (defalias !hash-map|double->object !hash-map|double->ref)) - -#?(:clj (defn ^Reference2LongOpenHashMap !hash-map|ref->long [] (Reference2LongOpenHashMap.))) -#?(:clj (defalias !hash-map|object->long !hash-map|ref->long)) - ;; ===== Ordered value-semantic maps ===== ;; ;; ---- Insertion-ordered ----- ;; @@ -329,58 +61,6 @@ [& ks] (list* `om (udata/quote-map-base >keyword ks)))) -;; TODO generate these functions via macros -(defn #?(:clj ^LinkedHashMap !ordered-map :cljs !ordered-map) - "Creates a single-threaded, mutable insertion-ordered map. - On the JVM, this is a `java.util.LinkedHashMap`. - On JS, this is a `goog.structs.LinkedMap`." - ([] #?(:clj (LinkedHashMap.) :cljs (LinkedMap.))) - ([k0 v0] - (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) - (#?(:clj .put :cljs .add) k0 v0))) - ([k0 v0 k1 v1] - (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) - (#?(:clj .put :cljs .add) k0 v0) - (#?(:clj .put :cljs .add) k1 v1))) - ([k0 v0 k1 v1 k2 v2] - (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) - (#?(:clj .put :cljs .add) k0 v0) - (#?(:clj .put :cljs .add) k1 v1) - (#?(:clj .put :cljs .add) k2 v2))) - ([k0 v0 k1 v1 k2 v2 k3 v3] - (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) - (#?(:clj .put :cl .add) k0 v0) - (#?(:clj .put :cljs .add) k1 v1) - (#?(:clj .put :cljs .add) k2 v2) - (#?(:clj .put :cljs .add) k3 v3))) - ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4] - (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) - (#?(:clj .put :cljs .add) k0 v0) - (#?(:clj .put :cljs .add) k1 v1) - (#?(:clj .put :cljs .add) k2 v2) - (#?(:clj .put :cljs .add) k3 v3) - (#?(:clj .put :cljs .add) k4 v4))) - ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5] - (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) - (#?(:clj .put :cljs .add) k0 v0) - (#?(:clj .put :cljs .add) k1 v1) - (#?(:clj .put :cljs .add) k2 v2) - (#?(:clj .put :cljs .add) k3 v3) - (#?(:clj .put :cljs .add) k4 v4) - (#?(:clj .put :cljs .add) k5 v5))) - ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 & kvs] - (reduce-pair - (fn [#?(:clj ^LinkedHashMap m :cljs m) k v] (doto m (#?(:clj .put :cljs .add) k v))) - (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) - (#?(:clj .put :cljs .add) k0 v0) - (#?(:clj .put :cljs .add) k1 v1) - (#?(:clj .put :cljs .add) k2 v2) - (#?(:clj .put :cljs .add) k3 v3) - (#?(:clj .put :cljs .add) k4 v4) - (#?(:clj .put :cljs .add) k5 v5) - (#?(:clj .put :cljs .add) k6 v6)) - kvs))) - ;; ----- Comparison-ordered (sorted) ----- ;; (defalias core/sorted-map) @@ -390,76 +70,6 @@ (defn sorted-map-by-val [m & kvs] (apply sorted-map-by (gen-compare-by-val m) kvs)) -;; TODO generate these functions via macros -(defn #?(:clj ^TreeMap !sorted-map-by :cljs !sorted-map-by) - "Creates a single-threaded, mutable sorted map with the specified comparator. - On the JVM, this is a `java.util.TreeMap`. - On JS, this is a `goog.structs.AvlTree`." - ([compf] #?(:clj (TreeMap. compf) :cljs (AvlTree. compf))) - ([compf k0 v0] - (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) - (#?(:clj .put :cljs .add) k0 v0))) - ([compf k0 v0 k1 v1] - (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) - (#?(:clj .put :cljs .add) k0 v0) - (#?(:clj .put :cljs .add) k1 v1))) - ([compf k0 v0 k1 v1 k2 v2] - (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) - (#?(:clj .put :cljs .add) k0 v0) - (#?(:clj .put :cljs .add) k1 v1) - (#?(:clj .put :cljs .add) k2 v2))) - ([compf k0 v0 k1 v1 k2 v2 k3 v3] - (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) - (#?(:clj .put :cljs .add) k0 v0) - (#?(:clj .put :cljs .add) k1 v1) - (#?(:clj .put :cljs .add) k2 v2) - (#?(:clj .put :cljs .add) k3 v3))) - ([compf k0 v0 k1 v1 k2 v2 k3 v3 k4 v4] - (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) - (#?(:clj .put :cljs .add) k0 v0) - (#?(:clj .put :cljs .add) k1 v1) - (#?(:clj .put :cljs .add) k2 v2) - (#?(:clj .put :cljs .add) k3 v3) - (#?(:clj .put :cljs .add) k4 v4))) - ([compf k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5] - (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) - (#?(:clj .put :cljs .add) k0 v0) - (#?(:clj .put :cljs .add) k1 v1) - (#?(:clj .put :cljs .add) k2 v2) - (#?(:clj .put :cljs .add) k3 v3) - (#?(:clj .put :cljs .add) k4 v4) - (#?(:clj .put :cljs .add) k5 v5))) - ([compf k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 & kvs] - (reduce-pair - (fn [#?(:clj ^TreeMap m :cljs m) k v] (doto m (#?(:clj .put :cljs .add) k v))) - (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) - (#?(:clj .put :cljs .add) k0 v0) - (#?(:clj .put :cljs .add) k1 v1) - (#?(:clj .put :cljs .add) k2 v2) - (#?(:clj .put :cljs .add) k3 v3) - (#?(:clj .put :cljs .add) k4 v4) - (#?(:clj .put :cljs .add) k5 v5) - (#?(:clj .put :cljs .add) k6 v6)) - kvs))) - -;; TODO generate these functions via macros -(defn #?(:clj ^TreeMap !sorted-map :cljs !sorted-map) - "Creates a single-threaded, mutable sorted map. - On the JVM, this is a `java.util.TreeMap`. - On JS, this is a `goog.structs.AvlTree`." - ([] (!sorted-map-by compare)) - ([k0 v0] (!sorted-map-by compare k0 v0)) - ([k0 v0 k1 v1] (!sorted-map-by compare k0 v0 k1 v1)) - ([k0 v0 k1 v1 k2 v2] (!sorted-map-by compare k0 v0 k1 v1 k2 v2)) - ([k0 v0 k1 v1 k2 v2 k3 v3] (!sorted-map-by compare k0 v0 k1 v1 k2 v2 k3 v3)) - ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4] (!sorted-map-by compare k0 v0 k1 v1 k2 v2 k3 v3 k4 v4)) - ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5] - (!sorted-map-by compare k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5)) - ([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 & kvs] - (apply !sorted-map-by compare k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 kvs))) - -(defn !sorted-map-by-val [m & kvs] (apply !sorted-map-by (gen-compare-by-val m) kvs)) - ;; TODO `goog.structs.AvlTree` has similar to this; implement with `defnt` (defalias sorted-rank-map avl/sorted-map) (defalias sorted-rank-map-by avl/sorted-map-by) @@ -520,7 +130,7 @@ ; TODO use |clojure.data.int-map/merge and merge-with|, |update|, |update!| for int maps. ; Benchmark these. (defn merge - "A performant drop-in replacement for |clojure.core/merge|. + "A performant drop-in replacement for `clojure.core/merge`. 398.815137 msecs (core/merge m1 m2) 188.270844 msecs (seqspert.hash-map/sequential-splice-hash-maps m1 m2) diff --git a/src-untyped/quantum/untyped/core/specs.cljc b/src-untyped/quantum/untyped/core/specs.cljc index 521d1439..ec2482a4 100644 --- a/src-untyped/quantum/untyped/core/specs.cljc +++ b/src-untyped/quantum/untyped/core/specs.cljc @@ -136,7 +136,7 @@ (dissoc :quantum.core.specs/docstring :quantum.core.specs/pre-meta :quantum.core.specs/post-meta) - (update :quantum.core.specs/fn|name with-meta nil) + (update :quantum.core.specs/fn|name #(some-> % (with-meta nil))) (assoc :quantum.core.specs/meta (-> ;; TODO use `merge-unique` instead of `:quantum.core.specs/fn|unique-meta` (merge (meta fn|name) pre-meta post-meta) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index ef870108..fb667d17 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -30,8 +30,6 @@ [quantum.untyped.core.core :as ucore] [quantum.untyped.core.data.bits :as ubit] [quantum.untyped.core.data.hash :as uhash] - [quantum.untyped.core.data.map - #?@(:cljs [:refer [MutableHashMap]])] [quantum.untyped.core.data.set :as uset] [quantum.untyped.core.data.tuple] [quantum.untyped.core.defnt @@ -573,32 +571,6 @@ ;; ===== Predicates ===== ;; ;; ---------------------- ;; - (def basic-type-syms '[boolean byte char short int long float double ref]) - -#?(:clj (defns- >v-sym [prefix c/symbol?, kind c/symbol? > c/symbol?] - (symbol (str prefix "|" kind "?")))) - -#?(:clj (defns- >kv-sym [prefix c/symbol?, from-type c/symbol?, to-type c/symbol? > c/symbol?] - (symbol (str prefix "|" from-type "->" to-type "?")))) - -#?(:clj (defmacro- def-preds|map|same-types [prefix #_symbol?] - `(do ~@(for [kind (conj basic-type-syms 'any)] - (list `-def (>v-sym prefix kind) (>kv-sym prefix kind kind)))))) - -#?(:clj (defmacro- def-preds|map|any [prefix #_symbol?] - (let [anys (->> (for [kind basic-type-syms] - [(list `-def (>kv-sym prefix kind 'any) - (->> basic-type-syms (map #(>kv-sym prefix kind %)) (list* `or))) - (list `-def (>kv-sym prefix 'any kind) - (->> basic-type-syms (map #(>kv-sym prefix % kind)) (list* `or)))]) - (apply concat)) - any->any (list `-def (>kv-sym prefix 'any 'any) - (->> basic-type-syms - (map #(vector (>kv-sym prefix 'any %) (>kv-sym prefix % 'any))) - (apply concat) - (list* `or)))] - `(do ~@(concat anys [any->any]))))) - ;; TODO TYPED — split the below predicate definitions into appropriate namespaces ;; ===== General ===== ;; @@ -610,6 +582,8 @@ (-def val|by-class? (or object? #?@(:cljs [(isa? js/String) (isa? js/Symbol)]))) (-def val? (not nil?)) + (-def ref? (ref any?)) + ;; ===== Meta ===== ;; #?(:clj (-def class? (isa? java.lang.Class))) @@ -727,7 +701,6 @@ (-def tuple? ;; clojure.lang.Tuple was discontinued; we won't support it for now (isa? quantum.untyped.core.data.tuple.Tuple)) #?(:clj (-def map-entry? (isa? java.util.Map$Entry))) - (-def +map-entry? (isa? #?(:clj clojure.lang.MapEntry :cljs cljs.core.MapEntry))) ;; ===== Sequences ===== ;; Sequential (generally not efficient Lookup / RandomAccess) @@ -919,640 +892,6 @@ (-def queue? (or ?!+queue? !queue? #?(:clj !!queue?))) -;; ===== Maps ===== ;; Associative - -;; ----- Identity Maps (identity-based equality) ----- ;; - - (-def !identity-map|ref->ref? #?(:clj (isa? java.util.IdentityHashMap) - :cljs (isa? js/Map))) - - (-def !identity-map? !identity-map|ref->ref?) - -#?(:clj (-def !!identity-map? none?)) - - (-def identity-map? (or !identity-map? #?(:clj !!identity-map?))) - -;; ----- Hash Maps (value-based equality) ----- ;; - - (-def +hash-map? (isa? #?(:clj clojure.lang.PersistentHashMap - :cljs cljs.core/PersistentHashMap))) - - (-def !+hash-map? (isa? #?(:clj clojure.lang.PersistentHashMap$TransientHashMap - :cljs cljs.core/TransientHashMap))) - - (-def ?!+hash-map? (or !+hash-map? +hash-map?)) - - (-def !hash-map|boolean->boolean? none?) - (-def !hash-map|boolean->byte? none?) - (-def !hash-map|boolean->char? none?) - (-def !hash-map|boolean->short? none?) - (-def !hash-map|boolean->int? none?) - (-def !hash-map|boolean->long? none?) - (-def !hash-map|boolean->float? none?) - (-def !hash-map|boolean->double? none?) - (-def !hash-map|boolean->ref? none?) - - (-def !hash-map|byte->boolean? #?(:clj (or (isa? it.unimi.dsi.fastutil.bytes.Byte2BooleanOpenHashMap) (isa? it.unimi.dsi.fastutil.bytes.Byte2BooleanOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|byte->byte? #?(:clj (or (isa? it.unimi.dsi.fastutil.bytes.Byte2ByteOpenHashMap) (isa? it.unimi.dsi.fastutil.bytes.Byte2ByteOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|byte->char? #?(:clj (or (isa? it.unimi.dsi.fastutil.bytes.Byte2CharOpenHashMap) (isa? it.unimi.dsi.fastutil.bytes.Byte2CharOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|byte->short? #?(:clj (or (isa? it.unimi.dsi.fastutil.bytes.Byte2ShortOpenHashMap) (isa? it.unimi.dsi.fastutil.bytes.Byte2ShortOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|byte->int? #?(:clj (or (isa? it.unimi.dsi.fastutil.bytes.Byte2IntOpenHashMap) (isa? it.unimi.dsi.fastutil.bytes.Byte2IntOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|byte->long? #?(:clj (or (isa? it.unimi.dsi.fastutil.bytes.Byte2LongOpenHashMap) (isa? it.unimi.dsi.fastutil.bytes.Byte2LongOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|byte->float? #?(:clj (or (isa? it.unimi.dsi.fastutil.bytes.Byte2FloatOpenHashMap) (isa? it.unimi.dsi.fastutil.bytes.Byte2FloatOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|byte->double? #?(:clj (or (isa? it.unimi.dsi.fastutil.bytes.Byte2DoubleOpenHashMap) (isa? it.unimi.dsi.fastutil.bytes.Byte2DoubleOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|byte->ref? #?(:clj (or (isa? it.unimi.dsi.fastutil.bytes.Byte2ReferenceOpenHashMap) (isa? it.unimi.dsi.fastutil.bytes.Byte2ReferenceOpenCustomHashMap)) :cljs none?)) - - (-def !hash-map|char->ref? #?(:clj (or (isa? it.unimi.dsi.fastutil.chars.Char2ReferenceOpenHashMap) (isa? it.unimi.dsi.fastutil.chars.Char2ReferenceOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|char->boolean? #?(:clj (or (isa? it.unimi.dsi.fastutil.chars.Char2BooleanOpenHashMap) (isa? it.unimi.dsi.fastutil.chars.Char2BooleanOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|char->byte? #?(:clj (or (isa? it.unimi.dsi.fastutil.chars.Char2ByteOpenHashMap) (isa? it.unimi.dsi.fastutil.chars.Char2ByteOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|char->char? #?(:clj (or (isa? it.unimi.dsi.fastutil.chars.Char2CharOpenHashMap) (isa? it.unimi.dsi.fastutil.chars.Char2CharOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|char->short? #?(:clj (or (isa? it.unimi.dsi.fastutil.chars.Char2ShortOpenHashMap) (isa? it.unimi.dsi.fastutil.chars.Char2ShortOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|char->int? #?(:clj (or (isa? it.unimi.dsi.fastutil.chars.Char2IntOpenHashMap) (isa? it.unimi.dsi.fastutil.chars.Char2IntOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|char->long? #?(:clj (or (isa? it.unimi.dsi.fastutil.chars.Char2LongOpenHashMap) (isa? it.unimi.dsi.fastutil.chars.Char2LongOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|char->float? #?(:clj (or (isa? it.unimi.dsi.fastutil.chars.Char2FloatOpenHashMap) (isa? it.unimi.dsi.fastutil.chars.Char2FloatOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|char->double? #?(:clj (or (isa? it.unimi.dsi.fastutil.chars.Char2DoubleOpenHashMap) (isa? it.unimi.dsi.fastutil.chars.Char2DoubleOpenCustomHashMap)) :cljs none?)) - - (-def !hash-map|short->boolean? #?(:clj (or (isa? it.unimi.dsi.fastutil.shorts.Short2BooleanOpenHashMap) (isa? it.unimi.dsi.fastutil.shorts.Short2BooleanOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|short->byte? #?(:clj (or (isa? it.unimi.dsi.fastutil.shorts.Short2ByteOpenHashMap) (isa? it.unimi.dsi.fastutil.shorts.Short2ByteOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|short->char? #?(:clj (or (isa? it.unimi.dsi.fastutil.shorts.Short2CharOpenHashMap) (isa? it.unimi.dsi.fastutil.shorts.Short2CharOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|short->short? #?(:clj (or (isa? it.unimi.dsi.fastutil.shorts.Short2ShortOpenHashMap) (isa? it.unimi.dsi.fastutil.shorts.Short2ShortOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|short->int? #?(:clj (or (isa? it.unimi.dsi.fastutil.shorts.Short2IntOpenHashMap) (isa? it.unimi.dsi.fastutil.shorts.Short2IntOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|short->long? #?(:clj (or (isa? it.unimi.dsi.fastutil.shorts.Short2LongOpenHashMap) (isa? it.unimi.dsi.fastutil.shorts.Short2LongOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|short->float? #?(:clj (or (isa? it.unimi.dsi.fastutil.shorts.Short2FloatOpenHashMap) (isa? it.unimi.dsi.fastutil.shorts.Short2FloatOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|short->double? #?(:clj (or (isa? it.unimi.dsi.fastutil.shorts.Short2DoubleOpenHashMap) (isa? it.unimi.dsi.fastutil.shorts.Short2DoubleOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|short->ref? #?(:clj (or (isa? it.unimi.dsi.fastutil.shorts.Short2ReferenceOpenHashMap) (isa? it.unimi.dsi.fastutil.shorts.Short2ReferenceOpenCustomHashMap)) :cljs none?)) - - (-def !hash-map|int->boolean? #?(:clj (or (isa? it.unimi.dsi.fastutil.ints.Int2BooleanOpenHashMap) (isa? it.unimi.dsi.fastutil.ints.Int2BooleanOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|int->byte? #?(:clj (or (isa? it.unimi.dsi.fastutil.ints.Int2ByteOpenHashMap) (isa? it.unimi.dsi.fastutil.ints.Int2ByteOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|int->char? #?(:clj (or (isa? it.unimi.dsi.fastutil.ints.Int2CharOpenHashMap) (isa? it.unimi.dsi.fastutil.ints.Int2CharOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|int->short? #?(:clj (or (isa? it.unimi.dsi.fastutil.ints.Int2ShortOpenHashMap) (isa? it.unimi.dsi.fastutil.ints.Int2ShortOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|int->int? #?(:clj (or (isa? it.unimi.dsi.fastutil.ints.Int2IntOpenHashMap) (isa? it.unimi.dsi.fastutil.ints.Int2IntOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|int->long? #?(:clj (or (isa? it.unimi.dsi.fastutil.ints.Int2LongOpenHashMap) (isa? it.unimi.dsi.fastutil.ints.Int2LongOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|int->float? #?(:clj (or (isa? it.unimi.dsi.fastutil.ints.Int2FloatOpenHashMap) (isa? it.unimi.dsi.fastutil.ints.Int2FloatOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|int->double? #?(:clj (or (isa? it.unimi.dsi.fastutil.ints.Int2DoubleOpenHashMap) (isa? it.unimi.dsi.fastutil.ints.Int2DoubleOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|int->ref? #?(:clj (or (isa? it.unimi.dsi.fastutil.ints.Int2ReferenceOpenHashMap) (isa? it.unimi.dsi.fastutil.ints.Int2ReferenceOpenCustomHashMap)) :cljs none?)) - - (-def !hash-map|long->boolean? #?(:clj (or (isa? it.unimi.dsi.fastutil.longs.Long2BooleanOpenHashMap) (isa? it.unimi.dsi.fastutil.longs.Long2BooleanOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|long->byte? #?(:clj (or (isa? it.unimi.dsi.fastutil.longs.Long2ByteOpenCustomHashMap) (isa? it.unimi.dsi.fastutil.longs.Long2ByteOpenHashMap)) :cljs none?)) - (-def !hash-map|long->char? #?(:clj (or (isa? it.unimi.dsi.fastutil.longs.Long2CharOpenHashMap) (isa? it.unimi.dsi.fastutil.longs.Long2CharOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|long->short? #?(:clj (or (isa? it.unimi.dsi.fastutil.longs.Long2ShortOpenHashMap) (isa? it.unimi.dsi.fastutil.longs.Long2ShortOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|long->int? #?(:clj (or (isa? it.unimi.dsi.fastutil.longs.Long2IntOpenHashMap) (isa? it.unimi.dsi.fastutil.longs.Long2IntOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|long->long? #?(:clj (or (isa? it.unimi.dsi.fastutil.longs.Long2LongOpenHashMap) (isa? it.unimi.dsi.fastutil.longs.Long2LongOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|long->float? #?(:clj (or (isa? it.unimi.dsi.fastutil.longs.Long2FloatOpenHashMap) (isa? it.unimi.dsi.fastutil.longs.Long2FloatOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|long->double? #?(:clj (or (isa? it.unimi.dsi.fastutil.longs.Long2DoubleOpenHashMap) (isa? it.unimi.dsi.fastutil.longs.Long2DoubleOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|long->ref? #?(:clj (or (isa? it.unimi.dsi.fastutil.longs.Long2ReferenceOpenHashMap) (isa? it.unimi.dsi.fastutil.longs.Long2ReferenceOpenCustomHashMap)) :cljs none?)) - - (-def !hash-map|float->boolean? #?(:clj (or (isa? it.unimi.dsi.fastutil.floats.Float2BooleanOpenHashMap) (isa? it.unimi.dsi.fastutil.floats.Float2BooleanOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|float->byte? #?(:clj (or (isa? it.unimi.dsi.fastutil.floats.Float2ByteOpenHashMap) (isa? it.unimi.dsi.fastutil.floats.Float2ByteOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|float->char? #?(:clj (or (isa? it.unimi.dsi.fastutil.floats.Float2CharOpenHashMap) (isa? it.unimi.dsi.fastutil.floats.Float2CharOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|float->short? #?(:clj (or (isa? it.unimi.dsi.fastutil.floats.Float2ShortOpenHashMap) (isa? it.unimi.dsi.fastutil.floats.Float2ShortOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|float->int? #?(:clj (or (isa? it.unimi.dsi.fastutil.floats.Float2IntOpenHashMap) (isa? it.unimi.dsi.fastutil.floats.Float2IntOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|float->long? #?(:clj (or (isa? it.unimi.dsi.fastutil.floats.Float2LongOpenHashMap) (isa? it.unimi.dsi.fastutil.floats.Float2LongOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|float->float? #?(:clj (or (isa? it.unimi.dsi.fastutil.floats.Float2FloatOpenHashMap) (isa? it.unimi.dsi.fastutil.floats.Float2FloatOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|float->double? #?(:clj (or (isa? it.unimi.dsi.fastutil.floats.Float2DoubleOpenHashMap) (isa? it.unimi.dsi.fastutil.floats.Float2DoubleOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|float->ref? #?(:clj (or (isa? it.unimi.dsi.fastutil.floats.Float2ReferenceOpenHashMap) (isa? it.unimi.dsi.fastutil.floats.Float2ReferenceOpenCustomHashMap)) :cljs none?)) - - (-def !hash-map|double->boolean? #?(:clj (or (isa? it.unimi.dsi.fastutil.doubles.Double2BooleanOpenHashMap) (isa? it.unimi.dsi.fastutil.doubles.Double2BooleanOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|double->byte? #?(:clj (or (isa? it.unimi.dsi.fastutil.doubles.Double2ByteOpenHashMap) (isa? it.unimi.dsi.fastutil.doubles.Double2ByteOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|double->char? #?(:clj (or (isa? it.unimi.dsi.fastutil.doubles.Double2CharOpenHashMap) (isa? it.unimi.dsi.fastutil.doubles.Double2CharOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|double->short? #?(:clj (or (isa? it.unimi.dsi.fastutil.doubles.Double2ShortOpenHashMap) (isa? it.unimi.dsi.fastutil.doubles.Double2ShortOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|double->int? #?(:clj (or (isa? it.unimi.dsi.fastutil.doubles.Double2IntOpenHashMap) (isa? it.unimi.dsi.fastutil.doubles.Double2IntOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|double->long? #?(:clj (or (isa? it.unimi.dsi.fastutil.doubles.Double2LongOpenHashMap) (isa? it.unimi.dsi.fastutil.doubles.Double2LongOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|double->float? #?(:clj (or (isa? it.unimi.dsi.fastutil.doubles.Double2FloatOpenHashMap) (isa? it.unimi.dsi.fastutil.doubles.Double2FloatOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|double->double? #?(:clj (or (isa? it.unimi.dsi.fastutil.doubles.Double2DoubleOpenHashMap) (isa? it.unimi.dsi.fastutil.doubles.Double2DoubleOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|double->ref? #?(:clj (or (isa? it.unimi.dsi.fastutil.doubles.Double2ReferenceOpenHashMap) (isa? it.unimi.dsi.fastutil.doubles.Double2ReferenceOpenCustomHashMap)) :cljs none?)) - - (-def !hash-map|ref->boolean? #?(:clj (or (isa? it.unimi.dsi.fastutil.objects.Reference2BooleanOpenHashMap) (isa? it.unimi.dsi.fastutil.objects.Reference2BooleanOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|ref->byte? #?(:clj (or (isa? it.unimi.dsi.fastutil.objects.Reference2ByteOpenHashMap) (isa? it.unimi.dsi.fastutil.objects.Reference2ByteOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|ref->char? #?(:clj (or (isa? it.unimi.dsi.fastutil.objects.Reference2CharOpenHashMap) (isa? it.unimi.dsi.fastutil.objects.Reference2CharOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|ref->short? #?(:clj (or (isa? it.unimi.dsi.fastutil.objects.Reference2ShortOpenHashMap) (isa? it.unimi.dsi.fastutil.objects.Reference2ShortOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|ref->int? #?(:clj (or (isa? it.unimi.dsi.fastutil.objects.Reference2IntOpenHashMap) (isa? it.unimi.dsi.fastutil.objects.Reference2IntOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|ref->long? #?(:clj (or (isa? it.unimi.dsi.fastutil.objects.Reference2LongOpenHashMap) (isa? it.unimi.dsi.fastutil.objects.Reference2LongOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|ref->float? #?(:clj (or (isa? it.unimi.dsi.fastutil.objects.Reference2FloatOpenHashMap) (isa? it.unimi.dsi.fastutil.objects.Reference2FloatOpenCustomHashMap)) :cljs none?)) - (-def !hash-map|ref->double? #?(:clj (or (isa? it.unimi.dsi.fastutil.objects.Reference2DoubleOpenHashMap) (isa? it.unimi.dsi.fastutil.objects.Reference2DoubleOpenCustomHashMap)) :cljs none?)) - - (-def !hash-map|ref->ref? (or #?@(:clj [(isa? java.util.HashMap) - ;; Because this has different semantics - #_(isa? java.util.IdentityHashMap) - (isa? it.unimi.dsi.fastutil.objects.Reference2ReferenceOpenHashMap) - (isa? it.unimi.dsi.fastutil.objects.Reference2ReferenceOpenCustomHashMap)] - :cljs [MutableHashMap]))) - - (def-preds|map|any !hash-map) - - (def-preds|map|same-types !hash-map) - - (-def !hash-map? !hash-map|any?) - -#?(:clj (-def !!hash-map? (isa? java.util.concurrent.ConcurrentHashMap))) - (-def hash-map? (or ?!+hash-map? #?(:clj !!hash-map?) !hash-map?)) - -;; ----- Array Maps ----- ;; - - (-def +array-map? (isa? #?(:clj clojure.lang.PersistentArrayMap - :cljs cljs.core/PersistentArrayMap))) - - (-def !+array-map? (isa? #?(:clj clojure.lang.PersistentArrayMap$TransientArrayMap - :cljs cljs.core/TransientArrayMap))) - - (-def ?!+array-map? (or !+array-map? +array-map?)) - - (-def !array-map|boolean->boolean? none?) - (-def !array-map|boolean->byte? none?) - (-def !array-map|boolean->char? none?) - (-def !array-map|boolean->short? none?) - (-def !array-map|boolean->int? none?) - (-def !array-map|boolean->long? none?) - (-def !array-map|boolean->float? none?) - (-def !array-map|boolean->double? none?) - (-def !array-map|boolean->ref? none?) - - (-def !array-map|byte->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2BooleanArrayMap) :cljs none?)) - (-def !array-map|byte->byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ByteArrayMap) :cljs none?)) - (-def !array-map|byte->char? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2CharArrayMap) :cljs none?)) - (-def !array-map|byte->short? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ShortArrayMap) :cljs none?)) - (-def !array-map|byte->int? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2IntArrayMap) :cljs none?)) - (-def !array-map|byte->long? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2LongArrayMap) :cljs none?)) - (-def !array-map|byte->float? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2FloatArrayMap) :cljs none?)) - (-def !array-map|byte->double? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2DoubleArrayMap) :cljs none?)) - (-def !array-map|byte->ref? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ReferenceArrayMap) :cljs none?)) - - (-def !array-map|char->ref? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ReferenceArrayMap) :cljs none?)) - (-def !array-map|char->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2BooleanArrayMap) :cljs none?)) - (-def !array-map|char->byte? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ByteArrayMap) :cljs none?)) - (-def !array-map|char->char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2CharArrayMap) :cljs none?)) - (-def !array-map|char->short? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ShortArrayMap) :cljs none?)) - (-def !array-map|char->int? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2IntArrayMap) :cljs none?)) - (-def !array-map|char->long? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2LongArrayMap) :cljs none?)) - (-def !array-map|char->float? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2FloatArrayMap) :cljs none?)) - (-def !array-map|char->double? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2DoubleArrayMap) :cljs none?)) - - (-def !array-map|short->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2BooleanArrayMap) :cljs none?)) - (-def !array-map|short->byte? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ByteArrayMap) :cljs none?)) - (-def !array-map|short->char? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2CharArrayMap) :cljs none?)) - (-def !array-map|short->short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ShortArrayMap) :cljs none?)) - (-def !array-map|short->int? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2IntArrayMap) :cljs none?)) - (-def !array-map|short->long? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2LongArrayMap) :cljs none?)) - (-def !array-map|short->float? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2FloatArrayMap) :cljs none?)) - (-def !array-map|short->double? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2DoubleArrayMap) :cljs none?)) - (-def !array-map|short->ref? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ReferenceArrayMap) :cljs none?)) - - (-def !array-map|int->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2BooleanArrayMap) :cljs none?)) - (-def !array-map|int->byte? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2ByteArrayMap) :cljs none?)) - (-def !array-map|int->char? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2CharArrayMap) :cljs none?)) - (-def !array-map|int->short? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2ShortArrayMap) :cljs none?)) - (-def !array-map|int->int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2IntArrayMap) :cljs none?)) - (-def !array-map|int->long? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2LongArrayMap) :cljs none?)) - (-def !array-map|int->float? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2FloatArrayMap) :cljs none?)) - (-def !array-map|int->double? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2DoubleArrayMap) :cljs none?)) - (-def !array-map|int->ref? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2ReferenceArrayMap) :cljs none?)) - - (-def !array-map|long->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2BooleanArrayMap) :cljs none?)) - (-def !array-map|long->byte? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2ByteArrayMap) :cljs none?)) - (-def !array-map|long->char? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2CharArrayMap) :cljs none?)) - (-def !array-map|long->short? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2ShortArrayMap) :cljs none?)) - (-def !array-map|long->int? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2IntArrayMap) :cljs none?)) - (-def !array-map|long->long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2LongArrayMap) :cljs none?)) - (-def !array-map|long->float? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2FloatArrayMap) :cljs none?)) - (-def !array-map|long->double? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2DoubleArrayMap) :cljs none?)) - (-def !array-map|long->ref? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2ReferenceArrayMap) :cljs none?)) - - (-def !array-map|float->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2BooleanArrayMap) :cljs none?)) - (-def !array-map|float->byte? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2ByteArrayMap) :cljs none?)) - (-def !array-map|float->char? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2CharArrayMap) :cljs none?)) - (-def !array-map|float->short? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2ShortArrayMap) :cljs none?)) - (-def !array-map|float->int? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2IntArrayMap) :cljs none?)) - (-def !array-map|float->long? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2LongArrayMap) :cljs none?)) - (-def !array-map|float->float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2FloatArrayMap) :cljs none?)) - (-def !array-map|float->double? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2DoubleArrayMap) :cljs none?)) - (-def !array-map|float->ref? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2ReferenceArrayMap) :cljs none?)) - - (-def !array-map|double->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2BooleanArrayMap) :cljs none?)) - (-def !array-map|double->byte? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2ByteArrayMap) :cljs none?)) - (-def !array-map|double->char? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2CharArrayMap) :cljs none?)) - (-def !array-map|double->short? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2ShortArrayMap) :cljs none?)) - (-def !array-map|double->int? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2IntArrayMap) :cljs none?)) - (-def !array-map|double->long? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2LongArrayMap) :cljs none?)) - (-def !array-map|double->float? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2FloatArrayMap) :cljs none?)) - (-def !array-map|double->double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2DoubleArrayMap) :cljs none?)) - (-def !array-map|double->ref? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2ReferenceArrayMap) :cljs none?)) - - (-def !array-map|ref->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2BooleanArrayMap) :cljs none?)) - (-def !array-map|ref->byte? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2ByteArrayMap) :cljs none?)) - (-def !array-map|ref->char? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2CharArrayMap) :cljs none?)) - (-def !array-map|ref->short? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2ShortArrayMap) :cljs none?)) - (-def !array-map|ref->int? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2IntArrayMap) :cljs none?)) - (-def !array-map|ref->long? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2LongArrayMap) :cljs none?)) - (-def !array-map|ref->float? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2FloatArrayMap) :cljs none?)) - (-def !array-map|ref->double? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2DoubleArrayMap) :cljs none?)) - (-def !array-map|ref->ref? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2ReferenceArrayMap) :cljs none?)) - - (def-preds|map|any !array-map) - - (def-preds|map|same-types !array-map) - - (-def !array-map? !array-map|any?) - -#?(:clj (-def !!array-map? none?)) - - (-def array-map? (or ?!+array-map? #?(:clj !!array-map?) !array-map?)) - -;; ----- Unsorted Maps ----- ;; TODO Perhaps the concept of unsortedness is `(- map sorted?)`? - - (-def +unsorted-map? (or +hash-map? +array-map?)) - (-def !+unsorted-map? (or !+hash-map? !+array-map?)) - (-def ?!+unsorted-map? (or ?!+hash-map? ?!+array-map?)) - - (-def !unsorted-map|boolean->boolean? (or !hash-map|boolean->boolean? !array-map|boolean->boolean?)) - (-def !unsorted-map|boolean->byte? (or !hash-map|boolean->byte? !array-map|boolean->byte?)) - (-def !unsorted-map|boolean->char? (or !hash-map|boolean->char? !array-map|boolean->char?)) - (-def !unsorted-map|boolean->short? (or !hash-map|boolean->short? !array-map|boolean->short?)) - (-def !unsorted-map|boolean->int? (or !hash-map|boolean->int? !array-map|boolean->int?)) - (-def !unsorted-map|boolean->long? (or !hash-map|boolean->long? !array-map|boolean->long?)) - (-def !unsorted-map|boolean->float? (or !hash-map|boolean->float? !array-map|boolean->float?)) - (-def !unsorted-map|boolean->double? (or !hash-map|boolean->double? !array-map|boolean->double?)) - (-def !unsorted-map|boolean->ref? (or !hash-map|boolean->ref? !array-map|boolean->ref?)) - - (-def !unsorted-map|byte->boolean? (or !hash-map|byte->boolean? !array-map|byte->boolean?)) - (-def !unsorted-map|byte->byte? (or !hash-map|byte->byte? !array-map|byte->byte?)) - (-def !unsorted-map|byte->char? (or !hash-map|byte->char? !array-map|byte->char?)) - (-def !unsorted-map|byte->short? (or !hash-map|byte->short? !array-map|byte->short?)) - (-def !unsorted-map|byte->int? (or !hash-map|byte->int? !array-map|byte->int?)) - (-def !unsorted-map|byte->long? (or !hash-map|byte->long? !array-map|byte->long?)) - (-def !unsorted-map|byte->float? (or !hash-map|byte->float? !array-map|byte->float?)) - (-def !unsorted-map|byte->double? (or !hash-map|byte->double? !array-map|byte->double?)) - (-def !unsorted-map|byte->ref? (or !hash-map|byte->ref? !array-map|byte->ref?)) - - (-def !unsorted-map|char->boolean? (or !hash-map|char->boolean? !array-map|char->boolean?)) - (-def !unsorted-map|char->byte? (or !hash-map|char->byte? !array-map|char->byte?)) - (-def !unsorted-map|char->char? (or !hash-map|char->char? !array-map|char->char?)) - (-def !unsorted-map|char->short? (or !hash-map|char->short? !array-map|char->short?)) - (-def !unsorted-map|char->int? (or !hash-map|char->int? !array-map|char->int?)) - (-def !unsorted-map|char->long? (or !hash-map|char->long? !array-map|char->long?)) - (-def !unsorted-map|char->float? (or !hash-map|char->float? !array-map|char->float?)) - (-def !unsorted-map|char->double? (or !hash-map|char->double? !array-map|char->double?)) - (-def !unsorted-map|char->ref? (or !hash-map|char->ref? !array-map|char->ref?)) - - (-def !unsorted-map|short->boolean? (or !hash-map|short->boolean? !array-map|short->boolean?)) - (-def !unsorted-map|short->byte? (or !hash-map|short->byte? !array-map|short->byte?)) - (-def !unsorted-map|short->char? (or !hash-map|short->char? !array-map|short->char?)) - (-def !unsorted-map|short->short? (or !hash-map|short->short? !array-map|short->short?)) - (-def !unsorted-map|short->int? (or !hash-map|short->int? !array-map|short->int?)) - (-def !unsorted-map|short->long? (or !hash-map|short->long? !array-map|short->long?)) - (-def !unsorted-map|short->float? (or !hash-map|short->float? !array-map|short->float?)) - (-def !unsorted-map|short->double? (or !hash-map|short->double? !array-map|short->double?)) - (-def !unsorted-map|short->ref? (or !hash-map|short->ref? !array-map|short->ref?)) - - (-def !unsorted-map|int->boolean? (or !hash-map|int->boolean? !array-map|int->boolean?)) - (-def !unsorted-map|int->byte? (or !hash-map|int->byte? !array-map|int->byte?)) - (-def !unsorted-map|int->char? (or !hash-map|int->char? !array-map|int->char?)) - (-def !unsorted-map|int->short? (or !hash-map|int->short? !array-map|int->short?)) - (-def !unsorted-map|int->int? (or !hash-map|int->int? !array-map|int->int?)) - (-def !unsorted-map|int->long? (or !hash-map|int->long? !array-map|int->long?)) - (-def !unsorted-map|int->float? (or !hash-map|int->float? !array-map|int->float?)) - (-def !unsorted-map|int->double? (or !hash-map|int->double? !array-map|int->double?)) - (-def !unsorted-map|int->ref? (or !hash-map|int->ref? !array-map|int->ref?)) - - (-def !unsorted-map|long->boolean? (or !hash-map|long->boolean? !array-map|long->boolean?)) - (-def !unsorted-map|long->byte? (or !hash-map|long->byte? !array-map|long->byte?)) - (-def !unsorted-map|long->char? (or !hash-map|long->char? !array-map|long->char?)) - (-def !unsorted-map|long->short? (or !hash-map|long->short? !array-map|long->short?)) - (-def !unsorted-map|long->int? (or !hash-map|long->int? !array-map|long->int?)) - (-def !unsorted-map|long->long? (or !hash-map|long->long? !array-map|long->long?)) - (-def !unsorted-map|long->float? (or !hash-map|long->float? !array-map|long->float?)) - (-def !unsorted-map|long->double? (or !hash-map|long->double? !array-map|long->double?)) - (-def !unsorted-map|long->ref? (or !hash-map|long->ref? !array-map|long->ref?)) - - (-def !unsorted-map|float->boolean? (or !hash-map|float->boolean? !array-map|float->boolean?)) - (-def !unsorted-map|float->byte? (or !hash-map|float->byte? !array-map|float->byte?)) - (-def !unsorted-map|float->char? (or !hash-map|float->char? !array-map|float->char?)) - (-def !unsorted-map|float->short? (or !hash-map|float->short? !array-map|float->short?)) - (-def !unsorted-map|float->int? (or !hash-map|float->int? !array-map|float->int?)) - (-def !unsorted-map|float->long? (or !hash-map|float->long? !array-map|float->long?)) - (-def !unsorted-map|float->float? (or !hash-map|float->float? !array-map|float->float?)) - (-def !unsorted-map|float->double? (or !hash-map|float->double? !array-map|float->double?)) - (-def !unsorted-map|float->ref? (or !hash-map|float->ref? !array-map|float->ref?)) - - (-def !unsorted-map|double->boolean? - (or !hash-map|double->boolean? !array-map|double->boolean?)) - (-def !unsorted-map|double->byte? - (or !hash-map|double->byte? !array-map|double->byte?)) - (-def !unsorted-map|double->char? - (or !hash-map|double->char? !array-map|double->char?)) - (-def !unsorted-map|double->short? - (or !hash-map|double->short? !array-map|double->short?)) - (-def !unsorted-map|double->int? - (or !hash-map|double->int? !array-map|double->int?)) - (-def !unsorted-map|double->long? - (or !hash-map|double->long? !array-map|double->long?)) - (-def !unsorted-map|double->float? - (or !hash-map|double->float? !array-map|double->float?)) - (-def !unsorted-map|double->double? - (or !hash-map|double->double? !array-map|double->double?)) - (-def !unsorted-map|double->ref? - (or !hash-map|double->ref? !array-map|double->ref?)) - - (-def !unsorted-map|ref->boolean? - (or !hash-map|ref->boolean? !array-map|ref->boolean?)) - (-def !unsorted-map|ref->byte? - (or !hash-map|ref->byte? !array-map|ref->byte?)) - (-def !unsorted-map|ref->char? - (or !hash-map|ref->char? !array-map|ref->char?)) - (-def !unsorted-map|ref->short? - (or !hash-map|ref->short? !array-map|ref->short?)) - (-def !unsorted-map|ref->int? - (or !hash-map|ref->int? !array-map|ref->int?)) - (-def !unsorted-map|ref->long? - (or !hash-map|ref->long? !array-map|ref->long?)) - (-def !unsorted-map|ref->float? - (or !hash-map|ref->float? !array-map|ref->float?)) - (-def !unsorted-map|ref->double? - (or !hash-map|ref->double? !array-map|ref->double?)) - (-def !unsorted-map|ref->ref? - (or !identity-map|ref->ref? !hash-map|ref->ref? !array-map|ref->ref?)) - - (def-preds|map|any !unsorted-map) - - (def-preds|map|same-types !unsorted-map) - - (-def !unsorted-map? !unsorted-map|any?) - -#?(:clj (-def !!unsorted-map? (or !!hash-map? !!array-map?))) - (-def unsorted-map? (or ?!+unsorted-map? !unsorted-map? #?(:clj !!unsorted-map?))) - -;; ----- Sorted Maps ----- ;; - - (-def +map? (isa? #?(:clj clojure.lang.IPersistentMap - :cljs cljs.core/IMap))) - (-def !+map? (isa? #?(:clj clojure.lang.ITransientMap - :cljs cljs.core/ITransientMap))) - - (-def +sorted-map? (and (isa? #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) - +map?)) - (-def !+sorted-map? (and (isa? #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) - !+map?)) - (-def ?!+sorted-map? none? #_(or +sorted-map? !+sorted-map?)) ; TODO re-enable when `or` implemented properly - - (-def !sorted-map|boolean->boolean? none?) - (-def !sorted-map|boolean->byte? none?) - (-def !sorted-map|boolean->char? none?) - (-def !sorted-map|boolean->short? none?) - (-def !sorted-map|boolean->int? none?) - (-def !sorted-map|boolean->long? none?) - (-def !sorted-map|boolean->float? none?) - (-def !sorted-map|boolean->double? none?) - (-def !sorted-map|boolean->ref? none?) - - (-def !sorted-map|byte->boolean? - #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2BooleanSortedMap) :cljs none?)) - (-def !sorted-map|byte->byte? - #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ByteSortedMap) :cljs none?)) - (-def !sorted-map|byte->char? - #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2CharSortedMap) :cljs none?)) - (-def !sorted-map|byte->short? - #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ShortSortedMap) :cljs none?)) - (-def !sorted-map|byte->int? - #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2IntSortedMap) :cljs none?)) - (-def !sorted-map|byte->long? - #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2LongSortedMap) :cljs none?)) - (-def !sorted-map|byte->float? - #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2FloatSortedMap) :cljs none?)) - (-def !sorted-map|byte->double? - #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2DoubleSortedMap) :cljs none?)) - (-def !sorted-map|byte->ref? - #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ReferenceSortedMap) :cljs none?)) - - (-def !sorted-map|char->ref? - #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ReferenceSortedMap) :cljs none?)) - (-def !sorted-map|char->boolean? - #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2BooleanSortedMap) :cljs none?)) - (-def !sorted-map|char->byte? - #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ByteSortedMap) :cljs none?)) - (-def !sorted-map|char->char? - #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2CharSortedMap) :cljs none?)) - (-def !sorted-map|char->short? - #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ShortSortedMap) :cljs none?)) - (-def !sorted-map|char->int? - #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2IntSortedMap) :cljs none?)) - (-def !sorted-map|char->long? - #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2LongSortedMap) :cljs none?)) - (-def !sorted-map|char->float? - #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2FloatSortedMap) :cljs none?)) - (-def !sorted-map|char->double? - #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2DoubleSortedMap) :cljs none?)) - - (-def !sorted-map|short->boolean? - #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2BooleanSortedMap) :cljs none?)) - (-def !sorted-map|short->byte? - #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ByteSortedMap) :cljs none?)) - (-def !sorted-map|short->char? - #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2CharSortedMap) :cljs none?)) - (-def !sorted-map|short->short? - #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ShortSortedMap) :cljs none?)) - (-def !sorted-map|short->int? - #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2IntSortedMap) :cljs none?)) - (-def !sorted-map|short->long? - #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2LongSortedMap) :cljs none?)) - (-def !sorted-map|short->float? - #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2FloatSortedMap) :cljs none?)) - (-def !sorted-map|short->double? - #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2DoubleSortedMap) :cljs none?)) - (-def !sorted-map|short->ref? - #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ReferenceSortedMap) :cljs none?)) - - (-def !sorted-map|int->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2BooleanSortedMap) :cljs none?)) - (-def !sorted-map|int->byte? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2ByteSortedMap) :cljs none?)) - (-def !sorted-map|int->char? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2CharSortedMap) :cljs none?)) - (-def !sorted-map|int->short? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2ShortSortedMap) :cljs none?)) - (-def !sorted-map|int->int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2IntSortedMap) :cljs none?)) - (-def !sorted-map|int->long? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2LongSortedMap) :cljs none?)) - (-def !sorted-map|int->float? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2FloatSortedMap) :cljs none?)) - (-def !sorted-map|int->double? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2DoubleSortedMap) :cljs none?)) - (-def !sorted-map|int->ref? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2ReferenceSortedMap) :cljs none?)) - - (-def !sorted-map|long->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2BooleanSortedMap) :cljs none?)) - (-def !sorted-map|long->byte? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2ByteSortedMap) :cljs none?)) - (-def !sorted-map|long->char? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2CharSortedMap) :cljs none?)) - (-def !sorted-map|long->short? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2ShortSortedMap) :cljs none?)) - (-def !sorted-map|long->int? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2IntSortedMap) :cljs none?)) - (-def !sorted-map|long->long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2LongSortedMap) :cljs none?)) - (-def !sorted-map|long->float? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2FloatSortedMap) :cljs none?)) - (-def !sorted-map|long->double? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2DoubleSortedMap) :cljs none?)) - (-def !sorted-map|long->ref? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2ReferenceSortedMap) :cljs none?)) - - (-def !sorted-map|float->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2BooleanSortedMap) :cljs none?)) - (-def !sorted-map|float->byte? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2ByteSortedMap) :cljs none?)) - (-def !sorted-map|float->char? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2CharSortedMap) :cljs none?)) - (-def !sorted-map|float->short? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2ShortSortedMap) :cljs none?)) - (-def !sorted-map|float->int? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2IntSortedMap) :cljs none?)) - (-def !sorted-map|float->long? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2LongSortedMap) :cljs none?)) - (-def !sorted-map|float->float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2FloatSortedMap) :cljs none?)) - (-def !sorted-map|float->double? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2DoubleSortedMap) :cljs none?)) - (-def !sorted-map|float->ref? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2ReferenceSortedMap) :cljs none?)) - - (-def !sorted-map|double->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2BooleanSortedMap) :cljs none?)) - (-def !sorted-map|double->byte? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2ByteSortedMap) :cljs none?)) - (-def !sorted-map|double->char? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2CharSortedMap) :cljs none?)) - (-def !sorted-map|double->short? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2ShortSortedMap) :cljs none?)) - (-def !sorted-map|double->int? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2IntSortedMap) :cljs none?)) - (-def !sorted-map|double->long? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2LongSortedMap) :cljs none?)) - (-def !sorted-map|double->float? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2FloatSortedMap) :cljs none?)) - (-def !sorted-map|double->double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2DoubleSortedMap) :cljs none?)) - (-def !sorted-map|double->ref? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2ReferenceSortedMap) :cljs none?)) - - (-def !sorted-map|ref->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2BooleanSortedMap) :cljs none?)) - (-def !sorted-map|ref->byte? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2ByteSortedMap) :cljs none?)) - (-def !sorted-map|ref->char? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2CharSortedMap) :cljs none?)) - (-def !sorted-map|ref->short? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2ShortSortedMap) :cljs none?)) - (-def !sorted-map|ref->int? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2IntSortedMap) :cljs none?)) - (-def !sorted-map|ref->long? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2LongSortedMap) :cljs none?)) - (-def !sorted-map|ref->float? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2FloatSortedMap) :cljs none?)) - (-def !sorted-map|ref->double? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2DoubleSortedMap) :cljs none?)) - - (-def !sorted-map|ref->ref? (or #?@(:clj [(isa? java.util.TreeMap) - (isa? it.unimi.dsi.fastutil.objects.Reference2ReferenceSortedMap)] - :cljs [(isa? goog.structs.AvlTree)]))) - - (def-preds|map|any !sorted-map) - - (def-preds|map|same-types !sorted-map) - - (-def !sorted-map? !sorted-map|any?) - -#?(:clj (-def !!sorted-map? (isa? java.util.concurrent.ConcurrentNavigableMap))) - (-def sorted-map? (or ?!+sorted-map? #?@(:clj [!!sorted-map? (isa? java.util.SortedMap)]) !sorted-map?)) - -;; ----- Other Maps ----- ;; - - (-def +insertion-ordered-map? (or (isa? linked.map.LinkedMap) - ;; This is true, but we have replaced OrderedMap with LinkedMap - #_(:clj (isa? flatland.ordered.map.OrderedMap)))) - (-def !+insertion-ordered-map? none? - ;; This is true, but we have replaced OrderedMap with LinkedMap - #_(isa? flatland.ordered.map.TransientOrderedMap)) - (-def ?!+insertion-ordered-map? (or +insertion-ordered-map? !+insertion-ordered-map?)) - - (-def !insertion-ordered-map? #?(:clj (isa? java.util.LinkedHashMap) :cljs none?)) - - ;; See https://github.com/ben-manes/concurrentlinkedhashmap (and links therefrom) for good implementation -#?(:clj (-def !!insertion-ordered-map? none?)) - - (-def insertion-ordered-map? (or ?!+insertion-ordered-map? !insertion-ordered-map? #?(:clj !!insertion-ordered-map?))) - -;; ----- General Maps ----- ;; - - (-def +map|built-in? (or (isa? #?(:clj clojure.lang.PersistentHashMap :cljs cljs.core/PersistentHashMap)) - (isa? #?(:clj clojure.lang.PersistentArrayMap :cljs cljs.core/PersistentArrayMap)) - (isa? #?(:clj clojure.lang.PersistentTreeMap :cljs cljs.core/PersistentTreeMap)))) - - ;; `+map?` and `!+map?` defined above - (-def ?!+map? (or !+map? +map?)) - - (-def !map|boolean->boolean? none?) - (-def !map|boolean->byte? none?) - (-def !map|boolean->char? none?) - (-def !map|boolean->short? none?) - (-def !map|boolean->int? none?) - (-def !map|boolean->long? none?) - (-def !map|boolean->float? none?) - (-def !map|boolean->double? none?) - (-def !map|boolean->ref? none?) - - (-def !map|byte->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2BooleanMap) :cljs none?)) - (-def !map|byte->byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ByteMap) :cljs none?)) - (-def !map|byte->char? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2CharMap) :cljs none?)) - (-def !map|byte->short? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ShortMap) :cljs none?)) - (-def !map|byte->int? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2IntMap) :cljs none?)) - (-def !map|byte->long? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2LongMap) :cljs none?)) - (-def !map|byte->float? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2FloatMap) :cljs none?)) - (-def !map|byte->double? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2DoubleMap) :cljs none?)) - (-def !map|byte->ref? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.Byte2ReferenceMap) :cljs none?)) - - (-def !map|char->ref? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ReferenceMap) :cljs none?)) - (-def !map|char->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2BooleanMap) :cljs none?)) - (-def !map|char->byte? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ByteMap) :cljs none?)) - (-def !map|char->char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2CharMap) :cljs none?)) - (-def !map|char->short? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2ShortMap) :cljs none?)) - (-def !map|char->int? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2IntMap) :cljs none?)) - (-def !map|char->long? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2LongMap) :cljs none?)) - (-def !map|char->float? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2FloatMap) :cljs none?)) - (-def !map|char->double? #?(:clj (isa? it.unimi.dsi.fastutil.chars.Char2DoubleMap) :cljs none?)) - - (-def !map|short->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2BooleanMap) :cljs none?)) - (-def !map|short->byte? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ByteMap) :cljs none?)) - (-def !map|short->char? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2CharMap) :cljs none?)) - (-def !map|short->short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ShortMap) :cljs none?)) - (-def !map|short->int? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2IntMap) :cljs none?)) - (-def !map|short->long? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2LongMap) :cljs none?)) - (-def !map|short->float? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2FloatMap) :cljs none?)) - (-def !map|short->double? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2DoubleMap) :cljs none?)) - (-def !map|short->ref? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.Short2ReferenceMap) :cljs none?)) - - (-def !map|int->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2BooleanMap) :cljs none?)) - (-def !map|int->byte? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2ByteMap) :cljs none?)) - (-def !map|int->char? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2CharMap) :cljs none?)) - (-def !map|int->short? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2ShortMap) :cljs none?)) - (-def !map|int->int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2IntMap) :cljs none?)) - (-def !map|int->long? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2LongMap) :cljs none?)) - (-def !map|int->float? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2FloatMap) :cljs none?)) - (-def !map|int->double? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2DoubleMap) :cljs none?)) - (-def !map|int->ref? #?(:clj (isa? it.unimi.dsi.fastutil.ints.Int2ReferenceMap) :cljs none?)) - - (-def !map|long->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2BooleanMap) :cljs none?)) - (-def !map|long->byte? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2ByteMap) :cljs none?)) - (-def !map|long->char? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2CharMap) :cljs none?)) - (-def !map|long->short? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2ShortMap) :cljs none?)) - (-def !map|long->int? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2IntMap) :cljs none?)) - (-def !map|long->long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2LongMap) :cljs none?)) - (-def !map|long->float? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2FloatMap) :cljs none?)) - (-def !map|long->double? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2DoubleMap) :cljs none?)) - (-def !map|long->ref? #?(:clj (isa? it.unimi.dsi.fastutil.longs.Long2ReferenceMap) :cljs none?)) - - (-def !map|float->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2BooleanMap) :cljs none?)) - (-def !map|float->byte? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2ByteMap) :cljs none?)) - (-def !map|float->char? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2CharMap) :cljs none?)) - (-def !map|float->short? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2ShortMap) :cljs none?)) - (-def !map|float->int? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2IntMap) :cljs none?)) - (-def !map|float->long? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2LongMap) :cljs none?)) - (-def !map|float->float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2FloatMap) :cljs none?)) - (-def !map|float->double? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2DoubleMap) :cljs none?)) - (-def !map|float->ref? #?(:clj (isa? it.unimi.dsi.fastutil.floats.Float2ReferenceMap) :cljs none?)) - - (-def !map|double->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2BooleanMap) :cljs none?)) - (-def !map|double->byte? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2ByteMap) :cljs none?)) - (-def !map|double->char? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2CharMap) :cljs none?)) - (-def !map|double->short? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2ShortMap) :cljs none?)) - (-def !map|double->int? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2IntMap) :cljs none?)) - (-def !map|double->long? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2LongMap) :cljs none?)) - (-def !map|double->float? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2FloatMap) :cljs none?)) - (-def !map|double->double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2DoubleMap) :cljs none?)) - (-def !map|double->ref? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.Double2ReferenceMap) :cljs none?)) - - (-def !map|ref->boolean? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2BooleanMap) :cljs none?)) - (-def !map|ref->byte? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2ByteMap) :cljs none?)) - (-def !map|ref->char? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2CharMap) :cljs none?)) - (-def !map|ref->short? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2ShortMap) :cljs none?)) - (-def !map|ref->int? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2IntMap) :cljs none?)) - (-def !map|ref->long? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2LongMap) :cljs none?)) - (-def !map|ref->float? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2FloatMap) :cljs none?)) - (-def !map|ref->double? #?(:clj (isa? it.unimi.dsi.fastutil.objects.Reference2DoubleMap) :cljs none?)) - - (-def !map|ref->ref? (or #?@(:clj [;; perhaps just `(- !map? )` ? - !unsorted-map|ref->ref? - !sorted-map|ref->ref? - (isa? it.unimi.dsi.fastutil.objects.Reference2ReferenceMap)] - :cljs [(isa? goog.structs.AvlTree)]))) - - (def-preds|map|any !map) - - (def-preds|map|same-types !map) - - (-def !map? !map|any?) - -#?(:clj (-def !!map? (or !!unsorted-map? !!sorted-map?))) - - (-def map? (or ?!+map? !map? #?@(:clj [!!map? (isa? java.util.Map)]))) - ;; ===== Sets ===== ;; Associative; A special type of Map whose keys and vals are identical #?(:clj (-def java-set? (isa? java.util.Set))) diff --git a/src-untyped/quantum/untyped/ui/features.cljc b/src-untyped/quantum/untyped/ui/features.cljc index c82b4498..b96f0a28 100644 --- a/src-untyped/quantum/untyped/ui/features.cljc +++ b/src-untyped/quantum/untyped/ui/features.cljc @@ -1,8 +1,6 @@ (ns quantum.untyped.ui.features (:require [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.data.map - :refer [map-entry]] [quantum.untyped.core.logic :refer [whenc fn=]] [quantum.untyped.core.system :as usys] @@ -25,5 +23,5 @@ :safari "-webkit-flex" :safari- "-webkit-box" ; (Older) :ie "-ms-flexbox"} - (map (fn [browser s] (map-entry (whenc browser (fn= :safari-) :safari) (flex-test div s)))) + (map (fn [browser s] [(whenc browser (fn= :safari-) :safari) (flex-test div s)])) (into {}))))) diff --git a/src/quantum/ai/ml/instance/selection.cljc b/src/quantum/ai/ml/instance/selection.cljc index 3b2b9aa2..19a7055e 100644 --- a/src/quantum/ai/ml/instance/selection.cljc +++ b/src/quantum/ai/ml/instance/selection.cljc @@ -11,11 +11,11 @@ [quantum.core.collections.core :as ccoll :refer [->objects-nd]] [quantum.core.data.map :as map - :refer [!hash-map #?(:clj !hash-map|int->ref)]] + :refer [>!hash-map #?(:clj >!hash-map|int->ref)]] [quantum.core.data.set :as set - :refer [!hash-set #?(:clj !hash-set|int)]] + :refer [>!hash-set #?(:clj >!hash-set|int)]] [quantum.core.data.vector - :refer [!vector]] + :refer [>!vector]] [quantum.core.error :refer [TODO]] [quantum.core.fn @@ -87,14 +87,14 @@ (; for multi-dimensional label vectors, with ; one hashf that outputs several bucket values and whose bucket values are dense longs 0..`ct:buckets` [#{doubles-2d?} x•• #{doubles-2d?} l•• ^fn? hashf ^long ct:buckets] - (let [x••':indices (do #?(:clj (!hash-set|int) :cljs (!hash-set))) + (let [x••':indices (do #?(:clj (!>hash-set|int) :cljs (!>hash-set))) i:hashf->bucket->hash:l•->x••:l• ; map of simulated hash-function index to (fortimes:objects2 [_ ct:buckets] ; map of bucket value `b` to (fortimes:objects [_ ct:buckets] ; map of label `l•` to all instances, `x••`, which are labeled with `l•` and in `b` - #?(:clj (!hash-map|int->ref) :cljs (!hash-map))))] + #?(:clj (!>hash-map|int->ref) :cljs (!>hash-map))))] (doseqi [x• x•• i:x•] ; T(|x••|*b*|x•|) (let [l• (get l•• i:x•)] (doseqi [bucket (hashf x•) i:hashf] ; T(b*|x•|) + T(hash) @@ -103,7 +103,7 @@ :cljs (hash l•)))] (if-let [x••:l• (get hash:l•->x••:l• hash:l•)] (conj! x••:l• x•) - (assoc! hash:l•->x••:l• hash:l• (!vector x•))))))) + (assoc! hash:l•->x••:l• hash:l• (!>vector x•))))))) (doseq [bucket->hash:l•->x••:l• i:hashf->bucket->hash:l•->x••:l•] ; T(|hashf•|*b*|l•◦|) (doseq [hash:l•->x••:l• bucket->hash:l•->x••:l•] ; T(b*|l•◦|) (doseq [_ x••:l• hash:l•->x••:l•] ; T(|l•◦|) diff --git a/src/quantum/apis/google/drive/core.cljc b/src/quantum/apis/google/drive/core.cljc index 225be08d..22e9d300 100644 --- a/src/quantum/apis/google/drive/core.cljc +++ b/src/quantum/apis/google/drive/core.cljc @@ -357,7 +357,7 @@ ; #(and (vector? %) ; (= 2 (count %)) ; (keyword? (first %)) ; id -; (t/+map? (second %)) ; id-meta +; (map/+map? (second %)) ; id-meta ; (contains? (second %) :title)) ; #(func (second %)) ; drive-dir)) diff --git a/src/quantum/apis/quip/core.cljc b/src/quantum/apis/quip/core.cljc index 79953589..fbbe41f0 100644 --- a/src/quantum/apis/quip/core.cljc +++ b/src/quantum/apis/quip/core.cljc @@ -2,7 +2,8 @@ #_(:require-quantum [:lib http auth]) #_(:require [hickory.core :as hp] [hickory.select :as hs] - [quantum.core.type-old :as t])) + [quantum.core.type-old :as t] + [quantum.core.data.map :as map])) #_(defn request! [req] (http/request! @@ -29,7 +30,7 @@ (->> table second :content (mapv (fn->> :content (mapv (fn-> :content first :content first - (whenf (fn1 t/+map?) (fn-> :content first)))))))] + (whenf (fn1 map/+map?) (fn-> :content first)))))))] (coll/zipmap map/om (first columns) (-> columns rest coll/transpose)))) #_(def ^{:doc "Checks whether the argument is a singleton string consisting of diff --git a/src/quantum/audio/midi.clj b/src/quantum/audio/midi.clj index f54a34be..57550a31 100644 --- a/src/quantum/audio/midi.clj +++ b/src/quantum/audio/midi.clj @@ -16,6 +16,7 @@ while-let lfor doseqi for fori red-for join reduce zip lzip]] [quantum.core.async :as async :refer [go ! put! timeout]] + [quantum.core.data.map :as map] [quantum.core.data.validated :as dv] [quantum.core.spec :as s :refer [validate]] @@ -351,7 +352,7 @@ (release-all! offset)) (defn gen-ops-for-note [{:keys [chan pitch velocity duration tie-on? measure-ties scheduler]}] - (let [_ (validate measure-ties (fn1 t/+map?)) + (let [_ (validate measure-ties (fn1 map/+map?)) tied (get measure-ties chan) prev-tied? (= tied pitch)] (cond prev-tied? @@ -378,7 +379,7 @@ {:as line :keys [instrument expr-0 measures octave]} {:keys [base-duration scheduler normal-chan bar-ties]}] - (validate bar-ties (fn1 t/+map?)) + (validate bar-ties (fn1 map/+map?)) (red-for [note* measure {:keys [measure-ties measure-ops]} {:measure-ties bar-ties :measure-ops []}] (let [{:keys [note note-duration duration relative-duration octave' pitch-int modwheel chan velocity tie?] :as setup} @@ -405,7 +406,7 @@ (defn gen-ops-for-bar [{:keys [music base-duration scheduler normal-chans i-measure ties ops]}] - (validate ties (fn1 t/+map?)) + (validate ties (fn1 map/+map?)) (red-for [[i-line line] (coll/lindexed music) {:keys [bar-ties bar-ops]} {:bar-ties ties :bar-ops []}] (let [measure (-> line :measures (get i-measure)) diff --git a/src/quantum/compile/transpile/to/core.cljc b/src/quantum/compile/transpile/to/core.cljc index a0e3c551..f91c06ae 100644 --- a/src/quantum/compile/transpile/to/core.cljc +++ b/src/quantum/compile/transpile/to/core.cljc @@ -1,18 +1,18 @@ (ns quantum.compile.transpile.to.core (:require - [quantum.compile.transpile.util :as util ] - [quantum.core.analyze.clojure.predicates :as anap ] - [quantum.core.data.map :as map ] + [quantum.compile.transpile.util :as util] + [quantum.core.analyze.clojure.predicates :as anap] + [quantum.core.data.map :as map] [quantum.core.collections :as coll :refer [containsv? kw-map popr popl contains? in? dropl]] [quantum.core.convert :as conv :refer [->name]] [quantum.core.error :as err :refer [throw-unless >ex-info]] - [quantum.core.log :as log ] - [quantum.core.compare :as comp ] - [quantum.core.string :as str ] - [quantum.core.string.format :as strf ] + [quantum.core.log :as log] + [quantum.core.compare :as comp] + [quantum.core.string :as str] + [quantum.core.string.format :as strf] [quantum.core.fn :as fn :refer [<- fn-> fn->> fn1 fn']] [quantum.core.logic :as logic @@ -564,7 +564,7 @@ (cond (even? arg-ct) (apply sorted-map arg-0 args) ; sorts the keys - (and (= 1 arg-ct) (t/+map? arg-0)) + (and (= 1 arg-ct) (map/+map? arg-0)) arg-0 (and (= 1 arg-ct) (nil? arg-0)) {} diff --git a/src/quantum/core/async/pool.cljc b/src/quantum/core/async/pool.cljc index aa920a83..77386a75 100644 --- a/src/quantum/core/async/pool.cljc +++ b/src/quantum/core/async/pool.cljc @@ -361,7 +361,7 @@ :generated shut-down-pools!))) (log/pr ::debug "Stopped ThreadpoolManager."))))) -#?(:clj (defn validate-pools-map [x] (t/+map? x))) ; TODO more validation +#?(:clj (defn validate-pools-map [x] (map/+map? x))) ; TODO more validation #?(:clj (dv/def-map threadpool-manager:config ; TODO merge with ThreadpoolManager diff --git a/src/quantum/core/collections.cljc b/src/quantum/core/collections.cljc index eb236efb..5c6d50db 100644 --- a/src/quantum/core/collections.cljc +++ b/src/quantum/core/collections.cljc @@ -46,12 +46,12 @@ [clojure.core :as c ] [fast-zip.core :as zip ] [quantum.core.data.map :as map - :refer [!hash-map]] + :refer [!>hash-map]] [quantum.core.data.set :as set ] [quantum.core.data.string :refer [!str]] [quantum.core.data.vector :as vec - :refer [catvec subsvec !vector]] + :refer [catvec subsvec !>vector]] [quantum.core.collections.core :as coll] [quantum.core.collections.sociative :as soc ] [quantum.core.collections.differential :as diff @@ -637,7 +637,7 @@ (fn [m k] (let [v (get m k)] (if (or (nil? v) - (and (or (t/+map? v) + (and (or (map/+map? v) (c/sequential? v)) (empty? v))) (dissoc m k) m))) @@ -1175,7 +1175,7 @@ (defnt probabilities+ ([ #_reducible? xs] - (let [ct (count xs)] (->> xs (frequencies (!hash-map)) (map-vals+ (fn1 / ct)))))) + (let [ct (count xs)] (->> xs (frequencies (!>hash-map)) (map-vals+ (fn1 / ct)))))) ;___________________________________________________________________________________________________________________________________ ;=================================================={ GROUPING }===================================================== ;=================================================={ group, aggregate }===================================================== @@ -1709,8 +1709,8 @@ (reduce-kv (fn [m k v] (if (or (and (not (> 0 max)) (<= max 1)) - (not (#?(:clj t/+hash-map? - :cljs t/+map?) v)) + (not (#?(:clj map/+hash-map? + :cljs map/+map?) v)) (and keep-empty (empty? v))) (assoc m (conj arr k) v) @@ -2187,7 +2187,7 @@ (long (num/ceil (double (* n p))))) ; TODO make not use long or double sorted (->> allocated (map-indexed+ vector) - (join! (!vector)) + (join! (!>vector)) (sort-by! (fn1 second))) total (->> allocated (reduce + 0)) *flow (long (- total n))] ; over- or underflow diff --git a/src/quantum/core/data/map.cljc b/src/quantum/core/data/map.cljc index 3121167f..eb0ec6f7 100644 --- a/src/quantum/core/data/map.cljc +++ b/src/quantum/core/data/map.cljc @@ -1,20 +1,21 @@ -(ns - ^{:doc "Useful map functions. |map-entry|, a better merge, sorted-maps, etc." - :attribution "alexandergunnarson"} +(ns ^{:attribution "alexandergunnarson"} quantum.core.data.map + "Useful map functions. |map-entry|, a better merge, sorted-maps, etc." (:refer-clojure :exclude - [split-at, merge, sorted-map sorted-map-by]) + [split-at, map?, merge, sorted-map sorted-map-by]) (:require #?(:clj [clojure.data.int-map]) ;; TODO TYPED - #_[quantum.core.reducers :as r + #_[quantum.core.reducers :as r :refer [reduce-pair]] - [quantum.untyped.core.data.map :as u] - [quantum.untyped.core.type :as t] + [quantum.core.type :as t] + [quantum.core.vars + :refer [defalias def- defmacro-]] + [quantum.untyped.core.data.map :as umap] + [quantum.untyped.core.defnt + :refer [defns-]] [quantum.untyped.core.type.defnt - :refer [defnt]] - [quantum.untyped.core.vars - :refer [defalias]]) + :refer [defnt]]) (:import #?@(:clj [[java.util HashMap IdentityHashMap LinkedHashMap TreeMap] [it.unimi.dsi.fastutil.ints Int2ReferenceOpenHashMap] @@ -24,11 +25,55 @@ [it.unimi.dsi.fastutil.objects Reference2LongOpenHashMap]] :cljs [[goog.structs AvlTree LinkedMap]]))) +;; TO EXPLORE +;; - Optimizing Hash-Array Mapped Tries for Fast and Lean Immutable JVM Collections +;; - Actual usable implementation: https://github.com/usethesource/capsule +;; - http://michael.steindorfer.name/publications/oopsla15.pdf +;; - Overall significantly faster on what they've chosen to measure. +;; - Alex Miller: "We have seen it and will probably investigate some of these ideas after 1.8." +;; ======================= + +(def- basic-type-syms-for-maps '[boolean byte short char int long float double ref]) + +#?(:clj +(defns- >v-sym [prefix symbol?, kind symbol? > symbol?] + (symbol (str prefix "|" kind "?")))) + +#?(:clj +(defns- >kv-sym [prefix symbol?, from-type symbol?, to-type symbol? > symbol?] + (symbol (str prefix "|" from-type "->" to-type "?")))) + +#?(:clj +(defmacro- def-preds|map|same-types [prefix #_symbol?] + `(do ~@(for [kind (conj basic-type-syms-for-maps 'any)] + (list 'def (>v-sym prefix kind) (>kv-sym prefix kind kind)))))) + +#?(:clj +(defmacro- def-preds|map|any [prefix #_symbol?] + (let [anys (->> (for [kind basic-type-syms] + [(list 'def (>kv-sym prefix kind 'any) + (->> basic-type-syms-for-maps + (map #(>kv-sym prefix kind %)) + (list* `t/or))) + (list 'def (>kv-sym prefix 'any kind) + (->> basic-type-syms-for-maps + (map #(>kv-sym prefix % kind)) + (list* `t/or)))]) + (apply concat)) + any->any (list 'def (>kv-sym prefix 'any 'any) + (->> basic-type-syms + (map #(vector (>kv-sym prefix 'any %) (>kv-sym prefix % 'any))) + (apply concat) + (list* `t/or)))] + `(do ~@(concat anys [any->any]))))) + ;; ===== Map entries ===== ;; +(def +map-entry? (t/isa? #?(:clj clojure.lang.MapEntry :cljs cljs.core.MapEntry))) + (defnt >map-entry "A performant replacement for creating 2-tuples (vectors), e.g., as return values - in a |kv-reduce| function. + in a `kv-reduce` function. Now overshadowed by ztellman's unrolled vectors in 1.8.0. @@ -39,23 +84,33 @@ However, insertion into maps is faster with map-entry: (def vs [[1 2] [3 4]]) - (def ms [(map-entry 1 2) (map-entry 3 4)]) + (def ms [(>map-entry 1 2) (>map-entry 3 4)]) (def m0 {}) 508.122831 ms (dotimes [n 1000000] (into m0 vs)) 310.335998 ms (dotimes [n 1000000] (into m0 ms))" {:attribution "alexandergunnarson"} - [k _, v _ > t/+map-entry?] + > +map-entry? + [k _, v _] #?(:clj (clojure.lang.MapEntry. k v) :cljs (cljs.core.MapEntry. k v nil))) -;; ===== Unordered identity-semantic maps ===== ;; +;; ===== Unordered identity-semantic (identity-based equality) maps ===== ;; + + (def !identity-map|ref->ref? + #?(:clj (t/isa? java.util.IdentityHashMap) :cljs (t/isa? js/Map))) + + (def !identity-map? !identity-map|ref->ref?) + +#?(:clj (def !!identity-map? t/none?)) + + (def identity-map? (t/or !identity-map? #?(:clj !!identity-map?))) ;; TODO generate this via macro? (defnt >!identity-map "Creates a single-threaded, mutable identity map. On the JVM, this is a `java.util.IdentityHashMap`. On JS, this is a `js/Map` (ECMAScript 6 Map)." - > t/!identity-map? + > !identity-map? ([] #?(:clj (IdentityHashMap.) :cljs (js/Map.))) ([k0 (t/ref t/any?), v0 (t/ref t/any?)] (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) @@ -113,12 +168,194 @@ (#?(:clj .put :cljs .set) k6 v6)) kvs))) -;; ===== Unordered value-semantic maps ===== ;; +;; ===== Unordered value-semantic (value-based equality) maps ===== ;; + +;; ----- Array maps ----- ;; + +(def +array-map? (t/isa? #?(:clj clojure.lang.PersistentArrayMap + :cljs cljs.core/PersistentArrayMap))) + +(def !+array-map? (t/isa? #?(:clj clojure.lang.PersistentArrayMap$TransientArrayMap + :cljs cljs.core/TransientArrayMap))) + +(def ?!+array-map? (t/or !+array-map? +array-map?)) + +(def !array-map|boolean->boolean? t/none?) +(def !array-map|boolean->byte? t/none?) +(def !array-map|boolean->short? t/none?) +(def !array-map|boolean->char? t/none?) +(def !array-map|boolean->int? t/none?) +(def !array-map|boolean->long? t/none?) +(def !array-map|boolean->float? t/none?) +(def !array-map|boolean->double? t/none?) +(def !array-map|boolean->ref? t/none?) + +(def !array-map|byte->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2BooleanArrayMap) :cljs t/none?)) +(def !array-map|byte->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2ByteArrayMap) :cljs t/none?)) +(def !array-map|byte->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2ShortArrayMap) :cljs t/none?)) +(def !array-map|byte->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2CharArrayMap) :cljs t/none?)) +(def !array-map|byte->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2IntArrayMap) :cljs t/none?)) +(def !array-map|byte->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2LongArrayMap) :cljs t/none?)) +(def !array-map|byte->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2FloatArrayMap) :cljs t/none?)) +(def !array-map|byte->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2DoubleArrayMap) :cljs t/none?)) +(def !array-map|byte->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2ReferenceArrayMap) :cljs t/none?)) + +(def !array-map|short->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2BooleanArrayMap) :cljs t/none?)) +(def !array-map|short->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2ByteArrayMap) :cljs t/none?)) +(def !array-map|short->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2ShortArrayMap) :cljs t/none?)) +(def !array-map|short->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2CharArrayMap) :cljs t/none?)) +(def !array-map|short->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2IntArrayMap) :cljs t/none?)) +(def !array-map|short->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2LongArrayMap) :cljs t/none?)) +(def !array-map|short->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2FloatArrayMap) :cljs t/none?)) +(def !array-map|short->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2DoubleArrayMap) :cljs t/none?)) +(def !array-map|short->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2ReferenceArrayMap) :cljs t/none?)) + +(def !array-map|char->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2ReferenceArrayMap) :cljs t/none?)) +(def !array-map|char->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2BooleanArrayMap) :cljs t/none?)) +(def !array-map|char->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2ByteArrayMap) :cljs t/none?)) +(def !array-map|char->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2ShortArrayMap) :cljs t/none?)) +(def !array-map|char->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2CharArrayMap) :cljs t/none?)) +(def !array-map|char->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2IntArrayMap) :cljs t/none?)) +(def !array-map|char->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2LongArrayMap) :cljs t/none?)) +(def !array-map|char->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2FloatArrayMap) :cljs t/none?)) +(def !array-map|char->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2DoubleArrayMap) :cljs t/none?)) + +(def !array-map|int->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2BooleanArrayMap) :cljs t/none?)) +(def !array-map|int->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2ByteArrayMap) :cljs t/none?)) +(def !array-map|int->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2ShortArrayMap) :cljs t/none?)) +(def !array-map|int->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2CharArrayMap) :cljs t/none?)) +(def !array-map|int->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2IntArrayMap) :cljs t/none?)) +(def !array-map|int->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2LongArrayMap) :cljs t/none?)) +(def !array-map|int->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2FloatArrayMap) :cljs t/none?)) +(def !array-map|int->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2DoubleArrayMap) :cljs t/none?)) +(def !array-map|int->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2ReferenceArrayMap) :cljs t/none?)) + +(def !array-map|long->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2BooleanArrayMap) :cljs t/none?)) +(def !array-map|long->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2ByteArrayMap) :cljs t/none?)) +(def !array-map|long->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2ShortArrayMap) :cljs t/none?)) +(def !array-map|long->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2CharArrayMap) :cljs t/none?)) +(def !array-map|long->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2IntArrayMap) :cljs t/none?)) +(def !array-map|long->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2LongArrayMap) :cljs t/none?)) +(def !array-map|long->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2FloatArrayMap) :cljs t/none?)) +(def !array-map|long->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2DoubleArrayMap) :cljs t/none?)) +(def !array-map|long->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2ReferenceArrayMap) :cljs t/none?)) + +(def !array-map|float->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2BooleanArrayMap) :cljs t/none?)) +(def !array-map|float->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2ByteArrayMap) :cljs t/none?)) +(def !array-map|float->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2ShortArrayMap) :cljs t/none?)) +(def !array-map|float->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2CharArrayMap) :cljs t/none?)) +(def !array-map|float->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2IntArrayMap) :cljs t/none?)) +(def !array-map|float->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2LongArrayMap) :cljs t/none?)) +(def !array-map|float->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2FloatArrayMap) :cljs t/none?)) +(def !array-map|float->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2DoubleArrayMap) :cljs t/none?)) +(def !array-map|float->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2ReferenceArrayMap) :cljs t/none?)) + +(def !array-map|double->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2BooleanArrayMap) :cljs t/none?)) +(def !array-map|double->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2ByteArrayMap) :cljs t/none?)) +(def !array-map|double->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2ShortArrayMap) :cljs t/none?)) +(def !array-map|double->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2CharArrayMap) :cljs t/none?)) +(def !array-map|double->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2IntArrayMap) :cljs t/none?)) +(def !array-map|double->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2LongArrayMap) :cljs t/none?)) +(def !array-map|double->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2FloatArrayMap) :cljs t/none?)) +(def !array-map|double->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2DoubleArrayMap) :cljs t/none?)) +(def !array-map|double->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2ReferenceArrayMap) :cljs t/none?)) + +(def !array-map|ref->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2BooleanArrayMap) :cljs t/none?)) +(def !array-map|ref->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2ByteArrayMap) :cljs t/none?)) +(def !array-map|ref->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2ShortArrayMap) :cljs t/none?)) +(def !array-map|ref->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2CharArrayMap) :cljs t/none?)) +(def !array-map|ref->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2IntArrayMap) :cljs t/none?)) +(def !array-map|ref->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2LongArrayMap) :cljs t/none?)) +(def !array-map|ref->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2FloatArrayMap) :cljs t/none?)) +(def !array-map|ref->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2DoubleArrayMap) :cljs t/none?)) +(def !array-map|ref->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2ReferenceArrayMap) :cljs t/none?)) + + (def-preds|map|any !array-map) + + (def-preds|map|same-types !array-map) + + (def !array-map? !array-map|any?) + +#?(:clj (def !!array-map? t/none?)) + + (def array-map? (t/or ?!+array-map? !array-map? #?(:clj !!array-map?))) (defnt >array-map "Creates a persistent array map. If any keys are equal, they are handled as if by repeated applications of `assoc`." - > t/+array-map? + > +array-map? ([] (. clojure.lang.PersistentArrayMap EMPTY)) ;; TODO TYPED handle varargs #_([& kvs] @@ -126,31 +363,1279 @@ ;; ----- Hash maps ----- ;; +;; TODO TYPED — use `deftypet` and also typed internals +#?(:cljs +(deftype MutableHashMap ; There can be no `undefined` values + [meta ^:mutable ct ^js/Map m #_"Keys are int hashes; vals are map entries from k to v" + ^:mutable ^boolean has-nil? ^:mutable nil-val ^:mutable __hash] + Object + (toString [this] (str (into {} (es6-iterator-seq (.values m))))) + (equiv [this other] (-equiv this other)) + (keys [this] (es6-iterator (cljs.core/keys this))) + (entries [this] (es6-entries-iterator (seq this))) + (values [this] (es6-iterator (vals this))) + (has [this k] (contains? this k)) + (get [this k not-found] (-lookup this k not-found)) + (forEach [this f] (doseq [[k v] this] (f v k))) + ICloneable + (-clone [_] (MutableHashMap. meta ct m has-nil? nil-val __hash)) + IIterable + (-iterator [this] (-iterator (vals this))) + IWithMeta + (-with-meta [this meta-] (MutableHashMap. meta- ct m has-nil? nil-val __hash)) + IMeta + (-meta [this] meta) + IEmptyableCollection + (-empty [this] (MutableHashMap. meta 0 (js/Map.) false nil 0)) + IEquiv + (-equiv [this that] (equiv-map this that)) + IHash + (-hash [this] (caching-hash this hash-unordered-coll __hash)) + ISeqable + (-seq [this] + (when (pos? ct) + (let [s (es6-iterator-seq (.values m))] + (if has-nil? + (cons (>map-entry nil nil-val) s) + s)))) + ICounted + (-count [this] ct) + ILookup + (-lookup [this k] (-lookup this k nil)) + (-lookup [this k not-found] + (if (nil? k) + (if has-nil? nil-val not-found) + (let [kv (.get m (hash k))] + (if (undefined? kv) not-found (-val kv))))) + IAssociative + (-contains-key? [this k] + (if (nil? k) + has-nil? + (.has m (hash k)))) + IFind + (-find [this k] + (if (nil? k) + (when has-nil? (>map-entry nil nil-val)) + (let [kv (.get m (hash k))] + (if (undefined? kv) nil kv)))) + ITransientCollection + (-conj! [this entry] + (if (vector? entry) + (-assoc! this (-nth entry 0) (-nth entry 1)) + (loop [ret this es (seq entry)] + (if (nil? es) + ret + (let [e (first es)] + (if (vector? e) + (recur (-assoc! ret (-nth e 0) (-nth e 1)) + (next es)) + (throw (ex-info "conj on a map takes map entries or seqables of map entries" {})))))))) + ITransientAssociative + (-assoc! [this k v] + (cond + (undefined? v) + (throw (ex-info "Cannot `assoc` undefined value to `MutableHashMap`" {})) + (nil? k) + (if (and has-nil? (identical? v nil-val)) + this + (do (when-not has-nil? (set! ct (inc ct))) + (set! has-nil? true) + (set! nil-val v) + (set! __hash nil) ; TODO recalculate incrementally? + this)) + :else + (let [hash-k (hash k)] + (if (.has m hash-k) + this + (do (.set m (hash k) (map-entry k v)) + (set! ct (inc ct)) + (set! __hash nil) ; TODO recalculate incrementally? + this))))) + ITransientMap + (-dissoc! [this k] + (if (nil? k) + (if has-nil? + (do (set! ct (dec ct)) + (set! has-nil? false) + (set! nil-val nil) + (set! __hash nil) ; TODO recalculate incrementally? + this) + this) + (if (.delete m (hash k)) + (do (set! ct (dec ct)) + (set! __hash nil) ; TODO recalculate incrementally? + this) + this))) + IKVReduce + (-kv-reduce [this f init] + (let [init (if has-nil? (f init nil nil-val) init)] + (if (reduced? init) + @init + (unreduced (reduce (fn [ret kv] (f ret (-key kv) (-val kv))) init m))))) + IFn + (-invoke [this k] (-lookup this k)) + (-invoke [this k not-found] (-lookup this k not-found)))) + +(def +hash-map? (t/isa? #?(:clj clojure.lang.PersistentHashMap + :cljs cljs.core/PersistentHashMap))) + +(def !+hash-map? (t/isa? #?(:clj clojure.lang.PersistentHashMap$TransientHashMap + :cljs cljs.core/TransientHashMap))) + +(def ?!+hash-map? (t/or !+hash-map? +hash-map?)) + (defnt >hash-map "Creates a persistent hash map. If any keys are equal, they are handled as if by repeated - applications of `assoc`." - > t/+array-map? - ([] clojure.lang.PersistentArrayMap/EMPTY) + applications of `assoc`. + + `(->> pairs (apply concat) (apply >hash-map))` <~> `lodash/fromPairs`" + > +hash-map? + ([] clojure.lang.PersistentHashMap/EMPTY) ;; TODO TYPED handle varargs -#_([& keyvals] +#_([& kvs] (clojure.lang.PersistentHashMap/create kvs))) -(def +hash-map|long->ref? (t/isa? clojure.data.int_map.PersistentIntMap)) +(def !hash-map|boolean->boolean? t/none?) +(def !hash-map|boolean->byte? t/none?) +(def !hash-map|boolean->short? t/none?) +(def !hash-map|boolean->char? t/none?) +(def !hash-map|boolean->int? t/none?) +(def !hash-map|boolean->long? t/none?) +(def !hash-map|boolean->float? t/none?) +(def !hash-map|boolean->double? t/none?) +(def !hash-map|boolean->ref? t/none?) + +(def !hash-map|byte->boolean? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.bytes.Byte2BooleanOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.bytes.Byte2BooleanOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|byte->byte? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.bytes.Byte2ByteOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.bytes.Byte2ByteOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|byte->short? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.bytes.Byte2ShortOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.bytes.Byte2ShortOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|byte->char? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.bytes.Byte2CharOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.bytes.Byte2CharOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|byte->int? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.bytes.Byte2IntOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.bytes.Byte2IntOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|byte->long? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.bytes.Byte2LongOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.bytes.Byte2LongOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|byte->float? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.bytes.Byte2FloatOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.bytes.Byte2FloatOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|byte->double? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.bytes.Byte2DoubleOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.bytes.Byte2DoubleOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|byte->ref? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.bytes.Byte2ReferenceOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.bytes.Byte2ReferenceOpenCustomHashMap)) + :cljs t/none?)) + +(def !hash-map|short->boolean? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.shorts.Short2BooleanOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.shorts.Short2BooleanOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|short->byte? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.shorts.Short2ByteOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.shorts.Short2ByteOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|short->short? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.shorts.Short2ShortOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.shorts.Short2ShortOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|short->char? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.shorts.Short2CharOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.shorts.Short2CharOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|short->int? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.shorts.Short2IntOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.shorts.Short2IntOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|short->long? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.shorts.Short2LongOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.shorts.Short2LongOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|short->float? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.shorts.Short2FloatOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.shorts.Short2FloatOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|short->double? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.shorts.Short2DoubleOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.shorts.Short2DoubleOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|short->ref? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.shorts.Short2ReferenceOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.shorts.Short2ReferenceOpenCustomHashMap)) + :cljs t/none?)) + +(def !hash-map|char->ref? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.chars.Char2ReferenceOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.chars.Char2ReferenceOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|char->boolean? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.chars.Char2BooleanOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.chars.Char2BooleanOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|char->byte? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.chars.Char2ByteOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.chars.Char2ByteOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|char->short? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.chars.Char2ShortOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.chars.Char2ShortOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|char->char? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.chars.Char2CharOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.chars.Char2CharOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|char->int? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.chars.Char2IntOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.chars.Char2IntOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|char->long? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.chars.Char2LongOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.chars.Char2LongOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|char->float? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.chars.Char2FloatOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.chars.Char2FloatOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|char->double? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.chars.Char2DoubleOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.chars.Char2DoubleOpenCustomHashMap)) + :cljs t/none?)) + +(def !hash-map|int->boolean? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.ints.Int2BooleanOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.ints.Int2BooleanOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|int->byte? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.ints.Int2ByteOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.ints.Int2ByteOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|int->short? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.ints.Int2ShortOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.ints.Int2ShortOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|int->char? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.ints.Int2CharOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.ints.Int2CharOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|int->int? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.ints.Int2IntOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.ints.Int2IntOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|int->long? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.ints.Int2LongOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.ints.Int2LongOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|int->float? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.ints.Int2FloatOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.ints.Int2FloatOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|int->double? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.ints.Int2DoubleOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.ints.Int2DoubleOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|int->ref? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.ints.Int2ReferenceOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.ints.Int2ReferenceOpenCustomHashMap)) + :cljs t/none?)) + +(def !hash-map|long->boolean? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.longs.Long2BooleanOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.longs.Long2BooleanOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|long->byte? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.longs.Long2ByteOpenCustomHashMap) + (t/isa? it.unimi.dsi.fastutil.longs.Long2ByteOpenHashMap)) + :cljs t/none?)) +(def !hash-map|long->short? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.longs.Long2ShortOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.longs.Long2ShortOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|long->char? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.longs.Long2CharOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.longs.Long2CharOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|long->int? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.longs.Long2IntOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.longs.Long2IntOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|long->long? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.longs.Long2LongOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.longs.Long2LongOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|long->float? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.longs.Long2FloatOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.longs.Long2FloatOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|long->double? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.longs.Long2DoubleOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.longs.Long2DoubleOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|long->ref? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.longs.Long2ReferenceOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.longs.Long2ReferenceOpenCustomHashMap)) + :cljs t/none?)) + +(def !hash-map|float->boolean? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.floats.Float2BooleanOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.floats.Float2BooleanOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|float->byte? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.floats.Float2ByteOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.floats.Float2ByteOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|float->short? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.floats.Float2ShortOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.floats.Float2ShortOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|float->char? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.floats.Float2CharOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.floats.Float2CharOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|float->int? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.floats.Float2IntOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.floats.Float2IntOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|float->long? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.floats.Float2LongOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.floats.Float2LongOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|float->float? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.floats.Float2FloatOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.floats.Float2FloatOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|float->double? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.floats.Float2DoubleOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.floats.Float2DoubleOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|float->ref? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.floats.Float2ReferenceOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.floats.Float2ReferenceOpenCustomHashMap)) + :cljs t/none?)) + +(def !hash-map|double->boolean? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.doubles.Double2BooleanOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.doubles.Double2BooleanOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|double->byte? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.doubles.Double2ByteOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.doubles.Double2ByteOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|double->short? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.doubles.Double2ShortOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.doubles.Double2ShortOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|double->char? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.doubles.Double2CharOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.doubles.Double2CharOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|double->int? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.doubles.Double2IntOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.doubles.Double2IntOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|double->long? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.doubles.Double2LongOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.doubles.Double2LongOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|double->float? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.doubles.Double2FloatOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.doubles.Double2FloatOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|double->double? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.doubles.Double2DoubleOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.doubles.Double2DoubleOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|double->ref? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.doubles.Double2ReferenceOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.doubles.Double2ReferenceOpenCustomHashMap)) + :cljs t/none?)) + +(def !hash-map|ref->boolean? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.objects.Reference2BooleanOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.objects.Reference2BooleanOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|ref->byte? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.objects.Reference2ByteOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.objects.Reference2ByteOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|ref->short? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.objects.Reference2ShortOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.objects.Reference2ShortOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|ref->char? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.objects.Reference2CharOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.objects.Reference2CharOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|ref->int? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.objects.Reference2IntOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.objects.Reference2IntOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|ref->long? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.objects.Reference2LongOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.objects.Reference2LongOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|ref->float? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.objects.Reference2FloatOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.objects.Reference2FloatOpenCustomHashMap)) + :cljs t/none?)) +(def !hash-map|ref->double? + #?(:clj (t/or (t/isa? it.unimi.dsi.fastutil.objects.Reference2DoubleOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.objects.Reference2DoubleOpenCustomHashMap)) + :cljs t/none?)) + +(def !hash-map|ref->ref? + (t/or #?@(:clj [(t/isa? java.util.HashMap) + ;; Because this has different semantics + #_(t/isa? java.util.IdentityHashMap) + (t/isa? it.unimi.dsi.fastutil.objects.Reference2ReferenceOpenHashMap) + (t/isa? it.unimi.dsi.fastutil.objects.Reference2ReferenceOpenCustomHashMap)] + :cljs [MutableHashMap]))) + +(def-preds|map|any !hash-map) + +(def-preds|map|same-types !hash-map) + + (def !hash-map? !hash-map|any?) + +#?(:clj (def !!hash-map? (t/isa? java.util.concurrent.ConcurrentHashMap))) + (def hash-map? (t/or ?!+hash-map? !hash-map? #?(:clj !!hash-map?))) + +;; TODO generate this function via macro? +(defnt >!hash-map + "Creates a single-threaded, mutable hash map. + On the JVM, this is a `java.util.HashMap`. + On JS, this is a `quantum.untyped.core.data.map.HashMap`." + > !hash-map? + ([] #?(:clj (HashMap.) :cljs (MutableHashMap. nil 0 (js/Map.) false nil nil))) + ([k0 t/ref?, v0 t/ref?] + (doto #?(:clj (HashMap.) :cljs (>!hash-map)) + (#?(:clj .put :cljs assoc!) k0 v0))) + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?] + (doto #?(:clj (HashMap.) :cljs (>!hash-map)) + (#?(:clj .put :cljs assoc!) k0 v0) + (#?(:clj .put :cljs assoc!) k1 v1))) + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?] + (doto #?(:clj (HashMap.) :cljs (>!hash-map)) + (#?(:clj .put :cljs assoc!) k0 v0) + (#?(:clj .put :cljs assoc!) k1 v1) + (#?(:clj .put :cljs assoc!) k2 v2))) + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?, k3 t/ref?, v3 t/ref?] + (doto #?(:clj (HashMap.) :cljs (>!hash-map)) + (#?(:clj .put :cljs assoc!) k0 v0) + (#?(:clj .put :cljs assoc!) k1 v1) + (#?(:clj .put :cljs assoc!) k2 v2) + (#?(:clj .put :cljs assoc!) k3 v3))) + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?, k3 t/ref?, v3 t/ref? + k4 t/ref?, v4 t/ref?] + (doto #?(:clj (HashMap.) :cljs (>!hash-map)) + (#?(:clj .put :cljs assoc!) k0 v0) + (#?(:clj .put :cljs assoc!) k1 v1) + (#?(:clj .put :cljs assoc!) k2 v2) + (#?(:clj .put :cljs assoc!) k3 v3) + (#?(:clj .put :cljs assoc!) k4 v4))) + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?, k3 t/ref?, v3 t/ref? + k4 t/ref?, v4 t/ref?, k5 t/ref?, v5 t/ref?] + (doto #?(:clj (HashMap.) :cljs (>!hash-map)) + (#?(:clj .put :cljs assoc!) k0 v0) + (#?(:clj .put :cljs assoc!) k1 v1) + (#?(:clj .put :cljs assoc!) k2 v2) + (#?(:clj .put :cljs assoc!) k3 v3) + (#?(:clj .put :cljs assoc!) k4 v4) + (#?(:clj .put :cljs assoc!) k5 v5))) + ;; TODO TYPED variadic support +#_([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?, k3 t/ref?, v3 t/ref? + k4 t/ref?, v4 t/ref?, k5 t/ref?, v5 t/ref?, k6 t/ref?, v6 t/ref?, & kvs] + (reduce-pair + (fn [^HashMap m k v] (doto m (#?(:clj .put :cljs assoc!) k v))) + (doto #?(:clj (HashMap.) :cljs (>!hash-map)) + (#?(:clj .put :cljs assoc!) k0 v0) + (#?(:clj .put :cljs assoc!) k1 v1) + (#?(:clj .put :cljs assoc!) k2 v2) + (#?(:clj .put :cljs assoc!) k3 v3) + (#?(:clj .put :cljs assoc!) k4 v4) + (#?(:clj .put :cljs assoc!) k5 v5) + (#?(:clj .put :cljs assoc!) k6 v6)) + kvs))) + +;; TODO generate these functions via macros +;; TODO this is incomplete +#?(:clj (defnt >!hash-map|int->ref > !hash-map|int->ref? [] (Int2ReferenceOpenHashMap.))) +#?(:clj (defnt >!hash-map|long->long > !hash-map|long->long? [] (Long2LongOpenHashMap.))) +#?(:clj (defnt >!hash-map|long->ref > !hash-map|long->ref? [] (Long2ReferenceOpenHashMap.))) +#?(:clj (defnt >!hash-map|double->ref > !hash-map|double->ref? [] (Double2ReferenceOpenHashMap.))) +#?(:clj (defnt >!hash-map|ref->long > !hash-map|ref->long? [] (Reference2LongOpenHashMap.))) + +;; ----- Unsorted Maps ----- ;; TODO Perhaps the concept of unsortedness is `(- map sorted?)`? + +#?(:clj (def +unsorted-map|long->ref? (t/isa? clojure.data.int_map.PersistentIntMap))) + + (def +unsorted-map? (t/or +hash-map? +array-map? +unsorted-map|long->ref?)) + (def !+unsorted-map? (t/or !+hash-map? !+array-map?)) + (def ?!+unsorted-map? (t/or ?!+hash-map? ?!+array-map?)) + +(def !unsorted-map|boolean->boolean? + (t/or !hash-map|boolean->boolean? !array-map|boolean->boolean?)) +(def !unsorted-map|boolean->byte? + (t/or !hash-map|boolean->byte? !array-map|boolean->byte?)) +(def !unsorted-map|boolean->short? + (t/or !hash-map|boolean->short? !array-map|boolean->short?)) +(def !unsorted-map|boolean->char? + (t/or !hash-map|boolean->char? !array-map|boolean->char?)) +(def !unsorted-map|boolean->int? + (t/or !hash-map|boolean->int? !array-map|boolean->int?)) +(def !unsorted-map|boolean->long? + (t/or !hash-map|boolean->long? !array-map|boolean->long?)) +(def !unsorted-map|boolean->float? + (t/or !hash-map|boolean->float? !array-map|boolean->float?)) +(def !unsorted-map|boolean->double? + (t/or !hash-map|boolean->double? !array-map|boolean->double?)) +(def !unsorted-map|boolean->ref? + (t/or !hash-map|boolean->ref? !array-map|boolean->ref?)) + +(def !unsorted-map|byte->boolean? + (t/or !hash-map|byte->boolean? !array-map|byte->boolean?)) +(def !unsorted-map|byte->byte? + (t/or !hash-map|byte->byte? !array-map|byte->byte?)) +(def !unsorted-map|byte->short? + (t/or !hash-map|byte->short? !array-map|byte->short?)) +(def !unsorted-map|byte->char? + (t/or !hash-map|byte->char? !array-map|byte->char?)) +(def !unsorted-map|byte->int? + (t/or !hash-map|byte->int? !array-map|byte->int?)) +(def !unsorted-map|byte->long? + (t/or !hash-map|byte->long? !array-map|byte->long?)) +(def !unsorted-map|byte->float? + (t/or !hash-map|byte->float? !array-map|byte->float?)) +(def !unsorted-map|byte->double? + (t/or !hash-map|byte->double? !array-map|byte->double?)) +(def !unsorted-map|byte->ref? + (t/or !hash-map|byte->ref? !array-map|byte->ref?)) + +(def !unsorted-map|short->boolean? + (t/or !hash-map|short->boolean? !array-map|short->boolean?)) +(def !unsorted-map|short->byte? + (t/or !hash-map|short->byte? !array-map|short->byte?)) +(def !unsorted-map|short->short? + (t/or !hash-map|short->short? !array-map|short->short?)) +(def !unsorted-map|short->char? + (t/or !hash-map|short->char? !array-map|short->char?)) +(def !unsorted-map|short->int? + (t/or !hash-map|short->int? !array-map|short->int?)) +(def !unsorted-map|short->long? + (t/or !hash-map|short->long? !array-map|short->long?)) +(def !unsorted-map|short->float? + (t/or !hash-map|short->float? !array-map|short->float?)) +(def !unsorted-map|short->double? + (t/or !hash-map|short->double? !array-map|short->double?)) +(def !unsorted-map|short->ref? + (t/or !hash-map|short->ref? !array-map|short->ref?)) + +(def !unsorted-map|char->boolean? + (t/or !hash-map|char->boolean? !array-map|char->boolean?)) +(def !unsorted-map|char->byte? + (t/or !hash-map|char->byte? !array-map|char->byte?)) +(def !unsorted-map|char->short? + (t/or !hash-map|char->short? !array-map|char->short?)) +(def !unsorted-map|char->char? + (t/or !hash-map|char->char? !array-map|char->char?)) +(def !unsorted-map|char->int? + (t/or !hash-map|char->int? !array-map|char->int?)) +(def !unsorted-map|char->long? + (t/or !hash-map|char->long? !array-map|char->long?)) +(def !unsorted-map|char->float? + (t/or !hash-map|char->float? !array-map|char->float?)) +(def !unsorted-map|char->double? + (t/or !hash-map|char->double? !array-map|char->double?)) +(def !unsorted-map|char->ref? + (t/or !hash-map|char->ref? !array-map|char->ref?)) + +(def !unsorted-map|int->boolean? + (t/or !hash-map|int->boolean? !array-map|int->boolean?)) +(def !unsorted-map|int->byte? + (t/or !hash-map|int->byte? !array-map|int->byte?)) +(def !unsorted-map|int->short? + (t/or !hash-map|int->short? !array-map|int->short?)) +(def !unsorted-map|int->char? + (t/or !hash-map|int->char? !array-map|int->char?)) +(def !unsorted-map|int->int? + (t/or !hash-map|int->int? !array-map|int->int?)) +(def !unsorted-map|int->long? + (t/or !hash-map|int->long? !array-map|int->long?)) +(def !unsorted-map|int->float? + (t/or !hash-map|int->float? !array-map|int->float?)) +(def !unsorted-map|int->double? + (t/or !hash-map|int->double? !array-map|int->double?)) +(def !unsorted-map|int->ref? + (t/or !hash-map|int->ref? !array-map|int->ref?)) + +(def !unsorted-map|long->boolean? + (t/or !hash-map|long->boolean? !array-map|long->boolean?)) +(def !unsorted-map|long->byte? + (t/or !hash-map|long->byte? !array-map|long->byte?)) +(def !unsorted-map|long->short? + (t/or !hash-map|long->short? !array-map|long->short?)) +(def !unsorted-map|long->char? + (t/or !hash-map|long->char? !array-map|long->char?)) +(def !unsorted-map|long->int? + (t/or !hash-map|long->int? !array-map|long->int?)) +(def !unsorted-map|long->long? + (t/or !hash-map|long->long? !array-map|long->long?)) +(def !unsorted-map|long->float? + (t/or !hash-map|long->float? !array-map|long->float?)) +(def !unsorted-map|long->double? + (t/or !hash-map|long->double? !array-map|long->double?)) +(def !unsorted-map|long->ref? + (t/or !hash-map|long->ref? !array-map|long->ref?)) + +(def !unsorted-map|float->boolean? + (t/or !hash-map|float->boolean? !array-map|float->boolean?)) +(def !unsorted-map|float->byte? + (t/or !hash-map|float->byte? !array-map|float->byte?)) +(def !unsorted-map|float->short? + (t/or !hash-map|float->short? !array-map|float->short?)) +(def !unsorted-map|float->char? + (t/or !hash-map|float->char? !array-map|float->char?)) +(def !unsorted-map|float->int? + (t/or !hash-map|float->int? !array-map|float->int?)) +(def !unsorted-map|float->long? + (t/or !hash-map|float->long? !array-map|float->long?)) +(def !unsorted-map|float->float? + (t/or !hash-map|float->float? !array-map|float->float?)) +(def !unsorted-map|float->double? + (t/or !hash-map|float->double? !array-map|float->double?)) +(def !unsorted-map|float->ref? + (t/or !hash-map|float->ref? !array-map|float->ref?)) + +(def !unsorted-map|double->boolean? + (t/or !hash-map|double->boolean? !array-map|double->boolean?)) +(def !unsorted-map|double->byte? + (t/or !hash-map|double->byte? !array-map|double->byte?)) +(def !unsorted-map|double->short? + (t/or !hash-map|double->short? !array-map|double->short?)) +(def !unsorted-map|double->char? + (t/or !hash-map|double->char? !array-map|double->char?)) +(def !unsorted-map|double->int? + (t/or !hash-map|double->int? !array-map|double->int?)) +(def !unsorted-map|double->long? + (t/or !hash-map|double->long? !array-map|double->long?)) +(def !unsorted-map|double->float? + (t/or !hash-map|double->float? !array-map|double->float?)) +(def !unsorted-map|double->double? + (t/or !hash-map|double->double? !array-map|double->double?)) +(def !unsorted-map|double->ref? + (t/or !hash-map|double->ref? !array-map|double->ref?)) + +(def !unsorted-map|ref->boolean? + (t/or !hash-map|ref->boolean? !array-map|ref->boolean?)) +(def !unsorted-map|ref->byte? + (t/or !hash-map|ref->byte? !array-map|ref->byte?)) +(def !unsorted-map|ref->short? + (t/or !hash-map|ref->short? !array-map|ref->short?)) +(def !unsorted-map|ref->char? + (t/or !hash-map|ref->char? !array-map|ref->char?)) +(def !unsorted-map|ref->int? + (t/or !hash-map|ref->int? !array-map|ref->int?)) +(def !unsorted-map|ref->long? + (t/or !hash-map|ref->long? !array-map|ref->long?)) +(def !unsorted-map|ref->float? + (t/or !hash-map|ref->float? !array-map|ref->float?)) +(def !unsorted-map|ref->double? + (t/or !hash-map|ref->double? !array-map|ref->double?)) +(def !unsorted-map|ref->ref? + (t/or !identity-map|ref->ref? !hash-map|ref->ref? !array-map|ref->ref?)) + + (def-preds|map|any !unsorted-map) + + (def-preds|map|same-types !unsorted-map) + + (def !unsorted-map? !unsorted-map|any?) + +#?(:clj (def !!unsorted-map? (t/or !!hash-map? !!array-map?))) + (def unsorted-map? (t/or ?!+unsorted-map? !unsorted-map? #?(:clj !!unsorted-map?))) #?(:clj -(defnt >hash-map|long->ref +(defnt >unsorted-map|long->ref "Creates a persistent integer map that can only have non-negative integers as keys." - > +hash-map|long->ref? + > +unsorted-map|long->ref? ([] (clojure.data.int_map.PersistentIntMap. clojure.data.int_map.Nodes$Empty/EMPTY 0 nil)) ;; TODO TYPED handle varargs - ([k t/nneg-int? v (t/ref t/any?)] (assoc (>hash-map|long->ref) k v)) + ;; TODO TYPED `assoc`, `t/nneg-int?` +#_([k t/nneg-int? v (t/ref t/any?)] (assoc (>unsorted-map|long->ref) k v)) ;; TODO TYPED handle calling other typed fns #_([kv & kvs] (apply assoc (>hash-map|long->ref) k v kvs)))) -#?(:clj (defalias int-map hash-map|long->ref)) +#?(:clj (defalias >map|long->ref >unsorted-map|long->ref)) + +;; ===== Ordered value-semantic maps ===== ;; + +;; ----- Insertion-ordered ----- ;; + + (def +insertion-ordered-map? (t/or (t/isa? linked.map.LinkedMap) + ;; This is true, but we have replaced OrderedMap + ;; with LinkedMap + #_(:clj (t/isa? flatland.ordered.map.OrderedMap)))) + + (def !+insertion-ordered-map? t/none? + ;; This is true, but we have replaced OrderedMap with + ;; LinkedMap + #_(t/isa? flatland.ordered.map.TransientOrderedMap)) + + (def ?!+insertion-ordered-map? (t/or +insertion-ordered-map? !+insertion-ordered-map?)) + + (def !insertion-ordered-map? (t/isa? #?(:clj java.util.LinkedHashMap :cljs LinkedMap))) + + ;; See https://github.com/ben-manes/concurrentlinkedhashmap (and links therefrom) for good implementation +#?(:clj (def !!insertion-ordered-map? t/none?)) + + (def insertion-ordered-map? (t/or ?!+insertion-ordered-map? + !insertion-ordered-map? + #?(:clj !!insertion-ordered-map?))) + +;; TODO generate this function via macro +(defnt >!insertion-ordered-map + "Creates a single-threaded, mutable insertion-ordered map. + On the JVM, this is a `java.util.LinkedHashMap`. + On JS, this is a `goog.structs.LinkedMap`." + > !insertion-ordered-map? + ([] #?(:clj (LinkedHashMap.) :cljs (LinkedMap.))) + ([k0 t/ref?, v0 t/ref?] + (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) + (#?(:clj .put :cljs .add) k0 v0))) + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?] + (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1))) + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?] + (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2))) + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?, k3 t/ref?, v3 t/ref?] + (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) + (#?(:clj .put :cl .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2) + (#?(:clj .put :cljs .add) k3 v3))) + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?, k3 t/ref?, v3 t/ref? + k4 t/ref?, v4 t/ref?] + (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2) + (#?(:clj .put :cljs .add) k3 v3) + (#?(:clj .put :cljs .add) k4 v4))) + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?, k3 t/ref?, v3 t/ref? + k4 t/ref?, v4 t/ref?, k5 t/ref?, v5 t/ref?] + (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2) + (#?(:clj .put :cljs .add) k3 v3) + (#?(:clj .put :cljs .add) k4 v4) + (#?(:clj .put :cljs .add) k5 v5))) + ;; TODO TYPED `reduce-pair` and variadic + #_([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?, k3 t/ref?, v3 t/ref? + k4 t/ref?, v4 t/ref?, k5 t/ref?, v5 t/ref?, k6 t/ref?, v6 & kvs] + (reduce-pair + (fn [#?(:clj ^LinkedHashMap m :cljs m) k v] (doto m (#?(:clj .put :cljs .add) k v))) + (doto #?(:clj (LinkedHashMap.) :cljs (LinkedMap.)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2) + (#?(:clj .put :cljs .add) k3 v3) + (#?(:clj .put :cljs .add) k4 v4) + (#?(:clj .put :cljs .add) k5 v5) + (#?(:clj .put :cljs .add) k6 v6)) + kvs))) + +;; ----- Comparison-ordered (sorted) ----- ;; + +;; Forward declaration +(def +map? (t/isa? #?(:clj clojure.lang.IPersistentMap + :cljs cljs.core/IMap))) +;; Forward declaration +(def !+map? (t/isa? #?(:clj clojure.lang.ITransientMap + :cljs cljs.core/ITransientMap))) + +(def +sorted-map? (t/and (t/isa? #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) + +map?)) +(def !+sorted-map? (t/and (t/isa? #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) + !+map?)) +(def ?!+sorted-map? t/none? #_(t/or +sorted-map? !+sorted-map?)) ; TODO re-enable when `or` implemented properly + +(def !sorted-map|boolean->boolean? t/none?) +(def !sorted-map|boolean->byte? t/none?) +(def !sorted-map|boolean->char? t/none?) +(def !sorted-map|boolean->short? t/none?) +(def !sorted-map|boolean->int? t/none?) +(def !sorted-map|boolean->long? t/none?) +(def !sorted-map|boolean->float? t/none?) +(def !sorted-map|boolean->double? t/none?) +(def !sorted-map|boolean->ref? t/none?) + +(def !sorted-map|byte->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2BooleanSortedMap) :cljs t/none?)) +(def !sorted-map|byte->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2ByteSortedMap) :cljs t/none?)) +(def !sorted-map|byte->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2ShortSortedMap) :cljs t/none?)) +(def !sorted-map|byte->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2CharSortedMap) :cljs t/none?)) +(def !sorted-map|byte->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2IntSortedMap) :cljs t/none?)) +(def !sorted-map|byte->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2LongSortedMap) :cljs t/none?)) +(def !sorted-map|byte->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2FloatSortedMap) :cljs t/none?)) +(def !sorted-map|byte->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2DoubleSortedMap) :cljs t/none?)) +(def !sorted-map|byte->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2ReferenceSortedMap) :cljs t/none?)) + +(def !sorted-map|short->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2BooleanSortedMap) :cljs t/none?)) +(def !sorted-map|short->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2ByteSortedMap) :cljs t/none?)) +(def !sorted-map|short->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2ShortSortedMap) :cljs t/none?)) +(def !sorted-map|short->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2CharSortedMap) :cljs t/none?)) +(def !sorted-map|short->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2IntSortedMap) :cljs t/none?)) +(def !sorted-map|short->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2LongSortedMap) :cljs t/none?)) +(def !sorted-map|short->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2FloatSortedMap) :cljs t/none?)) +(def !sorted-map|short->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2DoubleSortedMap) :cljs t/none?)) +(def !sorted-map|short->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2ReferenceSortedMap) :cljs t/none?)) + +(def !sorted-map|char->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2ReferenceSortedMap) :cljs t/none?)) +(def !sorted-map|char->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2BooleanSortedMap) :cljs t/none?)) +(def !sorted-map|char->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2ByteSortedMap) :cljs t/none?)) +(def !sorted-map|char->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2ShortSortedMap) :cljs t/none?)) +(def !sorted-map|char->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2CharSortedMap) :cljs t/none?)) +(def !sorted-map|char->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2IntSortedMap) :cljs t/none?)) +(def !sorted-map|char->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2LongSortedMap) :cljs t/none?)) +(def !sorted-map|char->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2FloatSortedMap) :cljs t/none?)) +(def !sorted-map|char->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2DoubleSortedMap) :cljs t/none?)) + +(def !sorted-map|int->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2BooleanSortedMap) :cljs t/none?)) +(def !sorted-map|int->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2ByteSortedMap) :cljs t/none?)) +(def !sorted-map|int->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2ShortSortedMap) :cljs t/none?)) +(def !sorted-map|int->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2CharSortedMap) :cljs t/none?)) +(def !sorted-map|int->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2IntSortedMap) :cljs t/none?)) +(def !sorted-map|int->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2LongSortedMap) :cljs t/none?)) +(def !sorted-map|int->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2FloatSortedMap) :cljs t/none?)) +(def !sorted-map|int->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2DoubleSortedMap) :cljs t/none?)) +(def !sorted-map|int->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2ReferenceSortedMap) :cljs t/none?)) + +(def !sorted-map|long->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2BooleanSortedMap) :cljs t/none?)) +(def !sorted-map|long->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2ByteSortedMap) :cljs t/none?)) +(def !sorted-map|long->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2ShortSortedMap) :cljs t/none?)) +(def !sorted-map|long->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2CharSortedMap) :cljs t/none?)) +(def !sorted-map|long->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2IntSortedMap) :cljs t/none?)) +(def !sorted-map|long->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2LongSortedMap) :cljs t/none?)) +(def !sorted-map|long->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2FloatSortedMap) :cljs t/none?)) +(def !sorted-map|long->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2DoubleSortedMap) :cljs t/none?)) +(def !sorted-map|long->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2ReferenceSortedMap) :cljs t/none?)) + +(def !sorted-map|float->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2BooleanSortedMap) :cljs t/none?)) +(def !sorted-map|float->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2ByteSortedMap) :cljs t/none?)) +(def !sorted-map|float->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2ShortSortedMap) :cljs t/none?)) +(def !sorted-map|float->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2CharSortedMap) :cljs t/none?)) +(def !sorted-map|float->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2IntSortedMap) :cljs t/none?)) +(def !sorted-map|float->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2LongSortedMap) :cljs t/none?)) +(def !sorted-map|float->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2FloatSortedMap) :cljs t/none?)) +(def !sorted-map|float->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2DoubleSortedMap) :cljs t/none?)) +(def !sorted-map|float->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2ReferenceSortedMap) :cljs t/none?)) + +(def !sorted-map|double->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2BooleanSortedMap) :cljs t/none?)) +(def !sorted-map|double->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2ByteSortedMap) :cljs t/none?)) +(def !sorted-map|double->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2ShortSortedMap) :cljs t/none?)) +(def !sorted-map|double->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2CharSortedMap) :cljs t/none?)) +(def !sorted-map|double->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2IntSortedMap) :cljs t/none?)) +(def !sorted-map|double->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2LongSortedMap) :cljs t/none?)) +(def !sorted-map|double->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2FloatSortedMap) :cljs t/none?)) +(def !sorted-map|double->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2DoubleSortedMap) :cljs t/none?)) +(def !sorted-map|double->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2ReferenceSortedMap) :cljs t/none?)) + +(def !sorted-map|ref->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2BooleanSortedMap) :cljs t/none?)) +(def !sorted-map|ref->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2ByteSortedMap) :cljs t/none?)) +(def !sorted-map|ref->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2ShortSortedMap) :cljs t/none?)) +(def !sorted-map|ref->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2CharSortedMap) :cljs t/none?)) +(def !sorted-map|ref->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2IntSortedMap) :cljs t/none?)) +(def !sorted-map|ref->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2LongSortedMap) :cljs t/none?)) +(def !sorted-map|ref->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2FloatSortedMap) :cljs t/none?)) +(def !sorted-map|ref->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2DoubleSortedMap) :cljs t/none?)) +(def !sorted-map|ref->ref? + (t/or #?@(:clj [(t/isa? java.util.TreeMap) + (t/isa? it.unimi.dsi.fastutil.objects.Reference2ReferenceSortedMap)] + :cljs [(t/isa? goog.structs.AvlTree)]))) + +(def-preds|map|any !sorted-map) + +(def-preds|map|same-types !sorted-map) + + (def !sorted-map? !sorted-map|any?) + +#?(:clj (def !!sorted-map? (t/isa? java.util.concurrent.ConcurrentNavigableMap))) + (def sorted-map? (t/or ?!+sorted-map? + #?@(:clj [!!sorted-map? + (t/isa? java.util.SortedMap)]) + !sorted-map?)) + +;; TODO generate this function via macro +;; TODO TYPED replaced `t/fn?` with a more specific `(t/fn [...])` named as e.g. `fn/comparator?` +(defnt >!sorted-map-by + "Creates a single-threaded, mutable sorted map with the specified comparator. + On the JVM, this is a `java.util.TreeMap`. + On JS, this is a `goog.structs.AvlTree`." + > !sorted-map|ref->ref? + ([compf t/fn?] #?(:clj (TreeMap. compf) :cljs (AvlTree. compf))) + ([compf t/fn?, k0 t/ref?, v0 t/ref?] + (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) + (#?(:clj .put :cljs .add) k0 v0))) + ([compf t/fn?, k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?] + (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1))) + ([compf t/fn?, k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?] + (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2))) + ([compf t/fn?, k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref? + k3 t/ref?, v3 t/ref?] + (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2) + (#?(:clj .put :cljs .add) k3 v3))) + ([compf t/fn?, k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref? + k3 t/ref?, v3 t/ref?, k4 t/ref?, v4 t/ref?] + (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2) + (#?(:clj .put :cljs .add) k3 v3) + (#?(:clj .put :cljs .add) k4 v4))) + ([compf t/fn?, k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref? + k3 t/ref?, v3 t/ref?, k4 t/ref?, v4 t/ref?, k5 t/ref?, v5 t/ref?] + (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2) + (#?(:clj .put :cljs .add) k3 v3) + (#?(:clj .put :cljs .add) k4 v4) + (#?(:clj .put :cljs .add) k5 v5))) + ;; TODO TYPED `reduce-pair`, variadic +#_([compf t/fn?, k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref? + k3 t/ref?, v3 t/ref?, k4 t/ref?, v4 t/ref?, k5 t/ref?, v5 t/ref?, k6 t/ref?, v6 t/ref? & kvs] + (reduce-pair + (fn [#?(:clj ^TreeMap m :cljs m) k v] (doto m (#?(:clj .put :cljs .add) k v))) + (doto #?(:clj (TreeMap. compf) :cljs (AvlTree. compf)) + (#?(:clj .put :cljs .add) k0 v0) + (#?(:clj .put :cljs .add) k1 v1) + (#?(:clj .put :cljs .add) k2 v2) + (#?(:clj .put :cljs .add) k3 v3) + (#?(:clj .put :cljs .add) k4 v4) + (#?(:clj .put :cljs .add) k5 v5) + (#?(:clj .put :cljs .add) k6 v6)) + kvs))) + +;; TODO generate this function via macro +;; TODO TYPED replace `compare` with typed version +(defnt >!sorted-map + "Creates a single-threaded, mutable sorted map. + On the JVM, this is a `java.util.TreeMap`. + On JS, this is a `goog.structs.AvlTree`." + > !sorted-map|ref->ref? + ([] (>!sorted-map-by compare)) + ([k0 t/ref?, v0 t/ref?] + (>!sorted-map-by compare k0 v0)) + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?] + (>!sorted-map-by compare k0 v0 k1 v1)) + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?] + (>!sorted-map-by compare k0 v0 k1 v1 k2 v2)) + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?, k3 t/ref?, v3 t/ref?] + (>!sorted-map-by compare k0 v0 k1 v1 k2 v2 k3 v3)) + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?, k3 t/ref?, v3 t/ref? + k4 t/ref?, v4 t/ref?] + (>!sorted-map-by compare k0 v0 k1 v1 k2 v2 k3 v3 k4 v4)) + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?, k3 t/ref?, v3 t/ref? + k4 t/ref?, v4 t/ref?, k5 t/ref?, v5 t/ref?] + (>!sorted-map-by compare k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5)) + ;; TODO TYPED `apply`, `compare`, variadic +#_([k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 & kvs] + (apply >!sorted-map-by compare k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 kvs))) + +;; TODO TYPED `apply`, variadic +#_(defnt !sorted-map-by-val > !sorted-map|ref->ref? [m & kvs] + (apply !sorted-map-by (gen-compare-by-val m) kvs)) + +;; ----- General Maps ----- ;; + +(def +map|built-in? + (t/or (t/isa? #?(:clj clojure.lang.PersistentHashMap :cljs cljs.core/PersistentHashMap)) + (t/isa? #?(:clj clojure.lang.PersistentArrayMap :cljs cljs.core/PersistentArrayMap)) + (t/isa? #?(:clj clojure.lang.PersistentTreeMap :cljs cljs.core/PersistentTreeMap)))) + +;; `+map?` and `!+map?` defined above +(def ?!+map? (t/or !+map? +map?)) + +(def !map|boolean->boolean? t/none?) +(def !map|boolean->byte? t/none?) +(def !map|boolean->short? t/none?) +(def !map|boolean->char? t/none?) +(def !map|boolean->int? t/none?) +(def !map|boolean->long? t/none?) +(def !map|boolean->float? t/none?) +(def !map|boolean->double? t/none?) +(def !map|boolean->ref? t/none?) + +(def !map|byte->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2BooleanMap) :cljs t/none?)) +(def !map|byte->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2ByteMap) :cljs t/none?)) +(def !map|byte->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2ShortMap) :cljs t/none?)) +(def !map|byte->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2CharMap) :cljs t/none?)) +(def !map|byte->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2IntMap) :cljs t/none?)) +(def !map|byte->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2LongMap) :cljs t/none?)) +(def !map|byte->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2FloatMap) :cljs t/none?)) +(def !map|byte->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2DoubleMap) :cljs t/none?)) +(def !map|byte->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.Byte2ReferenceMap) :cljs t/none?)) + +(def !map|short->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2BooleanMap) :cljs t/none?)) +(def !map|short->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2ByteMap) :cljs t/none?)) +(def !map|short->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2ShortMap) :cljs t/none?)) +(def !map|short->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2CharMap) :cljs t/none?)) +(def !map|short->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2IntMap) :cljs t/none?)) +(def !map|short->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2LongMap) :cljs t/none?)) +(def !map|short->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2FloatMap) :cljs t/none?)) +(def !map|short->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2DoubleMap) :cljs t/none?)) +(def !map|short->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.Short2ReferenceMap) :cljs t/none?)) + +(def !map|char->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2ReferenceMap) :cljs t/none?)) +(def !map|char->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2BooleanMap) :cljs t/none?)) +(def !map|char->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2ByteMap) :cljs t/none?)) +(def !map|char->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2ShortMap) :cljs t/none?)) +(def !map|char->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2CharMap) :cljs t/none?)) +(def !map|char->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2IntMap) :cljs t/none?)) +(def !map|char->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2LongMap) :cljs t/none?)) +(def !map|char->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2FloatMap) :cljs t/none?)) +(def !map|char->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.Char2DoubleMap) :cljs t/none?)) + +(def !map|int->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2BooleanMap) :cljs t/none?)) +(def !map|int->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2ByteMap) :cljs t/none?)) +(def !map|int->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2ShortMap) :cljs t/none?)) +(def !map|int->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2CharMap) :cljs t/none?)) +(def !map|int->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2IntMap) :cljs t/none?)) +(def !map|int->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2LongMap) :cljs t/none?)) +(def !map|int->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2FloatMap) :cljs t/none?)) +(def !map|int->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2DoubleMap) :cljs t/none?)) +(def !map|int->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.Int2ReferenceMap) :cljs t/none?)) + +(def !map|long->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2BooleanMap) :cljs t/none?)) +(def !map|long->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2ByteMap) :cljs t/none?)) +(def !map|long->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2ShortMap) :cljs t/none?)) +(def !map|long->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2CharMap) :cljs t/none?)) +(def !map|long->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2IntMap) :cljs t/none?)) +(def !map|long->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2LongMap) :cljs t/none?)) +(def !map|long->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2FloatMap) :cljs t/none?)) +(def !map|long->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2DoubleMap) :cljs t/none?)) +(def !map|long->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.Long2ReferenceMap) :cljs t/none?)) + +(def !map|float->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2BooleanMap) :cljs t/none?)) +(def !map|float->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2ByteMap) :cljs t/none?)) +(def !map|float->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2ShortMap) :cljs t/none?)) +(def !map|float->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2CharMap) :cljs t/none?)) +(def !map|float->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2IntMap) :cljs t/none?)) +(def !map|float->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2LongMap) :cljs t/none?)) +(def !map|float->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2FloatMap) :cljs t/none?)) +(def !map|float->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2DoubleMap) :cljs t/none?)) +(def !map|float->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.Float2ReferenceMap) :cljs t/none?)) + +(def !map|double->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2BooleanMap) :cljs t/none?)) +(def !map|double->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2ByteMap) :cljs t/none?)) +(def !map|double->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2ShortMap) :cljs t/none?)) +(def !map|double->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2CharMap) :cljs t/none?)) +(def !map|double->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2IntMap) :cljs t/none?)) +(def !map|double->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2LongMap) :cljs t/none?)) +(def !map|double->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2FloatMap) :cljs t/none?)) +(def !map|double->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2DoubleMap) :cljs t/none?)) +(def !map|double->ref? + #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.Double2ReferenceMap) :cljs t/none?)) + +(def !map|ref->boolean? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2BooleanMap) :cljs t/none?)) +(def !map|ref->byte? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2ByteMap) :cljs t/none?)) +(def !map|ref->short? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2ShortMap) :cljs t/none?)) +(def !map|ref->char? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2CharMap) :cljs t/none?)) +(def !map|ref->int? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2IntMap) :cljs t/none?)) +(def !map|ref->long? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2LongMap) :cljs t/none?)) +(def !map|ref->float? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2FloatMap) :cljs t/none?)) +(def !map|ref->double? + #?(:clj (t/isa? it.unimi.dsi.fastutil.objects.Reference2DoubleMap) :cljs t/none?)) + +(def !map|ref->ref? + (t/or #?@(:clj [;; perhaps just `(- !map? )` ? + !unsorted-map|ref->ref? + !sorted-map|ref->ref? + (t/isa? it.unimi.dsi.fastutil.objects.Reference2ReferenceMap)] + :cljs [(t/isa? goog.structs.AvlTree)]))) + +(def-preds|map|any !map) + +(def-preds|map|same-types !map) + + (def !map? !map|any?) + +#?(:clj (def !!map? (t/or !!unsorted-map? !!sorted-map?))) + + (def map? (t/or ?!+map? !map? #?@(:clj [!!map? (t/isa? java.util.Map)]))) + + + + + -; `(apply hash-map pairs)` <~> `lodash/fromPairs` -(defaliases u +#_(defaliases umap + map-entry-seq ordered-map om #?(:clj !ordered-map) #?(:clj kw-omap) sorted-map sorted-map-by sorted-map-by-val sorted-rank-map sorted-rank-map-by diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index e08329e5..8b73c800 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -3,10 +3,14 @@ [char? double? float? int?]) (:require [quantum.core.type :as t - :refer [defnt]])) + :refer [defnt]] + [quantum.core.vars + :refer [def-]])) ;; TODO TYPED type coercion/casts should go in here +;; ===== Predicates ===== ;; + #?(:clj (def byte? (t/isa? Byte))) #?(:clj (def short? (t/isa? Short))) #?(:clj (def char? (t/isa? Character))) @@ -15,6 +19,33 @@ #?(:clj (def float? (t/isa? Float))) (def double? (t/isa? #?(:clj Double :cljs js/Number))) +;; ===== Class relationships ===== ;; + +#?(:clj +(def unboxed-class->boxed-class + {Boolean/TYPE Boolean + Byte/TYPE Byte + Character/TYPE Character + Long/TYPE Long + Double/TYPE Double + Short/TYPE Short + Integer/TYPE Integer + Float/TYPE Float})) + +#?(:clj +(def boxed-class->unboxed-class + {Integer Integer/TYPE + Long Long/TYPE + Float Float/TYPE + Short Short/TYPE + Boolean Boolean/TYPE + Byte Byte/TYPE + Character Character/TYPE + Double Double/TYPE + Void Void/TYPE})) + +;; ===== Extreme magnitudes and values ===== ;; + (defnt >min-magnitude #?(:clj ([x byte? > byte?] (byte 0))) #?(:clj ([x short? > short?] (short 0))) @@ -25,8 +56,8 @@ ([x double? > double?] #?(:clj Double/MIN_VALUE :cljs js/Number.MIN_VALUE))) -#?(:clj (def min-float (- Float/MAX_VALUE))) - (def min-double (- #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) +#?(:clj (def- min-float (- Float/MAX_VALUE))) + (def- min-double (- #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) ;; TODO TYPED for some reason it's not figuring out the type of `min-float` and `min-double` #_(defnt >min-value diff --git a/src/quantum/core/ns.cljc b/src/quantum/core/ns.cljc index a7219fad..fb4cf3c3 100644 --- a/src/quantum/core/ns.cljc +++ b/src/quantum/core/ns.cljc @@ -13,7 +13,7 @@ [quantum.untyped.core.ns :as uns] ;; TODO TYPED remove reference to `quantum.untyped.core.vars` [quantum.untyped.core.vars :as uvar - :refer [defalias]])) + :refer [defalias defaliases]])) #?(:clj (def namespace? (t/isa? clojure.lang.Namespace))) @@ -102,7 +102,7 @@ #_(:clj (defnt ns>mappings "Supersedes `clojure.core/ns-map`." - [x namespace? > (t/assume (t/of t/+map? t/unqualified-symbol? (t/or t/var? t/class?)))] + [x namespace? > (t/assume (t/of ut/+map? t/unqualified-symbol? (t/or t/var? t/class?)))] (.getMappings x))) ;; TODO TYPED finish `t/assume`, `t/of`, `t/unqualified-symbol?` @@ -111,7 +111,7 @@ "Outputs the alias->namespace mappings for the namespace. Supersedes `clojure.core/ns-aliases`." - [x namespace? > (t/assume (t/of t/+map? t/unqualified-symbol? namespace?))] + [x namespace? > (t/assume (t/of ut/+map? t/unqualified-symbol? namespace?))] (.getAliases x))) ;; TODO TYPED finish `t/assume`, `t/of`, `t/unqualified-symbol?`, decide on `filter-vals'`? @@ -120,7 +120,7 @@ "Outputs the import-mappings for the namespace. Supersedes `clojure.core/ns-imports`." - [x namespace? > (t/assume (t/of t/+map? t/unqualified-symbol? t/class?))] + [x namespace? > (t/assume (t/of ut/+map? t/unqualified-symbol? t/class?))] (->> x (filter-vals' t/class?)))) ;; TODO TYPED finish `t/assume`, `t/of`, `t/unqualified-symbol?`, decide on `filter-vals'`? @@ -129,7 +129,7 @@ "Outputs the intern-mappings for the namespace. Supersedes `clojure.core/ns-interns`." - [ns-val namespace? > (t/assume (t/of t/+map? t/unqualified-symbol? t/var?))] + [ns-val namespace? > (t/assume (t/of ut/+map? t/unqualified-symbol? t/var?))] (->> ns-val ns>mappings (filter-vals' (fn [^clojure.lang.Var v] (and (t/var? v) (= ns-val (.ns v)))))))) @@ -139,7 +139,7 @@ "Outputs the public intern-mappings for the namespace. Supersedes `clojure.core/ns-publics`." - [ns-val namespace? > (t/assume (t/of t/+map? t/unqualified-symbol? t/var?))] + [ns-val namespace? > (t/assume (t/of ut/+map? t/unqualified-symbol? t/var?))] (->> ns-val ns>interns (filter-vals' (fn [^clojure.lang.Var v] (.isPublic v)))))) @@ -150,7 +150,7 @@ "Outputs the refer-mappings for the namespace. Supersedes `clojure.core/ns-refers`." - [ns-val namespace? > (t/assume (t/of t/+map? t/unqualified-symbol? t/var?))] + [ns-val namespace? > (t/assume (t/of ut/+map? t/unqualified-symbol? t/var?))] (->> ns-val ns>mappings (remove-vals' (fn [^clojure.lang.Var v] (and (t/var? v) (= ns-val (.ns v)))))))) diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index 96a52efc..8e8bd28e 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -7,7 +7,7 @@ [quantum.untyped.core.type :as ut] ;; TODO TYPED prefer e.g. `deft-alias` [quantum.untyped.core.vars - :refer [defaliases]])) + :refer [defalias defaliases]])) (defalias udefnt/fnt) (defalias udefnt/defnt) @@ -19,7 +19,9 @@ and or ;; Predicates any? - +map? + none? + ref? + fn? metable? seq? symbol? diff --git a/src/quantum/core/vars.cljc b/src/quantum/core/vars.cljc index 0ee00300..31b941b8 100644 --- a/src/quantum/core/vars.cljc +++ b/src/quantum/core/vars.cljc @@ -9,6 +9,7 @@ [quantum.core.type :as t :refer [defnt]] ;; TODO TYPED remove reference to `quantum.untyped.core.vars` + [quantum.untyped.core.type :as ut] [quantum.untyped.core.vars :as uvar]) #?(:cljs (:require-macros [quantum.core.vars :as this]))) @@ -17,7 +18,7 @@ ;; ===== Meta ===== ;; -(def meta? (t/? t/+map?)) +(def meta? (t/? ut/+map?)) (defnt meta "Returns the (possibly nil) metadata of ->`x`." @@ -66,17 +67,17 @@ if supplied. The namespace must exist. The var will adopt any metadata from ->`name-val`. Returns the var." > t/var? - ([ns-val (t/or t/symbol? t/namespace?), var-name t/symbol? > (t/* t/var?)] + ([ns-val (t/or t/symbol? ns/namespace?), var-name t/symbol? > (t/* t/var?)] (let [var-ref (clojure.lang.Var/intern (ns/>ns ns-val) var-name)] (when (meta var-name) (.setMeta var-ref (meta var-name))) var-ref)) - ([ns-val (t/or t/symbol? t/namespace?), var-name t/symbol?, var-val (t/ref t/any?) > (t/* t/var?)] + ([ns-val (t/or t/symbol? ns/namespace?), var-name t/symbol?, var-val (t/ref t/any?) > (t/* t/var?)] (let [var-ref (clojure.lang.Var/intern (ns/>ns ns-val) var-name var-val)] (when (meta var-name) (.setMeta var-ref (meta var-name))) var-ref)))) ;; TODO TYPED -#?(:clj (defalias uvar/def)) +#?(:clj (uvar/defalias uvar/def)) ;; TODO TYPED #?(:clj (uvar/defaliases uvar defalias defaliases defaliases')) diff --git a/src/quantum/numeric/statistics/core.cljc b/src/quantum/numeric/statistics/core.cljc index 2124fde2..8c54c45b 100644 --- a/src/quantum/numeric/statistics/core.cljc +++ b/src/quantum/numeric/statistics/core.cljc @@ -9,11 +9,11 @@ reduce reduce-multi, transduce]] [quantum.core.compare :as comp] [quantum.core.data.map - :refer [!hash-map]] + :refer [!>hash-map]] [quantum.core.data.set - :refer [!hash-set]] + :refer [!>hash-set]] [quantum.core.data.vector - :refer [!vector]] + :refer [!>vector]] [quantum.core.fn :refer [fn1 fn&2 fnl fn-> <-]] [quantum.core.log :as log] @@ -104,7 +104,7 @@ {:attribution "alexandergunnarson"} [xs] ; TODO xs is `reducible?` (->> xs - (frequencies (!hash-map)) + (frequencies (!>hash-map)) (comp/reduce-max-keys-into !vector val) ; TODO this is possible to do this without allocating the intermediate collection (map+ key))) @@ -117,7 +117,7 @@ {:attribution "alexandergunnarson"} [xs] ; TODO xs is `reducible?` (->> xs - (frequencies (!hash-map)) + (frequencies (!>hash-map)) (comp/reduce-max-key val) key)) diff --git a/test/quantum/test/core/collections.cljc b/test/quantum/test/core/collections.cljc index 11c0b5c6..5a219695 100644 --- a/test/quantum/test/core/collections.cljc +++ b/test/quantum/test/core/collections.cljc @@ -185,10 +185,6 @@ :p 8}}} :q 9}}})))))) -; _______________________________________________________________ -; ======================== COMBINATIVE ========================== -; ••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••• -(defn test:sorted-map-by-val [m-0]) ; _______________________________________________________________ ; ========================== SOCIATIVE ========================== ; ••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••• From d95269604da26d373e1b9afdb891589b84ffabd9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 15 Sep 2018 10:31:59 -0600 Subject: [PATCH 249/810] Fleshed out several bit operations in Numeric --- .../src/java/quantum/core/Numeric.java | 754 +++++++++++++----- 1 file changed, 554 insertions(+), 200 deletions(-) diff --git a/subprojects/quantum-java/src/java/quantum/core/Numeric.java b/subprojects/quantum-java/src/java/quantum/core/Numeric.java index 65f089bd..076816b6 100644 --- a/subprojects/quantum-java/src/java/quantum/core/Numeric.java +++ b/subprojects/quantum-java/src/java/quantum/core/Numeric.java @@ -10,12 +10,12 @@ public class Numeric { public static final byte byte0 = (byte) 0; - public static final char char0 = (char) 0; public static final short short0 = (short)0; + public static final char char0 = (char) 0; public static final int int0 = 0; public static final byte byte1 = (byte) 1; - public static final char char1 = (char) 1; public static final short short1 = (short)1; + public static final char char1 = (char) 1; public static final int int1 = 1; // ============================ BOOLEAN OPERATIONS ================================ // @@ -29,43 +29,397 @@ public class Numeric { public static boolean xor (final boolean a, final boolean b) { return (a || b) && !(a && b); } // ============================ BIT OPERATIONS ================================ // - // Apparently '&' is fundamentally an int operation - - public static byte bitAnd (final byte a, final byte b) { return (byte) (a & b); } - public static char bitAnd (final byte a, final char b) { return (char) (a & b); } - public static short bitAnd (final byte a, final short b) { return (short)(a & b); } - public static int bitAnd (final byte a, final int b) { return a & b ; } - public static long bitAnd (final byte a, final long b) { return a & b ; } - public static char bitAnd (final char a, final byte b) { return (char) (a & b); } - public static char bitAnd (final char a, final char b) { return (char) (a & b); } - public static short bitAnd (final char a, final short b) { return (short)(a & b); } - public static int bitAnd (final char a, final int b) { return a & b ; } - public static long bitAnd (final char a, final long b) { return a & b ; } - public static short bitAnd (final short a, final byte b) { return (short)(a & b); } - public static short bitAnd (final short a, final char b) { return (short)(a & b); } - public static short bitAnd (final short a, final short b) { return (short)(a & b); } - public static int bitAnd (final short a, final int b) { return a & b ; } - public static long bitAnd (final short a, final long b) { return a & b ; } - public static int bitAnd (final int a, final byte b) { return a & b ; } - public static int bitAnd (final int a, final char b) { return a & b ; } - public static int bitAnd (final int a, final short b) { return a & b ; } - public static int bitAnd (final int a, final int b) { return a & b ; } - public static long bitAnd (final int a, final long b) { return a & b ; } - public static long bitAnd (final long a, final byte b) { return a & b ; } - public static long bitAnd (final long a, final char b) { return a & b ; } - public static long bitAnd (final long a, final short b) { return a & b ; } - public static long bitAnd (final long a, final int b) { return a & b ; } - public static long bitAnd (final long a, final long b) { return a & b ; } - - public static long bitOr (final long a, final long b) { return a | b; } // Implicitly checked - public static long bitXor (final long a, final long b) { return a ^ b; } // Implicitly checked - public static long bitNot (final long a ) { return ~a; } // Implicitly checked - public static long shiftLeft (final long a, final long b) { return a << b; } // Implicitly checked - public static long shiftRight (final long a, final long b) { return a >> b; } // Implicitly checked - public static long unsignedShiftRight (final long a, final long b) { return a >>> b; } - public static long unsignedShiftRight (final int a, final long b) { return a >>> b; } - - // TODO flipbit, testbit, setbit, clearbit + // Bit operations are fundamentally integer operations + + // ---------------------------- bitAnd : & ---------------------------- // + + public static boolean bitAnd (final boolean a, final boolean b) { return a & b ; } + public static byte bitAnd (final byte a, final byte b) { return (byte) (a & b); } + public static short bitAnd (final byte a, final short b) { return (short)(a & b); } + public static char bitAnd (final byte a, final char b) { return (char) (a & b); } + public static int bitAnd (final byte a, final int b) { return a & b ; } + public static long bitAnd (final byte a, final long b) { return a & b ; } + public static float bitAnd (final byte a, final float b) { + return Float.intBitsToFloat(a & Float.floatToIntBits(b)); + } + public static double bitAnd (final byte a, final double b) { + return Double.longBitsToDouble(a & Double.doubleToLongBits(b)); + } + public static short bitAnd (final short a, final byte b) { return (short)(a & b); } + public static short bitAnd (final short a, final short b) { return (short)(a & b); } + public static short bitAnd (final short a, final char b) { return (short)(a & b); } + public static int bitAnd (final short a, final int b) { return a & b ; } + public static long bitAnd (final short a, final long b) { return a & b ; } + public static float bitAnd (final short a, final float b) { + return Float.intBitsToFloat(a & Float.floatToIntBits(b)); + } + public static double bitAnd (final short a, final double b) { + return Double.longBitsToDouble(a & Double.doubleToLongBits(b)); + } + public static char bitAnd (final char a, final byte b) { return (char) (a & b); } + public static short bitAnd (final char a, final short b) { return (short)(a & b); } + public static char bitAnd (final char a, final char b) { return (char) (a & b); } + public static int bitAnd (final char a, final int b) { return a & b ; } + public static long bitAnd (final char a, final long b) { return a & b ; } + public static float bitAnd (final char a, final float b) { + return Float.intBitsToFloat(a & Float.floatToIntBits(b)); + } + public static double bitAnd (final char a, final double b) { + return Double.longBitsToDouble(a & Double.doubleToLongBits(b)); + } + public static int bitAnd (final int a, final byte b) { return a & b ; } + public static int bitAnd (final int a, final short b) { return a & b ; } + public static int bitAnd (final int a, final char b) { return a & b ; } + public static int bitAnd (final int a, final int b) { return a & b ; } + public static long bitAnd (final int a, final long b) { return a & b ; } + public static float bitAnd (final int a, final float b) { + return Float.intBitsToFloat(a & Float.floatToIntBits(b)); + } + public static double bitAnd (final int a, final double b) { + return Double.longBitsToDouble(a & Double.doubleToLongBits(b)); + } + public static long bitAnd (final long a, final byte b) { return a & b ; } + public static long bitAnd (final long a, final short b) { return a & b ; } + public static long bitAnd (final long a, final char b) { return a & b ; } + public static long bitAnd (final long a, final int b) { return a & b ; } + public static long bitAnd (final long a, final long b) { return a & b ; } + public static double bitAnd (final long a, final float b) { + return Double.longBitsToDouble(a & Float.floatToIntBits(b)); + } + public static double bitAnd (final long a, final double b) { + return Double.longBitsToDouble(a & Double.doubleToLongBits(b)); + } + + // ---------------------------- bitOr : | ---------------------------- // + + public static boolean bitOr (final boolean a, final boolean b) { return a | b ; } + public static byte bitOr (final byte a, final byte b) { return (byte) (a | b); } + public static short bitOr (final byte a, final short b) { return (short)(a | b); } + public static char bitOr (final byte a, final char b) { return (char) (a | b); } + public static int bitOr (final byte a, final int b) { return a | b ; } + public static long bitOr (final byte a, final long b) { return a | b ; } + public static float bitOr (final byte a, final float b) { + return Float.intBitsToFloat(a | Float.floatToIntBits(b)); + } + public static double bitOr (final byte a, final double b) { + return Double.longBitsToDouble(a | Double.doubleToLongBits(b)); + } + public static short bitOr (final short a, final byte b) { return (short)(a | b); } + public static short bitOr (final short a, final short b) { return (short)(a | b); } + public static short bitOr (final short a, final char b) { return (short)(a | b); } + public static int bitOr (final short a, final int b) { return a | b ; } + public static long bitOr (final short a, final long b) { return a | b ; } + public static float bitOr (final short a, final float b) { + return Float.intBitsToFloat(a | Float.floatToIntBits(b)); + } + public static double bitOr (final short a, final double b) { + return Double.longBitsToDouble(a | Double.doubleToLongBits(b)); + } + public static char bitOr (final char a, final byte b) { return (char) (a | b); } + public static short bitOr (final char a, final short b) { return (short)(a | b); } + public static char bitOr (final char a, final char b) { return (char) (a | b); } + public static int bitOr (final char a, final int b) { return a | b ; } + public static long bitOr (final char a, final long b) { return a | b ; } + public static float bitOr (final char a, final float b) { + return Float.intBitsToFloat(a | Float.floatToIntBits(b)); + } + public static double bitOr (final char a, final double b) { + return Double.longBitsToDouble(a | Double.doubleToLongBits(b)); + } + public static int bitOr (final int a, final byte b) { return a | b ; } + public static int bitOr (final int a, final short b) { return a | b ; } + public static int bitOr (final int a, final char b) { return a | b ; } + public static int bitOr (final int a, final int b) { return a | b ; } + public static long bitOr (final int a, final long b) { return a | b ; } + public static float bitOr (final int a, final float b) { + return Float.intBitsToFloat(a | Float.floatToIntBits(b)); + } + public static double bitOr (final int a, final double b) { + return Double.longBitsToDouble(a | Double.doubleToLongBits(b)); + } + public static long bitOr (final long a, final byte b) { return a | b ; } + public static long bitOr (final long a, final char b) { return a | b ; } + public static long bitOr (final long a, final short b) { return a | b ; } + public static long bitOr (final long a, final int b) { return a | b ; } + public static long bitOr (final long a, final long b) { return a | b ; } + public static double bitOr (final long a, final float b) { + return Double.longBitsToDouble(a | Float.floatToIntBits(b)); + } + public static double bitOr (final long a, final double b) { + return Double.longBitsToDouble(a | Double.doubleToLongBits(b)); + } + + // ---------------------------- bitXOr ---------------------------- // + + public static boolean bitXOr (final boolean a, final boolean b) { return a ^ b ; } + public static byte bitXOr (final byte a, final byte b) { return (byte) (a ^ b); } + public static short bitXOr (final byte a, final short b) { return (short)(a ^ b); } + public static char bitXOr (final byte a, final char b) { return (char) (a ^ b); } + public static int bitXOr (final byte a, final int b) { return a ^ b ; } + public static long bitXOr (final byte a, final long b) { return a ^ b ; } + public static float bitXOr (final byte a, final float b) { + return Float.intBitsToFloat(a ^ Float.floatToIntBits(b)); + } + public static double bitXOr (final byte a, final double b) { + return Double.longBitsToDouble(a ^ Double.doubleToLongBits(b)); + } + public static short bitXOr (final short a, final byte b) { return (short)(a ^ b); } + public static short bitXOr (final short a, final short b) { return (short)(a ^ b); } + public static short bitXOr (final short a, final char b) { return (short)(a ^ b); } + public static int bitXOr (final short a, final int b) { return a ^ b ; } + public static long bitXOr (final short a, final long b) { return a ^ b ; } + public static float bitXOr (final short a, final float b) { + return Float.intBitsToFloat(a ^ Float.floatToIntBits(b)); + } + public static double bitXOr (final short a, final double b) { + return Double.longBitsToDouble(a ^ Double.doubleToLongBits(b)); + } + public static char bitXOr (final char a, final byte b) { return (char) (a ^ b); } + public static short bitXOr (final char a, final short b) { return (short)(a ^ b); } + public static char bitXOr (final char a, final char b) { return (char) (a ^ b); } + public static int bitXOr (final char a, final int b) { return a ^ b ; } + public static long bitXOr (final char a, final long b) { return a ^ b ; } + public static float bitXOr (final char a, final float b) { + return Float.intBitsToFloat(a ^ Float.floatToIntBits(b)); + } + public static double bitXOr (final char a, final double b) { + return Double.longBitsToDouble(a ^ Double.doubleToLongBits(b)); + } + public static int bitXOr (final int a, final byte b) { return a ^ b ; } + public static int bitXOr (final int a, final short b) { return a ^ b ; } + public static int bitXOr (final int a, final char b) { return a ^ b ; } + public static int bitXOr (final int a, final int b) { return a ^ b ; } + public static long bitXOr (final int a, final long b) { return a ^ b ; } + public static float bitXOr (final int a, final float b) { + return Float.intBitsToFloat(a ^ Float.floatToIntBits(b)); + } + public static double bitXOr (final int a, final double b) { + return Double.longBitsToDouble(a ^ Double.doubleToLongBits(b)); + } + public static long bitXOr (final long a, final byte b) { return a ^ b ; } + public static long bitXOr (final long a, final char b) { return a ^ b ; } + public static long bitXOr (final long a, final short b) { return a ^ b ; } + public static long bitXOr (final long a, final int b) { return a ^ b ; } + public static long bitXOr (final long a, final long b) { return a ^ b ; } + public static double bitXOr (final long a, final float b) { + return Double.longBitsToDouble(a ^ Float.floatToIntBits(b)); + } + public static double bitXOr (final long a, final double b) { + return Double.longBitsToDouble(a ^ Double.doubleToLongBits(b)); + } + + // ---------------------------- bitNot : ! ---------------------------- // + + public static boolean bitNot (final boolean x) { return !x; } + public static byte bitNot (final byte x) { return (byte) ~x; } + public static short bitNot (final short x) { return (short)~x; } + public static char bitNot (final char x) { return (char) ~x; } + public static int bitNot (final int x) { return ~x; } + public static long bitNot (final long x) { return ~x; } + public static float bitNot (final float x) { + return Float.intBitsToFloat(~Float.floatToIntBits(x)); + } + public static double bitNot (final double x) { + return Double.longBitsToDouble(~Double.doubleToLongBits(x)); + } + + // ---------------------------- shiftLeft : << ---------------------------- // + + // Though technically `1 << 1` = 2, not 1 + public static boolean shiftLeft (final boolean a, final boolean b) { return a; } + public static byte shiftLeft (final byte a, final byte b) { return (byte) (a << b); } + public static short shiftLeft (final byte a, final short b) { return (short)(a << b); } + public static char shiftLeft (final byte a, final char b) { return (char) (a << b); } + public static int shiftLeft (final byte a, final int b) { return a << b ; } + public static long shiftLeft (final byte a, final long b) { return a << b ; } + public static float shiftLeft (final byte a, final float b) { + return Float.intBitsToFloat(a << Float.floatToIntBits(b)); + } + public static double shiftLeft (final byte a, final double b) { + return Double.longBitsToDouble(a << Double.doubleToLongBits(b)); + } + public static short shiftLeft (final short a, final byte b) { return (short)(a << b); } + public static short shiftLeft (final short a, final short b) { return (short)(a << b); } + public static short shiftLeft (final short a, final char b) { return (short)(a << b); } + public static int shiftLeft (final short a, final int b) { return a << b ; } + public static long shiftLeft (final short a, final long b) { return a << b ; } + public static float shiftLeft (final short a, final float b) { + return Float.intBitsToFloat(a << Float.floatToIntBits(b)); + } + public static double shiftLeft (final short a, final double b) { + return Double.longBitsToDouble(a << Double.doubleToLongBits(b)); + } + public static char shiftLeft (final char a, final byte b) { return (char) (a << b); } + public static short shiftLeft (final char a, final short b) { return (short)(a << b); } + public static char shiftLeft (final char a, final char b) { return (char) (a << b); } + public static int shiftLeft (final char a, final int b) { return a << b ; } + public static long shiftLeft (final char a, final long b) { return a << b ; } + public static float shiftLeft (final char a, final float b) { + return Float.intBitsToFloat(a << Float.floatToIntBits(b)); + } + public static double shiftLeft (final char a, final double b) { + return Double.longBitsToDouble(a << Double.doubleToLongBits(b)); + } + public static int shiftLeft (final int a, final byte b) { return a << b ; } + public static int shiftLeft (final int a, final short b) { return a << b ; } + public static int shiftLeft (final int a, final char b) { return a << b ; } + public static int shiftLeft (final int a, final int b) { return a << b ; } + public static long shiftLeft (final int a, final long b) { return a << b ; } + public static float shiftLeft (final int a, final float b) { + return Float.intBitsToFloat(a << Float.floatToIntBits(b)); + } + public static double shiftLeft (final int a, final double b) { + return Double.longBitsToDouble(a << Double.doubleToLongBits(b)); + } + public static long shiftLeft (final long a, final byte b) { return a << b ; } + public static long shiftLeft (final long a, final char b) { return a << b ; } + public static long shiftLeft (final long a, final short b) { return a << b ; } + public static long shiftLeft (final long a, final int b) { return a << b ; } + public static long shiftLeft (final long a, final long b) { return a << b ; } + public static double shiftLeft (final long a, final float b) { + return Double.longBitsToDouble(a << Float.floatToIntBits(b)); + } + public static double shiftLeft (final long a, final double b) { + return Double.longBitsToDouble(a << Double.doubleToLongBits(b)); + } + + // ---------------------------- shiftRight : >> ---------------------------- // + + public static boolean shiftRight (final boolean a, final boolean b) { return a && !b; } + public static byte shiftRight (final byte a, final byte b) { return (byte) (a >> b); } + public static short shiftRight (final byte a, final short b) { return (short)(a >> b); } + public static char shiftRight (final byte a, final char b) { return (char) (a >> b); } + public static int shiftRight (final byte a, final int b) { return a >> b ; } + public static long shiftRight (final byte a, final long b) { return a >> b ; } + public static float shiftRight (final byte a, final float b) { + return Float.intBitsToFloat(a >> Float.floatToIntBits(b)); + } + public static double shiftRight (final byte a, final double b) { + return Double.longBitsToDouble(a >> Double.doubleToLongBits(b)); + } + public static short shiftRight (final short a, final byte b) { return (short)(a >> b); } + public static short shiftRight (final short a, final short b) { return (short)(a >> b); } + public static short shiftRight (final short a, final char b) { return (short)(a >> b); } + public static int shiftRight (final short a, final int b) { return a >> b ; } + public static long shiftRight (final short a, final long b) { return a >> b ; } + public static float shiftRight (final short a, final float b) { + return Float.intBitsToFloat(a >> Float.floatToIntBits(b)); + } + public static double shiftRight (final short a, final double b) { + return Double.longBitsToDouble(a >> Double.doubleToLongBits(b)); + } + public static char shiftRight (final char a, final byte b) { return (char) (a >> b); } + public static short shiftRight (final char a, final short b) { return (short)(a >> b); } + public static char shiftRight (final char a, final char b) { return (char) (a >> b); } + public static int shiftRight (final char a, final int b) { return a >> b ; } + public static long shiftRight (final char a, final long b) { return a >> b ; } + public static float shiftRight (final char a, final float b) { + return Float.intBitsToFloat(a >> Float.floatToIntBits(b)); + } + public static double shiftRight (final char a, final double b) { + return Double.longBitsToDouble(a >> Double.doubleToLongBits(b)); + } + public static int shiftRight (final int a, final byte b) { return a >> b ; } + public static int shiftRight (final int a, final short b) { return a >> b ; } + public static int shiftRight (final int a, final char b) { return a >> b ; } + public static int shiftRight (final int a, final int b) { return a >> b ; } + public static long shiftRight (final int a, final long b) { return a >> b ; } + public static float shiftRight (final int a, final float b) { + return Float.intBitsToFloat(a >> Float.floatToIntBits(b)); + } + public static double shiftRight (final int a, final double b) { + return Double.longBitsToDouble(a >> Double.doubleToLongBits(b)); + } + public static long shiftRight (final long a, final byte b) { return a >> b ; } + public static long shiftRight (final long a, final char b) { return a >> b ; } + public static long shiftRight (final long a, final short b) { return a >> b ; } + public static long shiftRight (final long a, final int b) { return a >> b ; } + public static long shiftRight (final long a, final long b) { return a >> b ; } + public static double shiftRight (final long a, final float b) { + return Double.longBitsToDouble(a >> Float.floatToIntBits(b)); + } + public static double shiftRight (final long a, final double b) { + return Double.longBitsToDouble(a >> Double.doubleToLongBits(b)); + } + + // ---------------------------- unsignedShiftRight : >>> ---------------------------- // + + public static boolean ushiftRight (final boolean a, final boolean b) { return a && !b; } + public static byte ushiftRight (final byte a, final byte b) { return (byte) (a >>> b);} + public static short ushiftRight (final byte a, final short b) { return (short)(a >>> b);} + public static char ushiftRight (final byte a, final char b) { return (char) (a >>> b);} + public static int ushiftRight (final byte a, final int b) { return a >>> b ;} + public static long ushiftRight (final byte a, final long b) { return a >>> b ;} + public static float ushiftRight (final byte a, final float b) { + return Float.intBitsToFloat(a >>> Float.floatToIntBits(b)); + } + public static double ushiftRight (final byte a, final double b) { + return Double.longBitsToDouble(a >>> Double.doubleToLongBits(b)); + } + public static short ushiftRight (final short a, final byte b) { return (short)(a >>> b);} + public static short ushiftRight (final short a, final short b) { return (short)(a >>> b);} + public static short ushiftRight (final short a, final char b) { return (short)(a >>> b);} + public static int ushiftRight (final short a, final int b) { return a >>> b ;} + public static long ushiftRight (final short a, final long b) { return a >>> b ;} + public static float ushiftRight (final short a, final float b) { + return Float.intBitsToFloat(a >>> Float.floatToIntBits(b)); + } + public static double ushiftRight (final short a, final double b) { + return Double.longBitsToDouble(a >>> Double.doubleToLongBits(b)); + } + public static char ushiftRight (final char a, final byte b) { return (char) (a >>> b);} + public static short ushiftRight (final char a, final short b) { return (short)(a >>> b);} + public static char ushiftRight (final char a, final char b) { return (char) (a >>> b);} + public static int ushiftRight (final char a, final int b) { return a >>> b ;} + public static long ushiftRight (final char a, final long b) { return a >>> b ;} + public static float ushiftRight (final char a, final float b) { + return Float.intBitsToFloat(a >>> Float.floatToIntBits(b)); + } + public static double ushiftRight (final char a, final double b) { + return Double.longBitsToDouble(a >>> Double.doubleToLongBits(b)); + } + public static int ushiftRight (final int a, final byte b) { return a >>> b ;} + public static int ushiftRight (final int a, final short b) { return a >>> b ;} + public static int ushiftRight (final int a, final char b) { return a >>> b ;} + public static int ushiftRight (final int a, final int b) { return a >>> b ;} + public static long ushiftRight (final int a, final long b) { return a >>> b ;} + public static float ushiftRight (final int a, final float b) { + return Float.intBitsToFloat(a >>> Float.floatToIntBits(b)); + } + public static double ushiftRight (final int a, final double b) { + return Double.longBitsToDouble(a >>> Double.doubleToLongBits(b)); + } + public static long ushiftRight (final long a, final byte b) { return a >>> b ;} + public static long ushiftRight (final long a, final char b) { return a >>> b ;} + public static long ushiftRight (final long a, final short b) { return a >>> b ;} + public static long ushiftRight (final long a, final int b) { return a >>> b ;} + public static long ushiftRight (final long a, final long b) { return a >>> b ;} + public static double ushiftRight (final long a, final float b) { + return Double.longBitsToDouble(a >>> Float.floatToIntBits(b)); + } + public static double ushiftRight (final long a, final double b) { + return Double.longBitsToDouble(a >>> Double.doubleToLongBits(b)); + } + + // ---------------------------- bitFlip ---------------------------- // + + // public static byte bitFlip (final byte x, final long n) { return (byte) x ^ (1L << n); } + // public static short bitFlip (final short x, final long n) { return (short)x ^ (1L << n); } + // public static char bitFlip (final char x, final long n) { return (char) x ^ (1L << n); } + // public static int bitFlip (final int x, final long n) { return x ^ (1L << n); } + // public static long bitFlip (final long x, final long n) { return x ^ (1L << n); } + // public static float bitFlip (final float x, final long n) { + // return Float.intBitsToFloat(~Float.floatToIntBits(x)); + // } + // public static double bitFlip (final double x) { + // return Double.longBitsToDouble(~Double.doubleToLongBits(x)); + // } + + // ---------------------------- bitTest ---------------------------- // + + // ---------------------------- bitSet ---------------------------- // + + // ---------------------------- bitClear ---------------------------- // // Because "more than one matching method" public static short reverseShort(final short x) { @@ -88,12 +442,19 @@ public static long reverseLong (final long x) { // ============================ LT : < ================================ // public static boolean lt (final byte a, final byte b) { return a < b; } - public static boolean lt (final byte a, final char b) { return a < b; } public static boolean lt (final byte a, final short b) { return a < b; } + public static boolean lt (final byte a, final char b) { return a < b; } public static boolean lt (final byte a, final int b) { return a < b; } public static boolean lt (final byte a, final long b) { return a < b; } public static boolean lt (final byte a, final float b) { return a < b; } public static boolean lt (final byte a, final double b) { return a < b; } + public static boolean lt (final short a, final byte b) { return a < b; } + public static boolean lt (final short a, final short b) { return a < b; } + public static boolean lt (final short a, final char b) { return a < b; } + public static boolean lt (final short a, final int b) { return a < b; } + public static boolean lt (final short a, final long b) { return a < b; } + public static boolean lt (final short a, final float b) { return a < b; } + public static boolean lt (final short a, final double b) { return a < b; } public static boolean lt (final char a, final byte b) { return a < b; } public static boolean lt (final char a, final char b) { return a < b; } public static boolean lt (final char a, final short b) { return a < b; } @@ -101,37 +462,30 @@ public static long reverseLong (final long x) { public static boolean lt (final char a, final long b) { return a < b; } public static boolean lt (final char a, final float b) { return a < b; } public static boolean lt (final char a, final double b) { return a < b; } - public static boolean lt (final short a, final byte b) { return a < b; } - public static boolean lt (final short a, final char b) { return a < b; } - public static boolean lt (final short a, final short b) { return a < b; } - public static boolean lt (final short a, final int b) { return a < b; } - public static boolean lt (final short a, final long b) { return a < b; } - public static boolean lt (final short a, final float b) { return a < b; } - public static boolean lt (final short a, final double b) { return a < b; } public static boolean lt (final int a, final byte b) { return a < b; } - public static boolean lt (final int a, final char b) { return a < b; } public static boolean lt (final int a, final short b) { return a < b; } + public static boolean lt (final int a, final char b) { return a < b; } public static boolean lt (final int a, final int b) { return a < b; } public static boolean lt (final int a, final long b) { return a < b; } public static boolean lt (final int a, final float b) { return a < b; } public static boolean lt (final int a, final double b) { return a < b; } public static boolean lt (final long a, final byte b) { return a < b; } - public static boolean lt (final long a, final char b) { return a < b; } public static boolean lt (final long a, final short b) { return a < b; } + public static boolean lt (final long a, final char b) { return a < b; } public static boolean lt (final long a, final int b) { return a < b; } public static boolean lt (final long a, final long b) { return a < b; } public static boolean lt (final long a, final float b) { return a < b; } public static boolean lt (final long a, final double b) { return a < b; } public static boolean lt (final float a, final byte b) { return a < b; } - public static boolean lt (final float a, final char b) { return a < b; } public static boolean lt (final float a, final short b) { return a < b; } + public static boolean lt (final float a, final char b) { return a < b; } public static boolean lt (final float a, final int b) { return a < b; } public static boolean lt (final float a, final long b) { return a < b; } public static boolean lt (final float a, final float b) { return a < b; } public static boolean lt (final float a, final double b) { return a < b; } public static boolean lt (final double a, final byte b) { return a < b; } - public static boolean lt (final double a, final char b) { return a < b; } public static boolean lt (final double a, final short b) { return a < b; } + public static boolean lt (final double a, final char b) { return a < b; } public static boolean lt (final double a, final int b) { return a < b; } public static boolean lt (final double a, final long b) { return a < b; } public static boolean lt (final double a, final float b) { return a < b; } @@ -140,50 +494,50 @@ public static long reverseLong (final long x) { // ============================ LTE : <= ================================ // public static boolean lte (final byte a, final byte b) { return a <= b; } - public static boolean lte (final byte a, final char b) { return a <= b; } public static boolean lte (final byte a, final short b) { return a <= b; } + public static boolean lte (final byte a, final char b) { return a <= b; } public static boolean lte (final byte a, final int b) { return a <= b; } public static boolean lte (final byte a, final long b) { return a <= b; } public static boolean lte (final byte a, final float b) { return a <= b; } public static boolean lte (final byte a, final double b) { return a <= b; } - public static boolean lte (final char a, final byte b) { return a <= b; } - public static boolean lte (final char a, final char b) { return a <= b; } - public static boolean lte (final char a, final short b) { return a <= b; } - public static boolean lte (final char a, final int b) { return a <= b; } - public static boolean lte (final char a, final long b) { return a <= b; } - public static boolean lte (final char a, final float b) { return a <= b; } - public static boolean lte (final char a, final double b) { return a <= b; } public static boolean lte (final short a, final byte b) { return a <= b; } - public static boolean lte (final short a, final char b) { return a <= b; } public static boolean lte (final short a, final short b) { return a <= b; } + public static boolean lte (final short a, final char b) { return a <= b; } public static boolean lte (final short a, final int b) { return a <= b; } public static boolean lte (final short a, final long b) { return a <= b; } public static boolean lte (final short a, final float b) { return a <= b; } public static boolean lte (final short a, final double b) { return a <= b; } + public static boolean lte (final char a, final byte b) { return a <= b; } + public static boolean lte (final char a, final short b) { return a <= b; } + public static boolean lte (final char a, final char b) { return a <= b; } + public static boolean lte (final char a, final int b) { return a <= b; } + public static boolean lte (final char a, final long b) { return a <= b; } + public static boolean lte (final char a, final float b) { return a <= b; } + public static boolean lte (final char a, final double b) { return a <= b; } public static boolean lte (final int a, final byte b) { return a <= b; } - public static boolean lte (final int a, final char b) { return a <= b; } public static boolean lte (final int a, final short b) { return a <= b; } + public static boolean lte (final int a, final char b) { return a <= b; } public static boolean lte (final int a, final int b) { return a <= b; } public static boolean lte (final int a, final long b) { return a <= b; } public static boolean lte (final int a, final float b) { return a <= b; } public static boolean lte (final int a, final double b) { return a <= b; } public static boolean lte (final long a, final byte b) { return a <= b; } - public static boolean lte (final long a, final char b) { return a <= b; } public static boolean lte (final long a, final short b) { return a <= b; } + public static boolean lte (final long a, final char b) { return a <= b; } public static boolean lte (final long a, final int b) { return a <= b; } public static boolean lte (final long a, final long b) { return a <= b; } public static boolean lte (final long a, final float b) { return a <= b; } public static boolean lte (final long a, final double b) { return a <= b; } public static boolean lte (final float a, final byte b) { return a <= b; } - public static boolean lte (final float a, final char b) { return a <= b; } public static boolean lte (final float a, final short b) { return a <= b; } + public static boolean lte (final float a, final char b) { return a <= b; } public static boolean lte (final float a, final int b) { return a <= b; } public static boolean lte (final float a, final long b) { return a <= b; } public static boolean lte (final float a, final float b) { return a <= b; } public static boolean lte (final float a, final double b) { return a <= b; } public static boolean lte (final double a, final byte b) { return a <= b; } - public static boolean lte (final double a, final char b) { return a <= b; } public static boolean lte (final double a, final short b) { return a <= b; } + public static boolean lte (final double a, final char b) { return a <= b; } public static boolean lte (final double a, final int b) { return a <= b; } public static boolean lte (final double a, final long b) { return a <= b; } public static boolean lte (final double a, final float b) { return a <= b; } @@ -192,50 +546,50 @@ public static long reverseLong (final long x) { // ============================ GT : > ================================ // public static boolean gt (final byte a, final byte b) { return a > b; } - public static boolean gt (final byte a, final char b) { return a > b; } public static boolean gt (final byte a, final short b) { return a > b; } + public static boolean gt (final byte a, final char b) { return a > b; } public static boolean gt (final byte a, final int b) { return a > b; } public static boolean gt (final byte a, final long b) { return a > b; } public static boolean gt (final byte a, final float b) { return a > b; } public static boolean gt (final byte a, final double b) { return a > b; } - public static boolean gt (final char a, final byte b) { return a > b; } - public static boolean gt (final char a, final char b) { return a > b; } - public static boolean gt (final char a, final short b) { return a > b; } - public static boolean gt (final char a, final int b) { return a > b; } - public static boolean gt (final char a, final long b) { return a > b; } - public static boolean gt (final char a, final float b) { return a > b; } - public static boolean gt (final char a, final double b) { return a > b; } public static boolean gt (final short a, final byte b) { return a > b; } - public static boolean gt (final short a, final char b) { return a > b; } public static boolean gt (final short a, final short b) { return a > b; } + public static boolean gt (final short a, final char b) { return a > b; } public static boolean gt (final short a, final int b) { return a > b; } public static boolean gt (final short a, final long b) { return a > b; } public static boolean gt (final short a, final float b) { return a > b; } public static boolean gt (final short a, final double b) { return a > b; } + public static boolean gt (final char a, final byte b) { return a > b; } + public static boolean gt (final char a, final short b) { return a > b; } + public static boolean gt (final char a, final char b) { return a > b; } + public static boolean gt (final char a, final int b) { return a > b; } + public static boolean gt (final char a, final long b) { return a > b; } + public static boolean gt (final char a, final float b) { return a > b; } + public static boolean gt (final char a, final double b) { return a > b; } public static boolean gt (final int a, final byte b) { return a > b; } - public static boolean gt (final int a, final char b) { return a > b; } public static boolean gt (final int a, final short b) { return a > b; } + public static boolean gt (final int a, final char b) { return a > b; } public static boolean gt (final int a, final int b) { return a > b; } public static boolean gt (final int a, final long b) { return a > b; } public static boolean gt (final int a, final float b) { return a > b; } public static boolean gt (final int a, final double b) { return a > b; } public static boolean gt (final long a, final byte b) { return a > b; } - public static boolean gt (final long a, final char b) { return a > b; } public static boolean gt (final long a, final short b) { return a > b; } + public static boolean gt (final long a, final char b) { return a > b; } public static boolean gt (final long a, final int b) { return a > b; } public static boolean gt (final long a, final long b) { return a > b; } public static boolean gt (final long a, final float b) { return a > b; } public static boolean gt (final long a, final double b) { return a > b; } public static boolean gt (final float a, final byte b) { return a > b; } - public static boolean gt (final float a, final char b) { return a > b; } public static boolean gt (final float a, final short b) { return a > b; } + public static boolean gt (final float a, final char b) { return a > b; } public static boolean gt (final float a, final int b) { return a > b; } public static boolean gt (final float a, final long b) { return a > b; } public static boolean gt (final float a, final float b) { return a > b; } public static boolean gt (final float a, final double b) { return a > b; } public static boolean gt (final double a, final byte b) { return a > b; } - public static boolean gt (final double a, final char b) { return a > b; } public static boolean gt (final double a, final short b) { return a > b; } + public static boolean gt (final double a, final char b) { return a > b; } public static boolean gt (final double a, final int b) { return a > b; } public static boolean gt (final double a, final long b) { return a > b; } public static boolean gt (final double a, final float b) { return a > b; } @@ -244,50 +598,50 @@ public static long reverseLong (final long x) { // ============================ GTE : >= ================================ // public static boolean gte (final byte a, final byte b) { return a >= b; } - public static boolean gte (final byte a, final char b) { return a >= b; } public static boolean gte (final byte a, final short b) { return a >= b; } + public static boolean gte (final byte a, final char b) { return a >= b; } public static boolean gte (final byte a, final int b) { return a >= b; } public static boolean gte (final byte a, final long b) { return a >= b; } public static boolean gte (final byte a, final float b) { return a >= b; } public static boolean gte (final byte a, final double b) { return a >= b; } - public static boolean gte (final char a, final byte b) { return a >= b; } - public static boolean gte (final char a, final char b) { return a >= b; } - public static boolean gte (final char a, final short b) { return a >= b; } - public static boolean gte (final char a, final int b) { return a >= b; } - public static boolean gte (final char a, final long b) { return a >= b; } - public static boolean gte (final char a, final float b) { return a >= b; } - public static boolean gte (final char a, final double b) { return a >= b; } public static boolean gte (final short a, final byte b) { return a >= b; } - public static boolean gte (final short a, final char b) { return a >= b; } public static boolean gte (final short a, final short b) { return a >= b; } + public static boolean gte (final short a, final char b) { return a >= b; } public static boolean gte (final short a, final int b) { return a >= b; } public static boolean gte (final short a, final long b) { return a >= b; } public static boolean gte (final short a, final float b) { return a >= b; } public static boolean gte (final short a, final double b) { return a >= b; } + public static boolean gte (final char a, final byte b) { return a >= b; } + public static boolean gte (final char a, final short b) { return a >= b; } + public static boolean gte (final char a, final char b) { return a >= b; } + public static boolean gte (final char a, final int b) { return a >= b; } + public static boolean gte (final char a, final long b) { return a >= b; } + public static boolean gte (final char a, final float b) { return a >= b; } + public static boolean gte (final char a, final double b) { return a >= b; } public static boolean gte (final int a, final byte b) { return a >= b; } - public static boolean gte (final int a, final char b) { return a >= b; } public static boolean gte (final int a, final short b) { return a >= b; } + public static boolean gte (final int a, final char b) { return a >= b; } public static boolean gte (final int a, final int b) { return a >= b; } public static boolean gte (final int a, final long b) { return a >= b; } public static boolean gte (final int a, final float b) { return a >= b; } public static boolean gte (final int a, final double b) { return a >= b; } public static boolean gte (final long a, final byte b) { return a >= b; } - public static boolean gte (final long a, final char b) { return a >= b; } public static boolean gte (final long a, final short b) { return a >= b; } + public static boolean gte (final long a, final char b) { return a >= b; } public static boolean gte (final long a, final int b) { return a >= b; } public static boolean gte (final long a, final long b) { return a >= b; } public static boolean gte (final long a, final float b) { return a >= b; } public static boolean gte (final long a, final double b) { return a >= b; } public static boolean gte (final float a, final byte b) { return a >= b; } - public static boolean gte (final float a, final char b) { return a >= b; } public static boolean gte (final float a, final short b) { return a >= b; } + public static boolean gte (final float a, final char b) { return a >= b; } public static boolean gte (final float a, final int b) { return a >= b; } public static boolean gte (final float a, final long b) { return a >= b; } public static boolean gte (final float a, final float b) { return a >= b; } public static boolean gte (final float a, final double b) { return a >= b; } public static boolean gte (final double a, final byte b) { return a >= b; } - public static boolean gte (final double a, final char b) { return a >= b; } public static boolean gte (final double a, final short b) { return a >= b; } + public static boolean gte (final double a, final char b) { return a >= b; } public static boolean gte (final double a, final int b) { return a >= b; } public static boolean gte (final double a, final long b) { return a >= b; } public static boolean gte (final double a, final float b) { return a >= b; } @@ -297,50 +651,50 @@ public static long reverseLong (final long x) { public static boolean eq (final boolean a, final boolean b) { return a == b; } public static boolean eq (final byte a, final byte b) { return a == b; } - public static boolean eq (final byte a, final char b) { return a == b; } public static boolean eq (final byte a, final short b) { return a == b; } + public static boolean eq (final byte a, final char b) { return a == b; } public static boolean eq (final byte a, final int b) { return a == b; } public static boolean eq (final byte a, final long b) { return a == b; } public static boolean eq (final byte a, final float b) { return a == b; } public static boolean eq (final byte a, final double b) { return a == b; } - public static boolean eq (final char a, final byte b) { return a == b; } - public static boolean eq (final char a, final char b) { return a == b; } - public static boolean eq (final char a, final short b) { return a == b; } - public static boolean eq (final char a, final int b) { return a == b; } - public static boolean eq (final char a, final long b) { return a == b; } - public static boolean eq (final char a, final float b) { return a == b; } - public static boolean eq (final char a, final double b) { return a == b; } public static boolean eq (final short a, final byte b) { return a == b; } - public static boolean eq (final short a, final char b) { return a == b; } public static boolean eq (final short a, final short b) { return a == b; } + public static boolean eq (final short a, final char b) { return a == b; } public static boolean eq (final short a, final int b) { return a == b; } public static boolean eq (final short a, final long b) { return a == b; } public static boolean eq (final short a, final float b) { return a == b; } public static boolean eq (final short a, final double b) { return a == b; } + public static boolean eq (final char a, final byte b) { return a == b; } + public static boolean eq (final char a, final short b) { return a == b; } + public static boolean eq (final char a, final char b) { return a == b; } + public static boolean eq (final char a, final int b) { return a == b; } + public static boolean eq (final char a, final long b) { return a == b; } + public static boolean eq (final char a, final float b) { return a == b; } + public static boolean eq (final char a, final double b) { return a == b; } public static boolean eq (final int a, final byte b) { return a == b; } - public static boolean eq (final int a, final char b) { return a == b; } public static boolean eq (final int a, final short b) { return a == b; } + public static boolean eq (final int a, final char b) { return a == b; } public static boolean eq (final int a, final int b) { return a == b; } public static boolean eq (final int a, final long b) { return a == b; } public static boolean eq (final int a, final float b) { return a == b; } public static boolean eq (final int a, final double b) { return a == b; } public static boolean eq (final long a, final byte b) { return a == b; } - public static boolean eq (final long a, final char b) { return a == b; } public static boolean eq (final long a, final short b) { return a == b; } + public static boolean eq (final long a, final char b) { return a == b; } public static boolean eq (final long a, final int b) { return a == b; } public static boolean eq (final long a, final long b) { return a == b; } public static boolean eq (final long a, final float b) { return a == b; } public static boolean eq (final long a, final double b) { return a == b; } public static boolean eq (final float a, final byte b) { return a == b; } - public static boolean eq (final float a, final char b) { return a == b; } public static boolean eq (final float a, final short b) { return a == b; } + public static boolean eq (final float a, final char b) { return a == b; } public static boolean eq (final float a, final int b) { return a == b; } public static boolean eq (final float a, final long b) { return a == b; } public static boolean eq (final float a, final float b) { return a == b; } public static boolean eq (final float a, final double b) { return a == b; } public static boolean eq (final double a, final byte b) { return a == b; } - public static boolean eq (final double a, final char b) { return a == b; } public static boolean eq (final double a, final short b) { return a == b; } + public static boolean eq (final double a, final char b) { return a == b; } public static boolean eq (final double a, final int b) { return a == b; } public static boolean eq (final double a, final long b) { return a == b; } public static boolean eq (final double a, final float b) { return a == b; } @@ -350,50 +704,50 @@ public static long reverseLong (final long x) { public static boolean neq (final boolean a, final boolean b) { return a != b; } public static boolean neq (final byte a, final byte b) { return a != b; } - public static boolean neq (final byte a, final char b) { return a != b; } public static boolean neq (final byte a, final short b) { return a != b; } + public static boolean neq (final byte a, final char b) { return a != b; } public static boolean neq (final byte a, final int b) { return a != b; } public static boolean neq (final byte a, final long b) { return a != b; } public static boolean neq (final byte a, final float b) { return a != b; } public static boolean neq (final byte a, final double b) { return a != b; } - public static boolean neq (final char a, final byte b) { return a != b; } - public static boolean neq (final char a, final char b) { return a != b; } - public static boolean neq (final char a, final short b) { return a != b; } - public static boolean neq (final char a, final int b) { return a != b; } - public static boolean neq (final char a, final long b) { return a != b; } - public static boolean neq (final char a, final float b) { return a != b; } - public static boolean neq (final char a, final double b) { return a != b; } public static boolean neq (final short a, final byte b) { return a != b; } - public static boolean neq (final short a, final char b) { return a != b; } public static boolean neq (final short a, final short b) { return a != b; } + public static boolean neq (final short a, final char b) { return a != b; } public static boolean neq (final short a, final int b) { return a != b; } public static boolean neq (final short a, final long b) { return a != b; } public static boolean neq (final short a, final float b) { return a != b; } public static boolean neq (final short a, final double b) { return a != b; } + public static boolean neq (final char a, final byte b) { return a != b; } + public static boolean neq (final char a, final short b) { return a != b; } + public static boolean neq (final char a, final char b) { return a != b; } + public static boolean neq (final char a, final int b) { return a != b; } + public static boolean neq (final char a, final long b) { return a != b; } + public static boolean neq (final char a, final float b) { return a != b; } + public static boolean neq (final char a, final double b) { return a != b; } public static boolean neq (final int a, final byte b) { return a != b; } - public static boolean neq (final int a, final char b) { return a != b; } public static boolean neq (final int a, final short b) { return a != b; } + public static boolean neq (final int a, final char b) { return a != b; } public static boolean neq (final int a, final int b) { return a != b; } public static boolean neq (final int a, final long b) { return a != b; } public static boolean neq (final int a, final float b) { return a != b; } public static boolean neq (final int a, final double b) { return a != b; } public static boolean neq (final long a, final byte b) { return a != b; } - public static boolean neq (final long a, final char b) { return a != b; } public static boolean neq (final long a, final short b) { return a != b; } + public static boolean neq (final long a, final char b) { return a != b; } public static boolean neq (final long a, final int b) { return a != b; } public static boolean neq (final long a, final long b) { return a != b; } public static boolean neq (final long a, final float b) { return a != b; } public static boolean neq (final long a, final double b) { return a != b; } public static boolean neq (final float a, final byte b) { return a != b; } - public static boolean neq (final float a, final char b) { return a != b; } public static boolean neq (final float a, final short b) { return a != b; } + public static boolean neq (final float a, final char b) { return a != b; } public static boolean neq (final float a, final int b) { return a != b; } public static boolean neq (final float a, final long b) { return a != b; } public static boolean neq (final float a, final float b) { return a != b; } public static boolean neq (final float a, final double b) { return a != b; } public static boolean neq (final double a, final byte b) { return a != b; } - public static boolean neq (final double a, final char b) { return a != b; } public static boolean neq (final double a, final short b) { return a != b; } + public static boolean neq (final double a, final char b) { return a != b; } public static boolean neq (final double a, final int b) { return a != b; } public static boolean neq (final double a, final long b) { return a != b; } public static boolean neq (final double a, final float b) { return a != b; } @@ -402,16 +756,16 @@ public static long reverseLong (final long x) { // ============================ INC / DEC ================================ // public static byte inc (final byte a) { return (byte )(a + byte1 ); } - public static char inc (final char a) { return (char )(a + char1 ); } public static short inc (final short a) { return (short)(a + short1); } + public static char inc (final char a) { return (char )(a + char1 ); } public static int inc (final int a) { return a + 1; } public static long inc (final long a) { return a + 1L; } public static float inc (final float a) { return a + 1.0f; } public static double inc (final double a) { return a + 1.0d; } public static byte dec (final byte a) { return (byte )(a - byte1 ); } - public static char dec (final char a) { return (char )(a - char1 ); } public static short dec (final short a) { return (short)(a - short1); } + public static char dec (final char a) { return (char )(a - char1 ); } public static int dec (final int a) { return a - 1; } public static long dec (final long a) { return a - 1L; } public static float dec (final float a) { return a - 1.0f; } @@ -420,8 +774,8 @@ public static long reverseLong (final long x) { // ============================ ISZERO ================================ // public static boolean isZero (final byte a) { return a == byte0; } - public static boolean isZero (final char a) { return a == char0; } public static boolean isZero (final short a) { return a == short0; } + public static boolean isZero (final char a) { return a == char0; } public static boolean isZero (final int a) { return a == int0; } public static boolean isZero (final long a) { return a == 0L; } public static boolean isZero (final float a) { return a == 0.0f; } @@ -430,8 +784,8 @@ public static long reverseLong (final long x) { // ============================ ISNEG ================================ // public static boolean isNeg (final byte a) { return a < byte0; } // Implicitly checked - public static boolean isNeg (final char a) { return a < char0; } // Implicitly checked public static boolean isNeg (final short a) { return a < short0; } // Implicitly checked + public static boolean isNeg (final char a) { return a < char0; } // Implicitly checked public static boolean isNeg (final int a) { return a < int0; } // Implicitly checked public static boolean isNeg (final long a) { return a < 0L; } // Implicitly checked public static boolean isNeg (final float a) { return a < 0.0f; } // Implicitly checked @@ -440,8 +794,8 @@ public static long reverseLong (final long x) { // ============================ ISPOS ================================ // public static boolean isPos (final byte a) { return a > byte0; } // Implicitly checked - public static boolean isPos (final char a) { return a > char0; } // Implicitly checked public static boolean isPos (final short a) { return a > short0; } // Implicitly checked + public static boolean isPos (final char a) { return a > char0; } // Implicitly checked public static boolean isPos (final int a) { return a > int0; } // Implicitly checked public static boolean isPos (final long a) { return a > 0L; } // Implicitly checked public static boolean isPos (final float a) { return a > 0.0f; } // Implicitly checked @@ -450,50 +804,50 @@ public static long reverseLong (final long x) { // ============================ ADD : + ================================ // // "Infectious": uses a promotion of the largest data type passed public static short add (final byte a, final byte b) { return (short)(a + b); } // Implicitly checked - public static int add (final byte a, final char b) { return a + b; } // Implicitly checked public static int add (final byte a, final short b) { return a + b; } // Implicitly checked + public static int add (final byte a, final char b) { return a + b; } // Implicitly checked public static long add (final byte a, final int b) { return a + b; } // Implicitly checked public static long add (final byte a, final long b) { return a + b; } public static double add (final byte a, final float b) { return a + b; } // Implicitly checked public static double add (final byte a, final double b) { return a + b; } - public static int add (final char a, final byte b) { return a + b; } // Implicitly checked - public static int add (final char a, final char b) { return a + b; } // Implicitly checked - public static int add (final char a, final short b) { return a + b; } // Implicitly checked - public static long add (final char a, final int b) { return a + b; } // Implicitly checked - public static long add (final char a, final long b) { return a + b; } - public static double add (final char a, final float b) { return a + b; } // Implicitly checked - public static double add (final char a, final double b) { return a + b; } public static int add (final short a, final byte b) { return a + b; } // Implicitly checked - public static int add (final short a, final char b) { return a + b; } // Implicitly checked public static int add (final short a, final short b) { return a + b; } // Implicitly checked + public static int add (final short a, final char b) { return a + b; } // Implicitly checked public static long add (final short a, final int b) { return a + b; } // Implicitly checked public static long add (final short a, final long b) { return a + b; } public static double add (final short a, final float b) { return a + b; } // Implicitly checked public static double add (final short a, final double b) { return a + b; } + public static int add (final char a, final byte b) { return a + b; } // Implicitly checked + public static int add (final char a, final short b) { return a + b; } // Implicitly checked + public static int add (final char a, final char b) { return a + b; } // Implicitly checked + public static long add (final char a, final int b) { return a + b; } // Implicitly checked + public static long add (final char a, final long b) { return a + b; } + public static double add (final char a, final float b) { return a + b; } // Implicitly checked + public static double add (final char a, final double b) { return a + b; } public static long add (final int a, final byte b) { return a + b; } // Implicitly checked - public static long add (final int a, final char b) { return a + b; } // Implicitly checked public static long add (final int a, final short b) { return a + b; } // Implicitly checked + public static long add (final int a, final char b) { return a + b; } // Implicitly checked public static long add (final int a, final int b) { return a + b; } // Implicitly checked public static long add (final int a, final long b) { return a + b; } public static double add (final int a, final float b) { return a + b; } // Implicitly checked public static double add (final int a, final double b) { return a + b; } public static long add (final long a, final byte b) { return a + b; } - public static long add (final long a, final char b) { return a + b; } public static long add (final long a, final short b) { return a + b; } + public static long add (final long a, final char b) { return a + b; } public static long add (final long a, final int b) { return a + b; } public static long add (final long a, final long b) { return a + b; } public static double add (final long a, final float b) { return a + b; } public static double add (final long a, final double b) { return a + b; } public static double add (final float a, final byte b) { return a + b; } // Implicitly checked - public static double add (final float a, final char b) { return a + b; } // Implicitly checked public static double add (final float a, final short b) { return a + b; } // Implicitly checked + public static double add (final float a, final char b) { return a + b; } // Implicitly checked public static double add (final float a, final int b) { return a + b; } // Implicitly checked public static double add (final float a, final long b) { return a + b; } public static double add (final float a, final float b) { return a + b; } // Implicitly checked public static double add (final float a, final double b) { return a + b; } public static double add (final double a, final byte b) { return a + b; } - public static double add (final double a, final char b) { return a + b; } public static double add (final double a, final short b) { return a + b; } + public static double add (final double a, final char b) { return a + b; } public static double add (final double a, final int b) { return a + b; } public static double add (final double a, final long b) { return a + b; } public static double add (final double a, final float b) { return a + b; } @@ -503,50 +857,50 @@ public static long reverseLong (final long x) { // "Infectious": uses the largest data type passed public static short subtract (final byte a, final byte b) { return (short)(a - b); } // Implicitly checked - public static int subtract (final byte a, final char b) { return a - b; } // Implicitly checked public static int subtract (final byte a, final short b) { return a - b; } // Implicitly checked + public static int subtract (final byte a, final char b) { return a - b; } // Implicitly checked public static long subtract (final byte a, final int b) { return a - b; } // Implicitly checked public static long subtract (final byte a, final long b) { return a - b; } public static double subtract (final byte a, final float b) { return a - b; } // Implicitly checked public static double subtract (final byte a, final double b) { return a - b; } - public static int subtract (final char a, final byte b) { return a - b; } // Implicitly checked - public static int subtract (final char a, final char b) { return a - b; } // Implicitly checked - public static int subtract (final char a, final short b) { return a - b; } // Implicitly checked - public static long subtract (final char a, final int b) { return a - b; } // Implicitly checked - public static long subtract (final char a, final long b) { return a - b; } - public static double subtract (final char a, final float b) { return a - b; } // Implicitly checked - public static double subtract (final char a, final double b) { return a - b; } public static int subtract (final short a, final byte b) { return a - b; } // Implicitly checked - public static int subtract (final short a, final char b) { return a - b; } // Implicitly checked public static int subtract (final short a, final short b) { return a - b; } // Implicitly checked + public static int subtract (final short a, final char b) { return a - b; } // Implicitly checked public static long subtract (final short a, final int b) { return a - b; } // Implicitly checked public static long subtract (final short a, final long b) { return a - b; } public static double subtract (final short a, final float b) { return a - b; } // Implicitly checked public static double subtract (final short a, final double b) { return a - b; } + public static int subtract (final char a, final byte b) { return a - b; } // Implicitly checked + public static int subtract (final char a, final short b) { return a - b; } // Implicitly checked + public static int subtract (final char a, final char b) { return a - b; } // Implicitly checked + public static long subtract (final char a, final int b) { return a - b; } // Implicitly checked + public static long subtract (final char a, final long b) { return a - b; } + public static double subtract (final char a, final float b) { return a - b; } // Implicitly checked + public static double subtract (final char a, final double b) { return a - b; } public static long subtract (final int a, final byte b) { return a - b; } // Implicitly checked - public static long subtract (final int a, final char b) { return a - b; } // Implicitly checked public static long subtract (final int a, final short b) { return a - b; } // Implicitly checked + public static long subtract (final int a, final char b) { return a - b; } // Implicitly checked public static long subtract (final int a, final int b) { return a - b; } // Implicitly checked public static long subtract (final int a, final long b) { return a - b; } public static double subtract (final int a, final float b) { return a - b; } // Implicitly checked public static double subtract (final int a, final double b) { return a - b; } public static long subtract (final long a, final byte b) { return a - b; } - public static long subtract (final long a, final char b) { return a - b; } public static long subtract (final long a, final short b) { return a - b; } + public static long subtract (final long a, final char b) { return a - b; } public static long subtract (final long a, final int b) { return a - b; } public static long subtract (final long a, final long b) { return a - b; } public static double subtract (final long a, final float b) { return a - b; } public static double subtract (final long a, final double b) { return a - b; } public static double subtract (final float a, final byte b) { return a - b; } // Implicitly checked - public static double subtract (final float a, final char b) { return a - b; } // Implicitly checked public static double subtract (final float a, final short b) { return a - b; } // Implicitly checked + public static double subtract (final float a, final char b) { return a - b; } // Implicitly checked public static double subtract (final float a, final int b) { return a - b; } // Implicitly checked public static double subtract (final float a, final long b) { return a - b; } public static double subtract (final float a, final float b) { return a - b; } // Implicitly checked public static double subtract (final float a, final double b) { return a - b; } public static double subtract (final double a, final byte b) { return a - b; } - public static double subtract (final double a, final char b) { return a - b; } public static double subtract (final double a, final short b) { return a - b; } + public static double subtract (final double a, final char b) { return a - b; } public static double subtract (final double a, final int b) { return a - b; } public static double subtract (final double a, final long b) { return a - b; } public static double subtract (final double a, final float b) { return a - b; } @@ -555,8 +909,8 @@ public static long reverseLong (final long x) { // ============================ NEGATE : - ================================ // public static byte negate (final byte a) { return (byte )-a; } - public static char negate (final char a) { return (char )-a; } public static short negate (final short a) { return (short)-a; } + public static char negate (final char a) { return (char )-a; } public static int negate (final int a) { return -a; } public static long negate (final long a) { return -a; } public static float negate (final float a) { return -a; } @@ -566,50 +920,50 @@ public static long reverseLong (final long x) { // "Infectious": uses the largest data type passed public static short multiply (final byte a, final byte b) { return (short)(a * b); } // Implicitly checked - public static int multiply (final byte a, final char b) { return a * b; } // Implicitly checked public static int multiply (final byte a, final short b) { return a * b; } // Implicitly checked + public static int multiply (final byte a, final char b) { return a * b; } // Implicitly checked public static long multiply (final byte a, final int b) { return a * b; } // Implicitly checked public static long multiply (final byte a, final long b) { return a * b; } // ->BigInteger public static double multiply (final byte a, final float b) { return a * b; } // public static double multiply (final byte a, final double b) { return a * b; } - public static long multiply (final char a, final byte b) { return a * b; } - public static long multiply (final char a, final char b) { return a * b; } - public static long multiply (final char a, final short b) { return a * b; } - public static long multiply (final char a, final int b) { return a * b; } - public static long multiply (final char a, final long b) { return a * b; } - public static double multiply (final char a, final float b) { return a * b; } - public static double multiply (final char a, final double b) { return a * b; } public static long multiply (final short a, final byte b) { return a * b; } - public static long multiply (final short a, final char b) { return a * b; } public static long multiply (final short a, final short b) { return a * b; } + public static long multiply (final short a, final char b) { return a * b; } public static long multiply (final short a, final int b) { return a * b; } public static long multiply (final short a, final long b) { return a * b; } public static double multiply (final short a, final float b) { return a * b; } public static double multiply (final short a, final double b) { return a * b; } + public static long multiply (final char a, final byte b) { return a * b; } + public static long multiply (final char a, final short b) { return a * b; } + public static long multiply (final char a, final char b) { return a * b; } + public static long multiply (final char a, final int b) { return a * b; } + public static long multiply (final char a, final long b) { return a * b; } + public static double multiply (final char a, final float b) { return a * b; } + public static double multiply (final char a, final double b) { return a * b; } public static long multiply (final int a, final byte b) { return a * b; } - public static long multiply (final int a, final char b) { return a * b; } public static long multiply (final int a, final short b) { return a * b; } + public static long multiply (final int a, final char b) { return a * b; } public static long multiply (final int a, final int b) { return a * b; } public static long multiply (final int a, final long b) { return a * b; } public static double multiply (final int a, final float b) { return a * b; } public static double multiply (final int a, final double b) { return a * b; } public static long multiply (final long a, final byte b) { return a * b; } - public static long multiply (final long a, final char b) { return a * b; } public static long multiply (final long a, final short b) { return a * b; } + public static long multiply (final long a, final char b) { return a * b; } public static long multiply (final long a, final int b) { return a * b; } public static long multiply (final long a, final long b) { return a * b; } public static double multiply (final long a, final float b) { return a * b; } public static double multiply (final long a, final double b) { return a * b; } public static double multiply (final float a, final byte b) { return a * b; } - public static double multiply (final float a, final char b) { return a * b; } public static double multiply (final float a, final short b) { return a * b; } + public static double multiply (final float a, final char b) { return a * b; } public static double multiply (final float a, final int b) { return a * b; } public static double multiply (final float a, final long b) { return a * b; } public static double multiply (final float a, final float b) { return a * b; } public static double multiply (final float a, final double b) { return a * b; } public static double multiply (final double a, final byte b) { return a * b; } - public static double multiply (final double a, final char b) { return a * b; } public static double multiply (final double a, final short b) { return a * b; } + public static double multiply (final double a, final char b) { return a * b; } public static double multiply (final double a, final int b) { return a * b; } public static double multiply (final double a, final long b) { return a * b; } public static double multiply (final double a, final float b) { return a * b; } @@ -620,50 +974,50 @@ public static long reverseLong (final long x) { // TODO need to deal with int truncation here... sometimes it's intentional... public static double divide (final byte a, final byte b) { return a / b; } - public static double divide (final byte a, final char b) { return a / b; } public static double divide (final byte a, final short b) { return a / b; } + public static double divide (final byte a, final char b) { return a / b; } public static double divide (final byte a, final int b) { return a / b; } public static double divide (final byte a, final long b) { return a / b; } public static double divide (final byte a, final float b) { return a / b; } public static double divide (final byte a, final double b) { return a / b; } - public static double divide (final char a, final byte b) { return a / b; } - public static double divide (final char a, final char b) { return a / b; } - public static double divide (final char a, final short b) { return a / b; } - public static double divide (final char a, final int b) { return a / b; } - public static double divide (final char a, final long b) { return a / b; } - public static double divide (final char a, final float b) { return a / b; } - public static double divide (final char a, final double b) { return a / b; } public static double divide (final short a, final byte b) { return a / b; } - public static double divide (final short a, final char b) { return a / b; } public static double divide (final short a, final short b) { return a / b; } + public static double divide (final short a, final char b) { return a / b; } public static double divide (final short a, final int b) { return a / b; } public static double divide (final short a, final long b) { return a / b; } public static double divide (final short a, final float b) { return a / b; } public static double divide (final short a, final double b) { return a / b; } + public static double divide (final char a, final byte b) { return a / b; } + public static double divide (final char a, final short b) { return a / b; } + public static double divide (final char a, final char b) { return a / b; } + public static double divide (final char a, final int b) { return a / b; } + public static double divide (final char a, final long b) { return a / b; } + public static double divide (final char a, final float b) { return a / b; } + public static double divide (final char a, final double b) { return a / b; } public static double divide (final int a, final byte b) { return a / b; } - public static double divide (final int a, final char b) { return a / b; } public static double divide (final int a, final short b) { return a / b; } + public static double divide (final int a, final char b) { return a / b; } public static double divide (final int a, final int b) { return a / b; } public static double divide (final int a, final long b) { return a / b; } public static double divide (final int a, final float b) { return a / b; } public static double divide (final int a, final double b) { return a / b; } public static double divide (final long a, final byte b) { return a / b; } - public static double divide (final long a, final char b) { return a / b; } public static double divide (final long a, final short b) { return a / b; } + public static double divide (final long a, final char b) { return a / b; } public static double divide (final long a, final int b) { return a / b; } public static double divide (final long a, final long b) { return a / b; } public static double divide (final long a, final float b) { return a / b; } public static double divide (final long a, final double b) { return a / b; } public static double divide (final float a, final byte b) { return a / b; } - public static double divide (final float a, final char b) { return a / b; } public static double divide (final float a, final short b) { return a / b; } + public static double divide (final float a, final char b) { return a / b; } public static double divide (final float a, final int b) { return a / b; } public static double divide (final float a, final long b) { return a / b; } public static double divide (final float a, final float b) { return a / b; } public static double divide (final float a, final double b) { return a / b; } public static double divide (final double a, final byte b) { return a / b; } - public static double divide (final double a, final char b) { return a / b; } public static double divide (final double a, final short b) { return a / b; } + public static double divide (final double a, final char b) { return a / b; } public static double divide (final double a, final int b) { return a / b; } public static double divide (final double a, final long b) { return a / b; } public static double divide (final double a, final float b) { return a / b; } @@ -673,50 +1027,50 @@ public static long reverseLong (final long x) { // "Infectious": uses the largest data type passed public static byte max (final byte a, final byte b) { return (a < b) ? b : a; } - public static char max (final byte a, final char b) { return (char)((a < b) ? b : a); } public static short max (final byte a, final short b) { return (a < b) ? b : a; } + public static char max (final byte a, final char b) { return (char)((a < b) ? b : a); } public static int max (final byte a, final int b) { return (a < b) ? b : a; } public static long max (final byte a, final long b) { return (a < b) ? b : a; } public static float max (final byte a, final float b) { return (a < b) ? b : a; } public static double max (final byte a, final double b) { return (a < b) ? b : a; } - public static char max (final char a, final byte b) { return (char)((a < b) ? b : a); } - public static char max (final char a, final char b) { return (a < b) ? b : a; } - public static short max (final char a, final short b) { return (short)((a < b) ? b : a); } - public static int max (final char a, final int b) { return (a < b) ? b : a; } - public static long max (final char a, final long b) { return (a < b) ? b : a; } - public static float max (final char a, final float b) { return (a < b) ? b : a; } - public static double max (final char a, final double b) { return (a < b) ? b : a; } public static short max (final short a, final byte b) { return (a < b) ? b : a; } - public static short max (final short a, final char b) { return (short)((a < b) ? b : a); } public static short max (final short a, final short b) { return (a < b) ? b : a; } + public static short max (final short a, final char b) { return (short)((a < b) ? b : a); } public static int max (final short a, final int b) { return (a < b) ? b : a; } public static long max (final short a, final long b) { return (a < b) ? b : a; } public static float max (final short a, final float b) { return (a < b) ? b : a; } public static double max (final short a, final double b) { return (a < b) ? b : a; } + public static char max (final char a, final byte b) { return (char)((a < b) ? b : a); } + public static short max (final char a, final short b) { return (short)((a < b) ? b : a); } + public static char max (final char a, final char b) { return (a < b) ? b : a; } + public static int max (final char a, final int b) { return (a < b) ? b : a; } + public static long max (final char a, final long b) { return (a < b) ? b : a; } + public static float max (final char a, final float b) { return (a < b) ? b : a; } + public static double max (final char a, final double b) { return (a < b) ? b : a; } public static int max (final int a, final byte b) { return (a < b) ? b : a; } - public static int max (final int a, final char b) { return (a < b) ? b : a; } public static int max (final int a, final short b) { return (a < b) ? b : a; } + public static int max (final int a, final char b) { return (a < b) ? b : a; } public static int max (final int a, final int b) { return Math.max(a, b); } public static long max (final int a, final long b) { return (a < b) ? b : a; } public static float max (final int a, final float b) { return (a < b) ? b : a; } public static double max (final int a, final double b) { return (a < b) ? b : a; } public static long max (final long a, final byte b) { return (a < b) ? b : a; } - public static long max (final long a, final char b) { return (a < b) ? b : a; } public static long max (final long a, final short b) { return (a < b) ? b : a; } + public static long max (final long a, final char b) { return (a < b) ? b : a; } public static long max (final long a, final int b) { return (a < b) ? b : a; } public static long max (final long a, final long b) { return Math.max(a, b); } public static float max (final long a, final float b) { return (a < b) ? b : a; } public static double max (final long a, final double b) { return (a < b) ? b : a; } public static float max (final float a, final byte b) { return (a < b) ? b : a; } - public static float max (final float a, final char b) { return (a < b) ? b : a; } public static float max (final float a, final short b) { return (a < b) ? b : a; } + public static float max (final float a, final char b) { return (a < b) ? b : a; } public static float max (final float a, final int b) { return (a < b) ? b : a; } public static float max (final float a, final long b) { return (a < b) ? b : a; } public static float max (final float a, final float b) { return Math.max(a, b); } public static double max (final float a, final double b) { return (a < b) ? b : a; } public static double max (final double a, final byte b) { return (a < b) ? b : a; } - public static double max (final double a, final char b) { return (a < b) ? b : a; } public static double max (final double a, final short b) { return (a < b) ? b : a; } + public static double max (final double a, final char b) { return (a < b) ? b : a; } public static double max (final double a, final int b) { return (a < b) ? b : a; } public static double max (final double a, final long b) { return (a < b) ? b : a; } public static double max (final double a, final float b) { return (a < b) ? b : a; } @@ -726,29 +1080,29 @@ public static long reverseLong (final long x) { // "Infectious": uses the largest data type passed public static byte min (final byte a, final byte b) { return (a > b) ? b : a; } - public static char min (final byte a, final char b) { return (char)((a > b) ? b : a); } public static short min (final byte a, final short b) { return (a > b) ? b : a; } + public static char min (final byte a, final char b) { return (char)((a > b) ? b : a); } public static int min (final byte a, final int b) { return (a > b) ? b : a; } public static long min (final byte a, final long b) { return (a > b) ? b : a; } public static float min (final byte a, final float b) { return (a > b) ? b : a; } public static double min (final byte a, final double b) { return (a > b) ? b : a; } - public static char min (final char a, final byte b) { return (char)((a > b) ? b : a); } - public static char min (final char a, final char b) { return (a > b) ? b : a; } - public static short min (final char a, final short b) { return (short)((a > b) ? b : a); } - public static int min (final char a, final int b) { return (a > b) ? b : a; } - public static long min (final char a, final long b) { return (a > b) ? b : a; } - public static float min (final char a, final float b) { return (a > b) ? b : a; } - public static double min (final char a, final double b) { return (a > b) ? b : a; } public static short min (final short a, final byte b) { return (a > b) ? b : a; } - public static short min (final short a, final char b) { return (short)((a > b) ? b : a); } public static short min (final short a, final short b) { return (a > b) ? b : a; } + public static short min (final short a, final char b) { return (short)((a > b) ? b : a); } public static int min (final short a, final int b) { return (a > b) ? b : a; } public static long min (final short a, final long b) { return (a > b) ? b : a; } public static float min (final short a, final float b) { return (a > b) ? b : a; } public static double min (final short a, final double b) { return (a > b) ? b : a; } + public static char min (final char a, final byte b) { return (char)((a > b) ? b : a); } + public static short min (final char a, final short b) { return (short)((a > b) ? b : a); } + public static char min (final char a, final char b) { return (a > b) ? b : a; } + public static int min (final char a, final int b) { return (a > b) ? b : a; } + public static long min (final char a, final long b) { return (a > b) ? b : a; } + public static float min (final char a, final float b) { return (a > b) ? b : a; } + public static double min (final char a, final double b) { return (a > b) ? b : a; } public static int min (final int a, final byte b) { return (a > b) ? b : a; } - public static int min (final int a, final char b) { return (a > b) ? b : a; } public static int min (final int a, final short b) { return (a > b) ? b : a; } + public static int min (final int a, final char b) { return (a > b) ? b : a; } // Intrinsic; maybe the others could be acclerated in the same way? // TODO maybe use if-optimization? public static int min (final int a, final int b) { return Math.min(a, b); } @@ -756,22 +1110,22 @@ public static long reverseLong (final long x) { public static float min (final int a, final float b) { return (a > b) ? b : a; } public static double min (final int a, final double b) { return (a > b) ? b : a; } public static long min (final long a, final byte b) { return (a > b) ? b : a; } - public static long min (final long a, final char b) { return (a > b) ? b : a; } public static long min (final long a, final short b) { return (a > b) ? b : a; } + public static long min (final long a, final char b) { return (a > b) ? b : a; } public static long min (final long a, final int b) { return (a > b) ? b : a; } public static long min (final long a, final long b) { return Math.min(a, b); } public static float min (final long a, final float b) { return (a > b) ? b : a; } public static double min (final long a, final double b) { return (a > b) ? b : a; } public static float min (final float a, final byte b) { return (a > b) ? b : a; } - public static float min (final float a, final char b) { return (a > b) ? b : a; } public static float min (final float a, final short b) { return (a > b) ? b : a; } + public static float min (final float a, final char b) { return (a > b) ? b : a; } public static float min (final float a, final int b) { return (a > b) ? b : a; } public static float min (final float a, final long b) { return (a > b) ? b : a; } public static float min (final float a, final float b) { return Math.min(a, b); } public static double min (final float a, final double b) { return (a > b) ? b : a; } public static double min (final double a, final byte b) { return (a > b) ? b : a; } - public static double min (final double a, final char b) { return (a > b) ? b : a; } public static double min (final double a, final short b) { return (a > b) ? b : a; } + public static double min (final double a, final char b) { return (a > b) ? b : a; } public static double min (final double a, final int b) { return (a > b) ? b : a; } public static double min (final double a, final long b) { return (a > b) ? b : a; } public static double min (final double a, final float b) { return (a > b) ? b : a; } From 3df8f9c36920d425541114c4ff0ed0a910ca8d18 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 15 Sep 2018 10:32:09 -0600 Subject: [PATCH 250/810] Gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index e0c09fd9..e166b1b1 100644 --- a/.gitignore +++ b/.gitignore @@ -40,3 +40,4 @@ pom.xml.asc .lein-repl-history *.class +*.extract-native-dependencies From 5a6b77d5a19f84aab84e44923b0a6b9b5fcd55ab Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 15 Sep 2018 10:32:15 -0600 Subject: [PATCH 251/810] Remove unnecessary file --- test/quantum/test/core/numeric/types.cljc | 21 --------------------- 1 file changed, 21 deletions(-) delete mode 100644 test/quantum/test/core/numeric/types.cljc diff --git a/test/quantum/test/core/numeric/types.cljc b/test/quantum/test/core/numeric/types.cljc deleted file mode 100644 index f6d55e40..00000000 --- a/test/quantum/test/core/numeric/types.cljc +++ /dev/null @@ -1,21 +0,0 @@ -(ns quantum.test.core.numeric.types - (:require [quantum.core.numeric.types :as ns])) - -(defn test:number [x]) - -(defn test:Integer [x]) - -(defn test:->bigint - ([x])) - -(defn test:ratio [x]) - -(defn test:normalize - [n d]) - -(defn test:->ratio - ([x]) - ([x y])) - -(defn test:numerator [x]) -(defn test:denominator [x]) \ No newline at end of file From f99bb5e1dffcd7365b19c57c9cbd27740e87784b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 15 Sep 2018 10:33:54 -0600 Subject: [PATCH 252/810] Begin work on data.numeric --- resources-dev/defnt.cljc | 11 ++ src-dev/quantum/core/defnt_equivalences.cljc | 16 ++- .../quantum/untyped/core/data/numeric.cljc | 128 ++++++++++++++++++ src-untyped/quantum/untyped/core/type.cljc | 52 ------- src/data_readers.cljc | 2 +- src/quantum/core/compare.cljc | 2 +- src/quantum/core/compare/core.cljc | 6 +- src/quantum/core/convert/primitive.cljc | 13 +- src/quantum/core/data/bits.cljc | 24 ++-- src/quantum/core/numeric.cljc | 8 +- src/quantum/core/numeric/convert.cljc | 14 +- src/quantum/core/numeric/operators.cljc | 14 +- src/quantum/core/numeric/strict_args.cljc | 6 +- src/quantum/core/numeric/types.cljc | 69 +++------- 14 files changed, 212 insertions(+), 153 deletions(-) create mode 100644 src-untyped/quantum/untyped/core/data/numeric.cljc diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 495a1c2e..5f3b0b38 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -63,6 +63,16 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - quantum.core.data.bits - quantum.core.convert.primitive + + - quantum.core.numeric.convert + - quantum.core.numeric.misc + - quantum.core.numeric.operators + - quantum.core.numeric.predicates + - quantum.core.numeric.trig + - quantum.core.numeric.truncate + - quantum.core.data.numeric + - quantum.core.numeric + - quantum.core.string.regex - quantum.core.data.set - quantum.core.macros.type-hint @@ -96,6 +106,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - quantum.untyped.core.data - Standard metadata - e.g. `{:alternate-implementations #{'cljs.tools.reader/merge-meta}}` + - {:adapted-from } - Instead of e.g. `ns-` or `var-` we can do `ns-val` and `var-val` - Should we type `when`, `let`? diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 92b9a1f2..db468bea 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -2,7 +2,7 @@ (ns quantum.core.test.defnt-equivalences (:refer-clojure :exclude - [* count get seq zero?]) + [* count get ratio? seq zero?]) (:require [quantum.untyped.core.type.defnt :refer [defnt fnt unsupported!]] @@ -27,6 +27,8 @@ [quantum.core.data Array] [quantum.core Numeric Primitive])) +(def ratio? (t/isa? clojure.lang.Ratio)) + ;; Just in case (clojure.spec.test.alpha/unstrument) (do (require '[orchestra.spec.test :as st]) @@ -968,7 +970,7 @@ (eval '(do (is (identical? (defnt-reference) 1))))))) (defnt >big-integer > (t/isa? java.math.BigInteger) - ([x t/ratio? > (* (t/isa? java.math.BigInteger))] (.bigIntegerValue x))) + ([x ratio? > (* (t/isa? java.math.BigInteger))] (.bigIntegerValue x))) ;; NOTE would use `>long` but that's already an interface (deftest test|>long-checked @@ -991,7 +993,7 @@ ;; TODO add this back in #_(fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] (.longValue x)) - ([x t/ratio?] (-> x >big-integer >long-checked)) + ([x ratio?] (-> x >big-integer >long-checked)) ([x (t/value true)] 1) ([x (t/value false)] 0) ([x t/string?] (Long/parseLong x)) @@ -1081,10 +1083,10 @@ (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] (let* [~(tag "java.math.BigInteger" 'x) ~'x] ~'(.longValue x))))) - #_[x t/ratio?] + #_[x ratio?] #_(def ~'>long|__9|input-types - (*<> t/ratio?)) + (*<> ratio?)) #_(def ~'>long|__9|conditions (*<> (-> long|__8|input-types (core/get 0) utr/and-type>args (core/get 1)))) (def ~'>long|__9 @@ -1097,7 +1099,7 @@ ;; - `(t/and (t/or t/double? t/float?) ...)` -> t/<> ;; - `(t/and (t/isa? clojure.lang.BigInt) ...)` -> t/<> ;; - `(t/and (t/isa? java.math.BigInteger) ...)` -> t/> - ;; - `t/ratio?` -> t/<> + ;; - `ratio?` -> t/<> ;; - `(t/value true)` -> t/<> ;; - `(t/value false)` -> t/<> ;; - `t/string?` -> t/<> @@ -1157,7 +1159,7 @@ (fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] [(t/and (t/isa? java.math.BigInteger) (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] - [t/ratio?] + [ratio?] [(t/value true)] [(t/value false)] [t/string?] diff --git a/src-untyped/quantum/untyped/core/data/numeric.cljc b/src-untyped/quantum/untyped/core/data/numeric.cljc new file mode 100644 index 00000000..4631c3d3 --- /dev/null +++ b/src-untyped/quantum/untyped/core/data/numeric.cljc @@ -0,0 +1,128 @@ +(ns quantum.core.data.numeric + (:refer-clojure :exclude + [#?@(:cljs [-compare]) decimal? denominator integer? number? numerator ratio? + read-string]) + (:require + [clojure.core :as core] + [clojure.string :as str] + [clojure.tools.reader + :refer [read-string]] + #?(:cljs [com.gfredericks.goog.math.Integer :as int]) + [quantum.core.data.primitive :as p] + [quantum.core.logic + :refer [whenf fn-not fn=]] + [quantum.core.type :as t + :refer [defnt]] + [quantum.core.vars + :refer [defalias]]) + (:import + [clojure.lang BigInt Numbers] + [java.math BigDecimal BigInteger]) +#?(:cljs (:require-macros + [quantum.core.data.numeric :as self]))) + +;; ===== Integers ===== ;; + +#?(:clj (def big-integer? (t/isa? BigInteger))) + +#?(:clj (def clj-bigint? (t/isa? clojure.lang.BigInt))) + +(def bigint? #?(:clj (t/or clj-bigint? big-integer?) + :cljs (t/isa? com.gfredericks.goog.math.Integer))) + +(def integer? (t/or #?@(:clj [p/byte? p/short? p/int? p/long?]) bigint?)) + +#?(:clj +(defnt >big-integer > big-integer? + ([x big-integer?] x) + ([x clj-bigint? > (t/* big-integer?)] (.toBigInteger x)) + ([; TODO TYPED `(- number? BigInteger BigInt)` + x (t/or p/short? p/int? p/long?) > (t/* big-integer?)] ; TODO BigDecimal + (-> x p/>long (BigInteger/valueOf))))) + +#?(:cljs +(defnt >bigint > bigint? + ([x bigint?] x) + ([x t/string?] (int/fromString x)) + ([x p/double?] (-> x (.toString) >bigint)))) + +;; ===== Decimals ===== ;; + +#?(:clj (def bigdec? (t/isa? BigDecimal))) ; TODO CLJS may have this + +;; ===== Ratios ===== ;; + +(def ratio? (t/isa? #?(:clj clojure.lang.Ratio :cljs quantum.core.data.numeric.Ratio))) + +#?(:clj +(defnt rationalize + "Outputs the rational value of `n`." + {:adapted-from 'clojure.lang.Numbers/rationalize} + > (t/isa? java.lang.Number) + ([x (t/or p/float? p/double?)] + (rationalize (BigDecimal/valueOf (p/>double x)))) + ([x (t/isa? BigDecimal)] + (let [bv (.unscaledValue x) + scale (.scale x)] + (if (< scale 0) + (BigInt/fromBigInteger (.multiply bv (.pow BigInteger.TEN (- scale)))) + (Numbers/divide bv (.pow BigInteger.TEN scale))))) + ([x (t/isa? java.lang.Number)] x))) + +(defnt >ratio > ratio? + ([x ??] (>ratio x #?(:clj 1 :cljs int/ONE))) + ([x ??, y ??] + #?(:clj (whenf (rationalize (/ x y)) + (fn-not core/ratio?) + #(clojure.lang.Ratio. (->big-integer %) java.math.BigInteger/ONE)) + :cljs (let [x (>bigint x) + y (>bigint y) + d (gcd x y) + x' (.divide x d) + y' (.divide y d)] + (if (.isNegative y') + (Ratio. (.negate x') (.negate y')) + (Ratio. x' y')))))) + +;; ===== General ===== ;; + +(def decimal? (or #?(:clj p/float?) p/double? #?(:clj bigdec?))) + +;; ===== Likenesses ===== ;; + +#_(-def integer-value? (or integer? (and decimal? (>expr unum/integer-value?)))) + +#_(-def numeric-primitive? (and primitive? (not boolean?))) + +#_(-def numerically-byte? (and integer-value? (>expr (c/fn [x] (c/<= -128 x 127))))) +#_(-def numerically-short? (and integer-value? (>expr (c/fn [x] (c/<= -32768 x 32767))))) +#_(-def numerically-char? (and integer-value? (>expr (c/fn [x] (c/<= 0 x 65535))))) +#_(-def numerically-unsigned-short? numerically-char?) +#_(-def numerically-int? (and integer-value? (>expr (c/fn [x] (c/<= -2147483648 x 2147483647))))) +#_(-def numerically-long? (and integer-value? (>expr (c/fn [x] (c/<= -9223372036854775808 x 9223372036854775807))))) +#_(-def numerically-float? (and number? + (>expr (c/fn [x] (c/<= -3.4028235E38 x 3.4028235E38))) + (>expr (c/fn [x] (-> x #?(:clj clojure.lang.RT/floatCast :cljs c/float) (c/== x)))))) +#_(-def numerically-double? (and number? + (>expr (c/fn [x] (c/<= -1.7976931348623157E308 x 1.7976931348623157E308))) + (>expr (c/fn [x] (-> x clojure.lang.RT/doubleCast (c/== x)))))) + +#_(-def int-like? (and integer-value? numerically-int?)) + +#_(defn numerically + [t] + (assert (utr/class-type? t)) + (let [c (.-c ^ClassType t)] + (case (.getName ^Class c) + "java.lang.Byte" numerically-byte? + "java.lang.Short" numerically-short? + "java.lang.Character" numerically-char? + "java.lang.Integer" numerically-int? + "java.lang.Long" numerically-long? + "java.lang.Float" numerically-float? + ;; TODO fix + ;;"java.lang.Double" numerically-double? + (err! "Could not find numerical range type for class" {:c c})))) + +(def number? (t/or #?@(:clj [(t/isa? java.lang.Number)] + :cljs [integer? decimal? ratio?]))) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index fb667d17..6ca129b5 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -637,63 +637,11 @@ ;; ----- Integers ----- ;; - (-def bigint? #?(:clj (or (isa? clojure.lang.BigInt) (isa? java.math.BigInteger)) - :cljs (isa? com.gfredericks.goog.math.Integer))) - - (-def integer? (or #?@(:clj [byte? short? int? long?]) bigint?)) - -;; ----- Decimals ----- ;; - -#?(:clj (-def bigdec? (isa? java.math.BigDecimal))) ; TODO CLJS may have this - - (-def decimal? (or #?(:clj float?) double? #?(:clj bigdec?))) ;; ----- General ----- ;; - (-def ratio? (isa? #?(:clj clojure.lang.Ratio - :cljs quantum.core.numeric.types.Ratio))) ; TODO add this CLJS entry to the predicate after the fact - (-def primitive-number? (or #?@(:clj [short? int? long? float?]) double?)) - (-def number? (or #?@(:clj [(isa? java.lang.Number)] - :cljs [integer? decimal? ratio?]))) - -;; ----- Likenesses ----- ;; - - #_(-def integer-value? (or integer? (and decimal? (>expr unum/integer-value?)))) - - #_(-def numeric-primitive? (and primitive? (not boolean?))) - - #_(-def numerically-byte? (and integer-value? (>expr (c/fn [x] (c/<= -128 x 127))))) - #_(-def numerically-short? (and integer-value? (>expr (c/fn [x] (c/<= -32768 x 32767))))) - #_(-def numerically-char? (and integer-value? (>expr (c/fn [x] (c/<= 0 x 65535))))) - #_(-def numerically-unsigned-short? numerically-char?) - #_(-def numerically-int? (and integer-value? (>expr (c/fn [x] (c/<= -2147483648 x 2147483647))))) - #_(-def numerically-long? (and integer-value? (>expr (c/fn [x] (c/<= -9223372036854775808 x 9223372036854775807))))) - #_(-def numerically-float? (and number? - (>expr (c/fn [x] (c/<= -3.4028235E38 x 3.4028235E38))) - (>expr (c/fn [x] (-> x #?(:clj clojure.lang.RT/floatCast :cljs c/float) (c/== x)))))) - #_(-def numerically-double? (and number? - (>expr (c/fn [x] (c/<= -1.7976931348623157E308 x 1.7976931348623157E308))) - (>expr (c/fn [x] (-> x clojure.lang.RT/doubleCast (c/== x)))))) - - #_(-def int-like? (and integer-value? numerically-int?)) - -#_(defn numerically - [t] - (assert (utr/class-type? t)) - (let [c (.-c ^ClassType t)] - (case (.getName ^Class c) - "java.lang.Byte" numerically-byte? - "java.lang.Short" numerically-short? - "java.lang.Character" numerically-char? - "java.lang.Integer" numerically-int? - "java.lang.Long" numerically-long? - "java.lang.Float" numerically-float? - ;; TODO fix - ;;"java.lang.Double" numerically-double? - (err! "Could not find numerical range type for class" {:c c})))) - ;; ========== Collections ========== ;; ;; ===== Tuples ===== ;; diff --git a/src/data_readers.cljc b/src/data_readers.cljc index eb60bbe4..5a981107 100644 --- a/src/data_readers.cljc +++ b/src/data_readers.cljc @@ -1 +1 @@ -{r quantum.core.numeric.types/read-rational} +{r quantum.core.data.numeric/read-rational} diff --git a/src/quantum/core/compare.cljc b/src/quantum/core/compare.cljc index a479e34c..f69c17d4 100644 --- a/src/quantum/core/compare.cljc +++ b/src/quantum/core/compare.cljc @@ -23,7 +23,7 @@ :refer [- -' + abs inc div:natural]] [quantum.core.numeric.predicates :as pred :refer [neg? pos? zero?]] - [quantum.core.numeric.types :as ntypes] + [quantum.core.data.numeric :as dnum] [quantum.core.reducers :as red :refer [reduce, transduce]] [quantum.core.vars diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index 13385150..31fd321c 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -19,7 +19,7 @@ :refer [->num ->num&]] [quantum.core.convert.primitive :as pconv :refer [->boxed ->boolean ->long]] - [quantum.core.numeric.types :as ntypes]) + [quantum.core.data.numeric :as dnum]) #?(:cljs (:require-macros [quantum.core.compare.core :as self @@ -85,7 +85,7 @@ ([^prim? x y] (.equals ^Object y x))) :cljs (defn =-bin ([x] true) - ([x y] (TODO "fix") (core/zero? (ntypes/-compare x y))))) + ([x y] (TODO "fix") (core/zero? (dnum/-compare x y))))) #?(:clj (variadic-predicate-proxy = =-bin )) #?(:clj (variadic-predicate-proxy =& =-bin&)) @@ -94,7 +94,7 @@ ([#{#_Object prim?} x #{#_Object prim?} y] (Numeric/not (=-bin& x y)))) ; TODO make this one operation; TODO can only work with inline :cljs (defn not=-bin ([x] false) - ([x y] (TODO "fix") (not (core/zero? (ntypes/-compare x y)))))) + ([x y] (TODO "fix") (not (core/zero? (dnum/-compare x y)))))) #?(:clj (variadic-predicate-proxy not= not=-bin )) #?(:clj (variadic-predicate-proxy not=& not=-bin&)) diff --git a/src/quantum/core/convert/primitive.cljc b/src/quantum/core/convert/primitive.cljc index c0479c9a..b6b1a383 100644 --- a/src/quantum/core/convert/primitive.cljc +++ b/src/quantum/core/convert/primitive.cljc @@ -4,9 +4,7 @@ [clojure.core :as core] [quantum.core.data.bits :as bits :refer [&&]] - [quantum.core.error :as err - :refer [>ex-info]] - [quantum.core.type-old :as t + [quantum.core.type :as t :refer [defnt]] [quantum.core.vars :as var :refer [defalias]]) @@ -25,7 +23,7 @@ ;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° #?(:clj (defmacro long-out-of-range [x] - `(throw (>ex-info :illegal-argument (str "Value out of range for long: " ~x))))) + `(throw (ex-info (str "Value out of range for long: " ~x) {:type :illegal-argument})))) #?(:clj (defnt >long* @@ -47,7 +45,7 @@ (if (< (.bitLength x) 64) (.longValue x) (long-out-of-range x))) - ([x t/ratio?] (->long (.bigIntegerValue x))) + ([x dnum/ratio?] (->long (.bigIntegerValue x))) ([x (t/or t/char? t/byte? t/short? t/int? t/long?)] (>long* x)) ([x t/float?] (clojure.lang.RT/longCast x)) ; Because primitive casting in Clojure is not supported ; TODO fix ([x t/double?] (clojure.lang.RT/longCast x)) ; TODO fix @@ -64,7 +62,8 @@ (defmacro cast-via-long [class- x] `(let [n# (->long ~x)] (if (or (< n# ~(list '. class- 'MIN_VALUE)) (> n# ~(list '. class- 'MAX_VALUE))) - (throw (>ex-info :illegal-argument (str ~(str "value out of range for " (name class-) ": ") ~x))) + (throw (ex-info (str ~(str "value out of range for " (name class-) ": ") ~x) + {:type :illegal-argument})) n#)))) ;_____________________________________________________________________ ;==================={ BOOLEAN }====================== @@ -112,7 +111,7 @@ ([#{byte short char int long float double} x] (Primitive/uncheckedCharCast x)) ([^string? x] (if (->> x .length (= 1)) (.charAt x 0) - (throw (>ex-info "Cannot cast non-singleton string to char." x)))))) + (throw (ex-info "Cannot cast non-singleton string to char." {:string x})))))) ;_____________________________________________________________________ ;==================={ SHORT }====================== ;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° diff --git a/src/quantum/core/data/bits.cljc b/src/quantum/core/data/bits.cljc index 6e3186ab..79750a97 100644 --- a/src/quantum/core/data/bits.cljc +++ b/src/quantum/core/data/bits.cljc @@ -2,17 +2,17 @@ ^{:doc "Useful bit/binary operations." :attribution "alexandergunnarson"} quantum.core.data.bits - (:refer-clojure :exclude - [unsigned-bit-shift-right bit-shift-left bit-shift-right - bit-or bit-and bit-xor bit-not]) - (:require - [clojure.core :as core ] - [quantum.core.type :as t - :refer [defnt]] - [quantum.core.vars :as var - :refer [defalias]]) - #?(:clj (:import #_[quantum.core Numeric] - java.nio.ByteBuffer))) + (:refer-clojure :exclude + [and not or]) + (:require + [clojure.core :as core] + [quantum.core.type :as t + :refer [defnt]] + [quantum.core.vars :as var + :refer [defalias]]) +#?(:clj (:import + [quantum.core Numeric] + #_java.nio.ByteBuffer))) ; Because "cannot resolve symbol 'import'" #?(:clj @@ -59,6 +59,8 @@ #_(macros/variadic-proxy bool-or quantum.core.Numeric/or) ; || #_(macros/variadic-proxy bool-xor quantum.core.Numeric/xor) +(defnt not ) + (defalias bit-not core/bit-not) (defalias bit-and core/bit-and) (defalias && bit-and) ; tried to do `& but, "No method in multimethod 'parse' for dispatch value: &" diff --git a/src/quantum/core/numeric.cljc b/src/quantum/core/numeric.cljc index 8fcd652d..c846af69 100644 --- a/src/quantum/core/numeric.cljc +++ b/src/quantum/core/numeric.cljc @@ -12,6 +12,7 @@ [[com.gfredericks.goog.math.Integer :as int]]) [quantum.core.convert.primitive :as pconvert :refer [#?(:clj ->long)]] + [quantum.core.data.numeric :as dnum] [quantum.core.error :as err :refer [>err err! TODO]] [quantum.core.fn @@ -30,8 +31,7 @@ [quantum.core.numeric.predicates] [quantum.core.numeric.trig ] [quantum.core.numeric.truncate :as trunc - :include-macros true] - [quantum.core.numeric.types :as ntypes]) + :include-macros true]) #?(:cljs (:require-macros [quantum.core.numeric :as self])) @@ -185,8 +185,8 @@ ; ===== NON-TRANSFORMATIVE OPERATIONS ===== ; -(defalias numerator ntypes/numerator) -(defalias denominator ntypes/denominator) +(defalias numerator dnum/numerator) +(defalias denominator dnum/denominator) ;_____________________________________________________________________ ;==================={ CONVERT }====================== ;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° diff --git a/src/quantum/core/numeric/convert.cljc b/src/quantum/core/numeric/convert.cljc index 3d943287..f1d64837 100644 --- a/src/quantum/core/numeric/convert.cljc +++ b/src/quantum/core/numeric/convert.cljc @@ -2,13 +2,13 @@ (:refer-clojure :exclude [bigdec]) (:require [clojure.core :as core] + [quantum.core.data.numeric :as dnum] [quantum.core.error :as err :refer [TODO]] [quantum.core.macros - :refer [defnt #?@(:clj [defnt'])]] + :refer [defnt #?@(:clj [defnt'])]] [quantum.core.vars - :refer [defalias]] - [quantum.core.numeric.types :as ntypes]) + :refer [defalias]]) #?(:cljs (:require-macros [quantum.core.numeric.convert :as self])) @@ -23,7 +23,7 @@ (defn ->boolean-num [x] (if x 1 0)) -#?(:clj (defalias ->big-integer ntypes/->big-integer)) +#?(:clj (defalias ->big-integer dnum/->big-integer)) #?(:clj (defnt' ^BigInt ->bigint ([^BigInt x] x) @@ -31,7 +31,7 @@ ([^long x] (-> x BigInt/fromLong)) ([^string? x radix] (->bigint (BigInteger. x (int radix)))) ([#{double? Number} x] (-> x BigInteger/valueOf ->bigint))) - :cljs (defalias ->bigint ntypes/->bigint)) + :cljs (defalias ->bigint dnum/->bigint)) #?(:clj (doto (defalias ->bigdec core/bigdec) (alter-meta! assoc :tag BigDecimal)) #_(defnt' ^BigDecimal ->bigdec @@ -46,7 +46,7 @@ ([#{(- number? :curr)} x] (BigDecimal/valueOf x))) :cljs (defn ->bigdec [x] (TODO))) -#?(:clj (defalias ->ratio ntypes/->ratio) +#?(:clj (defalias ->ratio dnum/->ratio) #_(defnt ^clojure.lang.Ratio ->ratio ([^clojure.lang.Ratio x] x) ([^java.math.BigDecimal x] @@ -59,7 +59,7 @@ BigInteger/ONE) (Ratio. bv (-> BigInteger/TEN (.pow scale)))))) ([^Object x] (-> x ->big-integer (Ratio. BigInteger/ONE)))) - :cljs (defalias ->ratio ntypes/->ratio)) + :cljs (defalias ->ratio dnum/->ratio)) #?(:clj (defnt exactly diff --git a/src/quantum/core/numeric/operators.cljc b/src/quantum/core/numeric/operators.cljc index c5781d63..0c7d1bb9 100644 --- a/src/quantum/core/numeric/operators.cljc +++ b/src/quantum/core/numeric/operators.cljc @@ -7,13 +7,13 @@ [clojure.core :as core] #?(:cljs [com.gfredericks.goog.math.Integer :as int]) + [quantum.core.data.numeric :as dnum + :refer [numerator denominator]] [quantum.core.error :as err :refer [TODO]] [quantum.core.log :as log] [quantum.core.macros :refer [defnt defntp #?@(:clj [defnt' variadic-proxy])]] - [quantum.core.numeric.types :as ntypes - :refer [numerator denominator]] [quantum.core.numeric.convert :as conv :refer [->bigint #?@(:clj [->big-integer])]] [quantum.core.type-old :as t @@ -54,7 +54,7 @@ (if (nil? *math-context*) (.add x y) (.add x y *math-context*))) - #?(:cljs ([x y] (TODO) (ntypes/-add x y)))) + #?(:cljs ([x y] (TODO) (dnum/-add x y)))) :cljs (defalias +*-bin unchecked-add)) #?(:clj (variadic-proxy +* quantum.core.numeric.operators/+*-bin )) @@ -81,7 +81,7 @@ #?(:clj (defnt' -*-bin "Lax `-`. Continues on overflow/underflow." #?(:clj ([#{byte char short int long float double} x] (Numeric/negate x)) - :cljs (^first [^double? x] (TODO "fix") (ntypes/-negate x))) + :cljs (^first [^double? x] (TODO "fix") (dnum/-negate x))) ([#{byte char short int long float double} #_(- prim? boolean) x #{byte char short int long float double} #_(- prim? boolean) y] (Numeric/subtract x y)) @@ -133,7 +133,7 @@ :cljs (defn **-bin "Lax `*`. Continues on overflow/underflow." ([] 0) ([x] x) - ([x y] (TODO "fix") (ntypes/-multiply x y)))) + ([x y] (TODO "fix") (dnum/-multiply x y)))) #?(:clj (variadic-proxy ** quantum.core.numeric.operators/**-bin )) #?(:clj (variadic-proxy **& quantum.core.numeric.operators/**-bin&)) @@ -189,11 +189,11 @@ (.divide n d) (.divide n d *math-context*)))) :cljs (defnt div*-bin "Lax `/`. Continues on overflow/underflow." - ([^ratio? x ] (TODO "fix") (ntypes/-invert x)) + ([^ratio? x ] (TODO "fix") (dnum/-invert x)) ([^ratio? x y] (TODO "fix") ;(* x (-invert (apply * y more))) - (* x (ntypes/-invert y))) + (* x (dnum/-invert y))) ([^double? x ] (core// x)) ([^double? x y] (div*-bin- x y)))) diff --git a/src/quantum/core/numeric/strict_args.cljc b/src/quantum/core/numeric/strict_args.cljc index f4c1a539..244de5a9 100644 --- a/src/quantum/core/numeric/strict_args.cljc +++ b/src/quantum/core/numeric/strict_args.cljc @@ -10,6 +10,7 @@ #?@(:clj [bigint biginteger bigdec numerator denominator inc' dec'])]) (:require [clojure.core :as c] + [quantum.core.data.numeric :as dnum] [quantum.core.vars :as var :refer [defalias defaliases]] [quantum.core.numeric.convert ] @@ -17,11 +18,10 @@ [quantum.core.numeric.operators :as op] [quantum.core.numeric.predicates] [quantum.core.numeric.trig ] - [quantum.core.numeric.truncate :as trunc] - [quantum.core.numeric.types :as ntypes]) + [quantum.core.numeric.truncate :as trunc]) #?(:cljs (:require-macros - [quantum.core.numeric.strict-args :as self])) + [quantum.core.numeric.strict-args :as self])) #?(:clj (:import [java.nio ByteBuffer] diff --git a/src/quantum/core/numeric/types.cljc b/src/quantum/core/numeric/types.cljc index 462accce..ce1fa7ed 100644 --- a/src/quantum/core/numeric/types.cljc +++ b/src/quantum/core/numeric/types.cljc @@ -1,32 +1,20 @@ (ns quantum.core.numeric.types - (:refer-clojure :exclude - [denominator numerator ratio? #?@(:cljs [-compare]) read-string]) - (:require - [clojure.core :as core] - [clojure.string :as str] - [clojure.tools.reader - :refer [read-string]] - #?(:cljs - [com.gfredericks.goog.math.Integer :as int]) - [quantum.core.macros - :refer [defnt]] - [quantum.core.logic - :refer [whenf fn-not fn=]] - [quantum.core.vars - :refer [defalias]] - [quantum.core.error - :refer [>ex-info]]) -#?(:cljs - (:require-macros - [quantum.core.numeric.types :as self]))) - -#?(:clj -(defnt ^java.math.BigInteger ->big-integer - ([^java.math.BigInteger x] x) - ([^clojure.lang.BigInt x] (.toBigInteger x)) - ([;#{(- number? BigInteger BigInt)} x - #{short int long} x] ; TODO BigDecimal - (-> x core/long (BigInteger/valueOf))))) + (:refer-clojure :exclude + [denominator numerator ratio? #?@(:cljs [-compare]) read-string]) + (:require + [clojure.core :as core] + [clojure.string :as str] + [clojure.tools.reader + :refer [read-string]] + #?(:cljs [com.gfredericks.goog.math.Integer :as int]) + [quantum.core.logic + :refer [whenf fn-not fn=]] + [quantum.core.type + :refer [defnt]] + [quantum.core.vars + :refer [defalias]]) +#?(:cljs (:require-macros + [quantum.core.numeric.types :as self]))) (declare gcd) (declare normalize) @@ -77,11 +65,6 @@ IHash (-hash [this] (reduce bit-xor 899242490 (.-bits_ this))) IComparable (-compare [x y] (-compare x y)))) -#?(:cljs -(defnt ^com.gfredericks.goog.math.Integer ->bigint - ([^bigint? x] x) - ([^string? x] (int/fromString x)) - ([^double? x] (-> x str ->bigint)))) #?(:cljs (deftype Ratio [n d] @@ -144,20 +127,7 @@ n (->ratio n d))))) -(defn ->ratio - ([x] (->ratio x #?(:clj 1 :cljs int/ONE))) - ([x y] - #?(:clj (whenf (rationalize (/ x y)) - (fn-not core/ratio?) - #(clojure.lang.Ratio. (->big-integer %) java.math.BigInteger/ONE)) - :cljs (let [x (->bigint x) - y (->bigint y) - d (gcd x y) - x' (.divide x d) - y' (.divide y d)] - (if (.isNegative y') - (Ratio. (.negate x') (.negate y')) - (Ratio. x' y')))))) + #?(:clj (defalias numerator core/numerator) :cljs (defnt numerator @@ -190,10 +160,10 @@ (->> r-str rest (apply str)))) [integral-str decimal-str :as split] (str/split r-str #"\.") _ (when (-> split count (> 2)) - (throw (>ex-info "Number cannot have more than one decimal point" {:num r-str}))) + (throw (ex-info "Number cannot have more than one decimal point" {:num r-str}))) _ (doseq [s split] (when-not (every? #{\0 \1 \2 \3 \4 \5 \6 \7 \8 \9} s) - (throw (>ex-info "Number must have only numeric characters" {:num s})))) + (throw (ex-info "Number must have only numeric characters" {:num s})))) integral (read-string integral-str) decimal (read-string decimal-str) scale (if decimal @@ -202,4 +172,3 @@ (* (if (= minus-ct 1) -1 1) (->ratio (+ (* scale integral) (or decimal 0)) scale)))) - From e58ec0be859fa6aaf528b07cecc6824ff3a73c90 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 15 Sep 2018 12:00:32 -0600 Subject: [PATCH 253/810] Add some todos --- resources-dev/defnt.cljc | 2 ++ 1 file changed, 2 insertions(+) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 5f3b0b38..f4730c56 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -5,6 +5,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - t/... + - multi-arity `t/-` - t/assume - t/numerically - t/of @@ -61,6 +62,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - quantum.core.spec - quantum.core.error - quantum.core.data.bits + - quantum.core.data.string — this is where `>str` belongs - quantum.core.convert.primitive From ceebc0ee8e6120050df160032be8b469138cda4c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 15 Sep 2018 12:02:04 -0600 Subject: [PATCH 254/810] Move around some references to primitive types --- src-dev/quantum/core/defnt_equivalences.cljc | 115 ++++++++++-------- src-untyped/quantum/untyped/core/type.cljc | 39 ++---- src/quantum/ai/ml/validation.cljc | 5 +- .../core/analyze/clojure/predicates.cljc | 3 +- src/quantum/core/async/pool.cljc | 3 +- src/quantum/core/collections/core.cljc | 3 +- src/quantum/core/convert/primitive.cljc | 104 ++++++++-------- src/quantum/core/data/bits.cljc | 4 +- src/quantum/core/data/primitive.cljc | 21 ++-- src/quantum/core/string.cljc | 29 ++--- src/quantum/core/type.cljc | 4 +- src/quantum/db/datomic.cljc | 14 +-- src/quantum/db/datomic/core.cljc | 57 ++++----- 13 files changed, 199 insertions(+), 202 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index db468bea..f7a92385 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -2,7 +2,7 @@ (ns quantum.core.test.defnt-equivalences (:refer-clojure :exclude - [* count get ratio? seq zero?]) + [* boolean? char? count double? float? get int? ratio? seq zero?]) (:require [quantum.untyped.core.type.defnt :refer [defnt fnt unsupported!]] @@ -27,7 +27,20 @@ [quantum.core.data Array] [quantum.core Numeric Primitive])) -(def ratio? (t/isa? clojure.lang.Ratio)) +#?(:clj (def ratio? (t/isa? clojure.lang.Ratio))) + +#?(:clj (def boolean? (t/isa? #?(:clj Boolean :cljs js/Boolean)))) +#?(:clj (def byte? (t/isa? Byte))) +#?(:clj (def short? (t/isa? Short))) +#?(:clj (def char? (t/isa? Character))) +#?(:clj (def int? (t/isa? Integer))) +#?(:clj (def long? (t/isa? Long))) +#?(:clj (def float? (t/isa? Float))) + (def double? (t/isa? #?(:clj Double :cljs js/Number))) + + (def primitive? (t/or boolean? #?@(:clj [byte? short? char? int? long? float?]) double?)) + +#?(:clj (def comparable-primitive? (t/- primitive? boolean?))) ;; Just in case (clojure.spec.test.alpha/unstrument) @@ -308,13 +321,13 @@ (let [actual (macroexpand ' (defnt #_:inline >boolean - ([x t/boolean?] x) + ([x boolean?] x) ([x t/nil?] false) ([x t/any?] true))) expected (case (env-lang) :clj - ($ (do ;; [x t/boolean?] + ($ (do ;; [x boolean?] (def ~(tag "[Ljava.lang.Object;" '>boolean|__0|input0|types) (*<> (t/isa? Boolean))) @@ -322,7 +335,7 @@ (reify* [boolean>boolean] (~(tag "boolean" 'invoke) [~'_0__ ~(tag "boolean" 'x)] ~'x))) - ;; [x t/nil? -> (- t/nil? t/boolean?)] + ;; [x t/nil? -> (- t/nil? boolean?)] (def ~(tag "[Ljava.lang.Object;" '>boolean|__1|input0|types) (*<> (t/value nil))) @@ -330,7 +343,7 @@ (reify* [Object>boolean] (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false))) - ;; [x t/any? -> (- t/any? t/nil? t/boolean?)] + ;; [x t/any? -> (- t/any? t/nil? boolean?)] (def ~(tag "[Ljava.lang.Object;" '>boolean|__2|input0|types) (*<> t/any?)) @@ -350,7 +363,7 @@ (defn ~'>boolean {:quantum.core.type/type (t/fn t/any? - ~'[t/boolean?] + ~'[boolean?] ~'[t/nil?] ~'[t/any?])} ([~'x00__] @@ -387,13 +400,13 @@ (macroexpand ' ;; Auto-upcasts to long or double (because 64-bit) unless you tell it otherwise ;; Will error if not all return values can be safely converted to the return spec - (defnt #_:inline >int* > t/int? - ([x (t/- t/primitive? t/boolean?)] (Primitive/uncheckedIntCast x)) + (defnt #_:inline >int* > int? + ([x (t/- primitive? boolean?)] (Primitive/uncheckedIntCast x)) ([x (t/ref (t/isa? Number))] (.intValue x)))) expected (case (env-lang) :clj - ($ (do ;; [x (t/- t/primitive? t/boolean?)] + ($ (do ;; [x (t/- primitive? boolean?)] ;; These are non-primitivized (def ~(tag "[Ljava.lang.Object;" '>int*|__0|input0|types) @@ -434,7 +447,7 @@ ~'(. Primitive uncheckedIntCast x)))) ;; [x (t/ref (t/isa? Number)) - ;; -> (t/- (t/ref (t/isa? Number)) (t/- t/primitive? t/boolean?))] + ;; -> (t/- (t/ref (t/isa? Number)) (t/- primitive? boolean?))] (def ~(tag "[Ljava.lang.Object;" '>int*|__1|input0|types) (*<> ~(with-meta `(t/isa? Number) {:ref? true}))) @@ -446,7 +459,7 @@ (defn ~'>int* {:quantum.core.type/type (t/fn ~'t/int? - ~'[(t/- t/primitive? t/boolean?)] + ~'[(t/- primitive? boolean?)] ~'[(t/ref (t/isa? Number))])} ([~'x00__] (ifs ((Array/get ~'>int*|__0|input0|types 0) ~'x00__) @@ -486,14 +499,14 @@ (defnt #_:inline >|test ;; This is admittedly a place where inference might be nice, but luckily ;; there are no "sparse" combinations - #?(:clj ([a t/comparable-primitive? b t/comparable-primitive? > t/boolean?] + #?(:clj ([a comparable-primitive? b comparable-primitive? > boolean?] (Numeric/gt a b)) - :cljs ([a t/double? b t/double? > (t/assume t/boolean?)] + :cljs ([a double? b double? > (t/assume boolean?)] (cljs.core/> a b))))) expected (case (env-lang) :clj - ($ (do ;; [a t/comparable-primitive? b t/comparable-primitive? > t/boolean?] + ($ (do ;; [a t/comparable-primitive? b t/comparable-primitive? > boolean?] ;; These are non-primitivized (def ~(tag "[Ljava.lang.Object;" '>|test|__0|input0|types) @@ -713,10 +726,10 @@ (defn ~'>|test {:quantum.core.type/type (t/fn t/any? - #?(:clj ~'[t/comparable-primitive? t/comparable-primitive? - :> t/boolean?] - :cljs ~'[t/double? t/double? - :> (t/assume t/boolean?)]))} + #?(:clj ~'[comparable-primitive? comparable-primitive? + :> boolean?] + :cljs ~'[double? double? + :> (t/assume boolean?)]))} ([~'x00__ ~'x10__] (ifs ((Array/get ~'>|test|__0|input0|types 0) ~'x00__) @@ -859,12 +872,12 @@ (macroexpand ' (defnt #_:inline >long* {:source "clojure.lang.RT.uncheckedLongCast"} - > t/long? - ([x (t/- t/primitive? t/boolean?)] (Primitive/uncheckedLongCast x)) + long? + ([x (t/- primitive? boolean?)] (Primitive/uncheckedLongCast x)) ([x (t/ref (t/isa? Number))] (.longValue x)))) expected (case (env-lang) - :clj ($ (do ;; [x (t/- t/primitive? t/boolean?)] + :clj ($ (do ;; [x (t/- primitive? boolean?)] (def ~(tag "[Ljava.lang.Object;" '>long*|__0|input0|types) (*<> (t/isa? java.lang.Byte) @@ -915,8 +928,8 @@ (defn ~'>long* {:source "clojure.lang.RT.uncheckedLongCast" :quantum.core.type/type - (t/fn ~'t/long? - ~'[(t/- t/primitive? t/boolean?)] + (t/fn ~'long? + ~'[(t/- primitive? boolean?)] ~'[(t/ref (t/isa? Number))])} ([~'x00__] (ifs @@ -978,10 +991,10 @@ (macroexpand ' (defnt >long-checked {:source "clojure.lang.RT.longCast"} - > t/long? + > long? ;; TODO multi-arity `t/-` - ([x (t/- (t/- (t/- t/primitive? t/boolean?) t/float?) t/double?)] (>long* x)) - ([x (t/and (t/or t/double? t/float?) + ([x (t/- (t/- (t/- primitive? boolean?) float?) double?)] (>long* x)) + ([x (t/and (t/or double? float?) ;; TODO add this back in #_(fnt [x (t/or t/double? t/float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] (>long* x)) @@ -997,52 +1010,52 @@ ([x (t/value true)] 1) ([x (t/value false)] 0) ([x t/string?] (Long/parseLong x)) - ([x t/string?, radix t/int?] (Long/parseLong x radix)))) + ([x t/string?, radix int?] (Long/parseLong x radix)))) expected (case (env-lang) - :clj ($ (do #_[x (t/- t/primitive? t/boolean? t/float? t/double?)] + :clj ($ (do #_[x (t/- primitive? boolean? float? double?)] - #_(def ~'>long|__0|input-types (*<> t/byte?)) + #_(def ~'>long|__0|input-types (*<> byte?)) (def ~'>long|__0 (reify byte>long (~(tag "long" 'invoke) [_## ~(tag "byte" 'x)] ;; Resolved from `(>long* x)` (.invoke >long*|__0 ~'x)))) - #_(def ~'>long|__1|input-types (*<> t/char?)) + #_(def ~'>long|__1|input-types (*<> char?)) (def ~'>long|__1 (reify char>long (~(tag "long" 'invoke) [_## ~(tag "char" 'x)] ;; Resolved from `(>long* x)` (.invoke >long*|__1 ~'x)))) - #_(def ~'>long|__2|input-types (*<> t/short?)) + #_(def ~'>long|__2|input-types (*<> short?)) (def ~'>long|__2 (reify short>long (~(tag "long" 'invoke) [_## ~(tag "short" 'x)] ;; Resolved from `(>long* x)` (.invoke >long*|__2 ~'x)))) - #_(def ~'>long|__3|input-types (*<> t/int?)) + #_(def ~'>long|__3|input-types (*<> int?)) (def ~'>long|__3 (reify int>long (~(tag "long" 'invoke) [_## ~(tag "int" 'x)] ;; Resolved from `(>long* x)` (.invoke >long*|__3 ~'x)))) - #_(def ~'>long|__4|input-types (*<> t/long?)) + #_(def ~'>long|__4|input-types (*<> long?)) (def ~'>long|__4 (reify long>long (~(tag "long" 'invoke) [_## ~(tag "long" 'x)] ;; Resolved from `(>long* x)` (.invoke >long*|__4 ~'x)))) - #_[x (t/and (t/or t/double? t/float?) + #_[x (t/and (t/or double? float?) (fnt [x (t/or double? float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] #_(def ~'>long|__5|input-types - (*<> (t/and t/double? + (*<> (t/and double? (fnt [x (t/or double? float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE)))))) (def ~'>long|__5 @@ -1095,14 +1108,14 @@ (let* [~(tag "clojure.lang.Ratio" 'x) ~'x] ;; Resolved from `(>long (.bigIntegerValue x))` ;; In this case, `(t/compare (type-of '(.bigIntegerValue x)) overload-type)`: - ;; - `(t/- t/primitive? t/boolean? t/float? t/double?)` -> t/<> - ;; - `(t/and (t/or t/double? t/float?) ...)` -> t/<> - ;; - `(t/and (t/isa? clojure.lang.BigInt) ...)` -> t/<> - ;; - `(t/and (t/isa? java.math.BigInteger) ...)` -> t/> - ;; - `ratio?` -> t/<> - ;; - `(t/value true)` -> t/<> - ;; - `(t/value false)` -> t/<> - ;; - `t/string?` -> t/<> + ;; - `(t/- primitive? boolean? float? double?)` -> t/<> + ;; - `(t/and (t/or double? float?) ...)` -> t/<> + ;; - `(t/and (t/isa? clojure.lang.BigInt) ...)` -> t/<> + ;; - `(t/and (t/isa? java.math.BigInteger) ...)` -> t/> + ;; - `ratio?` -> t/<> + ;; - `(t/value true)` -> t/<> + ;; - `(t/value false)` -> t/<> + ;; - `t/string?` -> t/<> ;; ;; Since there is no overload that results in t/<, no compile-time match can ;; be found, but a possible runtime match lies in the overload that results in @@ -1142,7 +1155,7 @@ #_[x t/string?] #_(def ~'>long|__13|input-types - (*<> t/string? t/int?)) + (*<> t/string? int?)) (def ~'>long|__13 (reify Object+int>long (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x) ~(tag "int" 'radix)] @@ -1151,7 +1164,7 @@ #_(defn >long {:quantum.core.type/type (t/fn - [(t/- t/primitive? t/boolean? t/float? t/double?)] + [(t/- primitive? boolean? float? double?)] [(t/and (t/or t/double? t/float?) (fnt [x (t/or double? float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] @@ -1163,7 +1176,7 @@ [(t/value true)] [(t/value false)] [t/string?] - [t/string? t/int?])} + [t/string? int?])} ([x0##] (ifs ((Array/get >long|__0|input-types 0) x0##) (.invoke >long|__0 x0##) ((Array/get >long|__1|input-types 0) x0##) @@ -1196,7 +1209,7 @@ ;; If we had combined this arity, `t/or`ing the `t/string?` means it wouldn't have been ;; handled any differently than `t/char-seq?` #?(:clj ([x t/string?] (StringBuilder. x))) - ([x #?(:clj (t/or t/char-seq? t/int?) + ([x #?(:clj (t/or t/char-seq? int?) :cljs t/val?)] #?(:clj (StringBuilder. x) :cljs (StringBuffer. x))))) expected @@ -1235,7 +1248,7 @@ (t/fn ~'(t/isa? StringBuilder) ~'[] ~'[t/string?] - ~'[(t/or t/char-seq? t/int?)])} + ~'[(t/or t/char-seq? int?)])} ([] (.invoke ~(tag "quantum.core.test.defnt_equivalences.>Object" '!str|__0|0))) ([~'x00__] @@ -1399,8 +1412,8 @@ ;; =====|=====|=====|=====|===== ;; -(defnt zero? > t/boolean? - ([x (t/- t/primitive? t/boolean?)] (Numeric/isZero x))) +(defnt zero? > boolean? + ([x (t/- primitive? boolean?)] (Numeric/isZero x))) ; TODO CLJS version will come after #?(:clj diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 6ca129b5..0946e766 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -599,34 +599,16 @@ #?(:clj (-def protocol? (>expr (ufn/fn-> :on-interface class?)))) ;; ===== Primitives ===== ;; +;; NOTE these are kept here because they're used in both type analysis and various test namespaces - (-def boolean? (isa? #?(:clj Boolean :cljs js/Boolean))) - (-def ?boolean? (? boolean?)) - -#?(:clj (-def byte? (isa? Byte))) -#?(:clj (-def ?byte? (? byte?))) - -#?(:clj (-def char? (isa? Character))) -#?(:clj (-def ?char? (? char?))) - -#?(:clj (-def short? (isa? Short))) -#?(:clj (-def ?short? (? short?))) - -#?(:clj (-def int? (isa? Integer))) -#?(:clj (-def ?int? (? int?))) - -#?(:clj (-def long? (isa? Long))) -#?(:clj (-def ?long? (? long?))) - -#?(:clj (-def float? (isa? Float))) -#?(:clj (-def ?float? (? float?))) - - (-def double? (isa? #?(:clj Double :cljs js/Number))) - (-def ?double? (? double?)) - - (-def primitive? (or boolean? #?@(:clj [byte? short? char? int? long? float?]) double?)) - -#?(:clj (-def comparable-primitive? (- primitive? boolean?))) + (-def boolean? (isa? #?(:clj Boolean :cljs js/Boolean))) +#?(:clj (-def byte? (isa? Byte))) +#?(:clj (-def char? (isa? Character))) +#?(:clj (-def short? (isa? Short))) +#?(:clj (-def int? (isa? Integer))) +#?(:clj (-def long? (isa? Long))) +#?(:clj (-def float? (isa? Float))) + (-def double? (isa? #?(:clj Double :cljs js/Number))) ;; ===== Booleans ===== ;; @@ -635,9 +617,6 @@ ;; ===== Numbers ===== ;; -;; ----- Integers ----- ;; - - ;; ----- General ----- ;; (-def primitive-number? (or #?@(:clj [short? int? long? float?]) double?)) diff --git a/src/quantum/ai/ml/validation.cljc b/src/quantum/ai/ml/validation.cljc index 7477dcda..ed9615f1 100644 --- a/src/quantum/ai/ml/validation.cljc +++ b/src/quantum/ai/ml/validation.cljc @@ -9,6 +9,7 @@ contains?, subset?, assoc-default, count]] [quantum.core.compare :as comp :refer [reduce-min reduce-max]] + [quantum.core.data.primitive :as p] [quantum.core.data.validated :as dv] [quantum.core.data.vector :refer [!vector]] @@ -67,14 +68,14 @@ ^{:doc "Will be passed 3 args, `model`, `instance`, `output`."} (def :this/accuracyf fn?) ; TODO must return a number, accept 3 args, etc. ^{:doc "Whether to shuffle the instances+targets before using the sliding window. Defaults to `true`"} - (def :this/shuffle? (fn1 t/boolean?)) + (def :this/shuffle? (fn1 p/boolean?)) (def :this/compute-for (s/and (fn1 t/+set?) (fn1 subset? #{:train :validation})))] :opt-un [^{:doc "Number of iterations"} (def :this/n (fn1 t/integer?)) ^{:doc "Desired ratio of training instances to validation instances"} (def :this/training-ratio (s/and (fn1 t/number?) (fn1 > 0) (fn1 < 1))) ^{:doc "Whether to report the accuracies per split instead of calling `mean` on them"} - (def :this/verbose? (fn1 t/boolean?))]) + (def :this/verbose? (fn1 p/boolean?))]) (defn n-fold-cross-validation "Assumes `instances` and `targets` have same length and correspond to each other. diff --git a/src/quantum/core/analyze/clojure/predicates.cljc b/src/quantum/core/analyze/clojure/predicates.cljc index 029c2e30..9ca5636a 100644 --- a/src/quantum/core/analyze/clojure/predicates.cljc +++ b/src/quantum/core/analyze/clojure/predicates.cljc @@ -7,6 +7,7 @@ #?(:clj [clojure.jvm.tools.analyzer :as tana]) [quantum.core.analyze.clojure.core :as ana] + [quantum.core.data.primitive :as p] [quantum.core.fn :as fn :refer [fnl <- fn-> fn->> fn']] [quantum.core.logic :as logic @@ -50,7 +51,7 @@ (fn-and symbol? (fn-or (fn= 'default) (fn-> name (str-index-of "?") (not= -1)))))) (def hinted-literal? - (fn-or #?(:clj char?) number? string? vector? map? nil? keyword? ubit/boolean? ustr/regex?)) + (fn-or #?(:clj char?) number? string? vector? map? nil? keyword? p/boolean? ustr/regex?)) ; ===== SCOPE ===== (defn shadows-var? [bindings v] diff --git a/src/quantum/core/async/pool.cljc b/src/quantum/core/async/pool.cljc index 77386a75..a1fcf42c 100644 --- a/src/quantum/core/async/pool.cljc +++ b/src/quantum/core/async/pool.cljc @@ -10,6 +10,7 @@ :refer [close! go-loop put!]] [quantum.core.core :as qcore] [quantum.core.data.map :as map] + [quantum.core.data.primitive :as p] [quantum.core.data.set :as set] [quantum.core.data.validated :as dv] [quantum.core.fn @@ -534,7 +535,7 @@ threadpool-f (atom (or threadpool (->pool :fixed max-threads-f))) threadpool-interrupted? (doto (atom false) - (set-validator! (fn1 t/boolean?)) + (set-validator! (fn1 p/boolean?)) (add-watch :interrupt-monitor (fn [_ _ _ newv] (when (true? newv) diff --git a/src/quantum/core/collections/core.cljc b/src/quantum/core/collections/core.cljc index 35680934..fde541d3 100644 --- a/src/quantum/core/collections/core.cljc +++ b/src/quantum/core/collections/core.cljc @@ -26,6 +26,7 @@ ->long* ->float* ->double*])]] + [quantum.core.data.primitive :as p] [quantum.core.data.string :refer [!str]] [quantum.core.data.vector :as vec @@ -131,7 +132,7 @@ ;; TODO for O(1) reversible inputs, you can just do that with `drop+` ;; TODO this is not suitable for `fold` contexts {:attribution "Christophe Grand - http://grokbase.com/t/gg/clojure/1388ev2krx/butlast-with-reducers"} - [n (t/numerically t/int?), xs t/reducible? > t/reducible?] + [n (t/numerically p/int?), xs t/reducible? > t/reducible?] (let [n' (>int n)] (r/transformer xs (fnt [rf r/rf?] diff --git a/src/quantum/core/convert/primitive.cljc b/src/quantum/core/convert/primitive.cljc index b6b1a383..0952fc24 100644 --- a/src/quantum/core/convert/primitive.cljc +++ b/src/quantum/core/convert/primitive.cljc @@ -1,26 +1,24 @@ (ns quantum.core.convert.primitive - (:require + (:require #?(:cljs [com.gfredericks.goog.math.Integer :as int]) - [clojure.core :as core] - [quantum.core.data.bits :as bits - :refer [&&]] - [quantum.core.type :as t - :refer [defnt]] - [quantum.core.vars :as var - :refer [defalias]]) -#?(:cljs - (:require-macros - [quantum.core.convert.primitive])) -#?(:clj - (:import - java.nio.ByteBuffer - [quantum.core Numeric Primitive]))) + [clojure.core :as core] + [quantum.core.data.bits :as bits + :refer [&&]] + [quantum.core.data.primitive :as p] + [quantum.core.type :as t + :refer [defnt]] + [quantum.core.vars :as var + :refer [defalias]]) +#?(:cljs (:require-macros + [quantum.core.convert.primitive])) +#?(:clj (:import + [java.nio ByteBuffer] + [quantum.core Numeric Primitive]))) ; TODO go back over these — there are inconsistencies -;_____________________________________________________________________ -;==================={ LONG }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° +;; ===== Long ===== ;; + #?(:clj (defmacro long-out-of-range [x] `(throw (ex-info (str "Value out of range for long: " ~x) {:type :illegal-argument})))) @@ -28,15 +26,14 @@ #?(:clj (defnt >long* {:source "clojure.lang.RT.uncheckedLongCast"} - > t/long? - ([x (t/or t/byte? t/char? t/short? t/int? t/long? t/float? t/double?)] - (Primitive/uncheckedLongCast x)) + > p/long? + ([x (t/- p/primitive? p/boolean?)] (Primitive/uncheckedLongCast x)) ([x (t/ref (t/isa? Number))] (.longValue x))))) #?(:clj (defnt >long {:source "clojure.lang.RT.longCast"} - > t/long? + > p/long? ([x (t/isa? clojure.lang.BigInt)] (if (nil? (.bipart x)) (.lpart x) @@ -46,17 +43,17 @@ (.longValue x) (long-out-of-range x))) ([x dnum/ratio?] (->long (.bigIntegerValue x))) - ([x (t/or t/char? t/byte? t/short? t/int? t/long?)] (>long* x)) - ([x t/float?] (clojure.lang.RT/longCast x)) ; Because primitive casting in Clojure is not supported ; TODO fix - ([x t/double?] (clojure.lang.RT/longCast x)) ; TODO fix - ([x t/boolean?] (if x 1 0)) + ([x (t/or p/char? p/byte? p/short? p/int? p/long?)] (>long* x)) + ([x p/float?] (clojure.lang.RT/longCast x)) ; Because primitive casting in Clojure is not supported ; TODO fix + ([x p/double?] (clojure.lang.RT/longCast x)) ; TODO fix + ([x p/boolean?] (if x 1 0)) ([x t/string?] (-> x Long/parseLong >long)) - ([x t/string?, radix t/int?] (Long/parseLong x radix))) + ([x t/string?, radix p/int?] (Long/parseLong x radix))) :cljs - (defnt >long > (t/range-of t/long?) - ([x t/double?] (js/Math.trunc x)) + (defnt >long > (t/range-of p/long?) + ([x p/double?] (js/Math.trunc x)) ([x t/string?] (-> x int/fromString >long)) - ([x t/boolean?] (if x 1 0)))) + ([x p/boolean?] (if x 1 0)))) #?(:clj (defmacro cast-via-long [class- x] @@ -65,18 +62,18 @@ (throw (ex-info (str ~(str "value out of range for " (name class-) ": ") ~x) {:type :illegal-argument})) n#)))) -;_____________________________________________________________________ -;==================={ BOOLEAN }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° + +;; ===== Boolean ===== ;; + #?(:clj (defnt ^boolean ->boolean {:source "clojure.lang.RT.booleanCast"} ([^boolean x] x) ([#{byte char short int long float double Object} x] (.booleanValue (not= x nil)))) ; TODO #{(- prim? boolean) Object} :cljs (defalias ->boolean core/boolean)) -;_____________________________________________________________________ -;==================={ BYTE }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° + +;; ===== Byte ===== ;; + #?(:clj (defnt ^byte ->byte {:source "clojure.lang.RT.byteCast"} @@ -92,9 +89,9 @@ {:source "clojure.lang.RT.uncheckedByteCast"} ([^Number x] (.byteValue x)) ([#{byte short int long float double} x] (Primitive/uncheckedByteCast x)))) -;_____________________________________________________________________ -;==================={ CHAR }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° + +;; ===== Char ===== ;; + ; TODO reflection issues ; (defnt ^char ->char ; {:source "clojure.lang.RT.charCast"} @@ -112,9 +109,9 @@ ([^string? x] (if (->> x .length (= 1)) (.charAt x 0) (throw (ex-info "Cannot cast non-singleton string to char." {:string x})))))) -;_____________________________________________________________________ -;==================={ SHORT }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° + +;; ===== Short ===== ;; + #?(:clj (defnt ^short ->short* {:source "clojure.lang.RT.uncheckedShortCast"} @@ -129,9 +126,9 @@ ([^string? x] (-> x Short/parseShort ->short)) ([#{boolean} x] (-> x ->long ->short))) :cljs (defalias ->short core/short)) -;_____________________________________________________________________ -;==================={ INT }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° + +;; ===== Int ===== ;; + #?(:clj (defnt ^int ->int* {:source "clojure.lang.RT.uncheckedIntCast"} @@ -152,9 +149,8 @@ :cljs (defalias ->int core/int)) ; js/Math.trunc for CLJS -;_____________________________________________________________________ -;==================={ FLOAT }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° + +;; ===== Float ===== ;; #?(:clj (defnt ^float ->float* @@ -172,9 +168,9 @@ ; round to float: (js.Math/fround x) #?(:clj (defalias ->float core/float)) -;_____________________________________________________________________ -;==================={ DOUBLE }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° + +;; ===== Double ===== ;; + #?(:clj (defnt ^double ->double* {:source "clojure.lang.RT/uncheckedDoubleCast"} @@ -215,9 +211,9 @@ (^long ^:intrinsic [^Long x] (.longValue x)) (^float ^:intrinsic [^Float x] (.floatValue x)) (^double ^:intrinsic [^Double x] (.doubleValue x)))) -;_____________________________________________________________________ -;==================={ UNSIGNED }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° + +;; ===== Unsigned ===== ;; + #?(:clj (def ^:const bytes2 (->short 0xFF))) #?(:clj (def ^:const bytes4 (->int 0xFFFF))) #?(:clj (def ^:const bytes8 (->long 0xFFFFFFFF))) diff --git a/src/quantum/core/data/bits.cljc b/src/quantum/core/data/bits.cljc index 79750a97..a7fdc719 100644 --- a/src/quantum/core/data/bits.cljc +++ b/src/quantum/core/data/bits.cljc @@ -51,7 +51,6 @@ #?(:clj (defalias false? core/false?)) -#_(defmacro bit-not [x] `(Numeric/bitNot ~x)) #_(macros/variadic-proxy bit-and quantum.core.Numeric/bitAnd) ; & #_(macros/variadic-proxy bit-or quantum.core.Numeric/bitOr) ; | #_(macros/variadic-proxy bit-xor quantum.core.Numeric/bitXor) @@ -59,9 +58,8 @@ #_(macros/variadic-proxy bool-or quantum.core.Numeric/or) ; || #_(macros/variadic-proxy bool-xor quantum.core.Numeric/xor) -(defnt not ) +(defnt ^:inline not []) -(defalias bit-not core/bit-not) (defalias bit-and core/bit-and) (defalias && bit-and) ; tried to do `& but, "No method in multimethod 'parse' for dispatch value: &" (defalias bit-or core/bit-or) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 8b73c800..385a6042 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -1,6 +1,6 @@ (ns quantum.core.data.primitive (:refer-clojure :exclude - [char? double? float? int?]) + [boolean? char? double? float? int?]) (:require [quantum.core.type :as t :refer [defnt]] @@ -11,13 +11,18 @@ ;; ===== Predicates ===== ;; -#?(:clj (def byte? (t/isa? Byte))) -#?(:clj (def short? (t/isa? Short))) -#?(:clj (def char? (t/isa? Character))) -#?(:clj (def int? (t/isa? Integer))) -#?(:clj (def long? (t/isa? Long))) -#?(:clj (def float? (t/isa? Float))) - (def double? (t/isa? #?(:clj Double :cljs js/Number))) +#?(:clj (def boolean? (t/isa? #?(:clj Boolean :cljs js/Boolean)))) +#?(:clj (def byte? (t/isa? Byte))) +#?(:clj (def short? (t/isa? Short))) +#?(:clj (def char? (t/isa? Character))) +#?(:clj (def int? (t/isa? Integer))) +#?(:clj (def long? (t/isa? Long))) +#?(:clj (def float? (t/isa? Float))) + (def double? (t/isa? #?(:clj Double :cljs js/Number))) + + (def primitive? (t/or boolean? #?@(:clj [byte? short? char? int? long? float?]) double?)) + +#?(:clj (def comparable-primitive? (t/- primitive? boolean?))) ;; ===== Class relationships ===== ;; diff --git a/src/quantum/core/string.cljc b/src/quantum/core/string.cljc index e0d58c52..d0dae7c4 100644 --- a/src/quantum/core/string.cljc +++ b/src/quantum/core/string.cljc @@ -10,31 +10,32 @@ (:refer-clojure :exclude [reverse replace remove val re-find reduce]) (:require - [clojure.core :as core] - [clojure.string :as str] + [clojure.core :as core] + [clojure.string :as str] [frak] - [cuerdas.core :as str+] - [quantum.core.data.map :as map] - [quantum.core.data.set :as set] + [cuerdas.core :as str+] + [quantum.core.data.primitive :as p] + [quantum.core.data.map :as map] + [quantum.core.data.set :as set] [quantum.core.error :refer [>ex-info]] - [quantum.core.fn :as fn + [quantum.core.fn :as fn :refer [fn-> fn1 rfn fnl]] - [quantum.core.logic :as logic + [quantum.core.logic :as logic :refer [fn-and whenc whenc1 ifn condf]] - [quantum.core.loops :as loops + [quantum.core.loops :as loops :refer [reduce reducei]] - [quantum.core.macros :as macros + [quantum.core.macros :as macros :refer [defnt defnt']] [quantum.core.collections.core :refer [contains? containsv?]] [quantum.core.collections.logic :refer [seq-and]] - [quantum.core.string.format :as form] - [quantum.core.string.regex :as regex] - [quantum.core.vars :as var + [quantum.core.string.format :as form] + [quantum.core.string.regex :as regex] + [quantum.core.vars :as var :refer [defalias]] - [quantum.core.type-old :as t + [quantum.core.type-old :as t :refer [val?]]) #?(:cljs (:require-macros @@ -402,7 +403,7 @@ (defn properize-key [k v] (let [k-0 (keywordize k) - k-f (if (t/boolean? v) + k-f (if (p/boolean? v) (keyword+ k-0 "?") k-0)] k-f)) diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index 8e8bd28e..c7837c21 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -1,7 +1,7 @@ (ns quantum.core.type "This is this the namespace upon which all other fully-typed namespaces rest." (:refer-clojure :exclude - [* and any? fn isa? or ref seq? symbol? var?]) + [* - and any? fn isa? or ref seq? symbol? var?]) (:require [quantum.untyped.core.type.defnt :as udefnt] [quantum.untyped.core.type :as ut] @@ -16,7 +16,7 @@ ;; Generators ? * isa? fn ref ;; Combinators - and or + and or - ;; Predicates any? none? diff --git a/src/quantum/db/datomic.cljc b/src/quantum/db/datomic.cljc index 8db82b18..1b9c6b74 100644 --- a/src/quantum/db/datomic.cljc +++ b/src/quantum/db/datomic.cljc @@ -120,9 +120,9 @@ (let [history-limit (validate (or history-limit #?(:clj Integer/MAX_VALUE :cljs js/Number.MAX_SAFE_INTEGER)) integer?) - reactive? (validate (default reactive? true ) (fn1 t/boolean?)) - set-main-conn? (validate (default set-main-conn? false) (fn1 t/boolean?)) - set-main-part? (validate (default set-main-part? false) (fn1 t/boolean?)) + reactive? (validate (default reactive? true ) (fn1 p/boolean?)) + set-main-conn? (validate (default set-main-conn? false) (fn1 p/boolean?)) + set-main-part? (validate (default set-main-part? false) (fn1 p/boolean?)) _ (validate conn nil?)] (try (log/pr ::debug "EPHEMERAL:" (kw-map post schemas set-main-conn? reactive?)) @@ -275,10 +275,10 @@ name (validate (or name "test") (s/and string? (fn1 contains?))) host (validate (or host "localhost") (s/and string? (fn1 contains?))) port (validate (or port 4334) integer?) ; TODO `net/valid-port?` - create? (validate (default create? false) (fn1 t/boolean?)) - create-if-not-present? (validate (default create-if-not-present? true ) (fn1 t/boolean?)) - set-main-conn? (validate (default set-main-conn? false) (fn1 t/boolean?)) - set-main-part? (validate (default set-main-part? false) (fn1 t/boolean?)) + create? (validate (default create? false) (fn1 p/boolean?)) + create-if-not-present? (validate (default create-if-not-present? true ) (fn1 p/boolean?)) + set-main-conn? (validate (default set-main-conn? false) (fn1 p/boolean?)) + set-main-part? (validate (default set-main-part? false) (fn1 p/boolean?)) default-partition (validate (or default-partition :db.part/test) (s/and keyword? (fn-> namespace (= "db.part")))) conn (validate (or conn (atom nil)) t/atom?) connection-retries (validate (or (if (= type :dynamo) 1 5)) integer?) ; DynamoDB auto-retries diff --git a/src/quantum/db/datomic/core.cljc b/src/quantum/db/datomic/core.cljc index 44f0ac6a..44d1fe78 100644 --- a/src/quantum/db/datomic/core.cljc +++ b/src/quantum/db/datomic/core.cljc @@ -5,37 +5,38 @@ update merge if-let for doseq nth filter contains?]) (:require - [clojure.core :as c] + [clojure.core :as c] #?@(:clj - [[datomic.api :as db]]) - [datascript.core :as mdb] - [com.stuartsierra.component :as comp] - [quantum.core.collections :as coll + [[datomic.api :as db]]) + [datascript.core :as mdb] + [com.stuartsierra.component :as comp] + [quantum.core.collections :as coll :refer [join for kw-map val? contains? filter+ filter-vals+ filter-vals', remove-vals+, map+, remove+ remove', nth group-by+ prewalk postwalk merge-deep dissoc-in doseq]] - [quantum.core.core :as qcore] - [quantum.core.async :as async + [quantum.core.core :as qcore] + [quantum.core.async :as async :refer [! >!!]] - [quantum.core.data.set :as set] - [quantum.core.error :as err + [quantum.core.data.primitive :as p] + [quantum.core.data.set :as set] + [quantum.core.error :as err :refer [>ex-info >err TODO catch-all]] - [quantum.core.fn :as fn + [quantum.core.fn :as fn :refer [<- fn-> fn->> fn1 fnl fn' rfn with-do]] - [quantum.core.log :as log] - [quantum.core.logic :as logic + [quantum.core.log :as log] + [quantum.core.logic :as logic :refer [fn-not fn-and fn-or whenf whenf1 ifn ifn1 if-let condf1]] - [quantum.core.print :as pr] - [quantum.core.resources :as res] - [quantum.core.process :as proc] + [quantum.core.print :as pr] + [quantum.core.resources :as res] + [quantum.core.process :as proc] [quantum.core.convert.primitive :as pconv :refer [->long]] - [quantum.core.vars :as var + [quantum.core.vars :as var :refer [defalias]] - [quantum.core.data.validated :as dv] - [quantum.core.spec :as s + [quantum.core.data.validated :as dv] + [quantum.core.spec :as s :refer [validate]] - [quantum.core.type-old :as t] + [quantum.core.type-old :as t] [quantum.untyped.core.identification :refer [>?name]]) #?(:clj @@ -322,18 +323,18 @@ (dv/def -ref (s/or* :db/id :db/ident dbfn-call?)) ; TODO look over this more (dv/def -keyword (s/or* keyword? dbfn-call?)) (dv/def -string (s/or* string? dbfn-call?)) -(dv/def -boolean (s/or* (fn1 t/boolean?) dbfn-call?)) +(dv/def -boolean (s/or* (fn1 p/boolean?) dbfn-call?)) (dv/def -long (s/or* #?(:clj (fn-or (fnl instance? Long ) - (fnl instance? Integer) - (fnl instance? Short )) #_long? + (fnl instance? Integer) + (fnl instance? Short )) #_long? :cljs c/integer?) ; TODO CLJS |long?| ; TODO autocast from e.g. bigint if safe to do so dbfn-call?)) (dv/def -bigint (s/or* (fn1 t/bigint?) dbfn-call?)) -(dv/def -float (s/or* #?(:clj (fn1 t/float?) +(dv/def -float (s/or* #?(:clj (fn1 p/float?) :cljs number?) dbfn-call?)) ; TODO CLJS |float?| -(dv/def -double (s/or* #?(:clj (fn1 t/double?) +(dv/def -double (s/or* #?(:clj (fn1 p/double?) :cljs number?) dbfn-call?)) (dv/def -bigdec (s/or* #?(:clj (fnl instance? BigDecimal) #_bigdec? @@ -419,10 +420,10 @@ (def :datomic:schema/type allowed-types) (def :datomic:schema/cardinality #{:one :many})] :opt-un [(def :datomic:schema/doc string?) - (def :datomic:schema/component? (fn1 t/boolean?)) - (def :datomic:schema/index? (fn1 t/boolean?)) - (def :datomic:schema/full-text? (fn1 t/boolean?)) - (def :datomic:schema/no-history? (fn1 t/boolean?)) + (def :datomic:schema/component? (fn1 p/boolean?)) + (def :datomic:schema/index? (fn1 p/boolean?)) + (def :datomic:schema/full-text? (fn1 p/boolean?)) + (def :datomic:schema/no-history? (fn1 p/boolean?)) (def :datomic:schema/unique #{:identity :value})]) ; TODO for datascript: From 41d9780e56c9ca9ab5666411c8b43c57d84c2d83 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 15 Sep 2018 12:02:11 -0600 Subject: [PATCH 255/810] Ignore .swp --- .gitignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.gitignore b/.gitignore index e166b1b1..70c8ea6d 100644 --- a/.gitignore +++ b/.gitignore @@ -41,3 +41,4 @@ pom.xml.asc *.class *.extract-native-dependencies +*.swp From 30c401dcff8a6a0d365c879006d4b24430888779 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 15 Sep 2018 12:02:24 -0600 Subject: [PATCH 256/810] Incorporate quantum-java subproject --- project-base.clj | 3 +- .../quantum/core/Collections.java | 0 .../java => src-java}/quantum/core/Core.java | 0 .../java => src-java}/quantum/core/Fn.java | 0 .../quantum/core/Numeric.java | 0 .../quantum/core/Primitive.java | 0 .../quantum/core/data/Array.java | 0 .../core/data/queue/LinkedBlockingQueue.java | 0 .../data/streams/ByteBufferInputStream.java | 0 .../core/data/streams/InputStream.java | 0 .../quantum/core/error/Error.java | 0 .../quantum/misc}/ClassIntrospector.java | 48 +++++++++---------- .../quantum/misc}/ObjectInfo.java | 24 +++++----- .../quantum/misc}/Packed12.java | 12 ++--- .../quantum/misc}/PackedBase.java | 18 +++---- src/quantum/core/io/compress.cljc | 2 +- src/quantum/core/meta/profile.cljc | 3 +- subprojects/quantum-java/pom.xml.asc | 16 ------- subprojects/quantum-java/project.clj | 17 ------- 19 files changed, 55 insertions(+), 88 deletions(-) rename {subprojects/quantum-java/src/java => src-java}/quantum/core/Collections.java (100%) rename {subprojects/quantum-java/src/java => src-java}/quantum/core/Core.java (100%) rename {subprojects/quantum-java/src/java => src-java}/quantum/core/Fn.java (100%) rename {subprojects/quantum-java/src/java => src-java}/quantum/core/Numeric.java (100%) rename {subprojects/quantum-java/src/java => src-java}/quantum/core/Primitive.java (100%) rename {subprojects/quantum-java/src/java => src-java}/quantum/core/data/Array.java (100%) rename {subprojects/quantum-java/src/java => src-java}/quantum/core/data/queue/LinkedBlockingQueue.java (100%) rename {subprojects/quantum-java/src/java => src-java}/quantum/core/data/streams/ByteBufferInputStream.java (100%) rename {subprojects/quantum-java/src/java => src-java}/quantum/core/data/streams/InputStream.java (100%) rename {subprojects/quantum-java/src/java => src-java}/quantum/core/error/Error.java (100%) rename {subprojects/quantum-java/src/java/quanta => src-java/quantum/misc}/ClassIntrospector.java (99%) rename {subprojects/quantum-java/src/java/quanta => src-java/quantum/misc}/ObjectInfo.java (99%) rename {subprojects/quantum-java/src/java/quanta => src-java/quantum/misc}/Packed12.java (98%) rename {subprojects/quantum-java/src/java/quanta => src-java/quantum/misc}/PackedBase.java (98%) delete mode 100644 subprojects/quantum-java/pom.xml.asc delete mode 100644 subprojects/quantum-java/project.clj diff --git a/project-base.clj b/project-base.clj index 2f73ea3e..50e519a5 100644 --- a/project-base.clj +++ b/project-base.clj @@ -167,7 +167,6 @@ [org.clojure/math.combinatorics "0.1.3" ] [net.mikera/core.matrix "0.57.0" :exclusions [org.clojure/clojure]] - [quantum/java "1.8.2" ] [uncomplicate/neanderthal "0.8.0" ] ; BLAS ; ==== PRINT ==== [fipp "0.6.10" @@ -703,7 +702,7 @@ ;; ===== Paths ===== ;; :target-path "target" :test-paths ["test"] - :source-paths ["src"] + :source-paths ["src" "src-java"] ;; ===== Compilation ===== ;; :jar-name (str artifact-base-name "-dep.jar") :uberjar-name (str artifact-base-name ".jar") diff --git a/subprojects/quantum-java/src/java/quantum/core/Collections.java b/src-java/quantum/core/Collections.java similarity index 100% rename from subprojects/quantum-java/src/java/quantum/core/Collections.java rename to src-java/quantum/core/Collections.java diff --git a/subprojects/quantum-java/src/java/quantum/core/Core.java b/src-java/quantum/core/Core.java similarity index 100% rename from subprojects/quantum-java/src/java/quantum/core/Core.java rename to src-java/quantum/core/Core.java diff --git a/subprojects/quantum-java/src/java/quantum/core/Fn.java b/src-java/quantum/core/Fn.java similarity index 100% rename from subprojects/quantum-java/src/java/quantum/core/Fn.java rename to src-java/quantum/core/Fn.java diff --git a/subprojects/quantum-java/src/java/quantum/core/Numeric.java b/src-java/quantum/core/Numeric.java similarity index 100% rename from subprojects/quantum-java/src/java/quantum/core/Numeric.java rename to src-java/quantum/core/Numeric.java diff --git a/subprojects/quantum-java/src/java/quantum/core/Primitive.java b/src-java/quantum/core/Primitive.java similarity index 100% rename from subprojects/quantum-java/src/java/quantum/core/Primitive.java rename to src-java/quantum/core/Primitive.java diff --git a/subprojects/quantum-java/src/java/quantum/core/data/Array.java b/src-java/quantum/core/data/Array.java similarity index 100% rename from subprojects/quantum-java/src/java/quantum/core/data/Array.java rename to src-java/quantum/core/data/Array.java diff --git a/subprojects/quantum-java/src/java/quantum/core/data/queue/LinkedBlockingQueue.java b/src-java/quantum/core/data/queue/LinkedBlockingQueue.java similarity index 100% rename from subprojects/quantum-java/src/java/quantum/core/data/queue/LinkedBlockingQueue.java rename to src-java/quantum/core/data/queue/LinkedBlockingQueue.java diff --git a/subprojects/quantum-java/src/java/quantum/core/data/streams/ByteBufferInputStream.java b/src-java/quantum/core/data/streams/ByteBufferInputStream.java similarity index 100% rename from subprojects/quantum-java/src/java/quantum/core/data/streams/ByteBufferInputStream.java rename to src-java/quantum/core/data/streams/ByteBufferInputStream.java diff --git a/subprojects/quantum-java/src/java/quantum/core/data/streams/InputStream.java b/src-java/quantum/core/data/streams/InputStream.java similarity index 100% rename from subprojects/quantum-java/src/java/quantum/core/data/streams/InputStream.java rename to src-java/quantum/core/data/streams/InputStream.java diff --git a/subprojects/quantum-java/src/java/quantum/core/error/Error.java b/src-java/quantum/core/error/Error.java similarity index 100% rename from subprojects/quantum-java/src/java/quantum/core/error/Error.java rename to src-java/quantum/core/error/Error.java diff --git a/subprojects/quantum-java/src/java/quanta/ClassIntrospector.java b/src-java/quantum/misc/ClassIntrospector.java similarity index 99% rename from subprojects/quantum-java/src/java/quanta/ClassIntrospector.java rename to src-java/quantum/misc/ClassIntrospector.java index e85356f4..e1857a93 100644 --- a/subprojects/quantum-java/src/java/quanta/ClassIntrospector.java +++ b/src-java/quantum/misc/ClassIntrospector.java @@ -1,12 +1,12 @@ -package quanta; +package quantum.misc; import sun.misc.Unsafe; - + import java.lang.reflect.Array; import java.lang.reflect.Field; import java.lang.reflect.Modifier; import java.math.BigDecimal; import java.util.*; - + /** * This class could be used for any object contents/memory layout printing. */ @@ -25,11 +25,11 @@ public static void main(String[] args) throws IllegalAccessException { //res = ci.introspect( new String[] { "str1", "str2" } ); //res = ci.introspect(ObjectInfo.class); //res = ci.introspect( new TestObj() ); - + System.out.println( res.getDeepSize() ); System.out.println( res ); } - + /** First test object - testing various arrays and complex objects */ private static class TestObj { @@ -37,7 +37,7 @@ private static class TestObj protected final int[] ints = { 14, 16 }; private final Integer i = 28; protected final BigDecimal bigDecimal = BigDecimal.ONE; - + @Override public String toString() { return "TestObj{" + @@ -48,13 +48,13 @@ public String toString() { '}'; } } - + /** Test class 2 - testing inheritance */ private static class TestObjChild extends TestObj { private final boolean[] flags = { true, true, false }; private final boolean flag = false; - + @Override public String toString() { return "TestObjChild{" + @@ -63,7 +63,7 @@ public String toString() { '}'; } } - + private static final Unsafe unsafe; /** Size of any Object reference */ private static final int objectRefSize; @@ -74,7 +74,7 @@ public String toString() { Field field = Unsafe.class.getDeclaredField("theUnsafe"); field.setAccessible(true); unsafe = (Unsafe)field.get(null); - + objectRefSize = unsafe.arrayIndexScale( Object[].class ); } catch (Exception e) @@ -82,10 +82,10 @@ public String toString() { throw new RuntimeException(e); } } - + /** Sizes of all primitive values */ private static final Map primitiveSizes; - + static { primitiveSizes = new HashMap( 10 ); @@ -97,7 +97,7 @@ public String toString() { primitiveSizes.put( double.class, 8 ); primitiveSizes.put( boolean.class, 1 ); } - + /** * Get object information for any Java object. Do not pass primitives to this method because they * will boxed and the information you will get will be related to a boxed version of your value. @@ -115,10 +115,10 @@ public ObjectInfo introspect( final Object obj ) throws IllegalAccessException m_visited.clear(); } } - + //we need to keep track of already visited objects in order to support cycles in the object graphs private IdentityHashMap m_visited = new IdentityHashMap( 100 ); - + private ObjectInfo introspect( final Object obj, final Field fld ) throws IllegalAccessException { //use Field type only if the field contains null. In this case we will at least know what's expected to be @@ -133,7 +133,7 @@ private ObjectInfo introspect( final Object obj, final Field fld ) throws Illega isRecursive = true; m_visited.put( obj, true ); } - + final Class type = ( fld == null || ( obj != null && !isPrimitive) ) ? obj.getClass() : fld.getType(); int arraySize = 0; @@ -145,7 +145,7 @@ private ObjectInfo introspect( final Object obj, final Field fld ) throws Illega indexScale = unsafe.arrayIndexScale( type ); arraySize = baseOffset + indexScale * Array.getLength( obj ); } - + final ObjectInfo root; if ( fld == null ) { @@ -158,7 +158,7 @@ private ObjectInfo introspect( final Object obj, final Field fld ) throws Illega root = new ObjectInfo( fld.getName(), type.getCanonicalName(), getContents( obj, type ), offset, getShallowSize( type ), arraySize, baseOffset, indexScale ); } - + if ( !isRecursive && obj != null ) { if ( isObjectArray( type ) ) @@ -182,11 +182,11 @@ private ObjectInfo introspect( final Object obj, final Field fld ) throws Illega } } } - + root.sort(); //sort by offset return root; } - + //get all fields for this class, including all superclasses fields private static List getAllFields( final Class type ) { @@ -203,7 +203,7 @@ private static List getAllFields( final Class type ) } return res; } - + //check if it is an array of objects. I suspect there must be a more API-friendly way to make this check. private static boolean isObjectArray( final Class type ) { @@ -214,7 +214,7 @@ private static boolean isObjectArray( final Class type ) return false; return true; } - + //advanced toString logic private static String getContents( final Object val, final Class type ) { @@ -243,7 +243,7 @@ else if ( type == double[].class ) } return val.toString(); } - + //obtain a shallow size of a field of given class (primitive or object reference size) private static int getShallowSize( final Class type ) { @@ -255,4 +255,4 @@ private static int getShallowSize( final Class type ) else return objectRefSize; } -} \ No newline at end of file +} diff --git a/subprojects/quantum-java/src/java/quanta/ObjectInfo.java b/src-java/quantum/misc/ObjectInfo.java similarity index 99% rename from subprojects/quantum-java/src/java/quanta/ObjectInfo.java rename to src-java/quantum/misc/ObjectInfo.java index 4b692201..821452cc 100644 --- a/subprojects/quantum-java/src/java/quanta/ObjectInfo.java +++ b/src-java/quantum/misc/ObjectInfo.java @@ -1,10 +1,10 @@ -package quanta; +package quantum.misc; import java.util.ArrayList; import java.util.Collections; import java.util.Comparator; import java.util.List; - + /** * This class contains object info generated by ClassIntrospector tool */ @@ -27,7 +27,7 @@ public class ObjectInfo { public final int arraySize; /** This object fields */ public final List children; - + public ObjectInfo(String name, String type, String contents, int offset, int length, int arraySize, int arrayBase, int arrayElementSize) { @@ -41,13 +41,13 @@ public ObjectInfo(String name, String type, String contents, int offset, int len this.arrayElementSize = arrayElementSize; children = new ArrayList( 1 ); } - + public void addChild( final ObjectInfo info ) { if ( info != null ) children.add( info ); } - + /** * Get the full amount of memory occupied by a given object. This value may be slightly less than * an actual value because we don't worry about memory alignment - possible padding after the last object field. @@ -59,7 +59,7 @@ public long getDeepSize() { return length + arraySize + getUnderlyingSize( arraySize != 0 ); } - + private long getUnderlyingSize( final boolean isArray ) { long size = 0; @@ -69,7 +69,7 @@ private long getUnderlyingSize( final boolean isArray ) size += children.get( children.size() - 1 ).offset + children.get( children.size() - 1 ).length; return size; } - + private static final class OffsetComparator implements Comparator { @Override @@ -78,20 +78,20 @@ public int compare( final ObjectInfo o1, final ObjectInfo o2 ) return o1.offset - o2.offset; //safe because offsets are small non-negative numbers } } - + //sort all children by their offset public void sort() { Collections.sort( children, new OffsetComparator() ); } - + @Override public String toString() { final StringBuilder sb = new StringBuilder(); toStringHelper( sb, 0 ); return sb.toString(); } - + private void toStringHelper( final StringBuilder sb, final int depth ) { depth( sb, depth ).append("name=").append( name ).append(", type=").append( type ) @@ -109,11 +109,11 @@ private void toStringHelper( final StringBuilder sb, final int depth ) child.toStringHelper(sb, depth + 1); } } - + private StringBuilder depth( final StringBuilder sb, final int depth ) { for ( int i = 0; i < depth; ++i ) sb.append( '\t' ); return sb; } -} \ No newline at end of file +} diff --git a/subprojects/quantum-java/src/java/quanta/Packed12.java b/src-java/quantum/misc/Packed12.java similarity index 98% rename from subprojects/quantum-java/src/java/quanta/Packed12.java rename to src-java/quantum/misc/Packed12.java index 7a7eb176..68448a9c 100644 --- a/subprojects/quantum-java/src/java/quanta/Packed12.java +++ b/src-java/quantum/misc/Packed12.java @@ -1,4 +1,4 @@ -package quanta; +package quantum.misc; import java.nio.ByteBuffer; import java.nio.charset.Charset; @@ -10,14 +10,14 @@ public class Packed12 extends PackedBase private final int f1; private final int f2; private final int f3; - + public Packed12( final byte[] ar ) { // should be the same logic as in java.util.Bits.getInt, because ByteBuffer.putInt use it f1 = get( ar, 3 ) | get( ar, 2 ) << 8 | get( ar, 1 ) << 16 | get( ar, 0 ) << 24; f2 = get( ar, 7 ) | get( ar, 6 ) << 8 | get( ar, 5 ) << 16 | get( ar, 4 ) << 24; f3 = get( ar, 11 ) | get( ar, 10 ) << 8 | get( ar, 9 ) << 16 | get( ar, 8 ) << 24; } - + protected ByteBuffer toByteBuffer() { final ByteBuffer bbuf = ByteBuffer.allocate( 12 ); bbuf.putInt( f1 ); @@ -25,7 +25,7 @@ protected ByteBuffer toByteBuffer() { bbuf.putInt( f3 ); return bbuf; } - + @Override public boolean equals(Object o) { if ( this == o ) return true; @@ -33,7 +33,7 @@ public boolean equals(Object o) { Packed12 packed12 = ( Packed12 ) o; return f1 == packed12.f1 && f2 == packed12.f2 && f3 == packed12.f3; } - + @Override public int hashCode() { int result = f1; @@ -41,4 +41,4 @@ public int hashCode() { result = 31 * result + f3; return result; } -} \ No newline at end of file +} diff --git a/subprojects/quantum-java/src/java/quanta/PackedBase.java b/src-java/quantum/misc/PackedBase.java similarity index 98% rename from subprojects/quantum-java/src/java/quanta/PackedBase.java rename to src-java/quantum/misc/PackedBase.java index 73202be7..74ca47dd 100644 --- a/subprojects/quantum-java/src/java/quanta/PackedBase.java +++ b/src-java/quantum/misc/PackedBase.java @@ -1,4 +1,4 @@ -package quanta; +package quantum.misc; import java.nio.ByteBuffer; import java.nio.charset.Charset; @@ -10,9 +10,9 @@ protected static int get( final byte[] ar, final int index ) { return index < ar.length ? ar[ index ] : 0; } - + protected abstract ByteBuffer toByteBuffer(); - + protected String toString( final ByteBuffer bbuf ) { final byte[] ar = bbuf.array(); @@ -22,7 +22,7 @@ protected String toString( final ByteBuffer bbuf ) --last; return new String( ar, 0, last + 1, US_ASCII ); } - + @Override public String toString() { @@ -34,14 +34,14 @@ private class Packed12 extends PackedBase private final int f1; private final int f2; private final int f3; - + public Packed12( final byte[] ar ) { // should be the same logic as in java.util.Bits.getInt, because ByteBuffer.putInt use it f1 = get( ar, 3 ) | get( ar, 2 ) << 8 | get( ar, 1 ) << 16 | get( ar, 0 ) << 24; f2 = get( ar, 7 ) | get( ar, 6 ) << 8 | get( ar, 5 ) << 16 | get( ar, 4 ) << 24; f3 = get( ar, 11 ) | get( ar, 10 ) << 8 | get( ar, 9 ) << 16 | get( ar, 8 ) << 24; } - + protected ByteBuffer toByteBuffer() { final ByteBuffer bbuf = ByteBuffer.allocate( 12 ); bbuf.putInt( f1 ); @@ -49,7 +49,7 @@ protected ByteBuffer toByteBuffer() { bbuf.putInt( f3 ); return bbuf; } - + @Override public boolean equals(Object o) { if ( this == o ) return true; @@ -57,7 +57,7 @@ public boolean equals(Object o) { Packed12 packed12 = ( Packed12 ) o; return f1 == packed12.f1 && f2 == packed12.f2 && f3 == packed12.f3; } - + @Override public int hashCode() { int result = f1; @@ -66,4 +66,4 @@ public int hashCode() { return result; } } -} \ No newline at end of file +} diff --git a/src/quantum/core/io/compress.cljc b/src/quantum/core/io/compress.cljc index 3b01f074..bbc694ac 100644 --- a/src/quantum/core/io/compress.cljc +++ b/src/quantum/core/io/compress.cljc @@ -42,7 +42,7 @@ org.apache.commons.io.FileUtils (java.nio.charset Charset CharsetEncoder CharacterCodingException) (java.nio CharBuffer ByteBuffer) - (quanta Packed12 ClassIntrospector)))) + (quantum.misc Packed12)))) (defrecord CompressionCodec [name extension algorithm speed compression implemented? doc ]) diff --git a/src/quantum/core/meta/profile.cljc b/src/quantum/core/meta/profile.cljc index c6bfd2cc..d123fb6d 100644 --- a/src/quantum/core/meta/profile.cljc +++ b/src/quantum/core/meta/profile.cljc @@ -17,7 +17,7 @@ :refer [defalias]] [quantum.core.type-old :as t]) #?(:clj (:import com.carrotsearch.sizeof.RamUsageEstimator - quanta.ClassIntrospector))) + quantum.misc.ClassIntrospector))) ; TO EXPLORE ; - Timbre profiling @@ -52,6 +52,7 @@ (defn deep-byte-size "Warning: doesn't handle ref-cycles." [obj] + ;; TODO port ClassIntrospector (-> (ClassIntrospector.) (.introspect obj) (.getDeepSize)))) diff --git a/subprojects/quantum-java/pom.xml.asc b/subprojects/quantum-java/pom.xml.asc deleted file mode 100644 index a1058823..00000000 --- a/subprojects/quantum-java/pom.xml.asc +++ /dev/null @@ -1,16 +0,0 @@ ------BEGIN PGP SIGNATURE----- - -iQIcBAABCAAGBQJXV4koAAoJEGXow+9wO0KxKH0P/38T/iMpVkKqtL9CSH887Kv+ -D1cVRix67EzAvVlPB0dMhoawcnKPz5LdubMBxmRzjpSXI4wGRs8J4gSJgNPvvMJy -yjb/GZ3QbEd9rEU15z0jK/zORiujunnA6CtFIuxyAXr1eOTOwFrYILWsWXM7DjS8 -caTAa9jroLMUWjjLO7wbi+BNATsVziyYmMupODRnrMxIwkWrtBgfZpGrPRPwkgrc -ZsmkJfkFMjq1wX58vR3w2ejDHjyz6Uy3UzFXG/upUwadaEvpomZ8IVqUtJCb+JnQ -bKQjepxMMW2fw3+ugppCq+RQ6mQrCvck2K3JkK29bBLMtKAetFoa3x89cZzQBC6R -0cWF8ep4DjOS25fsnt8oPSIcoK9/v2kWBVk054VHTxhMm06yTBT0Y7EAcQRFM/Yz -2YZMkSA7JiWp2YqPyP3xN/VATwlO1olcbTP+nXUnxdgkVHwUTWvOR77bvohFGDF0 -3Ldns3jD4tZgoKNO0+goIECpOPBWhP8lVOjnVLyxudhttP0L4o4Ixr/6/0TY6OL7 -JacLAV6+G8aXkKmp1Y8MFGGCGVIOzIEhXa2vCsjVrUjg/oD/UEnHIAA91/Nb77aD -TstpuieCVWR+KpZy7yC0NJV6LfNUY0a8aplmhzO5y0+i8db7BTOSvwr5+JQ2rnqL -n/REWoCASvxL4BpuiYIv -=UZWJ ------END PGP SIGNATURE----- diff --git a/subprojects/quantum-java/project.clj b/subprojects/quantum-java/project.clj deleted file mode 100644 index 43702ca4..00000000 --- a/subprojects/quantum-java/project.clj +++ /dev/null @@ -1,17 +0,0 @@ -(defproject quantum/java "1.8.2" - :description "Some quanta of computational abstraction, assembled." - :jvm-opts [] - ;:uberjar {:aot :all} - :jar-name "quantum-java-dep.jar" - :uberjar-name "quantum-java.jar" - :url "https://www.github.com/alexandergunnarson/quantum-java" - :license {:name "Creative Commons Attribution-ShareAlike 3.0 US (CC-SA) license" - :url "https://creativecommons.org/licenses/by-sa/3.0/us/"} - ; :signing {:gpg-key "72F3C25A"} - ;:deploy-repositories [["releases" :clojars] - ; ["clojars" {:creds :gpg}]] - :dependencies [[org.clojure/clojure "1.8.0"]] - :aliases {"deploy-dev" ["do" "clean," "install"] - "deploy-prod" ["do" "clean," "install," "deploy" "clojars"]} - :source-paths ["src/cljc"] - :java-source-paths ["src/java"]) From b64cd1ad3d6e83618b90ac25580b8c1b3407ed18 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 15 Sep 2018 12:11:52 -0600 Subject: [PATCH 257/810] Move quantum.core.error.Error --- project-base.clj | 3 ++- src-java/quantum/core/{error => }/Error.java | 2 +- src-untyped/quantum/untyped/core/error.cljc | 9 ++++----- src-untyped/quantum/untyped/core/print/prettier.cljc | 2 +- 4 files changed, 8 insertions(+), 8 deletions(-) rename src-java/quantum/core/{error => }/Error.java (99%) diff --git a/project-base.clj b/project-base.clj index 50e519a5..9ea06393 100644 --- a/project-base.clj +++ b/project-base.clj @@ -702,7 +702,8 @@ ;; ===== Paths ===== ;; :target-path "target" :test-paths ["test"] - :source-paths ["src" "src-java"] + :source-paths ["src"] + :java-source-paths ["src-java"] ;; ===== Compilation ===== ;; :jar-name (str artifact-base-name "-dep.jar") :uberjar-name (str artifact-base-name ".jar") diff --git a/src-java/quantum/core/error/Error.java b/src-java/quantum/core/Error.java similarity index 99% rename from src-java/quantum/core/error/Error.java rename to src-java/quantum/core/Error.java index cb2775eb..292d8249 100644 --- a/src-java/quantum/core/error/Error.java +++ b/src-java/quantum/core/Error.java @@ -1,4 +1,4 @@ -package quantum.core.error; +package quantum.core; import java.util.Collection; import java.util.Iterator; diff --git a/src-untyped/quantum/untyped/core/error.cljc b/src-untyped/quantum/untyped/core/error.cljc index a7e95bfe..80e4b0f4 100644 --- a/src-untyped/quantum/untyped/core/error.cljc +++ b/src-untyped/quantum/untyped/core/error.cljc @@ -15,8 +15,6 @@ [quantum.untyped.core.error :as self :refer [err-constructor]]))) -#?(:clj (do (ns-unmap *ns* 'Error) (import quantum.core.error.Error))) - (ucore/log-this-ns) ;; ===== Types ===== ;; @@ -109,16 +107,17 @@ ;; ===== Error type: `defrecord`/map ===== ;; -#?(#_:clj #_(defrecord Error [ident message data trace cause]) ; defined in Java as `quantum.core.error.Error` + ;; Defined in Java as `quantum.core.Error` +#?(#_:clj #_(defrecord Error [ident message data trace cause]) :cljs (defrecord Error [ident message data trace cause])) -(def error-map-type #?(:clj quantum.core.error.Error :cljs quantum.untyped.core.error/Error)) +(def error-map-type #?(:clj quantum.core.Error :cljs quantum.untyped.core.error/Error)) (def error-map? (fnl instance? error-map-type)) #?(:clj (defmacro- err-constructor [& args] - `(~(case-env :clj 'quantum.core.error.Error. + `(~(case-env :clj 'quantum.core.Error. :cljs 'quantum.untyped.core.error.Error.) ~@args))) (declare ?ex-data) diff --git a/src-untyped/quantum/untyped/core/print/prettier.cljc b/src-untyped/quantum/untyped/core/print/prettier.cljc index 88437395..8615c083 100644 --- a/src-untyped/quantum/untyped/core/print/prettier.cljc +++ b/src-untyped/quantum/untyped/core/print/prettier.cljc @@ -169,7 +169,7 @@ fipp.ednize/IOverride fipp.ednize/IEdn (-edn [this] (tagged-literal '!! (into {} this)))) ; TODO ->map - (extend-type quantum.core.error.Error + (extend-type quantum.core.Error fipp.ednize/IOverride fipp.ednize/IEdn (-edn [this] (tagged-literal 'err (into {} this)))) From 412035040cc7cb9a5fc1f77491715bc9113523b4 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 15 Sep 2018 12:55:37 -0600 Subject: [PATCH 258/810] Finish rest of bit operations --- src-java/quantum/core/Numeric.java | 323 +++++++++++++++++++---------- 1 file changed, 208 insertions(+), 115 deletions(-) diff --git a/src-java/quantum/core/Numeric.java b/src-java/quantum/core/Numeric.java index 076816b6..581a47dd 100644 --- a/src-java/quantum/core/Numeric.java +++ b/src-java/quantum/core/Numeric.java @@ -1,5 +1,5 @@ package quantum.core; -// TAKEN FROM ztellman/primitive-math AND EXPANDED +// Parts of `ztellman/primitive-math` were adapted for this // Note from java.lang.Math: // Code generators are encouraged to use platform-specific native libraries or @@ -18,7 +18,7 @@ public class Numeric { public static final char char1 = (char) 1; public static final int int1 = 1; - // ============================ BOOLEAN OPERATIONS ================================ // + // ================================= Boolean Operations ===================================== // public static boolean isTrue (final boolean a ) { return a == true; } public static boolean isFalse (final boolean a ) { return a == false; } @@ -26,12 +26,10 @@ public class Numeric { public static boolean and (final boolean a, final boolean b) { return a && b; } public static boolean or (final boolean a, final boolean b) { return a || b; } public static boolean not (final boolean a ) { return !a; } - public static boolean xor (final boolean a, final boolean b) { return (a || b) && !(a && b); } - // ============================ BIT OPERATIONS ================================ // - // Bit operations are fundamentally integer operations + // =================================== Bit Operations ======================================= // - // ---------------------------- bitAnd : & ---------------------------- // + // ---------------------------- bitAnd : & (implicitly checked) ---------------------------- // public static boolean bitAnd (final boolean a, final boolean b) { return a & b ; } public static byte bitAnd (final byte a, final byte b) { return (byte) (a & b); } @@ -90,7 +88,7 @@ public static double bitAnd (final long a, final double b) { return Double.longBitsToDouble(a & Double.doubleToLongBits(b)); } - // ---------------------------- bitOr : | ---------------------------- // + // ----------------------------- bitOr : | (implicitly checked) ----------------------------- // public static boolean bitOr (final boolean a, final boolean b) { return a | b ; } public static byte bitOr (final byte a, final byte b) { return (byte) (a | b); } @@ -149,7 +147,7 @@ public static double bitOr (final long a, final double b) { return Double.longBitsToDouble(a | Double.doubleToLongBits(b)); } - // ---------------------------- bitXOr ---------------------------- // + // ------------------------------ bitXOr (implicitly checked) ------------------------------ // public static boolean bitXOr (final boolean a, final boolean b) { return a ^ b ; } public static byte bitXOr (final byte a, final byte b) { return (byte) (a ^ b); } @@ -208,7 +206,7 @@ public static double bitXOr (final long a, final double b) { return Double.longBitsToDouble(a ^ Double.doubleToLongBits(b)); } - // ---------------------------- bitNot : ! ---------------------------- // + // ---------------------------- bitNot : ! (implicitly checked) ---------------------------- // public static boolean bitNot (final boolean x) { return !x; } public static byte bitNot (final byte x) { return (byte) ~x; } @@ -223,7 +221,7 @@ public static double bitNot (final double x) { return Double.longBitsToDouble(~Double.doubleToLongBits(x)); } - // ---------------------------- shiftLeft : << ---------------------------- // + // -------------------------- shiftLeft : << (implicitly checked) -------------------------- // // Though technically `1 << 1` = 2, not 1 public static boolean shiftLeft (final boolean a, final boolean b) { return a; } @@ -283,7 +281,7 @@ public static double shiftLeft (final long a, final double b) { return Double.longBitsToDouble(a << Double.doubleToLongBits(b)); } - // ---------------------------- shiftRight : >> ---------------------------- // + // -------------------------- shiftRight : >> (implicitly checked) -------------------------- // public static boolean shiftRight (final boolean a, final boolean b) { return a && !b; } public static byte shiftRight (final byte a, final byte b) { return (byte) (a >> b); } @@ -342,7 +340,7 @@ public static double shiftRight (final long a, final double b) { return Double.longBitsToDouble(a >> Double.doubleToLongBits(b)); } - // ---------------------------- unsignedShiftRight : >>> ---------------------------- // + // -------------------------------- unsignedShiftRight : >>> -------------------------------- // public static boolean ushiftRight (final boolean a, final boolean b) { return a && !b; } public static byte ushiftRight (final byte a, final byte b) { return (byte) (a >>> b);} @@ -401,25 +399,63 @@ public static double ushiftRight (final long a, final double b) { return Double.longBitsToDouble(a >>> Double.doubleToLongBits(b)); } - // ---------------------------- bitFlip ---------------------------- // + // ---------------------------------- bitClear (unchecked) ---------------------------------- // - // public static byte bitFlip (final byte x, final long n) { return (byte) x ^ (1L << n); } - // public static short bitFlip (final short x, final long n) { return (short)x ^ (1L << n); } - // public static char bitFlip (final char x, final long n) { return (char) x ^ (1L << n); } - // public static int bitFlip (final int x, final long n) { return x ^ (1L << n); } - // public static long bitFlip (final long x, final long n) { return x ^ (1L << n); } - // public static float bitFlip (final float x, final long n) { - // return Float.intBitsToFloat(~Float.floatToIntBits(x)); - // } - // public static double bitFlip (final double x) { - // return Double.longBitsToDouble(~Double.doubleToLongBits(x)); - // } + public static byte bitClear (final byte x, final long n) { return (byte) (x & ~(1L << n)); } + public static short bitClear (final short x, final long n) { return (short)(x & ~(1L << n)); } + public static char bitClear (final char x, final long n) { return (char) (x & ~(1L << n)); } + public static int bitClear (final int x, final long n) { return (int) (x & ~(1L << n)); } + public static long bitClear (final long x, final long n) { return x & ~(1L << n) ; } + public static float bitClear (final float x, final long n) { + return Float.intBitsToFloat((int)(Float.floatToIntBits(x) & ~(1L << n))); + } + public static double bitClear (final double x, final long n) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) & ~(1L << n)); + } - // ---------------------------- bitTest ---------------------------- // + // ---------------------------------- bitFlip (unchecked) ---------------------------------- // - // ---------------------------- bitSet ---------------------------- // + public static byte bitFlip (final byte x, final long n) { return (byte) (x ^ (1L << n)); } + public static short bitFlip (final short x, final long n) { return (short)(x ^ (1L << n)); } + public static char bitFlip (final char x, final long n) { return (char) (x ^ (1L << n)); } + public static int bitFlip (final int x, final long n) { return (int) (x ^ (1L << n)); } + public static long bitFlip (final long x, final long n) { return x ^ (1L << n) ; } + public static float bitFlip (final float x, final long n) { + return Float.intBitsToFloat((int)(Float.floatToIntBits(x) ^ (1L << n))); + } + public static double bitFlip (final double x, final long n) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) ^ (1L << n)); + } - // ---------------------------- bitClear ---------------------------- // + // ----------------------------------- bitSet (unchecked) ----------------------------------- // + + public static byte bitSet (final byte x, final long n) { return (byte) (x | (1L << n)); } + public static short bitSet (final short x, final long n) { return (short)(x | (1L << n)); } + public static char bitSet (final char x, final long n) { return (char) (x | (1L << n)); } + public static int bitSet (final int x, final long n) { return (int) (x | (1L << n)); } + public static long bitSet (final long x, final long n) { return x | (1L << n) ; } + public static float bitSet (final float x, final long n) { + return Float.intBitsToFloat((int)(Float.floatToIntBits(x) | (1L << n))); + } + public static double bitSet (final double x, final long n) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) | (1L << n)); + } + + // ---------------------------------- bitTest (unchecked) ---------------------------------- // + + public static boolean bitTest (final byte x, final long n) { return (x & (1L << n)) != 0L; } + public static boolean bitTest (final short x, final long n) { return (x & (1L << n)) != 0L; } + public static boolean bitTest (final char x, final long n) { return (x & (1L << n)) != 0L; } + public static boolean bitTest (final int x, final long n) { return (x & (1L << n)) != 0L; } + public static boolean bitTest (final long x, final long n) { return (x & (1L << n)) != 0L; } + public static boolean bitTest (final float x, final long n) { + return (Float.floatToIntBits(x) & (1L << n)) != 0L; + } + public static boolean bitTest (final double x, final long n) { + return (Double.doubleToLongBits(x) & (1L << n)) != 0L; + } + + // ------------------------------ reverse (implicitly checked) ------------------------------ // // Because "more than one matching method" public static short reverseShort(final short x) { @@ -439,7 +475,7 @@ public static long reverseLong (final long x) { | ((long) reverseInt((int)(x >>> 32)) & 0xffffffffL)); } - // ============================ LT : < ================================ // + // ======================================= lt : < =========================================== // public static boolean lt (final byte a, final byte b) { return a < b; } public static boolean lt (final byte a, final short b) { return a < b; } @@ -491,7 +527,7 @@ public static long reverseLong (final long x) { public static boolean lt (final double a, final float b) { return a < b; } public static boolean lt (final double a, final double b) { return a < b; } - // ============================ LTE : <= ================================ // + // ====================================== lte : <= ========================================== // public static boolean lte (final byte a, final byte b) { return a <= b; } public static boolean lte (final byte a, final short b) { return a <= b; } @@ -543,7 +579,7 @@ public static long reverseLong (final long x) { public static boolean lte (final double a, final float b) { return a <= b; } public static boolean lte (final double a, final double b) { return a <= b; } - // ============================ GT : > ================================ // + // ======================================= gt : > =========================================== // public static boolean gt (final byte a, final byte b) { return a > b; } public static boolean gt (final byte a, final short b) { return a > b; } @@ -595,7 +631,7 @@ public static long reverseLong (final long x) { public static boolean gt (final double a, final float b) { return a > b; } public static boolean gt (final double a, final double b) { return a > b; } - // ============================ GTE : >= ================================ // + // ====================================== gte : >= ========================================== // public static boolean gte (final byte a, final byte b) { return a >= b; } public static boolean gte (final byte a, final short b) { return a >= b; } @@ -647,7 +683,7 @@ public static long reverseLong (final long x) { public static boolean gte (final double a, final float b) { return a >= b; } public static boolean gte (final double a, final double b) { return a >= b; } - // ============================ EQ : == ================================ // + // ====================================== eq : == ========================================== // public static boolean eq (final boolean a, final boolean b) { return a == b; } public static boolean eq (final byte a, final byte b) { return a == b; } @@ -700,7 +736,7 @@ public static long reverseLong (final long x) { public static boolean eq (final double a, final float b) { return a == b; } public static boolean eq (final double a, final double b) { return a == b; } - // ============================ NEQ : != ================================ // + // =========================== neq : != (implicitly checked) =============================== // public static boolean neq (final boolean a, final boolean b) { return a != b; } public static boolean neq (final byte a, final byte b) { return a != b; } @@ -753,7 +789,7 @@ public static long reverseLong (final long x) { public static boolean neq (final double a, final float b) { return a != b; } public static boolean neq (final double a, final double b) { return a != b; } - // ============================ INC / DEC ================================ // + // =============================== inc / dec (unchecked) =================================== // public static byte inc (final byte a) { return (byte )(a + byte1 ); } public static short inc (final short a) { return (short)(a + short1); } @@ -771,7 +807,7 @@ public static long reverseLong (final long x) { public static float dec (final float a) { return a - 1.0f; } public static double dec (final double a) { return a - 1.0d; } - // ============================ ISZERO ================================ // + // ============================ isZero (implicitly checked) ================================ // public static boolean isZero (final byte a) { return a == byte0; } public static boolean isZero (final short a) { return a == short0; } @@ -781,55 +817,76 @@ public static long reverseLong (final long x) { public static boolean isZero (final float a) { return a == 0.0f; } public static boolean isZero (final double a) { return a == 0.0d; } - // ============================ ISNEG ================================ // + // ============================ isNeg (implicitly checked) ================================ // - public static boolean isNeg (final byte a) { return a < byte0; } // Implicitly checked - public static boolean isNeg (final short a) { return a < short0; } // Implicitly checked - public static boolean isNeg (final char a) { return a < char0; } // Implicitly checked - public static boolean isNeg (final int a) { return a < int0; } // Implicitly checked - public static boolean isNeg (final long a) { return a < 0L; } // Implicitly checked - public static boolean isNeg (final float a) { return a < 0.0f; } // Implicitly checked - public static boolean isNeg (final double a) { return a < 0.0d; } // Implicitly checked + public static boolean isNeg (final byte a) { return a < byte0; } + public static boolean isNeg (final short a) { return a < short0; } + public static boolean isNeg (final char a) { return a < char0; } + public static boolean isNeg (final int a) { return a < int0; } + public static boolean isNeg (final long a) { return a < 0L; } + public static boolean isNeg (final float a) { return a < 0.0f; } + public static boolean isNeg (final double a) { return a < 0.0d; } - // ============================ ISPOS ================================ // + // ============================ isPos (implicitly checked) ================================ // - public static boolean isPos (final byte a) { return a > byte0; } // Implicitly checked - public static boolean isPos (final short a) { return a > short0; } // Implicitly checked - public static boolean isPos (final char a) { return a > char0; } // Implicitly checked - public static boolean isPos (final int a) { return a > int0; } // Implicitly checked - public static boolean isPos (final long a) { return a > 0L; } // Implicitly checked - public static boolean isPos (final float a) { return a > 0.0f; } // Implicitly checked - public static boolean isPos (final double a) { return a > 0.0d; } // Implicitly checked + public static boolean isPos (final byte a) { return a > byte0; } + public static boolean isPos (final short a) { return a > short0; } + public static boolean isPos (final char a) { return a > char0; } + public static boolean isPos (final int a) { return a > int0; } + public static boolean isPos (final long a) { return a > 0L; } + public static boolean isPos (final float a) { return a > 0.0f; } + public static boolean isPos (final double a) { return a > 0.0d; } - // ============================ ADD : + ================================ // + // ===================== add : + (unchecked unless otherwise noted) ========================= // // "Infectious": uses a promotion of the largest data type passed - public static short add (final byte a, final byte b) { return (short)(a + b); } // Implicitly checked - public static int add (final byte a, final short b) { return a + b; } // Implicitly checked - public static int add (final byte a, final char b) { return a + b; } // Implicitly checked - public static long add (final byte a, final int b) { return a + b; } // Implicitly checked + + // Implicitly checked + public static short add (final byte a, final byte b) { return (short)(a + b); } + // Implicitly checked + public static int add (final byte a, final short b) { return a + b; } + // Implicitly checked + public static int add (final byte a, final char b) { return a + b; } + // Implicitly checked + public static long add (final byte a, final int b) { return a + b; } public static long add (final byte a, final long b) { return a + b; } - public static double add (final byte a, final float b) { return a + b; } // Implicitly checked + // Implicitly checked + public static double add (final byte a, final float b) { return a + b; } public static double add (final byte a, final double b) { return a + b; } - public static int add (final short a, final byte b) { return a + b; } // Implicitly checked - public static int add (final short a, final short b) { return a + b; } // Implicitly checked - public static int add (final short a, final char b) { return a + b; } // Implicitly checked - public static long add (final short a, final int b) { return a + b; } // Implicitly checked + // Implicitly checked + public static int add (final short a, final byte b) { return a + b; } + // Implicitly checked + public static int add (final short a, final short b) { return a + b; } + // Implicitly checked + public static int add (final short a, final char b) { return a + b; } + // Implicitly checked + public static long add (final short a, final int b) { return a + b; } public static long add (final short a, final long b) { return a + b; } - public static double add (final short a, final float b) { return a + b; } // Implicitly checked + // Implicitly checked + public static double add (final short a, final float b) { return a + b; } public static double add (final short a, final double b) { return a + b; } - public static int add (final char a, final byte b) { return a + b; } // Implicitly checked - public static int add (final char a, final short b) { return a + b; } // Implicitly checked - public static int add (final char a, final char b) { return a + b; } // Implicitly checked - public static long add (final char a, final int b) { return a + b; } // Implicitly checked + // Implicitly checked + public static int add (final char a, final byte b) { return a + b; } + // Implicitly checked + public static int add (final char a, final short b) { return a + b; } + // Implicitly checked + public static int add (final char a, final char b) { return a + b; } + // Implicitly checked + public static long add (final char a, final int b) { return a + b; } public static long add (final char a, final long b) { return a + b; } - public static double add (final char a, final float b) { return a + b; } // Implicitly checked + // Implicitly checked + public static double add (final char a, final float b) { return a + b; } public static double add (final char a, final double b) { return a + b; } - public static long add (final int a, final byte b) { return a + b; } // Implicitly checked - public static long add (final int a, final short b) { return a + b; } // Implicitly checked - public static long add (final int a, final char b) { return a + b; } // Implicitly checked - public static long add (final int a, final int b) { return a + b; } // Implicitly checked + // Implicitly checked + public static long add (final int a, final byte b) { return a + b; } + // Implicitly checked + public static long add (final int a, final short b) { return a + b; } + // Implicitly checked + public static long add (final int a, final char b) { return a + b; } + // Implicitly checked + public static long add (final int a, final int b) { return a + b; } public static long add (final int a, final long b) { return a + b; } - public static double add (final int a, final float b) { return a + b; } // Implicitly checked + // Implicitly checked + public static double add (final int a, final float b) { return a + b; } public static double add (final int a, final double b) { return a + b; } public static long add (final long a, final byte b) { return a + b; } public static long add (final long a, final short b) { return a + b; } @@ -838,12 +895,17 @@ public static long reverseLong (final long x) { public static long add (final long a, final long b) { return a + b; } public static double add (final long a, final float b) { return a + b; } public static double add (final long a, final double b) { return a + b; } - public static double add (final float a, final byte b) { return a + b; } // Implicitly checked - public static double add (final float a, final short b) { return a + b; } // Implicitly checked - public static double add (final float a, final char b) { return a + b; } // Implicitly checked - public static double add (final float a, final int b) { return a + b; } // Implicitly checked + // Implicitly checked + public static double add (final float a, final byte b) { return a + b; } + // Implicitly checked + public static double add (final float a, final short b) { return a + b; } + // Implicitly checked + public static double add (final float a, final char b) { return a + b; } + // Implicitly checked + public static double add (final float a, final int b) { return a + b; } public static double add (final float a, final long b) { return a + b; } - public static double add (final float a, final float b) { return a + b; } // Implicitly checked + // Implicitly checked + public static double add (final float a, final float b) { return a + b; } public static double add (final float a, final double b) { return a + b; } public static double add (final double a, final byte b) { return a + b; } public static double add (final double a, final short b) { return a + b; } @@ -853,36 +915,56 @@ public static long reverseLong (final long x) { public static double add (final double a, final float b) { return a + b; } public static double add (final double a, final double b) { return a + b; } - // ============================ SUBTRACT : - ================================ // + // ================== subtract : - (unchecked unless otherwise noted) ====================== // // "Infectious": uses the largest data type passed - public static short subtract (final byte a, final byte b) { return (short)(a - b); } // Implicitly checked - public static int subtract (final byte a, final short b) { return a - b; } // Implicitly checked - public static int subtract (final byte a, final char b) { return a - b; } // Implicitly checked - public static long subtract (final byte a, final int b) { return a - b; } // Implicitly checked + // Implicitly checked + public static short subtract (final byte a, final byte b) { return (short)(a - b); } + // Implicitly checked + public static int subtract (final byte a, final short b) { return a - b; } + // Implicitly checked + public static int subtract (final byte a, final char b) { return a - b; } + // Implicitly checked + public static long subtract (final byte a, final int b) { return a - b; } public static long subtract (final byte a, final long b) { return a - b; } - public static double subtract (final byte a, final float b) { return a - b; } // Implicitly checked + // Implicitly checked + public static double subtract (final byte a, final float b) { return a - b; } public static double subtract (final byte a, final double b) { return a - b; } - public static int subtract (final short a, final byte b) { return a - b; } // Implicitly checked - public static int subtract (final short a, final short b) { return a - b; } // Implicitly checked - public static int subtract (final short a, final char b) { return a - b; } // Implicitly checked - public static long subtract (final short a, final int b) { return a - b; } // Implicitly checked + // Implicitly checked + public static int subtract (final short a, final byte b) { return a - b; } + // Implicitly checked + public static int subtract (final short a, final short b) { return a - b; } + // Implicitly checked + public static int subtract (final short a, final char b) { return a - b; } + // Implicitly checked + public static long subtract (final short a, final int b) { return a - b; } public static long subtract (final short a, final long b) { return a - b; } - public static double subtract (final short a, final float b) { return a - b; } // Implicitly checked + // Implicitly checked + public static double subtract (final short a, final float b) { return a - b; } public static double subtract (final short a, final double b) { return a - b; } - public static int subtract (final char a, final byte b) { return a - b; } // Implicitly checked - public static int subtract (final char a, final short b) { return a - b; } // Implicitly checked - public static int subtract (final char a, final char b) { return a - b; } // Implicitly checked - public static long subtract (final char a, final int b) { return a - b; } // Implicitly checked + // Implicitly checked + public static int subtract (final char a, final byte b) { return a - b; } + // Implicitly checked + public static int subtract (final char a, final short b) { return a - b; } + // Implicitly checked + public static int subtract (final char a, final char b) { return a - b; } + // Implicitly checked + public static long subtract (final char a, final int b) { return a - b; } public static long subtract (final char a, final long b) { return a - b; } - public static double subtract (final char a, final float b) { return a - b; } // Implicitly checked + // Implicitly checked + public static double subtract (final char a, final float b) { return a - b; } public static double subtract (final char a, final double b) { return a - b; } - public static long subtract (final int a, final byte b) { return a - b; } // Implicitly checked - public static long subtract (final int a, final short b) { return a - b; } // Implicitly checked - public static long subtract (final int a, final char b) { return a - b; } // Implicitly checked - public static long subtract (final int a, final int b) { return a - b; } // Implicitly checked + // Implicitly checked + public static long subtract (final int a, final byte b) { return a - b; } + // Implicitly checked + public static long subtract (final int a, final short b) { return a - b; } + // Implicitly checked + public static long subtract (final int a, final char b) { return a - b; } + // Implicitly checked + public static long subtract (final int a, final int b) { return a - b; } public static long subtract (final int a, final long b) { return a - b; } - public static double subtract (final int a, final float b) { return a - b; } // Implicitly checked + // Implicitly checked + public static double subtract (final int a, final float b) { return a - b; } public static double subtract (final int a, final double b) { return a - b; } public static long subtract (final long a, final byte b) { return a - b; } public static long subtract (final long a, final short b) { return a - b; } @@ -891,12 +973,17 @@ public static long reverseLong (final long x) { public static long subtract (final long a, final long b) { return a - b; } public static double subtract (final long a, final float b) { return a - b; } public static double subtract (final long a, final double b) { return a - b; } - public static double subtract (final float a, final byte b) { return a - b; } // Implicitly checked - public static double subtract (final float a, final short b) { return a - b; } // Implicitly checked - public static double subtract (final float a, final char b) { return a - b; } // Implicitly checked - public static double subtract (final float a, final int b) { return a - b; } // Implicitly checked + // Implicitly checked + public static double subtract (final float a, final byte b) { return a - b; } + // Implicitly checked + public static double subtract (final float a, final short b) { return a - b; } + // Implicitly checked + public static double subtract (final float a, final char b) { return a - b; } + // Implicitly checked + public static double subtract (final float a, final int b) { return a - b; } public static double subtract (final float a, final long b) { return a - b; } - public static double subtract (final float a, final float b) { return a - b; } // Implicitly checked + // Implicitly checked + public static double subtract (final float a, final float b) { return a - b; } public static double subtract (final float a, final double b) { return a - b; } public static double subtract (final double a, final byte b) { return a - b; } public static double subtract (final double a, final short b) { return a - b; } @@ -906,7 +993,7 @@ public static long reverseLong (final long x) { public static double subtract (final double a, final float b) { return a - b; } public static double subtract (final double a, final double b) { return a - b; } - // ============================ NEGATE : - ================================ // + // =============================== negate : - (unchecked) =================================== // public static byte negate (final byte a) { return (byte )-a; } public static short negate (final short a) { return (short)-a; } @@ -916,15 +1003,19 @@ public static long reverseLong (final long x) { public static float negate (final float a) { return -a; } public static double negate (final double a) { return -a; } - // ============================ MULTIPLY : * ================================ // + // ================== multiply : * (unchecked unless otherwise noted) ====================== // // "Infectious": uses the largest data type passed - public static short multiply (final byte a, final byte b) { return (short)(a * b); } // Implicitly checked - public static int multiply (final byte a, final short b) { return a * b; } // Implicitly checked - public static int multiply (final byte a, final char b) { return a * b; } // Implicitly checked - public static long multiply (final byte a, final int b) { return a * b; } // Implicitly checked + // Implicitly checked + public static short multiply (final byte a, final byte b) { return (short)(a * b); } + // Implicitly checked + public static int multiply (final byte a, final short b) { return a * b; } + // Implicitly checked + public static int multiply (final byte a, final char b) { return a * b; } + // Implicitly checked + public static long multiply (final byte a, final int b) { return a * b; } public static long multiply (final byte a, final long b) { return a * b; } // ->BigInteger - public static double multiply (final byte a, final float b) { return a * b; } // + public static double multiply (final byte a, final float b) { return a * b; } public static double multiply (final byte a, final double b) { return a * b; } public static long multiply (final short a, final byte b) { return a * b; } public static long multiply (final short a, final short b) { return a * b; } @@ -969,7 +1060,7 @@ public static long reverseLong (final long x) { public static double multiply (final double a, final float b) { return a * b; } public static double multiply (final double a, final double b) { return a * b; } - // ============================ DIVIDE : / ================================ // + // =============================== divde : / (unchecked) =================================== // // "Infectious": uses the largest data type passed // TODO need to deal with int truncation here... sometimes it's intentional... @@ -1023,7 +1114,7 @@ public static long reverseLong (final long x) { public static double divide (final double a, final float b) { return a / b; } public static double divide (final double a, final double b) { return a / b; } - // ============================ MAX ================================ // + // ============================== max (implicitly checked) ================================== // // "Infectious": uses the largest data type passed public static byte max (final byte a, final byte b) { return (a < b) ? b : a; } @@ -1076,7 +1167,7 @@ public static long reverseLong (final long x) { public static double max (final double a, final float b) { return (a < b) ? b : a; } public static double max (final double a, final double b) { return Math.max(a, b); } - // ============================ MIN ================================ // + // ============================== min (implicitly checked) ================================== // // "Infectious": uses the largest data type passed public static byte min (final byte a, final byte b) { return (a > b) ? b : a; } @@ -1131,12 +1222,14 @@ public static long reverseLong (final long x) { public static double min (final double a, final float b) { return (a > b) ? b : a; } public static double min (final double a, final double b) { return Math.min(a, b); } - // ============================ REM ================================ // + // ================================== rem (unchecked) ====================================== // + // TODO other overloads public static long rem (final long a, final long b) { return a % b; } - // ============================ EVEN? ================================ // + // ======================================= even? =========================================== // + // NOTE that this is here for the Java quantum.core.Collections public static boolean isEven (final long x) { return isZero(bitAnd(x, 1)); } From d65e154f2af39bab532e62a9371a59bebd82fd29 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 15 Sep 2018 12:55:47 -0600 Subject: [PATCH 259/810] Add more comments --- src-java/quantum/core/Error.java | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src-java/quantum/core/Error.java b/src-java/quantum/core/Error.java index 292d8249..b913e809 100644 --- a/src-java/quantum/core/Error.java +++ b/src-java/quantum/core/Error.java @@ -26,8 +26,11 @@ import static quantum.core.Core.keyword; import static quantum.core.Core.throw_; -// Like `clojure.lang.ExceptionInfo`, but a record -// This is expanded from `(macroexpand-all '(defrecord Error [ident message data trace cause]))`, while extending `RuntimeException` +// - Like `clojure.lang.ExceptionInfo`, but a record +// - This is expanded from `(macroexpand-all '(defrecord Error [ident message data trace cause]))`, +// while extending `RuntimeException` +// - The reason this is in Java code is in order to extend `RuntimeException` directly without using +// Clojure's `proxy` public class Error extends RuntimeException From 155add294fd634b97a2d7e92f4ef4d425148c11d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 15 Sep 2018 13:00:36 -0600 Subject: [PATCH 260/810] Better naming --- src-java/quantum/core/Numeric.java | 72 +++++++++++++++--------------- 1 file changed, 36 insertions(+), 36 deletions(-) diff --git a/src-java/quantum/core/Numeric.java b/src-java/quantum/core/Numeric.java index 581a47dd..b7156119 100644 --- a/src-java/quantum/core/Numeric.java +++ b/src-java/quantum/core/Numeric.java @@ -342,60 +342,60 @@ public static double shiftRight (final long a, final double b) { // -------------------------------- unsignedShiftRight : >>> -------------------------------- // - public static boolean ushiftRight (final boolean a, final boolean b) { return a && !b; } - public static byte ushiftRight (final byte a, final byte b) { return (byte) (a >>> b);} - public static short ushiftRight (final byte a, final short b) { return (short)(a >>> b);} - public static char ushiftRight (final byte a, final char b) { return (char) (a >>> b);} - public static int ushiftRight (final byte a, final int b) { return a >>> b ;} - public static long ushiftRight (final byte a, final long b) { return a >>> b ;} - public static float ushiftRight (final byte a, final float b) { + public static boolean uShiftRight (final boolean a, final boolean b) { return a && !b; } + public static byte uShiftRight (final byte a, final byte b) { return (byte) (a >>> b);} + public static short uShiftRight (final byte a, final short b) { return (short)(a >>> b);} + public static char uShiftRight (final byte a, final char b) { return (char) (a >>> b);} + public static int uShiftRight (final byte a, final int b) { return a >>> b ;} + public static long uShiftRight (final byte a, final long b) { return a >>> b ;} + public static float uShiftRight (final byte a, final float b) { return Float.intBitsToFloat(a >>> Float.floatToIntBits(b)); } - public static double ushiftRight (final byte a, final double b) { + public static double uShiftRight (final byte a, final double b) { return Double.longBitsToDouble(a >>> Double.doubleToLongBits(b)); } - public static short ushiftRight (final short a, final byte b) { return (short)(a >>> b);} - public static short ushiftRight (final short a, final short b) { return (short)(a >>> b);} - public static short ushiftRight (final short a, final char b) { return (short)(a >>> b);} - public static int ushiftRight (final short a, final int b) { return a >>> b ;} - public static long ushiftRight (final short a, final long b) { return a >>> b ;} - public static float ushiftRight (final short a, final float b) { + public static short uShiftRight (final short a, final byte b) { return (short)(a >>> b);} + public static short uShiftRight (final short a, final short b) { return (short)(a >>> b);} + public static short uShiftRight (final short a, final char b) { return (short)(a >>> b);} + public static int uShiftRight (final short a, final int b) { return a >>> b ;} + public static long uShiftRight (final short a, final long b) { return a >>> b ;} + public static float uShiftRight (final short a, final float b) { return Float.intBitsToFloat(a >>> Float.floatToIntBits(b)); } - public static double ushiftRight (final short a, final double b) { + public static double uShiftRight (final short a, final double b) { return Double.longBitsToDouble(a >>> Double.doubleToLongBits(b)); } - public static char ushiftRight (final char a, final byte b) { return (char) (a >>> b);} - public static short ushiftRight (final char a, final short b) { return (short)(a >>> b);} - public static char ushiftRight (final char a, final char b) { return (char) (a >>> b);} - public static int ushiftRight (final char a, final int b) { return a >>> b ;} - public static long ushiftRight (final char a, final long b) { return a >>> b ;} - public static float ushiftRight (final char a, final float b) { + public static char uShiftRight (final char a, final byte b) { return (char) (a >>> b);} + public static short uShiftRight (final char a, final short b) { return (short)(a >>> b);} + public static char uShiftRight (final char a, final char b) { return (char) (a >>> b);} + public static int uShiftRight (final char a, final int b) { return a >>> b ;} + public static long uShiftRight (final char a, final long b) { return a >>> b ;} + public static float uShiftRight (final char a, final float b) { return Float.intBitsToFloat(a >>> Float.floatToIntBits(b)); } - public static double ushiftRight (final char a, final double b) { + public static double uShiftRight (final char a, final double b) { return Double.longBitsToDouble(a >>> Double.doubleToLongBits(b)); } - public static int ushiftRight (final int a, final byte b) { return a >>> b ;} - public static int ushiftRight (final int a, final short b) { return a >>> b ;} - public static int ushiftRight (final int a, final char b) { return a >>> b ;} - public static int ushiftRight (final int a, final int b) { return a >>> b ;} - public static long ushiftRight (final int a, final long b) { return a >>> b ;} - public static float ushiftRight (final int a, final float b) { + public static int uShiftRight (final int a, final byte b) { return a >>> b ;} + public static int uShiftRight (final int a, final short b) { return a >>> b ;} + public static int uShiftRight (final int a, final char b) { return a >>> b ;} + public static int uShiftRight (final int a, final int b) { return a >>> b ;} + public static long uShiftRight (final int a, final long b) { return a >>> b ;} + public static float uShiftRight (final int a, final float b) { return Float.intBitsToFloat(a >>> Float.floatToIntBits(b)); } - public static double ushiftRight (final int a, final double b) { + public static double uShiftRight (final int a, final double b) { return Double.longBitsToDouble(a >>> Double.doubleToLongBits(b)); } - public static long ushiftRight (final long a, final byte b) { return a >>> b ;} - public static long ushiftRight (final long a, final char b) { return a >>> b ;} - public static long ushiftRight (final long a, final short b) { return a >>> b ;} - public static long ushiftRight (final long a, final int b) { return a >>> b ;} - public static long ushiftRight (final long a, final long b) { return a >>> b ;} - public static double ushiftRight (final long a, final float b) { + public static long uShiftRight (final long a, final byte b) { return a >>> b ;} + public static long uShiftRight (final long a, final char b) { return a >>> b ;} + public static long uShiftRight (final long a, final short b) { return a >>> b ;} + public static long uShiftRight (final long a, final int b) { return a >>> b ;} + public static long uShiftRight (final long a, final long b) { return a >>> b ;} + public static double uShiftRight (final long a, final float b) { return Double.longBitsToDouble(a >>> Float.floatToIntBits(b)); } - public static double ushiftRight (final long a, final double b) { + public static double uShiftRight (final long a, final double b) { return Double.longBitsToDouble(a >>> Double.doubleToLongBits(b)); } From 2486db43b54ea7021c6795c4bf5eecd385819e1b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 15 Sep 2018 14:03:36 -0600 Subject: [PATCH 261/810] Add bit ops for float and double --- src-java/quantum/core/Numeric.java | 355 ++++++++++++++++++++++++----- 1 file changed, 297 insertions(+), 58 deletions(-) diff --git a/src-java/quantum/core/Numeric.java b/src-java/quantum/core/Numeric.java index b7156119..35bf5a2c 100644 --- a/src-java/quantum/core/Numeric.java +++ b/src-java/quantum/core/Numeric.java @@ -23,18 +23,34 @@ public class Numeric { public static boolean isTrue (final boolean a ) { return a == true; } public static boolean isFalse (final boolean a ) { return a == false; } public static boolean isNil (final Object a ) { return a == null; } + public static boolean not (final boolean a ) { return !a; } public static boolean and (final boolean a, final boolean b) { return a && b; } public static boolean or (final boolean a, final boolean b) { return a || b; } - public static boolean not (final boolean a ) { return !a; } // =================================== Bit Operations ======================================= // + // ---------------------------- bitNot : ! (implicitly checked) ---------------------------- // + + public static boolean bitNot (final boolean x) { return !x; } + public static byte bitNot (final byte x) { return (byte) ~x; } + public static short bitNot (final short x) { return (short)~x; } + public static char bitNot (final char x) { return (char) ~x; } + public static int bitNot (final int x) { return ~x; } + public static long bitNot (final long x) { return ~x; } + public static float bitNot (final float x) { + return Float.intBitsToFloat(~Float.floatToIntBits(x)); + } + public static double bitNot (final double x) { + return Double.longBitsToDouble(~Double.doubleToLongBits(x)); + } + // ---------------------------- bitAnd : & (implicitly checked) ---------------------------- // + // Returns the smallest safe type; decimals are "infectious" public static boolean bitAnd (final boolean a, final boolean b) { return a & b ; } public static byte bitAnd (final byte a, final byte b) { return (byte) (a & b); } public static short bitAnd (final byte a, final short b) { return (short)(a & b); } - public static char bitAnd (final byte a, final char b) { return (char) (a & b); } + public static int bitAnd (final byte a, final char b) { return a & b ; } public static int bitAnd (final byte a, final int b) { return a & b ; } public static long bitAnd (final byte a, final long b) { return a & b ; } public static float bitAnd (final byte a, final float b) { @@ -45,7 +61,7 @@ public static double bitAnd (final byte a, final double b) { } public static short bitAnd (final short a, final byte b) { return (short)(a & b); } public static short bitAnd (final short a, final short b) { return (short)(a & b); } - public static short bitAnd (final short a, final char b) { return (short)(a & b); } + public static int bitAnd (final short a, final char b) { return a & b ; } public static int bitAnd (final short a, final int b) { return a & b ; } public static long bitAnd (final short a, final long b) { return a & b ; } public static float bitAnd (final short a, final float b) { @@ -54,8 +70,8 @@ public static float bitAnd (final short a, final float b) { public static double bitAnd (final short a, final double b) { return Double.longBitsToDouble(a & Double.doubleToLongBits(b)); } - public static char bitAnd (final char a, final byte b) { return (char) (a & b); } - public static short bitAnd (final char a, final short b) { return (short)(a & b); } + public static int bitAnd (final char a, final byte b) { return a & b ; } + public static int bitAnd (final char a, final short b) { return a & b ; } public static char bitAnd (final char a, final char b) { return (char) (a & b); } public static int bitAnd (final char a, final int b) { return a & b ; } public static long bitAnd (final char a, final long b) { return a & b ; } @@ -87,13 +103,56 @@ public static double bitAnd (final long a, final float b) { public static double bitAnd (final long a, final double b) { return Double.longBitsToDouble(a & Double.doubleToLongBits(b)); } + public static float bitAnd (final float a, final byte b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) & b); + } + public static float bitAnd (final float a, final short b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) & b); + } + public static float bitAnd (final float a, final char b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) & b); + } + public static float bitAnd (final float a, final int b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) & b); + } + public static double bitAnd (final float a, final long b) { + return Double.longBitsToDouble(Float.floatToIntBits(a) & b); + } + public static double bitAnd (final float a, final float b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) & Float.floatToIntBits(b)); + } + public static double bitAnd (final float a, final double b) { + return Double.longBitsToDouble(Float.floatToIntBits(a) & Double.doubleToLongBits(b)); + } + public static double bitAnd (final double a, final byte b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) & b); + } + public static double bitAnd (final double a, final short b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) & b); + } + public static double bitAnd (final double a, final char b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) & b); + } + public static double bitAnd (final double a, final int b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) & b); + } + public static double bitAnd (final double a, final long b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) & b); + } + public static double bitAnd (final double a, final float b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) & Float.floatToIntBits(b)); + } + public static double bitAnd (final double a, final double b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) & Double.doubleToLongBits(b)); + } // ----------------------------- bitOr : | (implicitly checked) ----------------------------- // + // Returns the smallest safe type; decimals are "infectious" public static boolean bitOr (final boolean a, final boolean b) { return a | b ; } public static byte bitOr (final byte a, final byte b) { return (byte) (a | b); } public static short bitOr (final byte a, final short b) { return (short)(a | b); } - public static char bitOr (final byte a, final char b) { return (char) (a | b); } + public static int bitOr (final byte a, final char b) { return a | b ; } public static int bitOr (final byte a, final int b) { return a | b ; } public static long bitOr (final byte a, final long b) { return a | b ; } public static float bitOr (final byte a, final float b) { @@ -104,7 +163,7 @@ public static double bitOr (final byte a, final double b) { } public static short bitOr (final short a, final byte b) { return (short)(a | b); } public static short bitOr (final short a, final short b) { return (short)(a | b); } - public static short bitOr (final short a, final char b) { return (short)(a | b); } + public static int bitOr (final short a, final char b) { return a | b ; } public static int bitOr (final short a, final int b) { return a | b ; } public static long bitOr (final short a, final long b) { return a | b ; } public static float bitOr (final short a, final float b) { @@ -113,8 +172,8 @@ public static float bitOr (final short a, final float b) { public static double bitOr (final short a, final double b) { return Double.longBitsToDouble(a | Double.doubleToLongBits(b)); } - public static char bitOr (final char a, final byte b) { return (char) (a | b); } - public static short bitOr (final char a, final short b) { return (short)(a | b); } + public static int bitOr (final char a, final byte b) { return a | b ; } + public static int bitOr (final char a, final short b) { return a | b ; } public static char bitOr (final char a, final char b) { return (char) (a | b); } public static int bitOr (final char a, final int b) { return a | b ; } public static long bitOr (final char a, final long b) { return a | b ; } @@ -146,13 +205,56 @@ public static double bitOr (final long a, final float b) { public static double bitOr (final long a, final double b) { return Double.longBitsToDouble(a | Double.doubleToLongBits(b)); } + public static float bitOr (final float a, final byte b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) | b); + } + public static float bitOr (final float a, final short b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) | b); + } + public static float bitOr (final float a, final char b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) | b); + } + public static float bitOr (final float a, final int b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) | b); + } + public static double bitOr (final float a, final long b) { + return Double.longBitsToDouble(Float.floatToIntBits(a) | b); + } + public static double bitOr (final float a, final float b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) | Float.floatToIntBits(b)); + } + public static double bitOr (final float a, final double b) { + return Double.longBitsToDouble(Float.floatToIntBits(a) | Double.doubleToLongBits(b)); + } + public static double bitOr (final double a, final byte b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) | b); + } + public static double bitOr (final double a, final short b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) | b); + } + public static double bitOr (final double a, final char b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) | b); + } + public static double bitOr (final double a, final int b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) | b); + } + public static double bitOr (final double a, final long b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) | b); + } + public static double bitOr (final double a, final float b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) | Float.floatToIntBits(b)); + } + public static double bitOr (final double a, final double b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) | Double.doubleToLongBits(b)); + } // ------------------------------ bitXOr (implicitly checked) ------------------------------ // + // Returns the smallest safe type; decimals are "infectious" public static boolean bitXOr (final boolean a, final boolean b) { return a ^ b ; } public static byte bitXOr (final byte a, final byte b) { return (byte) (a ^ b); } public static short bitXOr (final byte a, final short b) { return (short)(a ^ b); } - public static char bitXOr (final byte a, final char b) { return (char) (a ^ b); } + public static int bitXOr (final byte a, final char b) { return a ^ b ; } public static int bitXOr (final byte a, final int b) { return a ^ b ; } public static long bitXOr (final byte a, final long b) { return a ^ b ; } public static float bitXOr (final byte a, final float b) { @@ -163,7 +265,7 @@ public static double bitXOr (final byte a, final double b) { } public static short bitXOr (final short a, final byte b) { return (short)(a ^ b); } public static short bitXOr (final short a, final short b) { return (short)(a ^ b); } - public static short bitXOr (final short a, final char b) { return (short)(a ^ b); } + public static int bitXOr (final short a, final char b) { return a ^ b ; } public static int bitXOr (final short a, final int b) { return a ^ b ; } public static long bitXOr (final short a, final long b) { return a ^ b ; } public static float bitXOr (final short a, final float b) { @@ -172,8 +274,8 @@ public static float bitXOr (final short a, final float b) { public static double bitXOr (final short a, final double b) { return Double.longBitsToDouble(a ^ Double.doubleToLongBits(b)); } - public static char bitXOr (final char a, final byte b) { return (char) (a ^ b); } - public static short bitXOr (final char a, final short b) { return (short)(a ^ b); } + public static int bitXOr (final char a, final byte b) { return a ^ b ; } + public static int bitXOr (final char a, final short b) { return a ^ b ; } public static char bitXOr (final char a, final char b) { return (char) (a ^ b); } public static int bitXOr (final char a, final int b) { return a ^ b ; } public static long bitXOr (final char a, final long b) { return a ^ b ; } @@ -205,29 +307,57 @@ public static double bitXOr (final long a, final float b) { public static double bitXOr (final long a, final double b) { return Double.longBitsToDouble(a ^ Double.doubleToLongBits(b)); } - - // ---------------------------- bitNot : ! (implicitly checked) ---------------------------- // - - public static boolean bitNot (final boolean x) { return !x; } - public static byte bitNot (final byte x) { return (byte) ~x; } - public static short bitNot (final short x) { return (short)~x; } - public static char bitNot (final char x) { return (char) ~x; } - public static int bitNot (final int x) { return ~x; } - public static long bitNot (final long x) { return ~x; } - public static float bitNot (final float x) { - return Float.intBitsToFloat(~Float.floatToIntBits(x)); + public static float bitXOr (final float a, final byte b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) ^ b); } - public static double bitNot (final double x) { - return Double.longBitsToDouble(~Double.doubleToLongBits(x)); + public static float bitXOr (final float a, final short b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) ^ b); + } + public static float bitXOr (final float a, final char b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) ^ b); + } + public static float bitXOr (final float a, final int b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) ^ b); + } + public static double bitXOr (final float a, final long b) { + return Double.longBitsToDouble(Float.floatToIntBits(a) ^ b); + } + public static double bitXOr (final float a, final float b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) ^ Float.floatToIntBits(b)); + } + public static double bitXOr (final float a, final double b) { + return Double.longBitsToDouble(Float.floatToIntBits(a) ^ Double.doubleToLongBits(b)); + } + public static double bitXOr (final double a, final byte b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) ^ b); + } + public static double bitXOr (final double a, final short b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) ^ b); + } + public static double bitXOr (final double a, final char b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) ^ b); + } + public static double bitXOr (final double a, final int b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) ^ b); + } + public static double bitXOr (final double a, final long b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) ^ b); + } + public static double bitXOr (final double a, final float b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) ^ Float.floatToIntBits(b)); + } + public static double bitXOr (final double a, final double b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) ^ Double.doubleToLongBits(b)); } // -------------------------- shiftLeft : << (implicitly checked) -------------------------- // + // Returns the smallest safe type; decimals are "infectious" // Though technically `1 << 1` = 2, not 1 public static boolean shiftLeft (final boolean a, final boolean b) { return a; } public static byte shiftLeft (final byte a, final byte b) { return (byte) (a << b); } public static short shiftLeft (final byte a, final short b) { return (short)(a << b); } - public static char shiftLeft (final byte a, final char b) { return (char) (a << b); } + public static int shiftLeft (final byte a, final char b) { return a << b ; } public static int shiftLeft (final byte a, final int b) { return a << b ; } public static long shiftLeft (final byte a, final long b) { return a << b ; } public static float shiftLeft (final byte a, final float b) { @@ -238,7 +368,7 @@ public static double shiftLeft (final byte a, final double b) { } public static short shiftLeft (final short a, final byte b) { return (short)(a << b); } public static short shiftLeft (final short a, final short b) { return (short)(a << b); } - public static short shiftLeft (final short a, final char b) { return (short)(a << b); } + public static int shiftLeft (final short a, final char b) { return a << b ; } public static int shiftLeft (final short a, final int b) { return a << b ; } public static long shiftLeft (final short a, final long b) { return a << b ; } public static float shiftLeft (final short a, final float b) { @@ -247,8 +377,8 @@ public static float shiftLeft (final short a, final float b) { public static double shiftLeft (final short a, final double b) { return Double.longBitsToDouble(a << Double.doubleToLongBits(b)); } - public static char shiftLeft (final char a, final byte b) { return (char) (a << b); } - public static short shiftLeft (final char a, final short b) { return (short)(a << b); } + public static int shiftLeft (final char a, final byte b) { return a << b ; } + public static int shiftLeft (final char a, final short b) { return a << b ; } public static char shiftLeft (final char a, final char b) { return (char) (a << b); } public static int shiftLeft (final char a, final int b) { return a << b ; } public static long shiftLeft (final char a, final long b) { return a << b ; } @@ -280,13 +410,56 @@ public static double shiftLeft (final long a, final float b) { public static double shiftLeft (final long a, final double b) { return Double.longBitsToDouble(a << Double.doubleToLongBits(b)); } + public static float shiftLeft (final float a, final byte b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) << b); + } + public static float shiftLeft (final float a, final short b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) << b); + } + public static float shiftLeft (final float a, final char b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) << b); + } + public static float shiftLeft (final float a, final int b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) << b); + } + public static double shiftLeft (final float a, final long b) { + return Double.longBitsToDouble(Float.floatToIntBits(a) << b); + } + public static double shiftLeft (final float a, final float b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) << Float.floatToIntBits(b)); + } + public static double shiftLeft (final float a, final double b) { + return Double.longBitsToDouble(Float.floatToIntBits(a) << Double.doubleToLongBits(b)); + } + public static double shiftLeft (final double a, final byte b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) << b); + } + public static double shiftLeft (final double a, final short b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) << b); + } + public static double shiftLeft (final double a, final char b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) << b); + } + public static double shiftLeft (final double a, final int b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) << b); + } + public static double shiftLeft (final double a, final long b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) << b); + } + public static double shiftLeft (final double a, final float b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) << Float.floatToIntBits(b)); + } + public static double shiftLeft (final double a, final double b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) << Double.doubleToLongBits(b)); + } // -------------------------- shiftRight : >> (implicitly checked) -------------------------- // + // Returns the smallest safe type; decimals are "infectious" public static boolean shiftRight (final boolean a, final boolean b) { return a && !b; } public static byte shiftRight (final byte a, final byte b) { return (byte) (a >> b); } public static short shiftRight (final byte a, final short b) { return (short)(a >> b); } - public static char shiftRight (final byte a, final char b) { return (char) (a >> b); } + public static int shiftRight (final byte a, final char b) { return a >> b ; } public static int shiftRight (final byte a, final int b) { return a >> b ; } public static long shiftRight (final byte a, final long b) { return a >> b ; } public static float shiftRight (final byte a, final float b) { @@ -297,7 +470,7 @@ public static double shiftRight (final byte a, final double b) { } public static short shiftRight (final short a, final byte b) { return (short)(a >> b); } public static short shiftRight (final short a, final short b) { return (short)(a >> b); } - public static short shiftRight (final short a, final char b) { return (short)(a >> b); } + public static int shiftRight (final short a, final char b) { return a >> b ; } public static int shiftRight (final short a, final int b) { return a >> b ; } public static long shiftRight (final short a, final long b) { return a >> b ; } public static float shiftRight (final short a, final float b) { @@ -306,8 +479,8 @@ public static float shiftRight (final short a, final float b) { public static double shiftRight (final short a, final double b) { return Double.longBitsToDouble(a >> Double.doubleToLongBits(b)); } - public static char shiftRight (final char a, final byte b) { return (char) (a >> b); } - public static short shiftRight (final char a, final short b) { return (short)(a >> b); } + public static int shiftRight (final char a, final byte b) { return a >> b ; } + public static int shiftRight (final char a, final short b) { return a >> b ; } public static char shiftRight (final char a, final char b) { return (char) (a >> b); } public static int shiftRight (final char a, final int b) { return a >> b ; } public static long shiftRight (final char a, final long b) { return a >> b ; } @@ -339,13 +512,56 @@ public static double shiftRight (final long a, final float b) { public static double shiftRight (final long a, final double b) { return Double.longBitsToDouble(a >> Double.doubleToLongBits(b)); } + public static float shiftRight (final float a, final byte b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) >> b); + } + public static float shiftRight (final float a, final short b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) >> b); + } + public static float shiftRight (final float a, final char b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) >> b); + } + public static float shiftRight (final float a, final int b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) >> b); + } + public static double shiftRight (final float a, final long b) { + return Double.longBitsToDouble(Float.floatToIntBits(a) >> b); + } + public static double shiftRight (final float a, final float b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) >> Float.floatToIntBits(b)); + } + public static double shiftRight (final float a, final double b) { + return Double.longBitsToDouble(Float.floatToIntBits(a) >> Double.doubleToLongBits(b)); + } + public static double shiftRight (final double a, final byte b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) >> b); + } + public static double shiftRight (final double a, final short b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) >> b); + } + public static double shiftRight (final double a, final char b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) >> b); + } + public static double shiftRight (final double a, final int b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) >> b); + } + public static double shiftRight (final double a, final long b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) >> b); + } + public static double shiftRight (final double a, final float b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) >> Float.floatToIntBits(b)); + } + public static double shiftRight (final double a, final double b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) >> Double.doubleToLongBits(b)); + } // -------------------------------- unsignedShiftRight : >>> -------------------------------- // + // Returns the smallest safe type; decimals are "infectious" public static boolean uShiftRight (final boolean a, final boolean b) { return a && !b; } public static byte uShiftRight (final byte a, final byte b) { return (byte) (a >>> b);} public static short uShiftRight (final byte a, final short b) { return (short)(a >>> b);} - public static char uShiftRight (final byte a, final char b) { return (char) (a >>> b);} + public static int uShiftRight (final byte a, final char b) { return a >>> b ;} public static int uShiftRight (final byte a, final int b) { return a >>> b ;} public static long uShiftRight (final byte a, final long b) { return a >>> b ;} public static float uShiftRight (final byte a, final float b) { @@ -356,7 +572,7 @@ public static double uShiftRight (final byte a, final double b) { } public static short uShiftRight (final short a, final byte b) { return (short)(a >>> b);} public static short uShiftRight (final short a, final short b) { return (short)(a >>> b);} - public static short uShiftRight (final short a, final char b) { return (short)(a >>> b);} + public static int uShiftRight (final short a, final char b) { return a >>> b ;} public static int uShiftRight (final short a, final int b) { return a >>> b ;} public static long uShiftRight (final short a, final long b) { return a >>> b ;} public static float uShiftRight (final short a, final float b) { @@ -365,8 +581,8 @@ public static float uShiftRight (final short a, final float b) { public static double uShiftRight (final short a, final double b) { return Double.longBitsToDouble(a >>> Double.doubleToLongBits(b)); } - public static char uShiftRight (final char a, final byte b) { return (char) (a >>> b);} - public static short uShiftRight (final char a, final short b) { return (short)(a >>> b);} + public static int uShiftRight (final char a, final byte b) { return a >>> b ;} + public static int uShiftRight (final char a, final short b) { return a >>> b ;} public static char uShiftRight (final char a, final char b) { return (char) (a >>> b);} public static int uShiftRight (final char a, final int b) { return a >>> b ;} public static long uShiftRight (final char a, final long b) { return a >>> b ;} @@ -398,6 +614,48 @@ public static double uShiftRight (final long a, final float b) { public static double uShiftRight (final long a, final double b) { return Double.longBitsToDouble(a >>> Double.doubleToLongBits(b)); } + public static float uShiftRight (final float a, final byte b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) >>> b); + } + public static float uShiftRight (final float a, final short b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) >>> b); + } + public static float uShiftRight (final float a, final char b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) >>> b); + } + public static float uShiftRight (final float a, final int b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) >>> b); + } + public static double uShiftRight (final float a, final long b) { + return Double.longBitsToDouble(Float.floatToIntBits(a) >>> b); + } + public static double uShiftRight (final float a, final float b) { + return Float.intBitsToFloat(Float.floatToIntBits(a) >>> Float.floatToIntBits(b)); + } + public static double uShiftRight (final float a, final double b) { + return Double.longBitsToDouble(Float.floatToIntBits(a) >>> Double.doubleToLongBits(b)); + } + public static double uShiftRight (final double a, final byte b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) >>> b); + } + public static double uShiftRight (final double a, final short b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) >>> b); + } + public static double uShiftRight (final double a, final char b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) >>> b); + } + public static double uShiftRight (final double a, final int b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) >>> b); + } + public static double uShiftRight (final double a, final long b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) >>> b); + } + public static double uShiftRight (final double a, final float b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) >>> Float.floatToIntBits(b)); + } + public static double uShiftRight (final double a, final double b) { + return Double.longBitsToDouble(Double.doubleToLongBits(a) >>> Double.doubleToLongBits(b)); + } // ---------------------------------- bitClear (unchecked) ---------------------------------- // @@ -428,6 +686,7 @@ public static double bitFlip (final double x, final long n) { } // ----------------------------------- bitSet (unchecked) ----------------------------------- // + // Returns the smallest safe type public static byte bitSet (final byte x, final long n) { return (byte) (x | (1L << n)); } public static short bitSet (final short x, final long n) { return (short)(x | (1L << n)); } @@ -455,26 +714,6 @@ public static boolean bitTest (final double x, final long n) { return (Double.doubleToLongBits(x) & (1L << n)) != 0L; } - // ------------------------------ reverse (implicitly checked) ------------------------------ // - - // Because "more than one matching method" - public static short reverseShort(final short x) { - return (short) ((x << 8) - | ((char) x >>> 8)); - } - - public static int reverseInt (final int x) { - return ( (x << 24) - | ((x & 0x0000ff00) << 8) - | ((x & 0x00ff0000) >>> 8) - | (x >>> 24)); - } - - public static long reverseLong (final long x) { - return ( ((long) reverseInt((int)x) << 32) - | ((long) reverseInt((int)(x >>> 32)) & 0xffffffffL)); - } - // ======================================= lt : < =========================================== // public static boolean lt (final byte a, final byte b) { return a < b; } From 092b3ab54d90172b52b52c87bb2fcc5dec81cd7d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 15 Sep 2018 14:05:58 -0600 Subject: [PATCH 262/810] Fix return type --- src-java/quantum/core/Numeric.java | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src-java/quantum/core/Numeric.java b/src-java/quantum/core/Numeric.java index 35bf5a2c..b63c1b37 100644 --- a/src-java/quantum/core/Numeric.java +++ b/src-java/quantum/core/Numeric.java @@ -118,7 +118,7 @@ public static float bitAnd (final float a, final int b) { public static double bitAnd (final float a, final long b) { return Double.longBitsToDouble(Float.floatToIntBits(a) & b); } - public static double bitAnd (final float a, final float b) { + public static float bitAnd (final float a, final float b) { return Float.intBitsToFloat(Float.floatToIntBits(a) & Float.floatToIntBits(b)); } public static double bitAnd (final float a, final double b) { @@ -220,7 +220,7 @@ public static float bitOr (final float a, final int b) { public static double bitOr (final float a, final long b) { return Double.longBitsToDouble(Float.floatToIntBits(a) | b); } - public static double bitOr (final float a, final float b) { + public static float bitOr (final float a, final float b) { return Float.intBitsToFloat(Float.floatToIntBits(a) | Float.floatToIntBits(b)); } public static double bitOr (final float a, final double b) { @@ -322,7 +322,7 @@ public static float bitXOr (final float a, final int b) { public static double bitXOr (final float a, final long b) { return Double.longBitsToDouble(Float.floatToIntBits(a) ^ b); } - public static double bitXOr (final float a, final float b) { + public static float bitXOr (final float a, final float b) { return Float.intBitsToFloat(Float.floatToIntBits(a) ^ Float.floatToIntBits(b)); } public static double bitXOr (final float a, final double b) { @@ -425,7 +425,7 @@ public static float shiftLeft (final float a, final int b) { public static double shiftLeft (final float a, final long b) { return Double.longBitsToDouble(Float.floatToIntBits(a) << b); } - public static double shiftLeft (final float a, final float b) { + public static float shiftLeft (final float a, final float b) { return Float.intBitsToFloat(Float.floatToIntBits(a) << Float.floatToIntBits(b)); } public static double shiftLeft (final float a, final double b) { @@ -527,7 +527,7 @@ public static float shiftRight (final float a, final int b) { public static double shiftRight (final float a, final long b) { return Double.longBitsToDouble(Float.floatToIntBits(a) >> b); } - public static double shiftRight (final float a, final float b) { + public static float shiftRight (final float a, final float b) { return Float.intBitsToFloat(Float.floatToIntBits(a) >> Float.floatToIntBits(b)); } public static double shiftRight (final float a, final double b) { @@ -629,7 +629,7 @@ public static float uShiftRight (final float a, final int b) { public static double uShiftRight (final float a, final long b) { return Double.longBitsToDouble(Float.floatToIntBits(a) >>> b); } - public static double uShiftRight (final float a, final float b) { + public static float uShiftRight (final float a, final float b) { return Float.intBitsToFloat(Float.floatToIntBits(a) >>> Float.floatToIntBits(b)); } public static double uShiftRight (final float a, final double b) { From 2b8b52a676951f7654820fae342cbfb2dfa1860b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 15 Sep 2018 15:10:14 -0600 Subject: [PATCH 263/810] Fix all the shifts --- src-java/quantum/core/Numeric.java | 465 ++++++++++------------------- src/quantum/core/data/bits.cljc | 245 +++++++++++---- 2 files changed, 359 insertions(+), 351 deletions(-) diff --git a/src-java/quantum/core/Numeric.java b/src-java/quantum/core/Numeric.java index b63c1b37..e2648d52 100644 --- a/src-java/quantum/core/Numeric.java +++ b/src-java/quantum/core/Numeric.java @@ -351,310 +351,177 @@ public static double bitXOr (final double a, final double b) { } // -------------------------- shiftLeft : << (implicitly checked) -------------------------- // - // Returns the smallest safe type; decimals are "infectious" - // Though technically `1 << 1` = 2, not 1 - public static boolean shiftLeft (final boolean a, final boolean b) { return a; } - public static byte shiftLeft (final byte a, final byte b) { return (byte) (a << b); } - public static short shiftLeft (final byte a, final short b) { return (short)(a << b); } - public static int shiftLeft (final byte a, final char b) { return a << b ; } - public static int shiftLeft (final byte a, final int b) { return a << b ; } - public static long shiftLeft (final byte a, final long b) { return a << b ; } - public static float shiftLeft (final byte a, final float b) { - return Float.intBitsToFloat(a << Float.floatToIntBits(b)); - } - public static double shiftLeft (final byte a, final double b) { - return Double.longBitsToDouble(a << Double.doubleToLongBits(b)); - } - public static short shiftLeft (final short a, final byte b) { return (short)(a << b); } - public static short shiftLeft (final short a, final short b) { return (short)(a << b); } - public static int shiftLeft (final short a, final char b) { return a << b ; } - public static int shiftLeft (final short a, final int b) { return a << b ; } - public static long shiftLeft (final short a, final long b) { return a << b ; } - public static float shiftLeft (final short a, final float b) { - return Float.intBitsToFloat(a << Float.floatToIntBits(b)); - } - public static double shiftLeft (final short a, final double b) { - return Double.longBitsToDouble(a << Double.doubleToLongBits(b)); - } - public static int shiftLeft (final char a, final byte b) { return a << b ; } - public static int shiftLeft (final char a, final short b) { return a << b ; } - public static char shiftLeft (final char a, final char b) { return (char) (a << b); } - public static int shiftLeft (final char a, final int b) { return a << b ; } - public static long shiftLeft (final char a, final long b) { return a << b ; } - public static float shiftLeft (final char a, final float b) { - return Float.intBitsToFloat(a << Float.floatToIntBits(b)); - } - public static double shiftLeft (final char a, final double b) { - return Double.longBitsToDouble(a << Double.doubleToLongBits(b)); - } - public static int shiftLeft (final int a, final byte b) { return a << b ; } - public static int shiftLeft (final int a, final short b) { return a << b ; } - public static int shiftLeft (final int a, final char b) { return a << b ; } - public static int shiftLeft (final int a, final int b) { return a << b ; } - public static long shiftLeft (final int a, final long b) { return a << b ; } - public static float shiftLeft (final int a, final float b) { - return Float.intBitsToFloat(a << Float.floatToIntBits(b)); - } - public static double shiftLeft (final int a, final double b) { - return Double.longBitsToDouble(a << Double.doubleToLongBits(b)); - } - public static long shiftLeft (final long a, final byte b) { return a << b ; } - public static long shiftLeft (final long a, final char b) { return a << b ; } - public static long shiftLeft (final long a, final short b) { return a << b ; } - public static long shiftLeft (final long a, final int b) { return a << b ; } - public static long shiftLeft (final long a, final long b) { return a << b ; } - public static double shiftLeft (final long a, final float b) { - return Double.longBitsToDouble(a << Float.floatToIntBits(b)); - } - public static double shiftLeft (final long a, final double b) { - return Double.longBitsToDouble(a << Double.doubleToLongBits(b)); - } - public static float shiftLeft (final float a, final byte b) { - return Float.intBitsToFloat(Float.floatToIntBits(a) << b); - } - public static float shiftLeft (final float a, final short b) { - return Float.intBitsToFloat(Float.floatToIntBits(a) << b); - } - public static float shiftLeft (final float a, final char b) { - return Float.intBitsToFloat(Float.floatToIntBits(a) << b); - } - public static float shiftLeft (final float a, final int b) { - return Float.intBitsToFloat(Float.floatToIntBits(a) << b); - } - public static double shiftLeft (final float a, final long b) { - return Double.longBitsToDouble(Float.floatToIntBits(a) << b); - } - public static float shiftLeft (final float a, final float b) { - return Float.intBitsToFloat(Float.floatToIntBits(a) << Float.floatToIntBits(b)); - } - public static double shiftLeft (final float a, final double b) { - return Double.longBitsToDouble(Float.floatToIntBits(a) << Double.doubleToLongBits(b)); - } - public static double shiftLeft (final double a, final byte b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) << b); - } - public static double shiftLeft (final double a, final short b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) << b); - } - public static double shiftLeft (final double a, final char b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) << b); - } - public static double shiftLeft (final double a, final int b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) << b); - } - public static double shiftLeft (final double a, final long b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) << b); - } - public static double shiftLeft (final double a, final float b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) << Float.floatToIntBits(b)); - } - public static double shiftLeft (final double a, final double b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) << Double.doubleToLongBits(b)); + public static byte shiftLeft (final byte x, final byte n) { return (byte) (x << n); } + public static byte shiftLeft (final byte x, final short n) { return (byte) (x << n); } + public static byte shiftLeft (final byte x, final char n) { return (byte) (x << n); } + public static byte shiftLeft (final byte x, final int n) { return (byte) (x << n); } + public static byte shiftLeft (final byte x, final long n) { return (byte) (x << n); } + public static short shiftLeft (final short x, final byte n) { return (short)(x << n); } + public static short shiftLeft (final short x, final short n) { return (short)(x << n); } + public static short shiftLeft (final short x, final char n) { return (short)(x << n); } + public static short shiftLeft (final short x, final int n) { return (short)(x << n); } + public static short shiftLeft (final short x, final long n) { return (short)(x << n); } + public static char shiftLeft (final char x, final byte n) { return (char) (x << n); } + public static char shiftLeft (final char x, final short n) { return (char) (x << n); } + public static char shiftLeft (final char x, final char n) { return (char) (x << n); } + public static char shiftLeft (final char x, final int n) { return (char) (x << n); } + public static char shiftLeft (final char x, final long n) { return (char) (x << n); } + public static int shiftLeft (final int x, final byte n) { return x << n ; } + public static int shiftLeft (final int x, final short n) { return x << n ; } + public static int shiftLeft (final int x, final char n) { return x << n ; } + public static int shiftLeft (final int x, final int n) { return x << n ; } + public static int shiftLeft (final int x, final long n) { return x << n ; } + public static long shiftLeft (final long x, final byte n) { return x << n ; } + public static long shiftLeft (final long x, final char n) { return x << n ; } + public static long shiftLeft (final long x, final short n) { return x << n ; } + public static long shiftLeft (final long x, final int n) { return x << n ; } + public static long shiftLeft (final long x, final long n) { return x << n ; } + public static float shiftLeft (final float x, final byte n) { + return Float.intBitsToFloat(Float.floatToIntBits(x) << n); + } + public static float shiftLeft (final float x, final short n) { + return Float.intBitsToFloat(Float.floatToIntBits(x) << n); + } + public static float shiftLeft (final float x, final char n) { + return Float.intBitsToFloat(Float.floatToIntBits(x) << n); + } + public static float shiftLeft (final float x, final int n) { + return Float.intBitsToFloat(Float.floatToIntBits(x) << n); + } + public static float shiftLeft (final float x, final long n) { + return Float.intBitsToFloat(Float.floatToIntBits(x) << n); + } + public static double shiftLeft (final double x, final byte n) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) << n); + } + public static double shiftLeft (final double x, final short n) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) << n); + } + public static double shiftLeft (final double x, final char n) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) << n); + } + public static double shiftLeft (final double x, final int n) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) << n); + } + public static double shiftLeft (final double x, final long n) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) << n); } // -------------------------- shiftRight : >> (implicitly checked) -------------------------- // - // Returns the smallest safe type; decimals are "infectious" - public static boolean shiftRight (final boolean a, final boolean b) { return a && !b; } - public static byte shiftRight (final byte a, final byte b) { return (byte) (a >> b); } - public static short shiftRight (final byte a, final short b) { return (short)(a >> b); } - public static int shiftRight (final byte a, final char b) { return a >> b ; } - public static int shiftRight (final byte a, final int b) { return a >> b ; } - public static long shiftRight (final byte a, final long b) { return a >> b ; } - public static float shiftRight (final byte a, final float b) { - return Float.intBitsToFloat(a >> Float.floatToIntBits(b)); - } - public static double shiftRight (final byte a, final double b) { - return Double.longBitsToDouble(a >> Double.doubleToLongBits(b)); - } - public static short shiftRight (final short a, final byte b) { return (short)(a >> b); } - public static short shiftRight (final short a, final short b) { return (short)(a >> b); } - public static int shiftRight (final short a, final char b) { return a >> b ; } - public static int shiftRight (final short a, final int b) { return a >> b ; } - public static long shiftRight (final short a, final long b) { return a >> b ; } - public static float shiftRight (final short a, final float b) { - return Float.intBitsToFloat(a >> Float.floatToIntBits(b)); - } - public static double shiftRight (final short a, final double b) { - return Double.longBitsToDouble(a >> Double.doubleToLongBits(b)); - } - public static int shiftRight (final char a, final byte b) { return a >> b ; } - public static int shiftRight (final char a, final short b) { return a >> b ; } - public static char shiftRight (final char a, final char b) { return (char) (a >> b); } - public static int shiftRight (final char a, final int b) { return a >> b ; } - public static long shiftRight (final char a, final long b) { return a >> b ; } - public static float shiftRight (final char a, final float b) { - return Float.intBitsToFloat(a >> Float.floatToIntBits(b)); - } - public static double shiftRight (final char a, final double b) { - return Double.longBitsToDouble(a >> Double.doubleToLongBits(b)); - } - public static int shiftRight (final int a, final byte b) { return a >> b ; } - public static int shiftRight (final int a, final short b) { return a >> b ; } - public static int shiftRight (final int a, final char b) { return a >> b ; } - public static int shiftRight (final int a, final int b) { return a >> b ; } - public static long shiftRight (final int a, final long b) { return a >> b ; } - public static float shiftRight (final int a, final float b) { - return Float.intBitsToFloat(a >> Float.floatToIntBits(b)); - } - public static double shiftRight (final int a, final double b) { - return Double.longBitsToDouble(a >> Double.doubleToLongBits(b)); - } - public static long shiftRight (final long a, final byte b) { return a >> b ; } - public static long shiftRight (final long a, final char b) { return a >> b ; } - public static long shiftRight (final long a, final short b) { return a >> b ; } - public static long shiftRight (final long a, final int b) { return a >> b ; } - public static long shiftRight (final long a, final long b) { return a >> b ; } - public static double shiftRight (final long a, final float b) { - return Double.longBitsToDouble(a >> Float.floatToIntBits(b)); - } - public static double shiftRight (final long a, final double b) { - return Double.longBitsToDouble(a >> Double.doubleToLongBits(b)); - } - public static float shiftRight (final float a, final byte b) { - return Float.intBitsToFloat(Float.floatToIntBits(a) >> b); - } - public static float shiftRight (final float a, final short b) { - return Float.intBitsToFloat(Float.floatToIntBits(a) >> b); - } - public static float shiftRight (final float a, final char b) { - return Float.intBitsToFloat(Float.floatToIntBits(a) >> b); - } - public static float shiftRight (final float a, final int b) { - return Float.intBitsToFloat(Float.floatToIntBits(a) >> b); - } - public static double shiftRight (final float a, final long b) { - return Double.longBitsToDouble(Float.floatToIntBits(a) >> b); - } - public static float shiftRight (final float a, final float b) { - return Float.intBitsToFloat(Float.floatToIntBits(a) >> Float.floatToIntBits(b)); - } - public static double shiftRight (final float a, final double b) { - return Double.longBitsToDouble(Float.floatToIntBits(a) >> Double.doubleToLongBits(b)); - } - public static double shiftRight (final double a, final byte b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) >> b); - } - public static double shiftRight (final double a, final short b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) >> b); - } - public static double shiftRight (final double a, final char b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) >> b); - } - public static double shiftRight (final double a, final int b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) >> b); - } - public static double shiftRight (final double a, final long b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) >> b); - } - public static double shiftRight (final double a, final float b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) >> Float.floatToIntBits(b)); - } - public static double shiftRight (final double a, final double b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) >> Double.doubleToLongBits(b)); - } - - // -------------------------------- unsignedShiftRight : >>> -------------------------------- // - // Returns the smallest safe type; decimals are "infectious" - - public static boolean uShiftRight (final boolean a, final boolean b) { return a && !b; } - public static byte uShiftRight (final byte a, final byte b) { return (byte) (a >>> b);} - public static short uShiftRight (final byte a, final short b) { return (short)(a >>> b);} - public static int uShiftRight (final byte a, final char b) { return a >>> b ;} - public static int uShiftRight (final byte a, final int b) { return a >>> b ;} - public static long uShiftRight (final byte a, final long b) { return a >>> b ;} - public static float uShiftRight (final byte a, final float b) { - return Float.intBitsToFloat(a >>> Float.floatToIntBits(b)); - } - public static double uShiftRight (final byte a, final double b) { - return Double.longBitsToDouble(a >>> Double.doubleToLongBits(b)); - } - public static short uShiftRight (final short a, final byte b) { return (short)(a >>> b);} - public static short uShiftRight (final short a, final short b) { return (short)(a >>> b);} - public static int uShiftRight (final short a, final char b) { return a >>> b ;} - public static int uShiftRight (final short a, final int b) { return a >>> b ;} - public static long uShiftRight (final short a, final long b) { return a >>> b ;} - public static float uShiftRight (final short a, final float b) { - return Float.intBitsToFloat(a >>> Float.floatToIntBits(b)); - } - public static double uShiftRight (final short a, final double b) { - return Double.longBitsToDouble(a >>> Double.doubleToLongBits(b)); - } - public static int uShiftRight (final char a, final byte b) { return a >>> b ;} - public static int uShiftRight (final char a, final short b) { return a >>> b ;} - public static char uShiftRight (final char a, final char b) { return (char) (a >>> b);} - public static int uShiftRight (final char a, final int b) { return a >>> b ;} - public static long uShiftRight (final char a, final long b) { return a >>> b ;} - public static float uShiftRight (final char a, final float b) { - return Float.intBitsToFloat(a >>> Float.floatToIntBits(b)); - } - public static double uShiftRight (final char a, final double b) { - return Double.longBitsToDouble(a >>> Double.doubleToLongBits(b)); - } - public static int uShiftRight (final int a, final byte b) { return a >>> b ;} - public static int uShiftRight (final int a, final short b) { return a >>> b ;} - public static int uShiftRight (final int a, final char b) { return a >>> b ;} - public static int uShiftRight (final int a, final int b) { return a >>> b ;} - public static long uShiftRight (final int a, final long b) { return a >>> b ;} - public static float uShiftRight (final int a, final float b) { - return Float.intBitsToFloat(a >>> Float.floatToIntBits(b)); - } - public static double uShiftRight (final int a, final double b) { - return Double.longBitsToDouble(a >>> Double.doubleToLongBits(b)); - } - public static long uShiftRight (final long a, final byte b) { return a >>> b ;} - public static long uShiftRight (final long a, final char b) { return a >>> b ;} - public static long uShiftRight (final long a, final short b) { return a >>> b ;} - public static long uShiftRight (final long a, final int b) { return a >>> b ;} - public static long uShiftRight (final long a, final long b) { return a >>> b ;} - public static double uShiftRight (final long a, final float b) { - return Double.longBitsToDouble(a >>> Float.floatToIntBits(b)); - } - public static double uShiftRight (final long a, final double b) { - return Double.longBitsToDouble(a >>> Double.doubleToLongBits(b)); - } - public static float uShiftRight (final float a, final byte b) { - return Float.intBitsToFloat(Float.floatToIntBits(a) >>> b); - } - public static float uShiftRight (final float a, final short b) { - return Float.intBitsToFloat(Float.floatToIntBits(a) >>> b); - } - public static float uShiftRight (final float a, final char b) { - return Float.intBitsToFloat(Float.floatToIntBits(a) >>> b); - } - public static float uShiftRight (final float a, final int b) { - return Float.intBitsToFloat(Float.floatToIntBits(a) >>> b); - } - public static double uShiftRight (final float a, final long b) { - return Double.longBitsToDouble(Float.floatToIntBits(a) >>> b); - } - public static float uShiftRight (final float a, final float b) { - return Float.intBitsToFloat(Float.floatToIntBits(a) >>> Float.floatToIntBits(b)); - } - public static double uShiftRight (final float a, final double b) { - return Double.longBitsToDouble(Float.floatToIntBits(a) >>> Double.doubleToLongBits(b)); - } - public static double uShiftRight (final double a, final byte b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) >>> b); - } - public static double uShiftRight (final double a, final short b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) >>> b); - } - public static double uShiftRight (final double a, final char b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) >>> b); - } - public static double uShiftRight (final double a, final int b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) >>> b); - } - public static double uShiftRight (final double a, final long b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) >>> b); - } - public static double uShiftRight (final double a, final float b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) >>> Float.floatToIntBits(b)); - } - public static double uShiftRight (final double a, final double b) { - return Double.longBitsToDouble(Double.doubleToLongBits(a) >>> Double.doubleToLongBits(b)); + public static byte shiftRight (final byte x, final byte n) { return (byte) (x >> n); } + public static byte shiftRight (final byte x, final short n) { return (byte) (x >> n); } + public static byte shiftRight (final byte x, final char n) { return (byte) (x >> n); } + public static byte shiftRight (final byte x, final int n) { return (byte) (x >> n); } + public static byte shiftRight (final byte x, final long n) { return (byte) (x >> n); } + public static short shiftRight (final short x, final byte n) { return (short)(x >> n); } + public static short shiftRight (final short x, final short n) { return (short)(x >> n); } + public static short shiftRight (final short x, final char n) { return (short)(x >> n); } + public static short shiftRight (final short x, final int n) { return (short)(x >> n); } + public static short shiftRight (final short x, final long n) { return (short)(x >> n); } + public static char shiftRight (final char x, final byte n) { return (char) (x >> n); } + public static char shiftRight (final char x, final short n) { return (char) (x >> n); } + public static char shiftRight (final char x, final char n) { return (char) (x >> n); } + public static char shiftRight (final char x, final int n) { return (char) (x >> n); } + public static char shiftRight (final char x, final long n) { return (char) (x >> n); } + public static int shiftRight (final int x, final byte n) { return x >> n ; } + public static int shiftRight (final int x, final short n) { return x >> n ; } + public static int shiftRight (final int x, final char n) { return x >> n ; } + public static int shiftRight (final int x, final int n) { return x >> n ; } + public static int shiftRight (final int x, final long n) { return x >> n ; } + public static long shiftRight (final long x, final byte n) { return x >> n ; } + public static long shiftRight (final long x, final char n) { return x >> n ; } + public static long shiftRight (final long x, final short n) { return x >> n ; } + public static long shiftRight (final long x, final int n) { return x >> n ; } + public static long shiftRight (final long x, final long n) { return x >> n ; } + public static float shiftRight (final float x, final byte n) { + return Float.intBitsToFloat(Float.floatToIntBits(x) >> n); + } + public static float shiftRight (final float x, final short n) { + return Float.intBitsToFloat(Float.floatToIntBits(x) >> n); + } + public static float shiftRight (final float x, final char n) { + return Float.intBitsToFloat(Float.floatToIntBits(x) >> n); + } + public static float shiftRight (final float x, final int n) { + return Float.intBitsToFloat(Float.floatToIntBits(x) >> n); + } + public static float shiftRight (final float x, final long n) { + return Float.intBitsToFloat(Float.floatToIntBits(x) >> n); + } + public static double shiftRight (final double x, final byte n) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) >> n); + } + public static double shiftRight (final double x, final short n) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) >> n); + } + public static double shiftRight (final double x, final char n) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) >> n); + } + public static double shiftRight (final double x, final int n) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) >> n); + } + public static double shiftRight (final double x, final long n) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) >> n); + } + + // --------------------- unsignedShiftRight : >>> (implicitly checked) --------------------- // + + public static byte uShiftRight (final byte x, final byte n) { return (byte) (x >>> n);} + public static byte uShiftRight (final byte x, final short n) { return (byte) (x >>> n);} + public static byte uShiftRight (final byte x, final char n) { return (byte) (x >>> n);} + public static byte uShiftRight (final byte x, final int n) { return (byte) (x >>> n);} + public static byte uShiftRight (final byte x, final long n) { return (byte) (x >>> n);} + public static short uShiftRight (final short x, final byte n) { return (short)(x >>> n);} + public static short uShiftRight (final short x, final short n) { return (short)(x >>> n);} + public static short uShiftRight (final short x, final char n) { return (short)(x >>> n);} + public static short uShiftRight (final short x, final int n) { return (short)(x >>> n);} + public static short uShiftRight (final short x, final long n) { return (short)(x >>> n);} + public static char uShiftRight (final char x, final byte n) { return (char) (x >>> n);} + public static char uShiftRight (final char x, final short n) { return (char) (x >>> n);} + public static char uShiftRight (final char x, final char n) { return (char) (x >>> n);} + public static char uShiftRight (final char x, final int n) { return (char) (x >>> n);} + public static char uShiftRight (final char x, final long n) { return (char) (x >>> n);} + public static int uShiftRight (final int x, final byte n) { return x >>> n ;} + public static int uShiftRight (final int x, final short n) { return x >>> n ;} + public static int uShiftRight (final int x, final char n) { return x >>> n ;} + public static int uShiftRight (final int x, final int n) { return x >>> n ;} + public static int uShiftRight (final int x, final long n) { return x >>> n ;} + public static long uShiftRight (final long x, final byte n) { return x >>> n ;} + public static long uShiftRight (final long x, final char n) { return x >>> n ;} + public static long uShiftRight (final long x, final short n) { return x >>> n ;} + public static long uShiftRight (final long x, final int n) { return x >>> n ;} + public static long uShiftRight (final long x, final long n) { return x >>> n ;} + public static float uShiftRight (final float x, final byte n) { + return Float.intBitsToFloat(Float.floatToIntBits(x) >>> n); + } + public static float uShiftRight (final float x, final short n) { + return Float.intBitsToFloat(Float.floatToIntBits(x) >>> n); + } + public static float uShiftRight (final float x, final char n) { + return Float.intBitsToFloat(Float.floatToIntBits(x) >>> n); + } + public static float uShiftRight (final float x, final int n) { + return Float.intBitsToFloat(Float.floatToIntBits(x) >>> n); + } + public static float uShiftRight (final float x, final long n) { + return Float.intBitsToFloat(Float.floatToIntBits(x) >>> n); + } + public static double uShiftRight (final double x, final byte n) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) >>> n); + } + public static double uShiftRight (final double x, final short n) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) >>> n); + } + public static double uShiftRight (final double x, final char n) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) >>> n); + } + public static double uShiftRight (final double x, final int n) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) >>> n); + } + public static double uShiftRight (final double x, final long n) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) >>> n); } // ---------------------------------- bitClear (unchecked) ---------------------------------- // diff --git a/src/quantum/core/data/bits.cljc b/src/quantum/core/data/bits.cljc index a7fdc719..ff5c85ba 100644 --- a/src/quantum/core/data/bits.cljc +++ b/src/quantum/core/data/bits.cljc @@ -5,10 +5,11 @@ (:refer-clojure :exclude [and not or]) (:require - [clojure.core :as core] - [quantum.core.type :as t + [clojure.core :as core] + [quantum.core.data.primitive :as p] + [quantum.core.type :as t :refer [defnt]] - [quantum.core.vars :as var + [quantum.core.vars :as var :refer [defalias]]) #?(:clj (:import [quantum.core Numeric] @@ -28,75 +29,215 @@ ; bit-set ; TODO ExceptionInInitializerError somewhere over here... -; TODO move namespace +;; TODO TYPED move #_(defnt ^boolean nil? ([^Object x] (quantum.core.Numeric/isNil x)) ([:else x] false)) +;; TODO TYPED move #?(:clj (defalias nil? core/nil?)) +;; TODO TYPED move #_(defnt ^boolean not' ([^boolean? x] (Numeric/not x)) ([x] (if (nil? x) true))) ; Lisp nil punning +;; TODO TYPED move #_(defnt ^boolean true? ([^boolean? x] x) ([:else x] false)) +;; TODO TYPED move #?(:clj (defalias true? core/true?)) +;; TODO TYPED move #_(defnt ^boolean false? ([^boolean? x] (not' x)) ([:else x] false)) +;; TODO TYPED move #?(:clj (defalias false? core/false?)) -#_(macros/variadic-proxy bit-and quantum.core.Numeric/bitAnd) ; & -#_(macros/variadic-proxy bit-or quantum.core.Numeric/bitOr) ; | -#_(macros/variadic-proxy bit-xor quantum.core.Numeric/bitXor) -#_(macros/variadic-proxy bool-and quantum.core.Numeric/and) ; && -#_(macros/variadic-proxy bool-or quantum.core.Numeric/or) ; || -#_(macros/variadic-proxy bool-xor quantum.core.Numeric/xor) +;; ===== Logical bit-operations ===== ;; -(defnt ^:inline not []) +;; TODO TYPED we can shorten this by having dependent types +(defnt ^:inline not +#_([x p/primitive? > (t/type x)] (Numeric/bitNot x)) + ([x p/boolean? > p/boolean?] (Numeric/bitNot x)) + ([x p/byte? > p/byte?] (Numeric/bitNot x)) + ([x p/short? > p/short?] (Numeric/bitNot x)) + ([x p/char? > p/char?] (Numeric/bitNot x)) + ([x p/int? > p/int?] (Numeric/bitNot x)) + ([x p/long? > p/long?] (Numeric/bitNot x)) + ([x p/float? > p/float?] (Numeric/bitNot x)) + ([x p/double? > p/double?] (Numeric/bitNot x))) -(defalias bit-and core/bit-and) -(defalias && bit-and) ; tried to do `& but, "No method in multimethod 'parse' for dispatch value: &" -(defalias bit-or core/bit-or) -(defalias | bit-or) -(defalias bit-xor core/bit-xor) +;; TODO TYPED we can shorten this by having dependent types +(defnt ^:inline and +#_([a p/boolean?, b p/boolean? > ?] (Numeric/bitAnd a b)) +#_([a (t/- p/primitive? t/boolean?), b (t/- p/primitive? t/boolean?) > ?] (Numeric/bitAnd a b)) + ([a p/boolean?, b p/boolean? > p/boolean?] (Numeric/bitAnd a b)) + ([a p/byte? , b p/byte? > p/byte?] (Numeric/bitAnd a b)) + ([a p/byte? , b p/short? > p/short?] (Numeric/bitAnd a b)) + ([a p/byte? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitAnd a b)) + ([a p/byte? , b p/long? > p/long?] (Numeric/bitAnd a b)) + ([a p/byte? , b p/float? > p/float?] (Numeric/bitAnd a b)) + ([a p/byte? , b p/double? > p/double?] (Numeric/bitAnd a b)) + ([a p/short? , b (t/or p/byte? p/short?) > p/short?] (Numeric/bitAnd a b)) + ([a p/short? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitAnd a b)) + ([a p/short? , b p/long? > p/long?] (Numeric/bitAnd a b)) + ([a p/short? , b p/float? > p/float?] (Numeric/bitAnd a b)) + ([a p/short? , b p/double? > p/double?] (Numeric/bitAnd a b)) + ([a p/char? , b (t/or p/byte? p/short?) > p/int?] (Numeric/bitAnd a b)) + ([a p/char? , b p/char? > p/char?] (Numeric/bitAnd a b)) + ([a p/char? , b p/int? > p/int?] (Numeric/bitAnd a b)) + ([a p/char? , b p/long? > p/long?] (Numeric/bitAnd a b)) + ([a p/char? , b p/float? > p/float?] (Numeric/bitAnd a b)) + ([a p/char? , b p/double? > p/double?] (Numeric/bitAnd a b)) + ([a p/int? , b (t/or p/byte? p/short? p/char? p/int?) > p/int?] (Numeric/bitAnd a b)) + ([a p/int? , b p/long? > p/long?] (Numeric/bitAnd a b)) + ([a p/int? , b p/float? > p/float?] (Numeric/bitAnd a b)) + ([a p/int? , b p/double? > p/double?] (Numeric/bitAnd a b)) + ([a p/long? , b (t/or p/byte? p/short? p/char? p/int? + p/int? p/long?) > p/long?] (Numeric/bitAnd a b)) + ([a p/long? , b (t/or p/float? p/double?) > p/double?] (Numeric/bitAnd a b)) + ([a p/float? , b (t/or p/byte? p/short? p/char? p/int? + p/float?) > p/float?] (Numeric/bitAnd a b)) + ([a p/float? , b (t/or p/long? p/double?) > p/double?] (Numeric/bitAnd a b)) + ([a p/double? , b p/primitive? > p/double?] (Numeric/bitAnd a b))) -;; ===== SHIFTS ===== ;; +;; TODO TYPED we can shorten this by having dependent types +(defnt ^:inline or +#_([a p/boolean?, b p/boolean? > ?] (Numeric/bitOr a b)) +#_([a (t/- p/primitive? t/boolean?), b (t/- p/primitive? t/boolean?) > ?] (Numeric/bitOr a b)) + ([a p/boolean?, b p/boolean? > p/boolean?] (Numeric/bitOr a b)) + ([a p/byte? , b p/byte? > p/byte?] (Numeric/bitOr a b)) + ([a p/byte? , b p/short? > p/short?] (Numeric/bitOr a b)) + ([a p/byte? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitOr a b)) + ([a p/byte? , b p/long? > p/long?] (Numeric/bitOr a b)) + ([a p/byte? , b p/float? > p/float?] (Numeric/bitOr a b)) + ([a p/byte? , b p/double? > p/double?] (Numeric/bitOr a b)) + ([a p/short? , b (t/or p/byte? p/short?) > p/short?] (Numeric/bitOr a b)) + ([a p/short? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitOr a b)) + ([a p/short? , b p/long? > p/long?] (Numeric/bitOr a b)) + ([a p/short? , b p/float? > p/float?] (Numeric/bitOr a b)) + ([a p/short? , b p/double? > p/double?] (Numeric/bitOr a b)) + ([a p/char? , b (t/or p/byte? p/short?) > p/int?] (Numeric/bitOr a b)) + ([a p/char? , b p/char? > p/char?] (Numeric/bitOr a b)) + ([a p/char? , b p/int? > p/int?] (Numeric/bitOr a b)) + ([a p/char? , b p/long? > p/long?] (Numeric/bitOr a b)) + ([a p/char? , b p/float? > p/float?] (Numeric/bitOr a b)) + ([a p/char? , b p/double? > p/double?] (Numeric/bitOr a b)) + ([a p/int? , b (t/or p/byte? p/short? p/char? p/int?) > p/int?] (Numeric/bitOr a b)) + ([a p/int? , b p/long? > p/long?] (Numeric/bitOr a b)) + ([a p/int? , b p/float? > p/float?] (Numeric/bitOr a b)) + ([a p/int? , b p/double? > p/double?] (Numeric/bitOr a b)) + ([a p/long? , b (t/or p/byte? p/short? p/char? p/int? + p/int? p/long?) > p/long?] (Numeric/bitOr a b)) + ([a p/long? , b (t/or p/float? p/double?) > p/double?] (Numeric/bitOr a b)) + ([a p/float? , b (t/or p/byte? p/short? p/char? p/int? + p/float?) > p/float?] (Numeric/bitOr a b)) + ([a p/float? , b (t/or p/long? p/double?) > p/double?] (Numeric/bitOr a b)) + ([a p/double? , b p/primitive? > p/double?] (Numeric/bitOr a b))) -#?(:clj (defalias bit-shift-left core/bit-shift-left) - #_(defmacro bit-shift-left [n bits] - `(Numeric/shiftLeft ~n ~bits)) - :cljs (defalias bit-shift-left core/bit-shift-left)) -(defalias << bit-shift-left) +;; TODO TYPED we can shorten this by having dependent types +(defnt ^:inline xor +#_([a p/boolean?, b p/boolean? > ?] (Numeric/bitXOr a b)) +#_([a (t/- p/primitive? t/boolean?), b (t/- p/primitive? t/boolean?) > ?] (Numeric/bitXOr a b)) + ([a p/boolean?, b p/boolean? > p/boolean?] (Numeric/bitXOr a b)) + ([a p/byte? , b p/byte? > p/byte?] (Numeric/bitXOr a b)) + ([a p/byte? , b p/short? > p/short?] (Numeric/bitXOr a b)) + ([a p/byte? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitXOr a b)) + ([a p/byte? , b p/long? > p/long?] (Numeric/bitXOr a b)) + ([a p/byte? , b p/float? > p/float?] (Numeric/bitXOr a b)) + ([a p/byte? , b p/double? > p/double?] (Numeric/bitXOr a b)) + ([a p/short? , b (t/or p/byte? p/short?) > p/short?] (Numeric/bitXOr a b)) + ([a p/short? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitXOr a b)) + ([a p/short? , b p/long? > p/long?] (Numeric/bitXOr a b)) + ([a p/short? , b p/float? > p/float?] (Numeric/bitXOr a b)) + ([a p/short? , b p/double? > p/double?] (Numeric/bitXOr a b)) + ([a p/char? , b (t/or p/byte? p/short?) > p/int?] (Numeric/bitXOr a b)) + ([a p/char? , b p/char? > p/char?] (Numeric/bitXOr a b)) + ([a p/char? , b p/int? > p/int?] (Numeric/bitXOr a b)) + ([a p/char? , b p/long? > p/long?] (Numeric/bitXOr a b)) + ([a p/char? , b p/float? > p/float?] (Numeric/bitXOr a b)) + ([a p/char? , b p/double? > p/double?] (Numeric/bitXOr a b)) + ([a p/int? , b (t/or p/byte? p/short? p/char? p/int?) > p/int?] (Numeric/bitXOr a b)) + ([a p/int? , b p/long? > p/long?] (Numeric/bitXOr a b)) + ([a p/int? , b p/float? > p/float?] (Numeric/bitXOr a b)) + ([a p/int? , b p/double? > p/double?] (Numeric/bitXOr a b)) + ([a p/long? , b (t/or p/byte? p/short? p/char? p/int? + p/int? p/long?) > p/long?] (Numeric/bitXOr a b)) + ([a p/long? , b (t/or p/float? p/double?) > p/double?] (Numeric/bitXOr a b)) + ([a p/float? , b (t/or p/byte? p/short? p/char? p/int? + p/float?) > p/float?] (Numeric/bitXOr a b)) + ([a p/float? , b (t/or p/long? p/double?) > p/double?] (Numeric/bitXOr a b)) + ([a p/double? , b p/primitive? > p/double?] (Numeric/bitXOr a b))) -#?(:clj (defalias bit-shift-right core/bit-shift-right) - #_(defmacro bit-shift-right [n bits] - `(Numeric/shiftRight ~n ~bits)) - :cljs (defalias bit-shift-right core/bit-shift-right)) -(defalias >> bit-shift-right) +;; ===== Bit-shifts ===== ;; -#?(:clj (defalias unsigned-bit-shift-right core/unsigned-bit-shift-right) - #_(defmacro unsigned-bit-shift-right - "Bit shift right, replace with zeros" - [n bits] - `(Numeric/unsignedShiftRight ~n ~bits)) - :cljs (defalias unsigned-bit-shift-right core/unsigned-bit-shift-right)) +;; ----- Logical bit-shifts ---- ;; -(defalias >>> unsigned-bit-shift-right) +;; TODO TYPED we can shorten this by having dependent types +(defnt ^:inline <<< + "Unsigned (logical) bit shift left" +#_([x (t/- p/primitive? t/boolean?), n (t/- p/primitive? t/boolean?) > (t/type x)] + (Numeric/bitOr a b)) + ([x p/byte? , n (t/- p/primitive? p/boolean?) > p/byte?] (Numeric/shiftLeft x n)) + ([x p/short? , n (t/- p/primitive? p/boolean?) > p/short?] (Numeric/shiftLeft x n)) + ;; TODO implement this correctly because it likely isn't correct just to do `<<` in Java +#_([x p/char? , n (t/- p/primitive? p/boolean?) > p/char?] (Numeric/shiftLeft x n)) + ([x p/int? , n (t/- p/primitive? p/boolean?) > p/int?] (Numeric/shiftLeft x n)) + ([x p/long? , n (t/- p/primitive? p/boolean?) > p/long?] (Numeric/shiftLeft x n)) + ([x p/float? , n (t/- p/primitive? p/boolean?) > p/float?] (Numeric/shiftLeft x n)) + ([x p/double?, n (t/- p/primitive? p/boolean?) > p/double?] (Numeric/shiftLeft x n))) -;; ===== ROTATIONS ===== ;; +;; TODO TYPED we can shorten this by having dependent types +(defnt ^:inline >>> + "Unsigned (logical) bit shift right" +#_([x (t/- p/primitive? t/boolean?), n (t/- p/primitive? t/boolean?) > (t/type x)] + (Numeric/bitOr a b)) + ([x p/byte? , n (t/- p/primitive? p/boolean?) > p/byte?] (Numeric/uShiftRight x n)) + ([x p/short? , n (t/- p/primitive? p/boolean?) > p/short?] (Numeric/uShiftRight x n)) + ([x p/char? , n (t/- p/primitive? p/boolean?) > p/char?] (Numeric/uShiftRight x n)) + ([x p/int? , n (t/- p/primitive? p/boolean?) > p/int?] (Numeric/uShiftRight x n)) + ([x p/long? , n (t/- p/primitive? p/boolean?) > p/long?] (Numeric/uShiftRight x n)) + ([x p/float? , n (t/- p/primitive? p/boolean?) > p/float?] (Numeric/uShiftRight x n)) + ([x p/double?, n (t/- p/primitive? p/boolean?) > p/double?] (Numeric/uShiftRight x n))) -(defn int-rotate-left +;; ----- Arithmetic bit-shifts ----- ;; + +;; TODO TYPED we can shorten this by having dependent types +(defnt ^:inline << + "Arithmetic bit shift left" +#_([x (t/- p/primitive? t/boolean?), n (t/- p/primitive? t/boolean?) > (t/type x)] + (Numeric/bitOr a b)) + ([x p/byte? , n (t/- p/primitive? p/boolean?) > p/byte?] (Numeric/shiftLeft x n)) + ([x p/short? , n (t/- p/primitive? p/boolean?) > p/short?] (Numeric/shiftLeft x n)) + ([x p/char? , n (t/- p/primitive? p/boolean?) > p/char?] (Numeric/shiftLeft x n)) + ([x p/int? , n (t/- p/primitive? p/boolean?) > p/int?] (Numeric/shiftLeft x n)) + ([x p/long? , n (t/- p/primitive? p/boolean?) > p/long?] (Numeric/shiftLeft x n)) + ([x p/float? , n (t/- p/primitive? p/boolean?) > p/float?] (Numeric/shiftLeft x n)) + ([x p/double?, n (t/- p/primitive? p/boolean?) > p/double?] (Numeric/shiftLeft x n))) + +;; TODO TYPED we can shorten this by having dependent types +(defnt ^:inline >> + "Arithmetic bit shift right" +#_([x (t/- p/primitive? t/boolean?), n (t/- p/primitive? t/boolean?) > (t/type x)] + (Numeric/bitOr a b)) + ([x p/byte? , n (t/- p/primitive? p/boolean?) > p/byte?] (Numeric/shiftRight x n)) + ([x p/short? , n (t/- p/primitive? p/boolean?) > p/short?] (Numeric/shiftRight x n)) + ([x p/char? , n (t/- p/primitive? p/boolean?) > p/char?] (Numeric/shiftRight x n)) + ([x p/int? , n (t/- p/primitive? p/boolean?) > p/int?] (Numeric/shiftRight x n)) + ([x p/long? , n (t/- p/primitive? p/boolean?) > p/long?] (Numeric/shiftRight x n)) + ([x p/float? , n (t/- p/primitive? p/boolean?) > p/float?] (Numeric/shiftRight x n)) + ([x p/double?, n (t/- p/primitive? p/boolean?) > p/double?] (Numeric/shiftRight x n))) + +;; ===== Rotations ===== ;; + +(defnt rotate-left {:from "http://hg.openjdk.java.net/jdk7u/jdk7u6/jdk/file/8c2c5d63a17e/src/share/classes/java/lang/Integer.java"} - [x n] - (bit-or - (bit-shift-left x n) - (unsigned-bit-shift-right x (- n)))) + [x ???, n ???] (or (<< x n) (>>> x (- n)))) (defn bit-count "Counts the number of bits set in n" @@ -110,18 +251,18 @@ (defalias ? core/bit-test) -; ===== BULK BIT OPERATIONS ===== ; +;; ===== Bulk bit-operations ===== ;; (defn ?-coll "Returns true or false for the bit at the given index of the collection." [bits i] - (? (bits (>> i 6)) (&& i 0x3f))) + (? (bits (>> i 6)) (and i 0x3f))) (defn bits "The bits of x, aggregated into a vector and truncated/extended to length n." {:adapted-from 'gloss.data.primitives} [x n] - (mapv #(if (pos? (&& (<< 1 %) x)) 1 0) (range n))) + (mapv #(if (pos? (and (<< 1 %) x)) 1 0) (range n))) (bits 1 64) @@ -130,9 +271,9 @@ {:adapted-from 'bigml.sketchy.murmur} [#?(:clj ^long x :cljs x) #?(:clj ^long n :cljs n)] - (&& x (unchecked-dec (<< 1 n)))) + (and x (unchecked-dec (<< 1 n)))) -; ====== ENDIANNESS REVERSAL ======= +;; ====== Endianness reversal ====== ;; ; TODO DEPS #_(:clj @@ -147,10 +288,10 @@ [^byte b7 ^byte b6 ^byte b5 ^byte b4 ^byte b3 ^byte b2 ^byte b1 ^byte b0] (bit-or (<< (long b7) 56) - (<< (bit-and (long b6) 0xff) 48) - (<< (bit-and (long b5) 0xff) 40) - (<< (bit-and (long b4) 0xff) 32) - (<< (bit-and (long b3) 0xff) 24) - (<< (bit-and (long b2) 0xff) 16) - (<< (bit-and (long b1) 0xff) 8) - (bit-and (long b0) 0xff)))) + (<< (and (long b6) 0xff) 48) + (<< (and (long b5) 0xff) 40) + (<< (and (long b4) 0xff) 32) + (<< (and (long b3) 0xff) 24) + (<< (and (long b2) 0xff) 16) + (<< (and (long b1) 0xff) 8) + (and (long b0) 0xff)))) From b4f1908fbb87f06e7aa056cbdc351cf82a6d48c0 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 15 Sep 2018 15:46:10 -0600 Subject: [PATCH 264/810] Add some more todos --- resources-dev/defnt.cljc | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index f4730c56..15948067 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -22,6 +22,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - declare-fnt (a way to do protocols/interfaces) - extend-fnt! - defnt (t/defn) + - ^:inline + - if you do (Numeric/bitAnd a b) inline then bitAnd needs to know the primitive type so maybe + we do the `let*`-binding approach to typing vars? - handle varargs - [& args _] shouldn't result in `t/any?` but rather like `t/seqable?` or whatever - do the defnt-equivalences @@ -65,6 +68,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - quantum.core.data.string — this is where `>str` belongs - quantum.core.convert.primitive + - quantum.core.data.collections + - quantum.core.data.tuple - quantum.core.numeric.convert - quantum.core.numeric.misc @@ -106,9 +111,28 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - quantum.untyped.core.data.map - quantum.untyped.core.type.defs - quantum.untyped.core.data + - List of Numeric fns to implement: + - [ ] isTrue (?) + - [ ] isFalse (?) + - [ ] isNil (?) + - [ ] (logical) and (?) + - [ ] (logical) or (?) + - [ ] (logical) not + - [ ] reverseBits + - [ ] reverseBytes + - List of Primitive fns to implement: + - uncheckedByteCast + - uncheckedCharCast + - uncheckedShortCast + - uncheckedIntCast + - uncheckedLongCast + - uncheckedFloatCast + - uncheckedDoubleCast - Standard metadata - e.g. `{:alternate-implementations #{'cljs.tools.reader/merge-meta}}` - {:adapted-from } + - :todo + - :attribution - Instead of e.g. `ns-` or `var-` we can do `ns-val` and `var-val` - Should we type `when`, `let`? From 9ef163a4403d4b5994c2009430e9fe1924acc0c5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 15 Sep 2018 15:46:24 -0600 Subject: [PATCH 265/810] Fix naming --- src-java/quantum/core/Numeric.java | 72 +++++++++++++++--------------- 1 file changed, 36 insertions(+), 36 deletions(-) diff --git a/src-java/quantum/core/Numeric.java b/src-java/quantum/core/Numeric.java index e2648d52..b07e1a45 100644 --- a/src-java/quantum/core/Numeric.java +++ b/src-java/quantum/core/Numeric.java @@ -526,59 +526,59 @@ public static double uShiftRight (final double x, final long n) { // ---------------------------------- bitClear (unchecked) ---------------------------------- // - public static byte bitClear (final byte x, final long n) { return (byte) (x & ~(1L << n)); } - public static short bitClear (final short x, final long n) { return (short)(x & ~(1L << n)); } - public static char bitClear (final char x, final long n) { return (char) (x & ~(1L << n)); } - public static int bitClear (final int x, final long n) { return (int) (x & ~(1L << n)); } - public static long bitClear (final long x, final long n) { return x & ~(1L << n) ; } - public static float bitClear (final float x, final long n) { - return Float.intBitsToFloat((int)(Float.floatToIntBits(x) & ~(1L << n))); + public static byte bitClear (final byte x, final long i) { return (byte) (x & ~(1L << i)); } + public static short bitClear (final short x, final long i) { return (short)(x & ~(1L << i)); } + public static char bitClear (final char x, final long i) { return (char) (x & ~(1L << i)); } + public static int bitClear (final int x, final long i) { return (int) (x & ~(1L << i)); } + public static long bitClear (final long x, final long i) { return x & ~(1L << i) ; } + public static float bitClear (final float x, final long i) { + return Float.intBitsToFloat((int)(Float.floatToIntBits(x) & ~(1L << i))); } - public static double bitClear (final double x, final long n) { - return Double.longBitsToDouble(Double.doubleToLongBits(x) & ~(1L << n)); + public static double bitClear (final double x, final long i) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) & ~(1L << i)); } // ---------------------------------- bitFlip (unchecked) ---------------------------------- // - public static byte bitFlip (final byte x, final long n) { return (byte) (x ^ (1L << n)); } - public static short bitFlip (final short x, final long n) { return (short)(x ^ (1L << n)); } - public static char bitFlip (final char x, final long n) { return (char) (x ^ (1L << n)); } - public static int bitFlip (final int x, final long n) { return (int) (x ^ (1L << n)); } - public static long bitFlip (final long x, final long n) { return x ^ (1L << n) ; } - public static float bitFlip (final float x, final long n) { - return Float.intBitsToFloat((int)(Float.floatToIntBits(x) ^ (1L << n))); + public static byte bitFlip (final byte x, final long i) { return (byte) (x ^ (1L << i)); } + public static short bitFlip (final short x, final long i) { return (short)(x ^ (1L << i)); } + public static char bitFlip (final char x, final long i) { return (char) (x ^ (1L << i)); } + public static int bitFlip (final int x, final long i) { return (int) (x ^ (1L << i)); } + public static long bitFlip (final long x, final long i) { return x ^ (1L << i) ; } + public static float bitFlip (final float x, final long i) { + return Float.intBitsToFloat((int)(Float.floatToIntBits(x) ^ (1L << i))); } - public static double bitFlip (final double x, final long n) { - return Double.longBitsToDouble(Double.doubleToLongBits(x) ^ (1L << n)); + public static double bitFlip (final double x, final long i) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) ^ (1L << i)); } // ----------------------------------- bitSet (unchecked) ----------------------------------- // // Returns the smallest safe type - public static byte bitSet (final byte x, final long n) { return (byte) (x | (1L << n)); } - public static short bitSet (final short x, final long n) { return (short)(x | (1L << n)); } - public static char bitSet (final char x, final long n) { return (char) (x | (1L << n)); } - public static int bitSet (final int x, final long n) { return (int) (x | (1L << n)); } - public static long bitSet (final long x, final long n) { return x | (1L << n) ; } - public static float bitSet (final float x, final long n) { - return Float.intBitsToFloat((int)(Float.floatToIntBits(x) | (1L << n))); + public static byte bitSet (final byte x, final long i) { return (byte) (x | (1L << i)); } + public static short bitSet (final short x, final long i) { return (short)(x | (1L << i)); } + public static char bitSet (final char x, final long i) { return (char) (x | (1L << i)); } + public static int bitSet (final int x, final long i) { return (int) (x | (1L << i)); } + public static long bitSet (final long x, final long i) { return x | (1L << i) ; } + public static float bitSet (final float x, final long i) { + return Float.intBitsToFloat((int)(Float.floatToIntBits(x) | (1L << i))); } - public static double bitSet (final double x, final long n) { - return Double.longBitsToDouble(Double.doubleToLongBits(x) | (1L << n)); + public static double bitSet (final double x, final long i) { + return Double.longBitsToDouble(Double.doubleToLongBits(x) | (1L << i)); } // ---------------------------------- bitTest (unchecked) ---------------------------------- // - public static boolean bitTest (final byte x, final long n) { return (x & (1L << n)) != 0L; } - public static boolean bitTest (final short x, final long n) { return (x & (1L << n)) != 0L; } - public static boolean bitTest (final char x, final long n) { return (x & (1L << n)) != 0L; } - public static boolean bitTest (final int x, final long n) { return (x & (1L << n)) != 0L; } - public static boolean bitTest (final long x, final long n) { return (x & (1L << n)) != 0L; } - public static boolean bitTest (final float x, final long n) { - return (Float.floatToIntBits(x) & (1L << n)) != 0L; + public static boolean bitTest (final byte x, final long i) { return (x & (1L << i)) != 0L; } + public static boolean bitTest (final short x, final long i) { return (x & (1L << i)) != 0L; } + public static boolean bitTest (final char x, final long i) { return (x & (1L << i)) != 0L; } + public static boolean bitTest (final int x, final long i) { return (x & (1L << i)) != 0L; } + public static boolean bitTest (final long x, final long i) { return (x & (1L << i)) != 0L; } + public static boolean bitTest (final float x, final long i) { + return (Float.floatToIntBits(x) & (1L << i)) != 0L; } - public static boolean bitTest (final double x, final long n) { - return (Double.doubleToLongBits(x) & (1L << n)) != 0L; + public static boolean bitTest (final double x, final long i) { + return (Double.doubleToLongBits(x) & (1L << i)) != 0L; } // ======================================= lt : < =========================================== // From 8ebf32c68e0b148e10cbdaef8cb77b0187e7e3bf Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 15 Sep 2018 15:47:03 -0600 Subject: [PATCH 266/810] More distribution of type predicates --- src-untyped/quantum/untyped/core/analyze.cljc | 4 +- .../quantum/untyped/core/data/bits.cljc | 6 - .../quantum/untyped/core/data/map.cljc | 11 - src-untyped/quantum/untyped/core/type.cljc | 195 +----------------- .../quantum/untyped/core/type/defnt.cljc | 21 +- src/quantum/core/data/array.cljc | 94 ++++++++- src/quantum/core/data/collections.cljc | 96 +++++++++ src/quantum/core/data/map.cljc | 16 +- src/quantum/core/data/tuple.cljc | 13 +- src/quantum/core/type.cljc | 2 +- src/quantum/core/vars.cljc | 3 +- 11 files changed, 229 insertions(+), 232 deletions(-) create mode 100644 src/quantum/core/data/collections.cljc diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 620bb8a8..24615e18 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -48,7 +48,7 @@ #?(:clj (defns method? [x _] (instance? Method x))) #?(:clj -(defns class->methods [^Class c t/class? > t/map?] +(defns class->methods [^Class c t/class? > map?] (->> (.getMethods c) (c/remove+ (fn [^java.lang.reflect.Method x] (java.lang.reflect.Modifier/isPrivate (.getModifiers x)))) @@ -70,7 +70,7 @@ fipp.ednize/IOverride fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "F") (into (array-map) this)))) -(defns class->fields [^Class c t/class? > t/map?] +(defns class->fields [^Class c t/class? > map?] (->> (.getFields c) (c/remove+ (fn [^java.lang.reflect.Field x] (java.lang.reflect.Modifier/isPrivate (.getModifiers x)))) diff --git a/src-untyped/quantum/untyped/core/data/bits.cljc b/src-untyped/quantum/untyped/core/data/bits.cljc index c63d1dac..93c46068 100644 --- a/src-untyped/quantum/untyped/core/data/bits.cljc +++ b/src-untyped/quantum/untyped/core/data/bits.cljc @@ -92,12 +92,6 @@ #?(:clj ^long n :cljs n)] (and x (unchecked-dec (<< 1 n)))) -;; ===== Endianness reversal ===== ;; - -#?(:clj (defn reverse|short [x] (Numeric/reverseShort (short x)))) -#?(:clj (defn reverse|int [x] (Numeric/reverseInt (int x)))) -#?(:clj (defn reverse|long [^long x] (Numeric/reverseLong x))) - ;; ===== Primitives ===== ;; #?(:clj (eval `(defalias ~(if (resolve `fcore/boolean?) diff --git a/src-untyped/quantum/untyped/core/data/map.cljc b/src-untyped/quantum/untyped/core/data/map.cljc index 82e34bb9..3e5187e8 100644 --- a/src-untyped/quantum/untyped/core/data/map.cljc +++ b/src-untyped/quantum/untyped/core/data/map.cljc @@ -28,17 +28,6 @@ [it.unimi.dsi.fastutil.objects Reference2LongOpenHashMap]] :cljs [[goog.structs AvlTree LinkedMap]]))) -;; ===== Map entries ===== ;; - -;; TODO excise? -(defn map-entry-seq [args] - (loop [[k v :as args-n] args - accum []] - (if (empty? args-n) - accum - (recur (-> args-n rest rest) - (conj accum (map-entry k v)))))) - ;; ----- Hash maps ----- ;; #?(:clj (def hash-map? (partial instance? clojure.lang.PersistentHashMap))) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 0946e766..b93007e7 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -623,11 +623,11 @@ ;; ========== Collections ========== ;; -;; ===== Tuples ===== ;; - - (-def tuple? ;; clojure.lang.Tuple was discontinued; we won't support it for now - (isa? quantum.untyped.core.data.tuple.Tuple)) -#?(:clj (-def map-entry? (isa? java.util.Map$Entry))) +;; Necessary for `quantum.untyped.core.analyze` +(def +map|built-in? + (or (isa? #?(:clj clojure.lang.PersistentHashMap :cljs cljs.core/PersistentHashMap)) + (isa? #?(:clj clojure.lang.PersistentArrayMap :cljs cljs.core/PersistentArrayMap)) + (isa? #?(:clj clojure.lang.PersistentTreeMap :cljs cljs.core/PersistentTreeMap)))) ;; ===== Sequences ===== ;; Sequential (generally not efficient Lookup / RandomAccess) @@ -654,99 +654,6 @@ (-def list? #?(:clj (isa? java.util.List) :cljs +list?)) -;; ----- Generic ----- ;; - -;; ===== Arrays ===== ;; Sequential, Associative (specifically, whose keys are sequential, - ;; dense integer values), not extensible - -#?(:clj -(defns >array-nd-type [kind c/symbol?, n unum/pos-int? > utr/class-type?] - (let [prefix (apply str (repeat n \[)) - letter (case kind - boolean "Z" - byte "B" - char "C" - short "S" - int "I" - long "J" - float "F" - double "D" - object "Ljava.lang.Object;")] - (isa? (Class/forName (str prefix letter)))))) - -#?(:clj -(defns >array-nd-types [n unum/pos-int? > utr/type?] - (->> '[boolean byte char short int long float double object] - (map #(>array-nd-type % n)) - (apply or)))) - - (-def booleans? #?(:clj (>array-nd-type 'boolean 1) :cljs none?)) - (-def bytes? #?(:clj (>array-nd-type 'byte 1) :cljs (isa? js/Int8Array))) - (-def ubytes? #?(:clj none? :cljs (isa? js/Uint8Array))) - (-def ubytes-clamped? #?(:clj none? :cljs (isa? js/Uint8ClampedArray))) - (-def chars? #?(:clj (>array-nd-type 'char 1) :cljs (isa? js/Uint16Array))) ; kind of - (-def shorts? #?(:clj (>array-nd-type 'short 1) :cljs (isa? js/Int16Array))) - (-def ushorts? #?(:clj none? :cljs (isa? js/Uint16Array))) - (-def ints? #?(:clj (>array-nd-type 'int 1) :cljs (isa? js/Int32Array))) - (-def uints? #?(:clj none? :cljs (isa? js/Uint32Array))) - (-def longs? #?(:clj (>array-nd-type 'long 1) :cljs none?)) - (-def floats? #?(:clj (>array-nd-type 'float 1) :cljs (isa? js/Float32Array))) - (-def doubles? #?(:clj (>array-nd-type 'double 1) :cljs (isa? js/Float64Array))) - (-def objects? #?(:clj (>array-nd-type 'object 1) :cljs (isa? js/Array))) - - (-def numeric-1d? (or bytes? ubytes? ubytes-clamped? - chars? - shorts? ushorts? ints? uints? longs? - floats? doubles?)) - - (-def array-1d? (or booleans? bytes? ubytes? ubytes-clamped? - chars? - shorts? ushorts? ints? uints? longs? - floats? doubles? objects?)) - -#?(:clj (-def booleans-2d? (>array-nd-type 'boolean 2))) -#?(:clj (-def bytes-2d? (>array-nd-type 'byte 2))) -#?(:clj (-def chars-2d? (>array-nd-type 'char 2))) -#?(:clj (-def shorts-2d? (>array-nd-type 'short 2))) -#?(:clj (-def ints-2d? (>array-nd-type 'int 2))) -#?(:clj (-def longs-2d? (>array-nd-type 'long 2))) -#?(:clj (-def floats-2d? (>array-nd-type 'float 2))) -#?(:clj (-def doubles-2d? (>array-nd-type 'double 2))) -#?(:clj (-def objects-2d? (>array-nd-type 'object 2))) - -#?(:clj (-def numeric-2d? (or bytes-2d? - chars-2d? - shorts-2d? ints-2d? longs-2d? - floats-2d? doubles-2d?))) - -#?(:clj (-def array-2d? (>array-nd-types 2 ))) - -#?(:clj (-def array-3d? (>array-nd-types 3 ))) -#?(:clj (-def array-4d? (>array-nd-types 4 ))) -#?(:clj (-def array-5d? (>array-nd-types 5 ))) -#?(:clj (-def array-6d? (>array-nd-types 6 ))) -#?(:clj (-def array-7d? (>array-nd-types 7 ))) -#?(:clj (-def array-8d? (>array-nd-types 8 ))) -#?(:clj (-def array-9d? (>array-nd-types 9 ))) -#?(:clj (-def array-10d? (>array-nd-types 10))) - - ;; TODO differentiate between "all supported n-D arrays" and "all n-D arrays" - (-def objects-nd? (or objects? - #?@(:clj [(>array-nd-type 'object 2) - (>array-nd-type 'object 3) - (>array-nd-type 'object 4) - (>array-nd-type 'object 5) - (>array-nd-type 'object 6) - (>array-nd-type 'object 7) - (>array-nd-type 'object 8) - (>array-nd-type 'object 9) - (>array-nd-type 'object 10)]))) - - ;; TODO differentiate between "all supported n-D arrays" and "all n-D arrays" - (-def array? (or array-1d? - #?@(:clj [array-2d? array-3d? array-4d? array-5d? - array-6d? array-7d? array-8d? array-9d? array-10d?]))) - ;; ----- String ----- ;; A special wrapper for char array where different encodings, etc. are possible ;; Mutable String @@ -1027,95 +934,10 @@ ;; TODO other things are comparable; really it depends on the two objects in question :cljs (or nil? (isa? cljs.core/IComparable)))) - (-def record? (isa? #?(:clj clojure.lang.IRecord :cljs cljs.core/IRecord))) - (-def transformer? (isa? quantum.untyped.core.reducers.Transformer)) (-def delay? (isa? #?(:clj clojure.lang.Delay :cljs cljs.core/Delay))) -;; ----- Collections ----- ;; - - (-def sorted? (or (isa? #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) - #?@(:clj [(isa? java.util.SortedMap) - (isa? java.util.SortedSet)] - :cljs [(isa? goog.structs.AvlTree)]) - ;; TODO implement — monotonically <, <=, =, >=, > - #_(>expr monotonic?))) - - (-def transient? (isa? #?(:clj clojure.lang.ITransientCollection - :cljs cljs.core/ITransientCollection))) - - (-def editable? (isa? #?(:clj clojure.lang.IEditableCollection - :cljs cljs.core/IEditableCollection))) - - ;; Indicates efficient lookup by (integer) index (via `get`) - (-def indexed? (or (isa? #?(:clj clojure.lang.Indexed :cljs cljs.core/IIndexed)) - ;; Doesn't guarantee `java.util.List` is implemented, except by - ;; convention - #?(:clj (isa? java.util.RandomAccess)) - #?(:clj char-seq? :cljs string?) - array?)) - - ;; Indicates whether `assoc?!` is supported - (-def associative? (or (isa? #?(:clj clojure.lang.Associative :cljs cljs.core/IAssociative)) - (isa? #?(:clj clojure.lang.ITransientAssociative :cljs cljs.core/ITransientAssociative)) - (or map? indexed?))) - - (-def sequential? (or (isa? #?(:clj clojure.lang.Sequential :cljs cljs.core/ISequential)) - list? indexed?)) - - (-def counted? (or (isa? #?(:clj clojure.lang.Counted :cljs cljs.core/ICounted)) - #?(:clj char-seq? :cljs string?) vector? map? set? array?)) - -#?(:clj (-def java-coll? (isa? java.util.Collection))) - - ;; A group of objects/elements - (-def coll? (or #?(:clj java-coll?) - #?@(:clj [(isa? clojure.lang.IPersistentCollection) - (isa? clojure.lang.ITransientCollection)] - :cljs (isa? cljs.core/ICollection)) - sequential? associative?)) - - (-def iterable? (isa? #?(:clj java.lang.Iterable :cljs cljs.core/IIterable))) - - ;; Whatever is `seqable?` is reducible via a call to `seq`. - ;; Reduction is nearly always preferable to seq-iteration if for no other reason than that - ;; it can take advantage of transducers and reducers. This predicate just answers whether - ;; it is more efficient to reduce than to seq-iterate (note that it should be at least as - ;; efficient as seq-iteration). - ;; TODO re-enable when dispatch enabled - #_(-def prefer-reduce? (or (isa? #?(:clj clojure.lang.IReduceInit :cljs cljs.core/IReduce)) - (isa? #?(:clj clojure.lang.IKVReduce :cljs cljs.core/IKVReduce)) - #?(:clj (isa? clojure.core.protocols/IKVReduce)) - #?(:clj char-seq? :cljs string?) - array? - record? - (isa? #?(:clj fast_zip.core.ZipperLocation :cljs fast-zip.core/ZipperLocation)) - chan?)) - - ;; Whatever is `reducible?` is seqable via a call to `sequence`. - (-def seqable? (or #?@(:clj [(isa? clojure.lang.Seqable) - iterable? - char-seq? - map? - array?] - :cljs [(isa? cljs.core/ISeqable) - array? - string?]))) - - ;; Able to be traversed over in some fashion, whether by `first`/`next` seq-iteration, - ;; reduction, etc. - ;; TODO re-enable when dispatch enabled - #_(-def traversable? (or (isa? #?(:clj clojure.lang.IReduceInit :cljs cljs.core/IReduce)) - (isa? #?(:clj clojure.lang.IKVReduce :cljs cljs.core/IKVReduce)) - #?(:clj (isa? clojure.core.protocols/IKVReduce)) - (isa? #?(:clj clojure.lang.Seqable :cljs cljs.core/ISeqable)) - iterable? - #?(:clj char-seq? :cljs string?) - array? - (isa? #?(:clj fast_zip.core.ZipperLocation :cljs fast-zip.core/ZipperLocation)) - chan?)) - #?(:clj (-def tagged-literal? (isa? clojure.lang.TaggedLiteral))) (-def literal? (or nil? boolean? symbol? keyword? string? #?(:clj long?) double? #?(:clj tagged-literal?))) @@ -1123,10 +945,7 @@ ;; ===== Generic ===== ;; - ;; Standard "uncuttable" types - (-def integral? (or primitive? number?)) - ;; TODO make into a type - (def nneg-int? #(c/and (integer? %) (c/>= % 0))) + #_(def nneg-int? #(c/and (integer? %) (c/>= % 0))) ;; TODO make into a type - (def index? nneg-int?) + #_(def index? nneg-int?) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 06a217a2..32eca502 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -49,6 +49,9 @@ [quantum.core Numeric] [quantum.core.data Array])) +;; TODO probably move +(def index? #(and (integer? %) (>= % 0))) + #?(:clj (defns class>simplest-class "This ensures that special overloads are not created for non-primitive subclasses @@ -112,7 +115,7 @@ :body-form t/any? :out-class (? t/class?) :out-type t/type? - :positional-args-ct t/nneg-int? + :positional-args-ct (s/and integer? #(>= % 0)) ;; When present, varargs are considered to be of class Object :variadic? t/boolean?})) @@ -415,14 +418,14 @@ :out-class out-class}))) (defns >reify|name - [{:keys [::uss/fn|name ::uss/fn|name, i|fnt-overload t/index? - i|expanded-overload-group t/index?]} _ > simple-symbol?] + [{:keys [::uss/fn|name ::uss/fn|name, i|fnt-overload index? + i|expanded-overload-group index?]} _ > simple-symbol?] (>symbol (str fn|name "|__" i|fnt-overload "|" i|expanded-overload-group))) #?(:clj (defns expanded-overload-group>reify [{:as in - :keys [::uss/fn|name ::uss/fn|name, i|fnt-overload t/index?, i|expanded-overload-group t/index? + :keys [::uss/fn|name ::uss/fn|name, i|fnt-overload index?, i|expanded-overload-group index? expanded-overload-group ::expanded-overload-group]} _ {:as opts :keys [gen-gensym _]} ::opts > ::reify] @@ -445,14 +448,14 @@ :overloads reify-overloads}))) (defns >input-type-decl|name - [fn|name ::uss/fn|name, i|fnt-overload t/index?, i|arg t/index? > simple-symbol?] + [fn|name ::uss/fn|name, i|fnt-overload index?, i|arg index? > simple-symbol?] (>symbol (str fn|name "|__" i|fnt-overload "|input" i|arg "|types"))) (defns >i-arg->input-types-decl "The evaluated `form` of each input-types-decl is an array of non-primitivized types that the dynamic dispatch uses to dispatch off input types." [{:keys [fn|name _]} ::fnt-globals - arg-types|split ::expanded-overload-groups|arg-types|split, i|fnt-overload t/index? + arg-types|split ::expanded-overload-groups|arg-types|split, i|fnt-overload index? > (s/vec-of ::input-types-decl)] (->> arg-types|split (c/map-indexed @@ -513,7 +516,7 @@ overloads))) ;; TODO spec -(defns unsupported! [name- _ #_t/qualified-symbol?, args t/indexed?, i t/index?] +(defns unsupported! [name- _ #_t/qualified-symbol?, args _ #_indexed?, i index?] (TODO)) (defns >direct-dispatch @@ -566,7 +569,7 @@ `(~dotted-reify-method-sym ~hinted-reify-sym ~@arglist))) (defns >dynamic-dispatch|conditional - [fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?), i|arg t/index?, body _] + [fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?), i|arg index?, body _] (if (-> body count (= 1)) (first body) `(ifs ~@body (unsupported! (quote ~(uident/qualify fn|name)) [~@arglist] ~i|arg)))) @@ -586,7 +589,7 @@ c/lcat)] (>dynamic-dispatch|conditional fn|name arglist i|arg branches)))) ([fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?), reify-seq (s/vec-of ::reify) - input-types-decl-group' (s/seq-of ::input-types-decl), *i|reify _, i|arg t/index?] + input-types-decl-group' (s/seq-of ::input-types-decl), *i|reify _, i|arg index?] (let [{:as input-types-decl :keys [arg-type|split]} (first input-types-decl-group') input-types-decl-group'' (rest input-types-decl-group')] (->> arg-type|split diff --git a/src/quantum/core/data/array.cljc b/src/quantum/core/data/array.cljc index 90aac096..7825cb77 100644 --- a/src/quantum/core/data/array.cljc +++ b/src/quantum/core/data/array.cljc @@ -1,6 +1,8 @@ (ns - ^{:doc "Useful array functions. Array creation, joining, reversal, etc." - :attribution "alexandergunnarson" + ^{:doc "Useful array functions. Array creation, joining, reversal, etc. + Arrays are Sequential, Associative (specifically, whose keys are sequential, dense integer + values), and not extensible." + :attribution 'alexandergunnarson :todo ["Incorporate amap, areduce, etc."]} quantum.core.data.array (:refer-clojure :exclude @@ -41,6 +43,94 @@ (log/this-ns) +#?(:clj +(defns >array-nd-type [kind c/symbol?, n unum/pos-int? > utr/class-type?] + (let [prefix (apply str (repeat n \[)) + letter (case kind + boolean "Z" + byte "B" + char "C" + short "S" + int "I" + long "J" + float "F" + double "D" + object "Ljava.lang.Object;")] + (isa? (Class/forName (str prefix letter)))))) + +#?(:clj +(defns >array-nd-types [n unum/pos-int? > utr/type?] + (->> '[boolean byte char short int long float double object] + (map #(>array-nd-type % n)) + (apply or)))) + + (-def booleans? #?(:clj (>array-nd-type 'boolean 1) :cljs none?)) + (-def bytes? #?(:clj (>array-nd-type 'byte 1) :cljs (isa? js/Int8Array))) + (-def ubytes? #?(:clj none? :cljs (isa? js/Uint8Array))) + (-def ubytes-clamped? #?(:clj none? :cljs (isa? js/Uint8ClampedArray))) + (-def chars? #?(:clj (>array-nd-type 'char 1) :cljs (isa? js/Uint16Array))) ; kind of + (-def shorts? #?(:clj (>array-nd-type 'short 1) :cljs (isa? js/Int16Array))) + (-def ushorts? #?(:clj none? :cljs (isa? js/Uint16Array))) + (-def ints? #?(:clj (>array-nd-type 'int 1) :cljs (isa? js/Int32Array))) + (-def uints? #?(:clj none? :cljs (isa? js/Uint32Array))) + (-def longs? #?(:clj (>array-nd-type 'long 1) :cljs none?)) + (-def floats? #?(:clj (>array-nd-type 'float 1) :cljs (isa? js/Float32Array))) + (-def doubles? #?(:clj (>array-nd-type 'double 1) :cljs (isa? js/Float64Array))) + (-def objects? #?(:clj (>array-nd-type 'object 1) :cljs (isa? js/Array))) + + (-def numeric-1d? (or bytes? ubytes? ubytes-clamped? + chars? + shorts? ushorts? ints? uints? longs? + floats? doubles?)) + + (-def array-1d? (or booleans? bytes? ubytes? ubytes-clamped? + chars? + shorts? ushorts? ints? uints? longs? + floats? doubles? objects?)) + +#?(:clj (-def booleans-2d? (>array-nd-type 'boolean 2))) +#?(:clj (-def bytes-2d? (>array-nd-type 'byte 2))) +#?(:clj (-def chars-2d? (>array-nd-type 'char 2))) +#?(:clj (-def shorts-2d? (>array-nd-type 'short 2))) +#?(:clj (-def ints-2d? (>array-nd-type 'int 2))) +#?(:clj (-def longs-2d? (>array-nd-type 'long 2))) +#?(:clj (-def floats-2d? (>array-nd-type 'float 2))) +#?(:clj (-def doubles-2d? (>array-nd-type 'double 2))) +#?(:clj (-def objects-2d? (>array-nd-type 'object 2))) + +#?(:clj (-def numeric-2d? (or bytes-2d? + chars-2d? + shorts-2d? ints-2d? longs-2d? + floats-2d? doubles-2d?))) + +#?(:clj (-def array-2d? (>array-nd-types 2 ))) + +#?(:clj (-def array-3d? (>array-nd-types 3 ))) +#?(:clj (-def array-4d? (>array-nd-types 4 ))) +#?(:clj (-def array-5d? (>array-nd-types 5 ))) +#?(:clj (-def array-6d? (>array-nd-types 6 ))) +#?(:clj (-def array-7d? (>array-nd-types 7 ))) +#?(:clj (-def array-8d? (>array-nd-types 8 ))) +#?(:clj (-def array-9d? (>array-nd-types 9 ))) +#?(:clj (-def array-10d? (>array-nd-types 10))) + + ;; TODO differentiate between "all supported n-D arrays" and "all n-D arrays" + (-def objects-nd? (or objects? + #?@(:clj [(>array-nd-type 'object 2) + (>array-nd-type 'object 3) + (>array-nd-type 'object 4) + (>array-nd-type 'object 5) + (>array-nd-type 'object 6) + (>array-nd-type 'object 7) + (>array-nd-type 'object 8) + (>array-nd-type 'object 9) + (>array-nd-type 'object 10)]))) + + ;; TODO differentiate between "all supported n-D arrays" and "all n-D arrays" + (-def array? (or array-1d? + #?@(:clj [array-2d? array-3d? array-4d? array-5d? + array-6d? array-7d? array-8d? array-9d? array-10d?]))) + ; TODO look at http://fastutil.di.unimi.it to complete this namespace ; TODO `fill!` <~> `Arrays/fill`, `lodash/fill` ; TODO move this to type diff --git a/src/quantum/core/data/collections.cljc b/src/quantum/core/data/collections.cljc new file mode 100644 index 00000000..03d9007f --- /dev/null +++ b/src/quantum/core/data/collections.cljc @@ -0,0 +1,96 @@ +(ns quantum.core.data.collections + (:refer-clojure :exclude + [associative? indexed? list? sequential?]) + (:require + [quantum.core.data.array :as arr] + [quantum.core.data.map :as map] + [quantum.core.data.set :as set] + [quantum.core.data.string :as dstr] + [quantum.core.data.tuple :as tuple] + [quantum.core.data.vector :as vec] + [quantum.core.type :as t])) + +(def record? (t/isa? #?(:clj clojure.lang.IRecord :cljs cljs.core/IRecord))) + +(def sorted? + (t/or (t/isa? #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) + #?@(:clj [(t/isa? java.util.SortedMap) + (t/isa? java.util.SortedSet)] + :cljs [(t/isa? goog.structs.AvlTree)]) + ; TODO implement — monotonically <, <=, =, >=, > + #_(t/>expr monotonic?))) + +(def transient? (t/isa? #?(:clj clojure.lang.ITransientCollection + :cljs cljs.core/ITransientCollection))) + +(def editable? (t/isa? #?(:clj clojure.lang.IEditableCollection + :cljs cljs.core/IEditableCollection))) + +;; Indicates efficient lookup by (integer) index (via `get`) +(def indexed? + (t/or (t/isa? #?(:clj clojure.lang.Indexed :cljs cljs.core/IIndexed)) + ;; Doesn't guarantee `java.util.List` is implemented, except by convention + #?(:clj (t/isa? java.util.RandomAccess)) + #?(:clj dstr/char-seq? :cljs dstr/string?) + arr/array?)) + +;; Indicates whether `assoc?!` is supported +(def associative? + (t/or (t/isa? #?(:clj clojure.lang.Associative :cljs cljs.core/IAssociative)) + (t/isa? #?(:clj clojure.lang.ITransientAssociative :cljs cljs.core/ITransientAssociative)) + (t/or map/map? indexed?))) + +(def sequential? + (t/or (t/isa? #?(:clj clojure.lang.Sequential :cljs cljs.core/ISequential)) + list? indexed?)) + +(def counted? + (t/or (t/isa? #?(:clj clojure.lang.Counted :cljs cljs.core/ICounted)) + #?(:clj dstr/char-seq? :cljs dstr/string?) vec/vector? map/map? set/set? arr/array?)) + +(def iterable? (t/isa? #?(:clj java.lang.Iterable :cljs cljs.core/IIterable))) + +#?(:clj (def java-coll? (t/isa? java.util.Collection))) + +;; A group of objects/elements +(def coll? + (t/or #?(:clj java-coll?) + #?@(:clj [(t/isa? clojure.lang.IPersistentCollection) + (t/isa? clojure.lang.ITransientCollection)] + :cljs (t/isa? cljs.core/ICollection)) + sequential? associative?)) + +;; Whatever is `seqable?` is reducible via a call to `seq`. +;; Reduction is nearly always preferable to seq-iteration if for no other reason than that +;; it can take advantage of transducers and reducers. This predicate just answers whether +;; it is more efficient to reduce than to seq-iterate (note that it should be at least as +;; efficient as seq-iteration). +;; TODO re-enable when dispatch enabled +#_(def prefer-reduce? + (t/or (t/isa? #?(:clj clojure.lang.IReduceInit :cljs cljs.core/IReduce)) + (t/isa? #?(:clj clojure.lang.IKVReduce :cljs cljs.core/IKVReduce)) + #?(:clj (t/isa? clojure.core.protocols/IKVReduce)) + #?(:clj dstr/char-seq? :cljs dstr/string?) + arr/array? + record? + (t/isa? #?(:clj fast_zip.core.ZipperLocation :cljs fast-zip.core/ZipperLocation)) + chan?)) + +;; Whatever is `reducible?` is seqable via a call to `sequence`. +(def seqable? + (t/or #?@(:clj [(t/isa? clojure.lang.Seqable) iterable? dstr/char-seq? map/map? arr/array?] + :cljs [(t/isa? cljs.core/ISeqable) arr/array? dstr/string?]))) + +;; Able to be traversed over in some fashion, whether by `first`/`next` seq-iteration, +;; reduction, etc. +;; TODO re-enable when dispatch enabled +#_(def traversable? + (t/or (t/isa? #?(:clj clojure.lang.IReduceInit :cljs cljs.core/IReduce)) + (t/isa? #?(:clj clojure.lang.IKVReduce :cljs cljs.core/IKVReduce)) + #?(:clj (t/isa? clojure.core.protocols/IKVReduce)) + (t/isa? #?(:clj clojure.lang.Seqable :cljs cljs.core/ISeqable)) + iterable? + #?(:clj dstr/char-seq? :cljs dstr/string?) + arr/array? + (t/isa? #?(:clj fast_zip.core.ZipperLocation :cljs fast-zip.core/ZipperLocation)) + chan?)) diff --git a/src/quantum/core/data/map.cljc b/src/quantum/core/data/map.cljc index eb0ec6f7..2376c7d4 100644 --- a/src/quantum/core/data/map.cljc +++ b/src/quantum/core/data/map.cljc @@ -9,13 +9,14 @@ #_[quantum.core.reducers :as r :refer [reduce-pair]] [quantum.core.type :as t] - [quantum.core.vars - :refer [defalias def- defmacro-]] [quantum.untyped.core.data.map :as umap] [quantum.untyped.core.defnt :refer [defns-]] + [quantum.untyped.core.type :as ut] [quantum.untyped.core.type.defnt - :refer [defnt]]) + :refer [defnt]] + [quantum.untyped.core.vars + :refer [defalias def- defmacro-]]) (:import #?@(:clj [[java.util HashMap IdentityHashMap LinkedHashMap TreeMap] [it.unimi.dsi.fastutil.ints Int2ReferenceOpenHashMap] @@ -50,7 +51,7 @@ #?(:clj (defmacro- def-preds|map|any [prefix #_symbol?] - (let [anys (->> (for [kind basic-type-syms] + (let [anys (->> (for [kind basic-type-syms-for-maps] [(list 'def (>kv-sym prefix kind 'any) (->> basic-type-syms-for-maps (map #(>kv-sym prefix kind %)) @@ -61,7 +62,7 @@ (list* `t/or)))]) (apply concat)) any->any (list 'def (>kv-sym prefix 'any 'any) - (->> basic-type-syms + (->> basic-type-syms-for-maps (map #(vector (>kv-sym prefix 'any %) (>kv-sym prefix % 'any))) (apply concat) (list* `t/or)))] @@ -1444,10 +1445,7 @@ ;; ----- General Maps ----- ;; -(def +map|built-in? - (t/or (t/isa? #?(:clj clojure.lang.PersistentHashMap :cljs cljs.core/PersistentHashMap)) - (t/isa? #?(:clj clojure.lang.PersistentArrayMap :cljs cljs.core/PersistentArrayMap)) - (t/isa? #?(:clj clojure.lang.PersistentTreeMap :cljs cljs.core/PersistentTreeMap)))) +(defalias ut/+map|built-in?) ;; `+map?` and `!+map?` defined above (def ?!+map? (t/or !+map? +map?)) diff --git a/src/quantum/core/data/tuple.cljc b/src/quantum/core/data/tuple.cljc index 87b3ed39..81d5a71f 100644 --- a/src/quantum/core/data/tuple.cljc +++ b/src/quantum/core/data/tuple.cljc @@ -1,7 +1,14 @@ (ns quantum.core.data.tuple (:require - [quantum.untyped.core.data.tuple :as u] - [quantum.untyped.core.vars - :refer [defalias]])) + [quantum.core.type :as t] + [quantum.core.vars + :refer [defalias]] + ;; TODO TYPED excise + [quantum.untyped.core.data.tuple :as u])) + + ;; clojure.lang.Tuple was discontinued; we won't support it for now + (def tuple? (t/isa? quantum.untyped.core.data.tuple.Tuple)) + +#?(:clj (def map-entry? (t/isa? java.util.Map$Entry))) #?(:clj (defalias u/tuple)) diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index c7837c21..9d61ede9 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -1,7 +1,7 @@ (ns quantum.core.type "This is this the namespace upon which all other fully-typed namespaces rest." (:refer-clojure :exclude - [* - and any? fn isa? or ref seq? symbol? var?]) + [* - and any? fn fn? isa? or ref seq? symbol? var?]) (:require [quantum.untyped.core.type.defnt :as udefnt] [quantum.untyped.core.type :as ut] diff --git a/src/quantum/core/vars.cljc b/src/quantum/core/vars.cljc index 31b941b8..6e164489 100644 --- a/src/quantum/core/vars.cljc +++ b/src/quantum/core/vars.cljc @@ -5,6 +5,7 @@ (:require ;; TODO TYPED remove reference to `clojure.core` [clojure.core :as c] + [quantum.core.data.map :as map] [quantum.core.ns :as ns] [quantum.core.type :as t :refer [defnt]] @@ -18,7 +19,7 @@ ;; ===== Meta ===== ;; -(def meta? (t/? ut/+map?)) +(def meta? (t/? map/+map?)) (defnt meta "Returns the (possibly nil) metadata of ->`x`." From 797ddab5210e387008a96a50a4e048711f580694 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 15 Sep 2018 15:47:17 -0600 Subject: [PATCH 267/810] Add typed bit operation impls --- src/quantum/core/data/bits.cljc | 58 ++++++++++++++++++++++++++++++++- 1 file changed, 57 insertions(+), 1 deletion(-) diff --git a/src/quantum/core/data/bits.cljc b/src/quantum/core/data/bits.cljc index ff5c85ba..b52f68dd 100644 --- a/src/quantum/core/data/bits.cljc +++ b/src/quantum/core/data/bits.cljc @@ -182,7 +182,7 @@ (defnt ^:inline <<< "Unsigned (logical) bit shift left" #_([x (t/- p/primitive? t/boolean?), n (t/- p/primitive? t/boolean?) > (t/type x)] - (Numeric/bitOr a b)) + (Numeric/bitOr x n)) ([x p/byte? , n (t/- p/primitive? p/boolean?) > p/byte?] (Numeric/shiftLeft x n)) ([x p/short? , n (t/- p/primitive? p/boolean?) > p/short?] (Numeric/shiftLeft x n)) ;; TODO implement this correctly because it likely isn't correct just to do `<<` in Java @@ -233,6 +233,62 @@ ([x p/float? , n (t/- p/primitive? p/boolean?) > p/float?] (Numeric/shiftRight x n)) ([x p/double?, n (t/- p/primitive? p/boolean?) > p/double?] (Numeric/shiftRight x n))) +;; ===== Single-bit operations ===== ;; + +;; TODO TYPED we can shorten this by having dependent types +(defnt ^:inline clear* + "Bit-clear. Unchecked w.r.t. the bit index." + {:todo "Extend index to non-longs"} +#_([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitClear x i)) + ([x p/byte? , i p/long? > p/byte?] (Numeric/bitClear x i)) + ([x p/short? , i p/long? > p/short?] (Numeric/bitClear x i)) + ([x p/char? , i p/long? > p/char?] (Numeric/bitClear x i)) + ([x p/int? , i p/long? > p/int?] (Numeric/bitClear x i)) + ([x p/long? , i p/long? > p/long?] (Numeric/bitClear x i)) + ([x p/float? , i p/long? > p/float?] (Numeric/bitClear x i)) + ([x p/double?, i p/long? > p/double?] (Numeric/bitClear x i))) + +;; TODO TYPED we can shorten this by having dependent types +(defnt ^:inline invert* + "Bit-invert/bit-flip. Unchecked w.r.t. the bit index." + {:todo "Extend index to non-longs"} +#_([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitFlip x i)) + ([x p/byte? , i p/long? > p/byte?] (Numeric/bitFlip x i)) + ([x p/short? , i p/long? > p/short?] (Numeric/bitFlip x i)) + ([x p/char? , i p/long? > p/char?] (Numeric/bitFlip x i)) + ([x p/int? , i p/long? > p/int?] (Numeric/bitFlip x i)) + ([x p/long? , i p/long? > p/long?] (Numeric/bitFlip x i)) + ([x p/float? , i p/long? > p/float?] (Numeric/bitFlip x i)) + ([x p/double?, i p/long? > p/double?] (Numeric/bitFlip x i))) + +;; TODO TYPED we can shorten this by having dependent types +(defnt ^:inline set* + "Bit-set. Unchecked w.r.t. the bit index." + {:todo "Extend index to non-longs"} +#_([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitSet x i)) + ([x p/byte? , i p/long? > p/byte?] (Numeric/bitSet x i)) + ([x p/short? , i p/long? > p/short?] (Numeric/bitSet x i)) + ([x p/char? , i p/long? > p/char?] (Numeric/bitSet x i)) + ([x p/int? , i p/long? > p/int?] (Numeric/bitSet x i)) + ([x p/long? , i p/long? > p/long?] (Numeric/bitSet x i)) + ([x p/float? , i p/long? > p/float?] (Numeric/bitSet x i)) + ([x p/double?, i p/long? > p/double?] (Numeric/bitSet x i))) + +;; TODO TYPED we can shorten this by having dependent types +(defnt ^:inline test* + "Bit-test. Unchecked w.r.t. the bit index." + {:todo "Extend index to non-longs"} +#_([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitTest x i)) + ([x p/byte? , i p/long? > p/byte?] (Numeric/bitTest x i)) + ([x p/short? , i p/long? > p/short?] (Numeric/bitTest x i)) + ([x p/char? , i p/long? > p/char?] (Numeric/bitTest x i)) + ([x p/int? , i p/long? > p/int?] (Numeric/bitTest x i)) + ([x p/long? , i p/long? > p/long?] (Numeric/bitTest x i)) + ([x p/float? , i p/long? > p/float?] (Numeric/bitTest x i)) + ([x p/double?, i p/long? > p/double?] (Numeric/bitTest x i))) + +(defalias ? test*) + ;; ===== Rotations ===== ;; (defnt rotate-left From 5c00594472a90cbed124837a434ad73e4626f244 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 17 Sep 2018 01:46:10 -0600 Subject: [PATCH 268/810] Add some notes to defnt todos --- resources-dev/defnt.cljc | 64 ++++++++++++++++++++++++++++++++-------- 1 file changed, 51 insertions(+), 13 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 15948067..12dea4d5 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -1,3 +1,9 @@ +;; Truncation is different from safe coercion +`>integer` is for e.g.: +- truncation e.g. js/Math.trunc + +>boolean is different than `truthy?` + #_" LEFT OFF LAST TIME (9/3/2018): @@ -7,9 +13,16 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - t/... - multi-arity `t/-` - t/assume - - t/numerically + - t/numerically : e.g. a double representing exactly what a float is able to represent + - and variants thereof: `numerically-long?` etc. + - t/numerically-integer? + - range-of : e.g. a double being between float max values but possibly representing a 'hole' in + possible float values + - dependent types: `[x p/int? > (t/type x)]` + - t/extend-defnt! - t/of - - (t/of map/+map? t/symbol? str/string?) + - (t/of number?) ; implicitly the container is a `traversable?` + - (t/of map/+map? t/symbol? dstr/string?) - (t/of t/seq? namespace?) - t/map-of - t/seq-of @@ -22,6 +35,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - declare-fnt (a way to do protocols/interfaces) - extend-fnt! - defnt (t/defn) + - (t/and (t/or a b) c) should -> (t/or (t/and a c) (t/and b c)) for purposes of separating dispatches - ^:inline - if you do (Numeric/bitAnd a b) inline then bitAnd needs to know the primitive type so maybe we do the `let*`-binding approach to typing vars? @@ -64,7 +78,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - quantum.core.data.vector - quantum.core.spec - quantum.core.error - - quantum.core.data.bits - quantum.core.data.string — this is where `>str` belongs - quantum.core.convert.primitive @@ -104,13 +117,15 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - quantum.core.ns - quantum.core.vars - quantum.core.data.map + - quantum.core.data.bits - List of corresponding untyped namespaces to incorporate: - - quantum.untyped.core.core - - quantum.untyped.core.ns - - quantum.untyped.core.vars - - quantum.untyped.core.data.map - - quantum.untyped.core.type.defs - - quantum.untyped.core.data + - [ ] quantum.untyped.core.core + - [ ] quantum.untyped.core.ns + - [ ] quantum.untyped.core.vars + - [ ] quantum.untyped.core.data.map + - [ ] quantum.untyped.core.type.defs + - [ ] quantum.untyped.core.data + - [ ] quantum.untyped.core.data.bits - List of Numeric fns to implement: - [ ] isTrue (?) - [ ] isFalse (?) @@ -118,8 +133,29 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] (logical) and (?) - [ ] (logical) or (?) - [ ] (logical) not - - [ ] reverseBits - - [ ] reverseBytes + - [ ] lt + - [ ] lte + - [ ] gt + - [ ] gte + - [ ] eq + - [ ] neq + - [ ] inc + - [ ] dec + - [ ] isZero + - [ ] isNeg + - [ ] inc + - [ ] dec + - [ ] isZero + - [ ] isNeg + - [ ] isPos + - [ ] add + - [ ] subtract + - [ ] negate + - [ ] multiply + - [ ] divide + - [ ] max + - [ ] min + - [ ] rem - List of Primitive fns to implement: - uncheckedByteCast - uncheckedCharCast @@ -130,9 +166,11 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - uncheckedDoubleCast - Standard metadata - e.g. `{:alternate-implementations #{'cljs.tools.reader/merge-meta}}` - - {:adapted-from } - - :todo + - :adapted-from + - :source + - :todo #{} - :attribution + - :doc - Instead of e.g. `ns-` or `var-` we can do `ns-val` and `var-val` - Should we type `when`, `let`? From a742d9ecb974663452338ff5f8671cde18c18204 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 17 Sep 2018 01:46:17 -0600 Subject: [PATCH 269/810] Format --- src-untyped/quantum/untyped/core/data/bits.cljc | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/bits.cljc b/src-untyped/quantum/untyped/core/data/bits.cljc index 93c46068..f27e82fa 100644 --- a/src-untyped/quantum/untyped/core/data/bits.cljc +++ b/src-untyped/quantum/untyped/core/data/bits.cljc @@ -17,16 +17,16 @@ ;; ===== Bit logic ===== ;; -(defalias not bit-not) -(defalias and bit-and) -(defalias and-not bit-and-not) -(defalias or bit-or) -(defalias xor bit-xor) -(defalias not! bit-flip) +(defalias not bit-not) +(defalias and bit-and) +(defalias and-not bit-and-not) +(defalias or bit-or) +(defalias xor bit-xor) +(defalias not! bit-flip) ;; ===== Bit set operations ===== ;; -(defalias disj bit-clear) +(defalias disj bit-clear) (def ^:const empty 0) From d842d574c9b053c4814d2ab7b6302489fe142bea Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 17 Sep 2018 01:46:25 -0600 Subject: [PATCH 270/810] Add `>form` for strings --- src-untyped/quantum/untyped/core/form.cljc | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index 082ae424..88b8e867 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -39,6 +39,8 @@ #?@(:clj [java.lang.Long (>form [x] x)]) #?(:clj java.lang.Double :cljs number) (>form [x] x) + #?(:clj java.lang.String + :cljs string) (>form [x] x) #?(:clj clojure.lang.Symbol :cljs cljs.core.Symbol) (>form [x] (list 'quote x)) From 2a407ba3f916507604de4cda5306433d4cbaee1f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 17 Sep 2018 01:46:51 -0600 Subject: [PATCH 271/810] Add arity to `t/or` --- src-untyped/quantum/untyped/core/type.cljc | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index b93007e7..d9306c0b 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -128,9 +128,10 @@ "Sequential/ordered `or`. Analogous to `set/union`. Applies as much 'compression'/deduplication/simplification as possible to the supplied types. Effectively computes the union of the extension of the ->`args`." - [arg & args] - (create-logical-type :or ->OrType utr/or-type? utr/or-type>args - (cons arg args) (fn1 c/= >ident))) + ([] empty-set) + ([arg & args] + (create-logical-type :or ->OrType utr/or-type? utr/or-type>args + (cons arg args) (fn1 c/= >ident)))) (uvar/defalias | or) From 78124751916ebf543d9267b211c1ad918c5b32ae Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 17 Sep 2018 01:54:24 -0600 Subject: [PATCH 272/810] Add CLJS impls of bit operations --- src/quantum/core/data/bits.cljc | 596 +++++++++++++++++--------------- 1 file changed, 316 insertions(+), 280 deletions(-) diff --git a/src/quantum/core/data/bits.cljc b/src/quantum/core/data/bits.cljc index b52f68dd..28f9454e 100644 --- a/src/quantum/core/data/bits.cljc +++ b/src/quantum/core/data/bits.cljc @@ -1,329 +1,326 @@ -(ns - ^{:doc "Useful bit/binary operations." - :attribution "alexandergunnarson"} - quantum.core.data.bits +(ns quantum.core.data.bits + "Useful bit/binary operations." (:refer-clojure :exclude - [and not or]) + [and conj contains? empty not or]) (:require [clojure.core :as core] - [quantum.core.data.primitive :as p] + [quantum.core.data.primitive :as p + :refer [>long]] [quantum.core.type :as t :refer [defnt]] [quantum.core.vars :as var :refer [defalias]]) #?(:clj (:import - [quantum.core Numeric] - #_java.nio.ByteBuffer))) + [quantum.core Numeric]))) -; Because "cannot resolve symbol 'import'" -#?(:clj -(doseq [sym '[reverse - true? false? nil?]] - (ns-unmap 'quantum.core.data.bits sym))) - -; TODO -; bit-clear -; bit-and-not -; bit-test -; bit-flip -; bit-set - -; TODO ExceptionInInitializerError somewhere over here... -;; TODO TYPED move -#_(defnt ^boolean nil? - ([^Object x] (quantum.core.Numeric/isNil x)) - ([:else x] false)) - -;; TODO TYPED move -#?(:clj (defalias nil? core/nil?)) - -;; TODO TYPED move -#_(defnt ^boolean not' - ([^boolean? x] (Numeric/not x)) - ([x] (if (nil? x) true))) ; Lisp nil punning - -;; TODO TYPED move -#_(defnt ^boolean true? - ([^boolean? x] x) - ([:else x] false)) - -;; TODO TYPED move -#?(:clj (defalias true? core/true?)) - -;; TODO TYPED move -#_(defnt ^boolean false? - ([^boolean? x] (not' x)) - ([:else x] false)) - -;; TODO TYPED move -#?(:clj (defalias false? core/false?)) +(def bit-false 0) +(def bit-true 1) ;; ===== Logical bit-operations ===== ;; +;; NOTE: we won't be supporting `and-not` ;; TODO TYPED we can shorten this by having dependent types (defnt ^:inline not -#_([x p/primitive? > (t/type x)] (Numeric/bitNot x)) - ([x p/boolean? > p/boolean?] (Numeric/bitNot x)) - ([x p/byte? > p/byte?] (Numeric/bitNot x)) - ([x p/short? > p/short?] (Numeric/bitNot x)) - ([x p/char? > p/char?] (Numeric/bitNot x)) - ([x p/int? > p/int?] (Numeric/bitNot x)) - ([x p/long? > p/long?] (Numeric/bitNot x)) - ([x p/float? > p/float?] (Numeric/bitNot x)) - ([x p/double? > p/double?] (Numeric/bitNot x))) - + "Bitwise `not`." + #?@(:clj [#_([x p/primitive? > (t/type x)] (Numeric/bitNot x)) + ([x p/boolean? > p/boolean?] (Numeric/bitNot x)) + ([x p/byte? > p/byte?] (Numeric/bitNot x)) + ([x p/short? > p/short?] (Numeric/bitNot x)) + ([x p/char? > p/char?] (Numeric/bitNot x)) + ([x p/int? > p/int?] (Numeric/bitNot x)) + ([x p/long? > p/long?] (Numeric/bitNot x)) + ([x p/float? > p/float?] (Numeric/bitNot x)) + ([x p/double? > p/double?] (Numeric/bitNot x))] + :cljs [([x p/boolean? > p/boolean?] (if x false true)) + ([x p/double? > p/double?] (core/bit-not x))])) + +;; TODO make variadic ;; TODO TYPED we can shorten this by having dependent types (defnt ^:inline and -#_([a p/boolean?, b p/boolean? > ?] (Numeric/bitAnd a b)) -#_([a (t/- p/primitive? t/boolean?), b (t/- p/primitive? t/boolean?) > ?] (Numeric/bitAnd a b)) - ([a p/boolean?, b p/boolean? > p/boolean?] (Numeric/bitAnd a b)) - ([a p/byte? , b p/byte? > p/byte?] (Numeric/bitAnd a b)) - ([a p/byte? , b p/short? > p/short?] (Numeric/bitAnd a b)) - ([a p/byte? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitAnd a b)) - ([a p/byte? , b p/long? > p/long?] (Numeric/bitAnd a b)) - ([a p/byte? , b p/float? > p/float?] (Numeric/bitAnd a b)) - ([a p/byte? , b p/double? > p/double?] (Numeric/bitAnd a b)) - ([a p/short? , b (t/or p/byte? p/short?) > p/short?] (Numeric/bitAnd a b)) - ([a p/short? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitAnd a b)) - ([a p/short? , b p/long? > p/long?] (Numeric/bitAnd a b)) - ([a p/short? , b p/float? > p/float?] (Numeric/bitAnd a b)) - ([a p/short? , b p/double? > p/double?] (Numeric/bitAnd a b)) - ([a p/char? , b (t/or p/byte? p/short?) > p/int?] (Numeric/bitAnd a b)) - ([a p/char? , b p/char? > p/char?] (Numeric/bitAnd a b)) - ([a p/char? , b p/int? > p/int?] (Numeric/bitAnd a b)) - ([a p/char? , b p/long? > p/long?] (Numeric/bitAnd a b)) - ([a p/char? , b p/float? > p/float?] (Numeric/bitAnd a b)) - ([a p/char? , b p/double? > p/double?] (Numeric/bitAnd a b)) - ([a p/int? , b (t/or p/byte? p/short? p/char? p/int?) > p/int?] (Numeric/bitAnd a b)) - ([a p/int? , b p/long? > p/long?] (Numeric/bitAnd a b)) - ([a p/int? , b p/float? > p/float?] (Numeric/bitAnd a b)) - ([a p/int? , b p/double? > p/double?] (Numeric/bitAnd a b)) - ([a p/long? , b (t/or p/byte? p/short? p/char? p/int? - p/int? p/long?) > p/long?] (Numeric/bitAnd a b)) - ([a p/long? , b (t/or p/float? p/double?) > p/double?] (Numeric/bitAnd a b)) - ([a p/float? , b (t/or p/byte? p/short? p/char? p/int? - p/float?) > p/float?] (Numeric/bitAnd a b)) - ([a p/float? , b (t/or p/long? p/double?) > p/double?] (Numeric/bitAnd a b)) - ([a p/double? , b p/primitive? > p/double?] (Numeric/bitAnd a b))) - + "Bitwise `and`." +#?@(:clj [#_([a p/boolean?, b p/boolean? > ?] (Numeric/bitAnd a b)) + #_([a (t/- p/primitive? t/boolean?) + b (t/- p/primitive? t/boolean?) > ?] (Numeric/bitAnd a b)) + ([a p/boolean?, b p/boolean? > p/boolean?] (Numeric/bitAnd a b)) + ([a p/byte? , b p/byte? > p/byte?] (Numeric/bitAnd a b)) + ([a p/byte? , b p/short? > p/short?] (Numeric/bitAnd a b)) + ([a p/byte? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitAnd a b)) + ([a p/byte? , b p/long? > p/long?] (Numeric/bitAnd a b)) + ([a p/byte? , b p/float? > p/float?] (Numeric/bitAnd a b)) + ([a p/byte? , b p/double? > p/double?] (Numeric/bitAnd a b)) + ([a p/short? , b (t/or p/byte? p/short?) > p/short?] (Numeric/bitAnd a b)) + ([a p/short? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitAnd a b)) + ([a p/short? , b p/long? > p/long?] (Numeric/bitAnd a b)) + ([a p/short? , b p/float? > p/float?] (Numeric/bitAnd a b)) + ([a p/short? , b p/double? > p/double?] (Numeric/bitAnd a b)) + ([a p/char? , b (t/or p/byte? p/short?) > p/int?] (Numeric/bitAnd a b)) + ([a p/char? , b p/char? > p/char?] (Numeric/bitAnd a b)) + ([a p/char? , b p/int? > p/int?] (Numeric/bitAnd a b)) + ([a p/char? , b p/long? > p/long?] (Numeric/bitAnd a b)) + ([a p/char? , b p/float? > p/float?] (Numeric/bitAnd a b)) + ([a p/char? , b p/double? > p/double?] (Numeric/bitAnd a b)) + ([a p/int? , b (t/or p/byte? p/short? p/char? + p/int?) > p/int?] (Numeric/bitAnd a b)) + ([a p/int? , b p/long? > p/long?] (Numeric/bitAnd a b)) + ([a p/int? , b p/float? > p/float?] (Numeric/bitAnd a b)) + ([a p/int? , b p/double? > p/double?] (Numeric/bitAnd a b)) + ([a p/long? , b (t/or p/byte? p/short? p/char? + p/int? p/long?) > p/long?] (Numeric/bitAnd a b)) + ([a p/long? , b (t/or p/float? p/double?) > p/double?] (Numeric/bitAnd a b)) + ([a p/float? , b (t/or p/byte? p/short? p/char? + p/int? p/float?) > p/float?] (Numeric/bitAnd a b)) + ([a p/float? , b (t/or p/long? p/double?) > p/double?] (Numeric/bitAnd a b)) + ([a p/double? , b (t/- p/primitive? p/boolean?) > p/double?] (Numeric/bitAnd a b))] + :cljs [([a p/boolean?, b p/boolean? > p/boolean?] (core/and a b)) + ([a p/double? , b p/double? > p/double?] (core/bit-and a b))])) + +;; TODO make variadic ;; TODO TYPED we can shorten this by having dependent types (defnt ^:inline or -#_([a p/boolean?, b p/boolean? > ?] (Numeric/bitOr a b)) -#_([a (t/- p/primitive? t/boolean?), b (t/- p/primitive? t/boolean?) > ?] (Numeric/bitOr a b)) - ([a p/boolean?, b p/boolean? > p/boolean?] (Numeric/bitOr a b)) - ([a p/byte? , b p/byte? > p/byte?] (Numeric/bitOr a b)) - ([a p/byte? , b p/short? > p/short?] (Numeric/bitOr a b)) - ([a p/byte? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitOr a b)) - ([a p/byte? , b p/long? > p/long?] (Numeric/bitOr a b)) - ([a p/byte? , b p/float? > p/float?] (Numeric/bitOr a b)) - ([a p/byte? , b p/double? > p/double?] (Numeric/bitOr a b)) - ([a p/short? , b (t/or p/byte? p/short?) > p/short?] (Numeric/bitOr a b)) - ([a p/short? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitOr a b)) - ([a p/short? , b p/long? > p/long?] (Numeric/bitOr a b)) - ([a p/short? , b p/float? > p/float?] (Numeric/bitOr a b)) - ([a p/short? , b p/double? > p/double?] (Numeric/bitOr a b)) - ([a p/char? , b (t/or p/byte? p/short?) > p/int?] (Numeric/bitOr a b)) - ([a p/char? , b p/char? > p/char?] (Numeric/bitOr a b)) - ([a p/char? , b p/int? > p/int?] (Numeric/bitOr a b)) - ([a p/char? , b p/long? > p/long?] (Numeric/bitOr a b)) - ([a p/char? , b p/float? > p/float?] (Numeric/bitOr a b)) - ([a p/char? , b p/double? > p/double?] (Numeric/bitOr a b)) - ([a p/int? , b (t/or p/byte? p/short? p/char? p/int?) > p/int?] (Numeric/bitOr a b)) - ([a p/int? , b p/long? > p/long?] (Numeric/bitOr a b)) - ([a p/int? , b p/float? > p/float?] (Numeric/bitOr a b)) - ([a p/int? , b p/double? > p/double?] (Numeric/bitOr a b)) - ([a p/long? , b (t/or p/byte? p/short? p/char? p/int? - p/int? p/long?) > p/long?] (Numeric/bitOr a b)) - ([a p/long? , b (t/or p/float? p/double?) > p/double?] (Numeric/bitOr a b)) - ([a p/float? , b (t/or p/byte? p/short? p/char? p/int? - p/float?) > p/float?] (Numeric/bitOr a b)) - ([a p/float? , b (t/or p/long? p/double?) > p/double?] (Numeric/bitOr a b)) - ([a p/double? , b p/primitive? > p/double?] (Numeric/bitOr a b))) - + "Bitwise `or`." +#?@(:clj [#_([a p/boolean?, b p/boolean? > ?] (Numeric/bitOr a b)) + #_([a (t/- p/primitive? t/boolean?) + b (t/- p/primitive? t/boolean?) > ?] (Numeric/bitOr a b)) + ([a p/boolean?, b p/boolean? > p/boolean?] (Numeric/bitOr a b)) + ([a p/byte? , b p/byte? > p/byte?] (Numeric/bitOr a b)) + ([a p/byte? , b p/short? > p/short?] (Numeric/bitOr a b)) + ([a p/byte? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitOr a b)) + ([a p/byte? , b p/long? > p/long?] (Numeric/bitOr a b)) + ([a p/byte? , b p/float? > p/float?] (Numeric/bitOr a b)) + ([a p/byte? , b p/double? > p/double?] (Numeric/bitOr a b)) + ([a p/short? , b (t/or p/byte? p/short?) > p/short?] (Numeric/bitOr a b)) + ([a p/short? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitOr a b)) + ([a p/short? , b p/long? > p/long?] (Numeric/bitOr a b)) + ([a p/short? , b p/float? > p/float?] (Numeric/bitOr a b)) + ([a p/short? , b p/double? > p/double?] (Numeric/bitOr a b)) + ([a p/char? , b (t/or p/byte? p/short?) > p/int?] (Numeric/bitOr a b)) + ([a p/char? , b p/char? > p/char?] (Numeric/bitOr a b)) + ([a p/char? , b p/int? > p/int?] (Numeric/bitOr a b)) + ([a p/char? , b p/long? > p/long?] (Numeric/bitOr a b)) + ([a p/char? , b p/float? > p/float?] (Numeric/bitOr a b)) + ([a p/char? , b p/double? > p/double?] (Numeric/bitOr a b)) + ([a p/int? , b (t/or p/byte? p/short? p/char? + p/int?) > p/int?] (Numeric/bitOr a b)) + ([a p/int? , b p/long? > p/long?] (Numeric/bitOr a b)) + ([a p/int? , b p/float? > p/float?] (Numeric/bitOr a b)) + ([a p/int? , b p/double? > p/double?] (Numeric/bitOr a b)) + ([a p/long? , b (t/or p/byte? p/short? p/char? + p/int? p/long?) > p/long?] (Numeric/bitOr a b)) + ([a p/long? , b (t/or p/float? p/double?) > p/double?] (Numeric/bitOr a b)) + ([a p/float? , b (t/or p/byte? p/short? p/char? + p/int? p/float?) > p/float?] (Numeric/bitOr a b)) + ([a p/float? , b (t/or p/long? p/double?) > p/double?] (Numeric/bitOr a b)) + ([a p/double? , b (t/- p/primitive? p/boolean?) > p/double?] (Numeric/bitOr a b))] + :cljs [([a p/boolean?, b p/boolean? > p/boolean?] (core/or a b)) + ([a p/double? , b p/double? > p/double?] (core/bit-or a b))])) + +;; TODO make variadic ;; TODO TYPED we can shorten this by having dependent types (defnt ^:inline xor -#_([a p/boolean?, b p/boolean? > ?] (Numeric/bitXOr a b)) -#_([a (t/- p/primitive? t/boolean?), b (t/- p/primitive? t/boolean?) > ?] (Numeric/bitXOr a b)) - ([a p/boolean?, b p/boolean? > p/boolean?] (Numeric/bitXOr a b)) - ([a p/byte? , b p/byte? > p/byte?] (Numeric/bitXOr a b)) - ([a p/byte? , b p/short? > p/short?] (Numeric/bitXOr a b)) - ([a p/byte? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitXOr a b)) - ([a p/byte? , b p/long? > p/long?] (Numeric/bitXOr a b)) - ([a p/byte? , b p/float? > p/float?] (Numeric/bitXOr a b)) - ([a p/byte? , b p/double? > p/double?] (Numeric/bitXOr a b)) - ([a p/short? , b (t/or p/byte? p/short?) > p/short?] (Numeric/bitXOr a b)) - ([a p/short? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitXOr a b)) - ([a p/short? , b p/long? > p/long?] (Numeric/bitXOr a b)) - ([a p/short? , b p/float? > p/float?] (Numeric/bitXOr a b)) - ([a p/short? , b p/double? > p/double?] (Numeric/bitXOr a b)) - ([a p/char? , b (t/or p/byte? p/short?) > p/int?] (Numeric/bitXOr a b)) - ([a p/char? , b p/char? > p/char?] (Numeric/bitXOr a b)) - ([a p/char? , b p/int? > p/int?] (Numeric/bitXOr a b)) - ([a p/char? , b p/long? > p/long?] (Numeric/bitXOr a b)) - ([a p/char? , b p/float? > p/float?] (Numeric/bitXOr a b)) - ([a p/char? , b p/double? > p/double?] (Numeric/bitXOr a b)) - ([a p/int? , b (t/or p/byte? p/short? p/char? p/int?) > p/int?] (Numeric/bitXOr a b)) - ([a p/int? , b p/long? > p/long?] (Numeric/bitXOr a b)) - ([a p/int? , b p/float? > p/float?] (Numeric/bitXOr a b)) - ([a p/int? , b p/double? > p/double?] (Numeric/bitXOr a b)) - ([a p/long? , b (t/or p/byte? p/short? p/char? p/int? - p/int? p/long?) > p/long?] (Numeric/bitXOr a b)) - ([a p/long? , b (t/or p/float? p/double?) > p/double?] (Numeric/bitXOr a b)) - ([a p/float? , b (t/or p/byte? p/short? p/char? p/int? - p/float?) > p/float?] (Numeric/bitXOr a b)) - ([a p/float? , b (t/or p/long? p/double?) > p/double?] (Numeric/bitXOr a b)) - ([a p/double? , b p/primitive? > p/double?] (Numeric/bitXOr a b))) + "Bitwise `xor`." +#?@(:clj [#_([a p/boolean?, b p/boolean? > ?] (Numeric/bitXOr a b)) + #_([a (t/- p/primitive? t/boolean?) + b (t/- p/primitive? t/boolean?) > ?] (Numeric/bitXOr a b)) + ([a p/boolean?, b p/boolean? > p/boolean?] (Numeric/bitXOr a b)) + ([a p/byte? , b p/byte? > p/byte?] (Numeric/bitXOr a b)) + ([a p/byte? , b p/short? > p/short?] (Numeric/bitXOr a b)) + ([a p/byte? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitXOr a b)) + ([a p/byte? , b p/long? > p/long?] (Numeric/bitXOr a b)) + ([a p/byte? , b p/float? > p/float?] (Numeric/bitXOr a b)) + ([a p/byte? , b p/double? > p/double?] (Numeric/bitXOr a b)) + ([a p/short? , b (t/or p/byte? p/short?) > p/short?] (Numeric/bitXOr a b)) + ([a p/short? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitXOr a b)) + ([a p/short? , b p/long? > p/long?] (Numeric/bitXOr a b)) + ([a p/short? , b p/float? > p/float?] (Numeric/bitXOr a b)) + ([a p/short? , b p/double? > p/double?] (Numeric/bitXOr a b)) + ([a p/char? , b (t/or p/byte? p/short?) > p/int?] (Numeric/bitXOr a b)) + ([a p/char? , b p/char? > p/char?] (Numeric/bitXOr a b)) + ([a p/char? , b p/int? > p/int?] (Numeric/bitXOr a b)) + ([a p/char? , b p/long? > p/long?] (Numeric/bitXOr a b)) + ([a p/char? , b p/float? > p/float?] (Numeric/bitXOr a b)) + ([a p/char? , b p/double? > p/double?] (Numeric/bitXOr a b)) + ([a p/int? , b (t/or p/byte? p/short? p/char? + p/int?) > p/int?] (Numeric/bitXOr a b)) + ([a p/int? , b p/long? > p/long?] (Numeric/bitXOr a b)) + ([a p/int? , b p/float? > p/float?] (Numeric/bitXOr a b)) + ([a p/int? , b p/double? > p/double?] (Numeric/bitXOr a b)) + ([a p/long? , b (t/or p/byte? p/short? p/char? + p/int? p/long?) > p/long?] (Numeric/bitXOr a b)) + ([a p/long? , b (t/or p/float? p/double?) > p/double?] (Numeric/bitXOr a b)) + ([a p/float? , b (t/or p/byte? p/short? p/char? + p/int? p/float?) > p/float?] (Numeric/bitXOr a b)) + ([a p/float? , b (t/or p/long? p/double?) > p/double?] (Numeric/bitXOr a b)) + ([a p/double? , b (t/- p/primitive? p/boolean?) > p/double?] (Numeric/bitXOr a b))] + :cljs [([a p/boolean?, b p/boolean? > p/boolean?] (js* "(~{} !=== ~{})" a b)) + ([a p/double? , b p/double? > p/double?] (core/bit-xor a b))])) ;; ===== Bit-shifts ===== ;; ;; ----- Logical bit-shifts ---- ;; ;; TODO TYPED we can shorten this by having dependent types +;; TODO TYPED `t/numerically-integer?` (defnt ^:inline <<< - "Unsigned (logical) bit shift left" -#_([x (t/- p/primitive? t/boolean?), n (t/- p/primitive? t/boolean?) > (t/type x)] - (Numeric/bitOr x n)) - ([x p/byte? , n (t/- p/primitive? p/boolean?) > p/byte?] (Numeric/shiftLeft x n)) - ([x p/short? , n (t/- p/primitive? p/boolean?) > p/short?] (Numeric/shiftLeft x n)) - ;; TODO implement this correctly because it likely isn't correct just to do `<<` in Java -#_([x p/char? , n (t/- p/primitive? p/boolean?) > p/char?] (Numeric/shiftLeft x n)) - ([x p/int? , n (t/- p/primitive? p/boolean?) > p/int?] (Numeric/shiftLeft x n)) - ([x p/long? , n (t/- p/primitive? p/boolean?) > p/long?] (Numeric/shiftLeft x n)) - ([x p/float? , n (t/- p/primitive? p/boolean?) > p/float?] (Numeric/shiftLeft x n)) - ([x p/double?, n (t/- p/primitive? p/boolean?) > p/double?] (Numeric/shiftLeft x n))) + "Unsigned (logical) bitwise shift left" +#?@(:clj [#_([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] + (Numeric/bitOr x n)) + ([x p/byte? , n p/integral? > p/byte?] (Numeric/shiftLeft x n)) + ([x p/short? , n p/integral? > p/short?] (Numeric/shiftLeft x n)) + ;; TODO implement this correctly because it likely isn't correct just to do `<<` in Java + #_([x p/char? , n p/integral? > p/char?] (Numeric/shiftLeft x n)) + ([x p/int? , n p/integral? > p/int?] (Numeric/shiftLeft x n)) + ([x p/long? , n p/integral? > p/long?] (Numeric/shiftLeft x n)) + ([x p/float? , n p/integral? > p/float?] (Numeric/shiftLeft x n)) + ([x p/double?, n p/integral? > p/double?] (Numeric/shiftLeft x n))] + :cljs [([x p/double?, n t/numerically-integer? > p/double?] (core/bit-shift-left x n))])) ;; TODO TYPED we can shorten this by having dependent types (defnt ^:inline >>> - "Unsigned (logical) bit shift right" -#_([x (t/- p/primitive? t/boolean?), n (t/- p/primitive? t/boolean?) > (t/type x)] - (Numeric/bitOr a b)) - ([x p/byte? , n (t/- p/primitive? p/boolean?) > p/byte?] (Numeric/uShiftRight x n)) - ([x p/short? , n (t/- p/primitive? p/boolean?) > p/short?] (Numeric/uShiftRight x n)) - ([x p/char? , n (t/- p/primitive? p/boolean?) > p/char?] (Numeric/uShiftRight x n)) - ([x p/int? , n (t/- p/primitive? p/boolean?) > p/int?] (Numeric/uShiftRight x n)) - ([x p/long? , n (t/- p/primitive? p/boolean?) > p/long?] (Numeric/uShiftRight x n)) - ([x p/float? , n (t/- p/primitive? p/boolean?) > p/float?] (Numeric/uShiftRight x n)) - ([x p/double?, n (t/- p/primitive? p/boolean?) > p/double?] (Numeric/uShiftRight x n))) + "Unsigned (logical) bitwise shift right" +#?@(:clj [#_([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] + (Numeric/bitOr a b)) + ([x p/byte? , n p/integral? > p/byte?] (Numeric/uShiftRight x n)) + ([x p/short? , n p/integral? > p/short?] (Numeric/uShiftRight x n)) + ([x p/char? , n p/integral? > p/char?] (Numeric/uShiftRight x n)) + ([x p/int? , n p/integral? > p/int?] (Numeric/uShiftRight x n)) + ([x p/long? , n p/integral? > p/long?] (Numeric/uShiftRight x n)) + ([x p/float? , n p/integral? > p/float?] (Numeric/uShiftRight x n)) + ([x p/double?, n p/integral? > p/double?] (Numeric/uShiftRight x n))] + :cljs [([x p/double?, n t/numerically-integer? > p/double?] + (core/unsigned-bit-shift-right x n))])) ;; ----- Arithmetic bit-shifts ----- ;; ;; TODO TYPED we can shorten this by having dependent types (defnt ^:inline << - "Arithmetic bit shift left" -#_([x (t/- p/primitive? t/boolean?), n (t/- p/primitive? t/boolean?) > (t/type x)] - (Numeric/bitOr a b)) - ([x p/byte? , n (t/- p/primitive? p/boolean?) > p/byte?] (Numeric/shiftLeft x n)) - ([x p/short? , n (t/- p/primitive? p/boolean?) > p/short?] (Numeric/shiftLeft x n)) - ([x p/char? , n (t/- p/primitive? p/boolean?) > p/char?] (Numeric/shiftLeft x n)) - ([x p/int? , n (t/- p/primitive? p/boolean?) > p/int?] (Numeric/shiftLeft x n)) - ([x p/long? , n (t/- p/primitive? p/boolean?) > p/long?] (Numeric/shiftLeft x n)) - ([x p/float? , n (t/- p/primitive? p/boolean?) > p/float?] (Numeric/shiftLeft x n)) - ([x p/double?, n (t/- p/primitive? p/boolean?) > p/double?] (Numeric/shiftLeft x n))) + "Arithmetic bitwise shift left" +#?@(:clj [#_([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] + (Numeric/bitOr a b)) + ([x p/byte? , n p/integral? > p/byte?] (Numeric/shiftLeft x n)) + ([x p/short? , n p/integral? > p/short?] (Numeric/shiftLeft x n)) + ([x p/char? , n p/integral? > p/char?] (Numeric/shiftLeft x n)) + ([x p/int? , n p/integral? > p/int?] (Numeric/shiftLeft x n)) + ([x p/long? , n p/integral? > p/long?] (Numeric/shiftLeft x n)) + ([x p/float? , n p/integral? > p/float?] (Numeric/shiftLeft x n)) + ([x p/double?, n p/integral? > p/double?] (Numeric/shiftLeft x n))] + :cljs [([x p/double?, n t/numerically-integer? > p/double?] (core/bit-shift-left x n))])) ;; TODO TYPED we can shorten this by having dependent types (defnt ^:inline >> - "Arithmetic bit shift right" -#_([x (t/- p/primitive? t/boolean?), n (t/- p/primitive? t/boolean?) > (t/type x)] - (Numeric/bitOr a b)) - ([x p/byte? , n (t/- p/primitive? p/boolean?) > p/byte?] (Numeric/shiftRight x n)) - ([x p/short? , n (t/- p/primitive? p/boolean?) > p/short?] (Numeric/shiftRight x n)) - ([x p/char? , n (t/- p/primitive? p/boolean?) > p/char?] (Numeric/shiftRight x n)) - ([x p/int? , n (t/- p/primitive? p/boolean?) > p/int?] (Numeric/shiftRight x n)) - ([x p/long? , n (t/- p/primitive? p/boolean?) > p/long?] (Numeric/shiftRight x n)) - ([x p/float? , n (t/- p/primitive? p/boolean?) > p/float?] (Numeric/shiftRight x n)) - ([x p/double?, n (t/- p/primitive? p/boolean?) > p/double?] (Numeric/shiftRight x n))) + "Arithmetic bitwise shift right" +#?@(:clj [#_([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] + (Numeric/bitOr a b)) + ([x p/byte? , n p/integral? > p/byte?] (Numeric/shiftRight x n)) + ([x p/short? , n p/integral? > p/short?] (Numeric/shiftRight x n)) + ([x p/char? , n p/integral? > p/char?] (Numeric/shiftRight x n)) + ([x p/int? , n p/integral? > p/int?] (Numeric/shiftRight x n)) + ([x p/long? , n p/integral? > p/long?] (Numeric/shiftRight x n)) + ([x p/float? , n p/integral? > p/float?] (Numeric/shiftRight x n)) + ([x p/double?, n p/integral? > p/double?] (Numeric/shiftRight x n))] + :cljs [([x p/double?, n t/numerically-integer? > p/double?] (core/bit-shift-right x n))])) ;; ===== Single-bit operations ===== ;; -;; TODO TYPED we can shorten this by having dependent types -(defnt ^:inline clear* - "Bit-clear. Unchecked w.r.t. the bit index." - {:todo "Extend index to non-longs"} -#_([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitClear x i)) - ([x p/byte? , i p/long? > p/byte?] (Numeric/bitClear x i)) - ([x p/short? , i p/long? > p/short?] (Numeric/bitClear x i)) - ([x p/char? , i p/long? > p/char?] (Numeric/bitClear x i)) - ([x p/int? , i p/long? > p/int?] (Numeric/bitClear x i)) - ([x p/long? , i p/long? > p/long?] (Numeric/bitClear x i)) - ([x p/float? , i p/long? > p/float?] (Numeric/bitClear x i)) - ([x p/double?, i p/long? > p/double?] (Numeric/bitClear x i))) +;; TODO add bit operations with checked indices ;; TODO TYPED we can shorten this by having dependent types -(defnt ^:inline invert* - "Bit-invert/bit-flip. Unchecked w.r.t. the bit index." - {:todo "Extend index to non-longs"} -#_([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitFlip x i)) - ([x p/byte? , i p/long? > p/byte?] (Numeric/bitFlip x i)) - ([x p/short? , i p/long? > p/short?] (Numeric/bitFlip x i)) - ([x p/char? , i p/long? > p/char?] (Numeric/bitFlip x i)) - ([x p/int? , i p/long? > p/int?] (Numeric/bitFlip x i)) - ([x p/long? , i p/long? > p/long?] (Numeric/bitFlip x i)) - ([x p/float? , i p/long? > p/float?] (Numeric/bitFlip x i)) - ([x p/double?, i p/long? > p/double?] (Numeric/bitFlip x i))) +(defnt ^:inline bit-set-false* + "Makes the bit at the provided index ->`i` `bit-false`. + Unchecked w.r.t. the bit index. + Equivalent to `clojure.core/bit-clear`." + {:todo #{"Extend index to non-longs"}} +#?@(:clj [#_([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitClear x i)) + ([x p/byte? , i p/long? > p/byte?] (Numeric/bitClear x i)) + ([x p/short? , i p/long? > p/short?] (Numeric/bitClear x i)) + ([x p/char? , i p/long? > p/char?] (Numeric/bitClear x i)) + ([x p/int? , i p/long? > p/int?] (Numeric/bitClear x i)) + ([x p/long? , i p/long? > p/long?] (Numeric/bitClear x i)) + ([x p/float? , i p/long? > p/float?] (Numeric/bitClear x i)) + ([x p/double?, i p/long? > p/double?] (Numeric/bitClear x i))] + :cljs [([x p/double?, i t/numerically-integer? > p/double?] (core/bit-clear x i))])) ;; TODO TYPED we can shorten this by having dependent types -(defnt ^:inline set* - "Bit-set. Unchecked w.r.t. the bit index." - {:todo "Extend index to non-longs"} -#_([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitSet x i)) - ([x p/byte? , i p/long? > p/byte?] (Numeric/bitSet x i)) - ([x p/short? , i p/long? > p/short?] (Numeric/bitSet x i)) - ([x p/char? , i p/long? > p/char?] (Numeric/bitSet x i)) - ([x p/int? , i p/long? > p/int?] (Numeric/bitSet x i)) - ([x p/long? , i p/long? > p/long?] (Numeric/bitSet x i)) - ([x p/float? , i p/long? > p/float?] (Numeric/bitSet x i)) - ([x p/double?, i p/long? > p/double?] (Numeric/bitSet x i))) +(defnt ^:inline bit-set-true* + "Makes the bit at the provided index ->`i` `bit-true`. + Unchecked w.r.t. the bit index. + Equivalent to `clojure.core/bit-set`." + {:todo #{"Extend index to non-longs"}} +#?@(:clj [#_([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitSet x i)) + ([x p/byte? , i p/long? > p/byte?] (Numeric/bitSet x i)) + ([x p/short? , i p/long? > p/short?] (Numeric/bitSet x i)) + ([x p/char? , i p/long? > p/char?] (Numeric/bitSet x i)) + ([x p/int? , i p/long? > p/int?] (Numeric/bitSet x i)) + ([x p/long? , i p/long? > p/long?] (Numeric/bitSet x i)) + ([x p/float? , i p/long? > p/float?] (Numeric/bitSet x i)) + ([x p/double?, i p/long? > p/double?] (Numeric/bitSet x i))] + :cljs [([x p/double?, i t/numerically-integer? > p/double?] (core/bit-set x i))])) ;; TODO TYPED we can shorten this by having dependent types -(defnt ^:inline test* - "Bit-test. Unchecked w.r.t. the bit index." - {:todo "Extend index to non-longs"} -#_([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitTest x i)) - ([x p/byte? , i p/long? > p/byte?] (Numeric/bitTest x i)) - ([x p/short? , i p/long? > p/short?] (Numeric/bitTest x i)) - ([x p/char? , i p/long? > p/char?] (Numeric/bitTest x i)) - ([x p/int? , i p/long? > p/int?] (Numeric/bitTest x i)) - ([x p/long? , i p/long? > p/long?] (Numeric/bitTest x i)) - ([x p/float? , i p/long? > p/float?] (Numeric/bitTest x i)) - ([x p/double?, i p/long? > p/double?] (Numeric/bitTest x i))) +(defnt ^:inline bit-not* + "Applies `not` to the bit at the provided index ->`i`. + Unchecked w.r.t. the bit index. + Equivalent to `clojure.core/bit-flip`." + {:todo #{"Extend index to non-longs"}} +#?@(:clj [#_([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitFlip x i)) + ([x p/byte? , i p/long? > p/byte?] (Numeric/bitFlip x i)) + ([x p/short? , i p/long? > p/short?] (Numeric/bitFlip x i)) + ([x p/char? , i p/long? > p/char?] (Numeric/bitFlip x i)) + ([x p/int? , i p/long? > p/int?] (Numeric/bitFlip x i)) + ([x p/long? , i p/long? > p/long?] (Numeric/bitFlip x i)) + ([x p/float? , i p/long? > p/float?] (Numeric/bitFlip x i)) + ([x p/double?, i p/long? > p/double?] (Numeric/bitFlip x i))] + :cljs [([x p/double?, i t/numerically-integer? > p/double?] (core/bit-flip x i))])) + +(defnt ^:inline bit-true?* + "Outputs whether the bit at the provided index ->`i` is `bit-true`. + Unchecked w.r.t. the bit index. + Equivalent to `clojure.core/bit-test`." + {:todo #{"Extend index to non-longs"}} +#?(:clj ([x (t/- p/primitive? p/boolean?), i p/long? > p/boolean?] (Numeric/bitTest x i)) + :cljs ([x p/double?, i t/numerically-integer? > p/boolean?] (core/bit-test x i)))) (defalias ? test*) ;; ===== Rotations ===== ;; -(defnt rotate-left +;; TODO TYPED +#_(defnt rotate-left {:from "http://hg.openjdk.java.net/jdk7u/jdk7u6/jdk/file/8c2c5d63a17e/src/share/classes/java/lang/Integer.java"} [x ???, n ???] (or (<< x n) (>>> x (- n)))) +;; TODO extend to CLJ +;; TODO can use e.g. java.lang.Integer/bitCount for the purpose +;; TODO TYPED +#_(:cljs (defn bit-count "Counts the number of bits set in n" {:from 'cljs.core} [v] - (let [v (- v (bit-and (bit-shift-right v 1) 0x55555555)) - v (+ (bit-and v 0x33333333) (bit-and (bit-shift-right v 2) 0x33333333))] - (bit-shift-right (* (bit-and (+ v (bit-shift-right v 4)) 0xF0F0F0F) 0x1010101) 24))) - -(declare bits) - -(defalias ? core/bit-test) + (let [v (- v (and (>> v 1) 0x55555555)) + v (+ (and v 0x33333333) (and (>> v 2) 0x33333333))] + (>> (* (and (+ v (>> v 4)) 0xF0F0F0F) 0x1010101) 24)))) ;; ===== Bulk bit-operations ===== ;; -(defn ?-coll - "Returns true or false for the bit at the given index of the collection." - [bits i] - (? (bits (>> i 6)) (and i 0x3f))) - -(defn bits - "The bits of x, aggregated into a vector and truncated/extended to length n." +;; TODO TYPED +#_(defnt >bits + "The bits of ->`x`, aggregated into a vector and truncated/extended to length ->`n`." {:adapted-from 'gloss.data.primitives} - [x n] - (mapv #(if (pos? (and (<< 1 %) x)) 1 0) (range n))) - -(bits 1 64) - -(defn truncate - "Truncates x to the specified number of bits." + [x , n length?] + (->> (range n) + (mapv (fnt [] (if (pos? (and (<< 1 %) x)) + bit-true + bit-false))))) + +;; TODO TYPED +#_(defnt test*-coll + "Returns true or false for the bit at the given index ->`i` of ->`xs`." + [xs (t/of bit-like?), i index?] + (? (>bits (>> i 6)) (and i 0x3f))) + +;; TODO TYPED +#_(defn truncate + "Truncates ->`x` to the specified number of bits." {:adapted-from 'bigml.sketchy.murmur} [#?(:clj ^long x :cljs x) #?(:clj ^long n :cljs n)] @@ -331,23 +328,62 @@ ;; ====== Endianness reversal ====== ;; -; TODO DEPS +;; TODO implement based on https://github.com/ztellman/primitive-math/blob/master/src/primitive_math/Primitives.java #_(:clj -(defnt reverse - (^short [^short x] (Numeric/reverseShort x)) - (^int [^int x] (Numeric/reverseInt x)) - (^long [^long x] (Numeric/reverseLong x)))) +(defnt reverse [x p/primitive? > (t/type x)] ...)) + +;; TODO implement `reverse-bytes` (see related methods in e.g. `Integer` and `Long` classes) +#?(:clj +(defnt bytes>long + "Combines safely-byte-coercible values into a long value." + {:todo #{"Move" + "Implement for CLJS" + "Awaiting `bit/or` variadicity to make slightly cleaner" + "Support anything safely-byte-coercible, not just direct bytes"}} + > p/long? + [b7 p/byte?, b6 p/byte?, b5 p/byte?, b4 p/byte? + b3 p/byte?, b2 p/byte?, b1 p/byte?, b0 p/byte?] + (-> (<< (>long b7) 56) + (or (<< (and (>long b6) 0xff) 48)) + (or (<< (and (>long b5) 0xff) 40)) + (or (<< (and (>long b4) 0xff) 32)) + (or (<< (and (>long b3) 0xff) 24)) + (or (<< (and (>long b2) 0xff) 16)) + (or (<< (and (>long b1) 0xff) 8)) + (or (and (>long b0) 0xff))))) + +;; ===== Bit sets ===== ;; +;; May be thought of as a map from bit-index / non-negative integer to boolean, or as a set of +;; bit-indices / non-negative integers. + +(def bit-set? #?(:clj p/integral? :cljs p/double?)) + +(var/def empty + "For bit set purposes. + We choose the default bit set size to be `long` in CLJ and `number` (i.e. `double`) in CLJS to + give it the maximum size possible for a primitive bit set." + 0) + +;; TODO TYPED variadic, expressions #_(:clj -(defnt' make-long - "Combines byte values into a long value." - [^byte b7 ^byte b6 ^byte b5 ^byte b4 - ^byte b3 ^byte b2 ^byte b1 ^byte b0] - (bit-or (<< (long b7) 56) - (<< (and (long b6) 0xff) 48) - (<< (and (long b5) 0xff) 40) - (<< (and (long b4) 0xff) 32) - (<< (and (long b3) 0xff) 24) - (<< (and (long b2) 0xff) 16) - (<< (and (long b1) 0xff) 8) - (and (long b0) 0xff)))) +(defnt conj + "For bit set purposes." + {:todo #{"Implement variadic arity" + "Implement for CLJS" + ""}} + ([] empty) + ([v #?(:clj p/long? :cljs p/double?)] (conj empty v)) + ([xs bit-set?, v0 bit-set-value?] (bit-set-true* xs v0)) + ([xs bit-set?, v0 bit-set-value?, v1 bit-set-value?] (-> xs (conj v0) (conj v1))) +#_([xs bit-set?, v0 bit-set-value?, v1 bit-set-value? & vs (t/of bit-set-value?)] ...))) + +;; TODO TYPED `numerically-integer?`, expressions +#_(defnt contains? + "Tests if the bit set ->`xs` contains the value ->`v`." + > p/boolean? + ([xs p/byte? , v (t/and t/numerically-integer? (<= 0 % (>bit-size ...))] (bit-true?* xs v)) + ([xs p/short?, v (t/and t/numerically-integer? (<= 0 % (>bit-size ...)))] (bit-true?* xs v)) + ([xs p/char? , v (t/and t/numerically-integer? (<= 0 % (>bit-size ...)))] (bit-true?* xs v)) + ([xs p/int? , v (t/and t/numerically-integer? (<= 0 % (>bit-size ...)))] (bit-true?* xs v)) + ([xs p/long? , v (t/and t/numerically-integer? (<= 0 % (>bit-size ...)))] (bit-true?* xs v))) From 8db4f7df2e226f836354a1ee5a783ad5642f8aeb Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 17 Sep 2018 01:54:44 -0600 Subject: [PATCH 273/810] Temporarily (?) add some basic predicates to core.type --- src/quantum/core/type.cljc | 33 ++++++++++++++++++++++++++++++++- 1 file changed, 32 insertions(+), 1 deletion(-) diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index 9d61ede9..9e38875e 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -14,11 +14,12 @@ (defaliases ut ;; Generators - ? * isa? fn ref + ? * isa? fn ref value ;; Combinators and or - ;; Predicates any? + nil? none? ref? fn? @@ -27,3 +28,33 @@ symbol? var? with-metable?) + + +;; TODO TYPED move +#_(defnt ^boolean nil? + ([^Object x] (quantum.core.Numeric/isNil x)) + ([:else x] false)) + +;; TODO TYPED move +#_(:clj (defalias nil? core/nil?)) + +;; TODO TYPED move +#_(defnt ^boolean not' + ([^boolean? x] (Numeric/not x)) + ([x] (if (nil? x) true))) ; Lisp nil punning + +;; TODO TYPED move +#_(defnt ^boolean true? + ([^boolean? x] x) + ([:else x] false)) + +;; TODO TYPED move +#_(:clj (defalias true? core/true?)) + +;; TODO TYPED move +#_(defnt ^boolean false? + ([^boolean? x] (not' x)) + ([:else x] false)) + +;; TODO TYPED move +#_(:clj (defalias false? core/false?)) From fe277868defcb291369c75d587473b8aa3620724 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 17 Sep 2018 01:54:58 -0600 Subject: [PATCH 274/810] `quantum.core.convert.primitive` -> `quantum.core.data.primitive` --- src/quantum/core/convert/primitive.cljc | 254 --------------------- src/quantum/core/data/primitive.cljc | 279 ++++++++++++++++++++++-- 2 files changed, 260 insertions(+), 273 deletions(-) delete mode 100644 src/quantum/core/convert/primitive.cljc diff --git a/src/quantum/core/convert/primitive.cljc b/src/quantum/core/convert/primitive.cljc deleted file mode 100644 index 0952fc24..00000000 --- a/src/quantum/core/convert/primitive.cljc +++ /dev/null @@ -1,254 +0,0 @@ -(ns quantum.core.convert.primitive - (:require - #?(:cljs [com.gfredericks.goog.math.Integer :as int]) - [clojure.core :as core] - [quantum.core.data.bits :as bits - :refer [&&]] - [quantum.core.data.primitive :as p] - [quantum.core.type :as t - :refer [defnt]] - [quantum.core.vars :as var - :refer [defalias]]) -#?(:cljs (:require-macros - [quantum.core.convert.primitive])) -#?(:clj (:import - [java.nio ByteBuffer] - [quantum.core Numeric Primitive]))) - -; TODO go back over these — there are inconsistencies - -;; ===== Long ===== ;; - -#?(:clj -(defmacro long-out-of-range [x] - `(throw (ex-info (str "Value out of range for long: " ~x) {:type :illegal-argument})))) - -#?(:clj -(defnt >long* - {:source "clojure.lang.RT.uncheckedLongCast"} - > p/long? - ([x (t/- p/primitive? p/boolean?)] (Primitive/uncheckedLongCast x)) - ([x (t/ref (t/isa? Number))] (.longValue x))))) - -#?(:clj - (defnt >long - {:source "clojure.lang.RT.longCast"} - > p/long? - ([x (t/isa? clojure.lang.BigInt)] - (if (nil? (.bipart x)) - (.lpart x) - (long-out-of-range x))) - ([x (t/isa? java.math.BigInteger)] - (if (< (.bitLength x) 64) - (.longValue x) - (long-out-of-range x))) - ([x dnum/ratio?] (->long (.bigIntegerValue x))) - ([x (t/or p/char? p/byte? p/short? p/int? p/long?)] (>long* x)) - ([x p/float?] (clojure.lang.RT/longCast x)) ; Because primitive casting in Clojure is not supported ; TODO fix - ([x p/double?] (clojure.lang.RT/longCast x)) ; TODO fix - ([x p/boolean?] (if x 1 0)) - ([x t/string?] (-> x Long/parseLong >long)) - ([x t/string?, radix p/int?] (Long/parseLong x radix))) - :cljs - (defnt >long > (t/range-of p/long?) - ([x p/double?] (js/Math.trunc x)) - ([x t/string?] (-> x int/fromString >long)) - ([x p/boolean?] (if x 1 0)))) - -#?(:clj -(defmacro cast-via-long [class- x] - `(let [n# (->long ~x)] - (if (or (< n# ~(list '. class- 'MIN_VALUE)) (> n# ~(list '. class- 'MAX_VALUE))) - (throw (ex-info (str ~(str "value out of range for " (name class-) ": ") ~x) - {:type :illegal-argument})) - n#)))) - -;; ===== Boolean ===== ;; - -#?(:clj - (defnt ^boolean ->boolean - {:source "clojure.lang.RT.booleanCast"} - ([^boolean x] x) - ([#{byte char short int long float double Object} x] (.booleanValue (not= x nil)))) ; TODO #{(- prim? boolean) Object} - :cljs (defalias ->boolean core/boolean)) - -;; ===== Byte ===== ;; - -#?(:clj - (defnt ^byte ->byte - {:source "clojure.lang.RT.byteCast"} - ([^byte x] x) - ([#{short int long float double} x] (clojure.lang.RT/byteCast x)) - ([#{boolean} x] (-> x ->long ->byte)) - ; TODO do other numbers - ([ x] (clojure.lang.RT/byteCast x))) - :cljs (defalias ->byte core/byte)) - -#?(:clj -(defnt ^byte ->byte* - {:source "clojure.lang.RT.uncheckedByteCast"} - ([^Number x] (.byteValue x)) - ([#{byte short int long float double} x] (Primitive/uncheckedByteCast x)))) - -;; ===== Char ===== ;; - -; TODO reflection issues -; (defnt ^char ->char -; {:source "clojure.lang.RT.charCast"} -; ([^char x] x) -; ([^Character x] (.charValue x)) -; ([#{byte short int long float double} x] (clojure.lang.RT/shortCast x)) -; ([:else x] (cast-via-long Character x))) -#?(:clj (defalias ->char core/char)) - -#?(:clj -(defnt ^char ->char* - {:source "clojure.lang.RT.uncheckedCharCast"} - ([^Number x] (->char* (.longValue x))) - ([#{byte short char int long float double} x] (Primitive/uncheckedCharCast x)) - ([^string? x] (if (->> x .length (= 1)) - (.charAt x 0) - (throw (ex-info "Cannot cast non-singleton string to char." {:string x})))))) - -;; ===== Short ===== ;; - -#?(:clj -(defnt ^short ->short* - {:source "clojure.lang.RT.uncheckedShortCast"} - ([^Number x] (.shortValue x)) - ([#{byte short int long float double} x] (Primitive/uncheckedShortCast x)))) - -#?(:clj - (defnt ^short ->short - {:source "clojure.lang.RT.shortCast"} - ([#{byte short} x] (->short* x)) - ([#{int long float double} x] (clojure.lang.RT/shortCast x)) - ([^string? x] (-> x Short/parseShort ->short)) - ([#{boolean} x] (-> x ->long ->short))) - :cljs (defalias ->short core/short)) - -;; ===== Int ===== ;; - -#?(:clj -(defnt ^int ->int* - {:source "clojure.lang.RT.uncheckedIntCast"} - ([^Number x] (.intValue x)) - ([#{byte short char int long float double} x] (Primitive/uncheckedIntCast x)))) - -; (defnt' ->IntExact -; (^int [^long x] (Math/toIntExact x))) - -#?(:clj - (defnt ^int ->int - {:source "clojure.lang.RT.intCast"} - ([#{char byte short int} x] (->int* x)) - ([#{long double} x] (clojure.lang.RT/intCast x)) - ([^float x] (Float/floatToRawIntBits x)) - ([^string? x] (-> x #?(:clj Integer/parseInt :cljs js/parseInt) ->int)) - ([^string? x radix] (#?(:clj Integer/parseInt :cljs int/fromString) x radix))) - :cljs (defalias ->int core/int)) - -; js/Math.trunc for CLJS - -;; ===== Float ===== ;; - -#?(:clj -(defnt ^float ->float* - {:source "clojure.lang.RT/uncheckedFloatCast"} - ([^Number x] (.floatValue x)) - ([#{byte short int long float double} x] (Primitive/uncheckedFloatCast x)) - ([^string? x] (Float/parseFloat x)))) - -#?(:clj -(defnt ^float ->float - {:source "clojure.lang.RT/floatCast"} - ([#{byte short int float long} x] (->float* x)) - ([^string? x] (Float/parseFloat #_->float* x)))) ; TODO fix this - -; round to float: (js.Math/fround x) - -#?(:clj (defalias ->float core/float)) - -;; ===== Double ===== ;; - -#?(:clj -(defnt ^double ->double* - {:source "clojure.lang.RT/uncheckedDoubleCast"} - ([^Number x] (.doubleValue x)) - ([^double x] x) - ([#{byte short int long float} x] (Primitive/uncheckedDoubleCast x)) - ([ x] (clojure.lang.RT/uncheckedDoubleCast x)))) - -#?(:clj - (defnt ^double ->double - {:source "clojure.lang.RT/doubleCast" - :todo #{"Check for overflow}"}} - ([^Number x] (.doubleValue x)) - ([^double x] x) - ([#{byte short int float} x] (->double* x)) - ([^long x] (->double* x)) ; Double/longBitsToDouble is bad - ([^string? x] (-> x Double/parseDouble ->double))) - :cljs (defalias ->double core/double)) - -#?(:clj -(defnt' ->boxed - (^Boolean ^:intrinsic [^boolean x] (Boolean/valueOf x)) - (^Byte ^:intrinsic [^byte x] (Byte/valueOf x)) - (^Character ^:intrinsic [^char x] (Character/valueOf x)) - (^Short ^:intrinsic [^short x] (Short/valueOf x)) - (^Integer ^:intrinsic [^int x] (Integer/valueOf x)) - (^Long ^:intrinsic [^long x] (Long/valueOf x)) - (^Float ^:intrinsic [^float x] (Float/valueOf x)) - (^Double ^:intrinsic [^double x] (Double/valueOf x)))) - -#?(:clj -(defnt' ->unboxed - (^boolean ^:intrinsic [^Boolean x] (.booleanValue x)) - (^byte ^:intrinsic [^Byte x] (.byteValue x)) - (^char ^:intrinsic [^Character x] (.charValue x)) - (^short ^:intrinsic [^Short x] (.shortValue x)) - (^int ^:intrinsic [^Integer x] (.intValue x)) - (^long ^:intrinsic [^Long x] (.longValue x)) - (^float ^:intrinsic [^Float x] (.floatValue x)) - (^double ^:intrinsic [^Double x] (.doubleValue x)))) - -;; ===== Unsigned ===== ;; - -#?(:clj (def ^:const bytes2 (->short 0xFF))) -#?(:clj (def ^:const bytes4 (->int 0xFFFF))) -#?(:clj (def ^:const bytes8 (->long 0xFFFFFFFF))) - -; (quantum.core.Numeric/bitAnd (->short' bytes2) (->byte 1)) -#?(:clj -(defnt' ->unsigned - {:attribution ["ztellman/primitive-math" "gloss.data.primitives"] - :contributors {"Alex Gunnarson" "defnt-ed"} - :todo #{"change to unchecked-bit-and after making sure it won't overflow"}} - ([^byte x] (&& (->short* bytes2) x)) - ([^short x] (&& (->int* bytes4) x)) - ([^int x] (&& (->long* bytes8) x)) - ([^long x] - (BigInteger. 1 (-> (ByteBuffer/allocate 8) (.putLong x) .array))))) ; TODO reflection - -#?(:clj -(defn ubyte->byte - {:inline (fn [x] `(byte (long ~x)))} - ^long [^long x] - (long (byte x)))) - -#?(:clj -(defn ushort->short - {:inline (fn [x] `(short (long ~x)))} - ^long [^long x] - (long (short x)))) - -#?(:clj -(defn uint->int - {:inline (fn [x] `(int (long ~x)))} - ^long [^long x] - (long (int x)))) - -#?(:clj -(defn ulong->long - ^long [x] - (.longValue ^clojure.lang.BigInt (bigint x)))) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 385a6042..0b69df07 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -1,11 +1,15 @@ (ns quantum.core.data.primitive - (:refer-clojure :exclude - [boolean? char? double? float? int?]) - (:require - [quantum.core.type :as t - :refer [defnt]] - [quantum.core.vars - :refer [def-]])) + (:refer-clojure :exclude + [boolean? char? comparable? decimal? double? float? int? integer?]) + (:require + #?(:cljs [com.gfredericks.goog.math.Integer :as int]) + [quantum.core.type :as t + :refer [defnt]] + [quantum.core.vars + :refer [def-]]) +#?(:clj (:import + [java.nio ByteBuffer] + [quantum.core Numeric Primitive]))) ;; TODO TYPED type coercion/casts should go in here @@ -22,7 +26,17 @@ (def primitive? (t/or boolean? #?@(:clj [byte? short? char? int? long? float?]) double?)) -#?(:clj (def comparable-primitive? (t/- primitive? boolean?))) + ;; Specifically primitive integers + (def integer? (t/or #?@(:clj [byte? short? int? long?]))) + + ;; Specifically primitive decimals + (def decimal? (t/or #?(:clj float?) double?)) + + ;; Specifically primitive integrals + (def integral? (t/or integer? char?)) + + ;; Specifically comparable primitives + (def comparable? (t/- primitive? boolean?)) ;; ===== Class relationships ===== ;; @@ -51,7 +65,7 @@ ;; ===== Extreme magnitudes and values ===== ;; -(defnt >min-magnitude +(defnt ^:inline >min-magnitude #?(:clj ([x byte? > byte?] (byte 0))) #?(:clj ([x short? > short?] (short 0))) #?(:clj ([x char? > char?] (char 0))) @@ -65,7 +79,7 @@ (def- min-double (- #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) ;; TODO TYPED for some reason it's not figuring out the type of `min-float` and `min-double` -#_(defnt >min-value +#_(defnt ^:inline >min-value #?(:clj ([x byte? > byte?] Byte/MIN_VALUE)) #?(:clj ([x short? > short?] Short/MIN_VALUE)) #?(:clj ([x char? > char?] Character/MIN_VALUE)) @@ -74,12 +88,239 @@ #?(:clj ([x float? > float?] min-float)) ([x double? > double?] min-double)) -(defnt >max-value - #?(:clj ([x byte? > byte?] Byte/MAX_VALUE)) - #?(:clj ([x short? > short?] Short/MAX_VALUE)) - #?(:clj ([x char? > char?] Character/MAX_VALUE)) - #?(:clj ([x int? > int?] Integer/MAX_VALUE)) - #?(:clj ([x long? > long?] Long/MAX_VALUE)) - #?(:clj ([x float? > float?] Float/MAX_VALUE)) - ([x double? > double?] #?(:clj Double/MAX_VALUE - :cljs js/Number.MAX_VALUE))) +(defnt ^:inline >max-value + #?@(:clj [([x byte? > byte?] Byte/MAX_VALUE) + ([x short? > short?] Short/MAX_VALUE) + ([x char? > char?] Character/MAX_VALUE) + ([x int? > int?] Integer/MAX_VALUE) + ([x long? > long?] Long/MAX_VALUE) + ([x float? > float?] Float/MAX_VALUE)]) + ([x double? > double?] #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) + +;; ===== Primitive type properties ===== ;; + +(defnt ^:inline signed? + ([x (t/or char? (t/value Character))] false) +#?@(:clj [([x (t/or byte? (t/value Byte) + short? (t/value Short) + int? (t/value Integer) + long? (t/value Long) + float? (t/value Float) + double? #?(:clj Double :cljs js/Number))] true))) + +;; TODO TYPED `t/numerically-integer?` +(defnt ^:inline >bit-size ; > t/numerically-integer? + ([x (t/or boolean? (t/value #?(:clj Boolean :cljs js/Boolean)))] 1) ; kind of +#?@(:clj [([x (t/or byte? (t/value Byte))] 8) + ([x (t/or short? (t/value Short))] 16) + ([x (t/or char? (t/value Character))] 16) + ([x (t/or int? (t/value Integer))] 32) + ([x (t/or long? (t/value Long))] 64) + ([x (t/or float? (t/value Float))] 32)]) + ([x (t/or double? #?(:clj Double :cljs js/Number))] 64)) + +;; ===== Conversion ===== ;; + +(def radix? (fnt [x integer?] + (<= #?(:clj Character/MIN_RADIX :cljs 2) x #?(:clj Character/MAX_RADIX :cljs 36))) + +;; ----- Boolean ----- ;; + +(defnt ^:inline >boolean > boolean? + ([x boolean?] x) + ([x (t/value "true")] true) + ([x (t/value "false")] false) ;; For purposes of intrinsics + ([x (t/or long? double?)] (-> x clojure.lang.Numbers/isZero Numeric/not)) + ([x (t/- primitive? boolean? long? double?)] (-> x Numeric/isZero Numeric/not))) + +;; ----- Int ----- ;; +;; Forward-declared so `radix?` coercion to `int` works + +#?(:clj +(defnt ^:inline >int* > int? + "May involve non-out-of-range truncation" + ([x int?] x) ;; For purposes of intrinsics + ([x (t/- primitive? int? boolean?)] (clojure.lang.RT/uncheckedIntCast x)))) + +(defnt ^:inline >int > #?(:clj int? :cljs numerically-int?) + "May involve non-out-of-range truncation" + ([x #?(:clj int? :cljs numerically-int?)] x) +#?(:clj ([x (t/and (t/- primitive? int? boolean?) (range-of int?))] (>int* x)) + :cljs ([x (t/and double? (range-of int?))] (js/Math.round x))) + ([x boolean?] (if x #?(:clj (int 1) :cljs 1) #?(:clj (int 0) :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) (range-of int?))] (>int* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) (range-of int?))] (.intValue x))) +#?(:clj ([x (t/and dnum/ratio? (range-of int?))] (-> x .bigIntegerValue .intValue))) + ([x string?] + #?(:clj (Integer/parseInteger x) + ;; NOTE could use `js/parseInt` but it's very 'unsafe' + :cljs (throw (ex-info "Parsing not implemented" {:string x})))) + ([x string?, radix radix?] + #?(:clj (Integer/parseInteger x (>int radix)) + ;; NOTE could use `js/parseInt` but it's very 'unsafe' + :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) + +; js/Math.trunc for CLJS + +;; ----- Byte ----- ;; + +#?(:clj +(defnt ^:inline >byte* > byte? + "May involve non-out-of-range truncation" + ([x byte?] x) + ([x (t/- primitive? byte? boolean?)] (Primitive/uncheckedByteCast x)))) + +(defnt ^:inline >byte > #?(:clj byte? :cljs numerically-byte?) + "May involve non-out-of-range truncation" + ([x #?(:clj byte? :cljs numerically-byte?)] x) +#?(:clj ([x (t/and (t/- primitive? byte? boolean?) (range-of byte?))] (>byte* x)) + :cljs ([x (t/and double? (range-of byte?))] (js/Math.round x))) + ([x boolean?] (if x #?(:clj (byte 1) :cljs 1) #?(:clj (byte 0) :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) (range-of byte?))] (>byte* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) (range-of byte?))] (.byteValue x))) +#?(:clj ([x (t/and dnum/ratio? (range-of byte?))] (-> x .bigIntegerValue .byteValue))) + ([x string?] + #?(:clj (Byte/parseByte x) + ;; NOTE could use `js/parseInt` but it's very 'unsafe' + :cljs (throw (ex-info "Parsing not implemented" {:string x})))) + ([x string?, radix radix?] + #?(:clj (Byte/parseByte x (>int radix)) + ;; NOTE could use `js/parseInt` but it's very 'unsafe' + :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) + +;; ----- Short ----- ;; + +#?(:clj +(defnt ^:inline >short* > short? + "May involve non-out-of-range truncation" + ([x short?] x) + ([x (t/- primitive? short? boolean?)] (Primitive/uncheckedShortCast x)))) + +#?(:clj +(defnt ^:inline >short > #?(:clj short? :cljs numerically-short?) + "May involve non-out-of-range truncation" + ([x #?(:clj short? :cljs numerically-short?)] x) +#?(:clj ([x (t/and (t/- primitive? short? boolean?) (range-of short?))] (>short* x)) + :cljs ([x (t/and double? (range-of short?))] (js/Math.round x))) + ([x boolean?] (if x #?(:clj (short 1) :cljs 1) #?(:clj (short 0) :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) (range-of short?))] (>short* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) (range-of short?))] (.shortValue x))) +#?(:clj ([x (t/and dnum/ratio? (range-of short?))] (-> x .bigIntegerValue .shortValue))) + ([x string?] + #?(:clj (Short/parseShort x) + ;; NOTE could use `js/parseInt` but it's very 'unsafe' + :cljs (throw (ex-info "Parsing not implemented" {:string x})))) + ([x string?, radix radix?] + #?(:clj (Short/parseShort x (>int radix)) + ;; NOTE could use `js/parseInt` but it's very 'unsafe' + :cljs (throw (ex-info "Parsing not implemented" {:string x})))))) + +;; ----- Char ----- ;; + +#?(:clj +(defnt ^:inline >char* > char? + "May involve non-out-of-range truncation" + ([x char?] x) + ([x (t/- primitive? char? boolean?)] (Primitive/uncheckedCharCast x)))) + +(defnt ^:inline >char > #?(:clj char? :cljs numerically-char?) + "May involve non-out-of-range truncation. + For CLJS, returns not a String of length 1 but a numerically-char Number." + ([x #?(:clj char? :cljs numerically-char?)] x) +#?(:clj ([x (t/and (t/- primitive? char? boolean?) (range-of char?))] (>char* x)) + :cljs ([x (t/and double? (range-of char?))] (js/Math.round x))) + ([x boolean?] (if x #?(:clj (char 1) :cljs 1) #?(:clj (char 0) :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) (range-of char?))] (>char* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) (range-of char?))] (.charValue x))) +#?(:clj ([x (t/and dnum/ratio? (range-of char?))] (-> x .bigIntegerValue .charValue)))) + +;; ----- Long ----- ;; + +#?(:clj +(defnt ^:inline >long* > long? + "May involve non-out-of-range truncation" + ([x long?] x) ;; For purposes of intrinsics + ([x (t/- primitive? long? boolean?)] (clojure.lang.RT/uncheckedLongCast x)))) + +(defnt ^:inline >long > #?(:clj long? :cljs numerically-long?) + "May involve non-out-of-range truncation" + ([x #?(:clj long? :cljs numerically-long?)] x) +#?(:clj ([x (t/and (t/- primitive? long? boolean?) (range-of long?))] (>long* x)) + :cljs ([x double?] (js/Math.round x))) + ([x boolean?] (if x 1 0)) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) + (range-of long?) + ;; This might be faster than `(range-of long?)` + #_(fnt [x ?] (nil? (.bipart x))))] (.lpart x))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) + (range-of long?) + ;; This might be faster than `(range-of long?)` + #_(fnt [x ?] (< (.bitLength x) 64)))] (.longValue x))) +#?(:clj ([x (t/and dnum/ratio? (range-of long?))] (-> x .bigIntegerValue .longValue))) + ([x string?] + #?(:clj (Long/parseLong x) + ;; NOTE could use `js/parseInt` but it's very 'unsafe' + :cljs (throw (ex-info "Parsing not implemented" {:string x})))) + ([x string?, radix radix?] + #?(:clj (Long/parseLong x (>int radix)) + ;; NOTE could use `js/parseInt` but it's very 'unsafe' + :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) + +;; ----- Float ----- ;; + +#?(:clj +(defnt ^:inline >float* > float? + "May involve non-out-of-range truncation" + ([x float?] x) + ([x (t/- primitive? float? boolean?)] (Primitive/uncheckedFloatCast x)))) + +(defnt ^:inline >float > #?(:clj float? :cljs numerically-float?) + "May involve non-out-of-range truncation" + ([x #?(:clj float? :cljs numerically-float?)] x) +#?(:clj ([x (t/and (t/- primitive? float? boolean?) (range-of float?))] (>float* x)) + :cljs ([x (t/and double? (range-of float?)) > (t/assume numerically-float?)] (js.Math/fround x))) + ([x boolean?] (if x #?(:clj (float 1) :cljs 1) #?(:clj (float 0) :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) (range-of float?))] (>float* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) (range-of float?))] (.floatValue x))) +#?(:clj ([x (t/and dnum/ratio? (range-of float?))] (-> x .bigIntegerValue .floatValue))) + ([x string?] + #?(:clj (Float/parseFloat x) + ;; NOTE could use `js/parseFloat` but it's very 'unsafe' + :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) + +;; ----- Double ----- ;; + +#?(:clj +(defnt ^:inline >double* > double? + "May involve non-out-of-range truncation" + ([x double?] x) ;; For purposes of intrinsics + ([x (t/- primitive? double? boolean?)] (clojure.lang.RT/uncheckedDoubleCast x)))) + + +(defnt ^:inline >double > double? + "May involve non-out-of-range truncation" + ([x double?] x) +#?(:clj ([x (t/and (t/- primitive? double? boolean?) (range-of double?))] (>double* x))) + ([x boolean?] (if x #?(:clj (double 1) :cljs 1) #?(:clj (double 0) :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) (range-of double?))] (>double* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) (range-of double?))] (.doubleValue x))) +#?(:clj ([x (t/and dnum/ratio? (range-of double?))] (-> x .bigIntegerValue .doubleValue))) + ([x string?] + #?(:clj (Double/parseDouble x) + ;; NOTE could use `js/parseFloat` but it's very 'unsafe' + :cljs (throw (ex-info "Parsing not implemented" {:string x})))))) + +;; ===== Unsigned ===== ;; + +#?(:clj +(defnt >unsigned + {:adapted-from #{'ztellman/primitive-math 'gloss.data.primitives}} + ([x byte?] (Numeric/bitAnd (short 0xFF) x)) + ([x short?] (Numeric/bitAnd (int 0xFFFF) x)) + ([x int?] (Numeric/bitAnd (long 0xFFFFFFFF) x)) + ([x long?] (BigInteger. 1 (-> (ByteBuffer/allocate 8) (.putLong x) .array))))) ; TODO reflection + +#?(:clj (defnt ubyte>byte [x long? > long?] (>long (>byte x)))) +#?(:clj (defnt ushort>short [x long? > long?] (>long (>short x)))) +#?(:clj (defnt uint>int [x long? > long?] (>long (>int x)))) +#?(:clj (defnt ulong>long [x bigint? > long?] (>long (>bigint x)))) From 7d191394ed84d35d28a4b0ffed34bbcea3ef8e67 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 17 Sep 2018 02:10:53 -0600 Subject: [PATCH 275/810] Remove references to `[quantum.core.convert.primitive` --- resources-dev/defnt.cljc | 7 ++- src/quantum/audio/midi.clj | 4 +- src/quantum/compile/transpile/from/java.cljc | 4 +- src/quantum/core/collections/core.cljc | 47 ++++++++-------- src/quantum/core/compare.cljc | 2 - src/quantum/core/compare/core.cljc | 29 +++++----- src/quantum/core/convert.cljc | 1 - src/quantum/core/data/hex.cljc | 9 ++-- src/quantum/core/data/primitive.cljc | 2 +- src/quantum/core/numeric.cljc | 24 ++++----- src/quantum/core/numeric/truncate.cljc | 5 +- src/quantum/core/time/core.cljc | 36 ++++++------- src/quantum/db/datomic/core.cljc | 7 ++- src/quantum/numeric/tensors.cljc | 16 +++--- src/quantum/validate/specs.cljc | 1 - test/quantum/test/core/convert/primitive.cljc | 54 ------------------- 16 files changed, 94 insertions(+), 154 deletions(-) delete mode 100644 test/quantum/test/core/convert/primitive.cljc diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 12dea4d5..abfb7d2e 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -4,6 +4,8 @@ >boolean is different than `truthy?` +Sometimes you want (byte ) to fail at runtime rather than fail at runtime when you can't know everything + #_" LEFT OFF LAST TIME (9/3/2018): @@ -80,7 +82,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - quantum.core.error - quantum.core.data.string — this is where `>str` belongs - - quantum.core.convert.primitive - quantum.core.data.collections - quantum.core.data.tuple @@ -110,14 +111,16 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - quantum.core.reducers.reduce - quantum.core.collections.logic - quantum.core.collections.core + - Worked through all we can for now: - quantum.core.core - TODO delete this namespace? - - quantum.core.data.primitive + - quantum.core.data.primitive (TODO make it compile) - quantum.core.ns - quantum.core.vars - quantum.core.data.map - quantum.core.data.bits + - quantum.core.convert.primitive - List of corresponding untyped namespaces to incorporate: - [ ] quantum.untyped.core.core - [ ] quantum.untyped.core.ns diff --git a/src/quantum/audio/midi.clj b/src/quantum/audio/midi.clj index 57550a31..4995f8e0 100644 --- a/src/quantum/audio/midi.clj +++ b/src/quantum/audio/midi.clj @@ -4,6 +4,7 @@ (:require [clojure.core.match :refer [match]] + [quantum.core.data.primitive :as p] [quantum.core.fn :refer [<- fn-> fn->> fn1 fnl]] [quantum.core.logic @@ -25,7 +26,6 @@ [quantum.core.log :as log] [quantum.core.resources :as res] [quantum.core.string :as str] - [quantum.core.convert.primitive :as pconv] [quantum.core.convert :as conv] [quantum.measure.convert :refer [convert]] @@ -205,7 +205,7 @@ {:instrument (-> label str/trim) :expr-0 (-> expr-0 str/trim) :measures measures - :octave (-> octave str/trim pconv/->int)}))) + :octave (-> octave str/trim p/>int)}))) join) _ (dotimes [i-measure num-all-measures] (let [count-this-measure (fn [line] diff --git a/src/quantum/compile/transpile/from/java.cljc b/src/quantum/compile/transpile/from/java.cljc index e648beaf..ca73ab09 100644 --- a/src/quantum/compile/transpile/from/java.cljc +++ b/src/quantum/compile/transpile/from/java.cljc @@ -10,7 +10,7 @@ containsv? popl popr kw-map contains?]] [quantum.core.convert :as conv :refer [->name] ] - [quantum.core.convert.primitive :as pconv] + [quantum.core.data.primitive :as p] [quantum.core.error :as err :refer [>ex-info] ] [quantum.core.macros :as macros @@ -372,7 +372,7 @@ ([^StringLiteralExpr x] (-> x .getValue)) ([^LongLiteralExpr x] - `(~'long ~(->> x .getValue popr pconv/->long))) + `(~'long ~(->> x .getValue popr p/>long))) ([^BooleanLiteralExpr x] (-> x .getValue)) ([^IntegerLiteralExpr x] diff --git a/src/quantum/core/collections/core.cljc b/src/quantum/core/collections/core.cljc index fde541d3..cc5c4d96 100644 --- a/src/quantum/core/collections/core.cljc +++ b/src/quantum/core/collections/core.cljc @@ -10,23 +10,22 @@ #?(:clj [seqspert.vector]) #?(:clj [clojure.core.async :as casync]) [quantum.core.log :as log] - [quantum.core.convert.primitive :as pconvert - :refer [->boolean - ->byte - #?(:clj ->char) - ->short - ->int - ->long - #?(:clj ->float) - ->double - #?@(:clj [->byte* - ->char* - ->short* - ->int* - ->long* - ->float* - ->double*])]] - [quantum.core.data.primitive :as p] + [quantum.core.data.primitive :as p + :refer [>boolean + >byte + >short + #?(:clj >char) + >int + >long + #?(:clj >float) + >double + #?@(:clj [>byte* + >short* + >char* + >int* + >long* + >float* + >double*])]] [quantum.core.data.string :refer [!str]] [quantum.core.data.vector :as vec @@ -576,13 +575,13 @@ (defnt empty {:todo #{"implement core/empty"}} ( [^boolean x] false ) - #?(:clj ( [^char x] (->char 0) )) - #?(:clj ( [^byte x] (->byte 0) )) - #?(:clj ( [^short x] (->short 0) )) - #?(:clj ( [^int x] (->int 0) )) - #?(:clj ( [^long x] (->long 0) )) - #?(:clj ( [^float x] (->float 0) )) - #?(:clj ( [^double x] (->double 0) )) + #?(:clj ( [^char x] (>char 0) )) + #?(:clj ( [^byte x] (>byte 0) )) + #?(:clj ( [^short x] (>short 0) )) + #?(:clj ( [^int x] (>int 0) )) + #?(:clj ( [^long x] (>long 0) )) + #?(:clj ( [^float x] (>float 0) )) + #?(:clj ( [^double x] (>double 0) )) #?(:cljs (^<0> [^pnum? x] 0 )) (^<0> [^string? x] "" ) ; TODO ^array? diff --git a/src/quantum/core/compare.cljc b/src/quantum/core/compare.cljc index f69c17d4..598fc90d 100644 --- a/src/quantum/core/compare.cljc +++ b/src/quantum/core/compare.cljc @@ -9,8 +9,6 @@ [quantum.core.collections.core :as ccoll :refer [conj?! ?persistent! ?transient!, first, join]] [quantum.core.compare.core :as ccomp] - [quantum.core.convert.primitive :as pconv - :refer [->boxed ->boolean ->long]] [quantum.core.error :as err :refer [TODO]] [quantum.core.fn :as fn diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index 31fd321c..182e7912 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -17,9 +17,8 @@ :refer [neg? pos? zero?]] [quantum.core.numeric.convert :refer [->num ->num&]] - [quantum.core.convert.primitive :as pconv - :refer [->boxed ->boolean ->long]] - [quantum.core.data.numeric :as dnum]) + [quantum.core.data.numeric :as dnum] + [quantum.core.data.primitive :as p]) #?(:cljs (:require-macros [quantum.core.compare.core :as self @@ -59,7 +58,7 @@ (loop [i 0] (if (== i len) ; TODO = ? (- alen blen) - (let [x (pconv/->long-protocol (- (->num (aget a i)) (->num (aget b i))))] ; TODO remove protocol + (let [x (p/>long (- (->num (aget a i)) (->num (aget b i))))] ; TODO remove protocol (if (zero? x) (recur (core/inc i)) x)))))))) @@ -68,7 +67,7 @@ {:todo #{"Handle nil values"}} ([^Comparable a ^Comparable b] (int (.compareTo a b))) ([^Comparable a ^prim? b] (int (.compareTo a b))) - ([^prim? a ^Comparable b] (int (.compareTo (->boxed a) b))) + ([^prim? a ^Comparable b] (int (.compareTo (p/>boxed a) b))) ([^array-1d? a ^array-1d? b] (compare-1d-arrays-lexicographically a b))) :cljs (defalias compare core/compare)) @@ -78,8 +77,8 @@ ([#{byte char short int long float double} x #{byte char short int long float double} y] (Numeric/eq x y)) ([^boolean x ^boolean y] (Numeric/eq x y)) - ([^boolean x #{byte char short int long float double} y] (->boolean false)) - ([#{byte char short int long float double} x ^boolean y] (->boolean false)) + ([^boolean x #{byte char short int long float double} y] false) + ([#{byte char short int long float double} x ^boolean y] false) ([ x y] (.equals ^Object x y)) ([ x ^prim? y] (.equals ^Object x y)) ([^prim? x y] (.equals ^Object y x))) @@ -102,7 +101,7 @@ ; ===== `<` ===== ; #?(:clj (defnt' ^boolean <-bin - ([#{byte char short int long float double} x] (->boolean true)) + ([#{byte char short int long float double} x] true) ([#{byte char short int long float double} x #{byte char short int long float double} y] (Numeric/lt x y)) ; TODO numbers, but not nil @@ -115,7 +114,7 @@ ; ----- `comp<` ----- ; #?(:clj (defnt' ^boolean comp<-bin - ([^comparable? x] (->boolean true)) + ([^comparable? x] true) ([#{byte char short int long float double} x #{byte char short int long float double} y] (< x y)) ([^boolean x ^boolean y] (< (->num& x) (->num& y))) @@ -135,7 +134,7 @@ ; ===== `<=` ===== ; #?(:clj (defnt' ^boolean <=-bin - ([#{byte char short int long float double} x] (->boolean true)) + ([#{byte char short int long float double} x] true) ([#{byte char short int long float double} x #{byte char short int long float double} y] (Numeric/lte x y)) ; TODO numbers, but not nil @@ -148,7 +147,7 @@ ; ----- `comp<=` ----- ; #?(:clj (defnt' ^boolean comp<=-bin - ([^comparable? x] (->boolean true)) + ([^comparable? x] true) ([#{byte char short int long float double} x #{byte char short int long float double} y] (<= x y)) ([^boolean x ^boolean y] (<= (->num& x) (->num& y))) @@ -168,7 +167,7 @@ ; ===== `>` ===== ; #?(:clj (defnt' ^boolean >-bin - ([#{byte char short int long float double} x] (->boolean true)) + ([#{byte char short int long float double} x] true) ([#{byte char short int long float double} x #{byte char short int long float double} y] (Numeric/gt x y)) ; TODO numbers, but not nil @@ -181,7 +180,7 @@ ; ----- `comp>` ----- ; #?(:clj (defnt' ^boolean comp>-bin - ([^comparable? x] (->boolean true)) + ([^comparable? x] true) ([#{byte char short int long float double} x #{byte char short int long float double} y] (> x y)) ([^boolean x ^boolean y] (> (->num& x) (->num& y))) @@ -201,7 +200,7 @@ ; ===== `>=` ===== ; #?(:clj (defnt' ^boolean >=-bin - ([#{byte char short int long float double} x] (->boolean true)) + ([#{byte char short int long float double} x] true) ([#{byte char short int long float double} x #{byte char short int long float double} y] (Numeric/gte x y)) ; TODO numbers, but not nil @@ -214,7 +213,7 @@ ; ----- `comp>=` ----- ; #?(:clj (defnt' ^boolean comp>=-bin - ([^comparable? x] (->boolean true)) + ([^comparable? x] true) ([#{byte char short int long float double} x #{byte char short int long float double} y] (>= x y)) ([^boolean x ^boolean y] (>= (->num& x) (->num& y))) diff --git a/src/quantum/core/convert.cljc b/src/quantum/core/convert.cljc index 94a0d373..0b0f1e4c 100644 --- a/src/quantum/core/convert.cljc +++ b/src/quantum/core/convert.cljc @@ -29,7 +29,6 @@ [quantum.core.collections.core :refer [lasti]] [quantum.core.convert.core :as conv] - [quantum.core.convert.primitive :as pconv] [quantum.core.data.complex.json :as json] [quantum.core.macros :as macros :refer [defnt #?(:clj defnt')]] diff --git a/src/quantum/core/data/hex.cljc b/src/quantum/core/data/hex.cljc index d30a8640..ef437aa6 100644 --- a/src/quantum/core/data/hex.cljc +++ b/src/quantum/core/data/hex.cljc @@ -3,10 +3,10 @@ :attribution "alexandergunnarson"} quantum.core.data.hex (:require + [quantum.core.data.primitive + :refer [>int]] [quantum.core.macros :as macros :refer [defnt]] - [quantum.core.convert.primitive :as pconvert - :refer [->int ->byte*]] [quantum.core.string :as str])) (defnt ^String ->hex-string @@ -16,7 +16,7 @@ #?(:cljs ([^pnumber? x] (.toString x 16))) #?(:clj ([^int? x] (Integer/toHexString x))) #?(:clj ([^char? x] - (let [^String s (->hex-string (->int x))] + (let [^String s (->hex-string (>int x))] (.substring s 0 4)))) #?(:clj ([^byte? x] (let [^String hs (->hex-string (+ 256 (long x))) @@ -27,7 +27,7 @@ #?(:clj ([^bytes? bs] (->hex-string bs " "))) #?(:clj ([^bytes? bs separator] - (str/join separator (map (fn [x] (->hex-string (->byte* ^Byte x))) bs)))) + (str/join separator (map (fn [x] (->hex-string (>byte x))) bs)))) #_([:else n zero-pad-length] (text/pad-left (->hex-string n) zero-pad-length "0"))) @@ -45,4 +45,3 @@ (bit-and 0x0F (long (Character/getNumericValue (.charAt x (int (+ (* 2 i) 1)))))))))) res) :cljs (-> x js/goog.crypt.hexToByteArray js/Uint8Array.)))) - diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 0b69df07..dedec6b1 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -11,7 +11,7 @@ [java.nio ByteBuffer] [quantum.core Numeric Primitive]))) -;; TODO TYPED type coercion/casts should go in here +;; TODO TYPED `>boxed` and `>unboxed` ;; ===== Predicates ===== ;; diff --git a/src/quantum/core/numeric.cljc b/src/quantum/core/numeric.cljc index c846af69..0be48632 100644 --- a/src/quantum/core/numeric.cljc +++ b/src/quantum/core/numeric.cljc @@ -10,9 +10,9 @@ [clojure.core :as c] #?@(:cljs [[com.gfredericks.goog.math.Integer :as int]]) - [quantum.core.convert.primitive :as pconvert - :refer [#?(:clj ->long)]] [quantum.core.data.numeric :as dnum] + [quantum.core.data.primitive + :refer [#?(:clj >long)]] [quantum.core.error :as err :refer [>err err! TODO]] [quantum.core.fn @@ -234,16 +234,16 @@ :cljs (defonce ONE int/ONE )) ; For units -(defonce ^:const ten (#?(:clj ->long :cljs int) 10 )) -(defonce ^:const hundred (#?(:clj ->long :cljs int) 100 )) -(defonce ^:const thousand (#?(:clj ->long :cljs int) 1000 )) -(defonce ^:const ten-thousand (#?(:clj ->long :cljs int) 10000 )) -(defonce ^:const hundred-thousand (#?(:clj ->long :cljs int) 100000)) -(defonce ^:const million (#?(:clj ->long :cljs int) 1E6 )) -(defonce ^:const billion (#?(:clj ->long :cljs int) 1E9 )) -(defonce ^:const trillion (#?(:clj ->long :cljs int) 1E12 )) -(defonce ^:const quadrillion (#?(:clj ->long :cljs int) 1E15 )) -(defonce ^:const quintillion (#?(:clj ->long :cljs int) 1E18 )) ; + exa | - atto +(defonce ^:const ten (#?(:clj >long :cljs int) 10 )) +(defonce ^:const hundred (#?(:clj >long :cljs int) 100 )) +(defonce ^:const thousand (#?(:clj >long :cljs int) 1000 )) +(defonce ^:const ten-thousand (#?(:clj >long :cljs int) 10000 )) +(defonce ^:const hundred-thousand (#?(:clj >long :cljs int) 100000)) +(defonce ^:const million (#?(:clj >long :cljs int) 1E6 )) +(defonce ^:const billion (#?(:clj >long :cljs int) 1E9 )) +(defonce ^:const trillion (#?(:clj >long :cljs int) 1E12 )) +(defonce ^:const quadrillion (#?(:clj >long :cljs int) 1E15 )) +(defonce ^:const quintillion (#?(:clj >long :cljs int) 1E18 )) ; + exa | - atto (defonce ^:const sextillion #?(:clj (c/bigint 1E21 ) :cljs 0)) (defonce ^:const septillion #?(:clj (c/bigint 1E24 ) :cljs 0)) (defonce ^:const octillion #?(:clj (c/bigint 1E27 ) :cljs 0)) diff --git a/src/quantum/core/numeric/truncate.cljc b/src/quantum/core/numeric/truncate.cljc index 239b6ef9..dca443f1 100644 --- a/src/quantum/core/numeric/truncate.cljc +++ b/src/quantum/core/numeric/truncate.cljc @@ -8,8 +8,7 @@ :refer [defnt #?@(:clj [defnt'])]] [quantum.core.vars :as var :refer [defalias defaliases]] - [quantum.core.convert.primitive - :refer [#?@(:clj [->int ->double])]] + [quantum.core.data.primitive :as p] [quantum.core.numeric.convert :refer [->bigdec]] [quantum.core.compare.core :as ccomp @@ -31,7 +30,7 @@ (^BigDecimal [^BigDecimal x math-context] (.round x math-context)) (^long [#{long ratio?} x] - (round-int (->double x))) ; TODO 0 + (round-int (p/>double x))) ; TODO 0 (^BigDecimal [#{long ratio?} x math-context] (round-int (->bigdec x) math-context))) :cljs (defn round-int [x] (js/Math.round x))) diff --git a/src/quantum/core/time/core.cljc b/src/quantum/core/time/core.cljc index 5c9f9b9c..dd6c4045 100644 --- a/src/quantum/core/time/core.cljc +++ b/src/quantum/core/time/core.cljc @@ -14,8 +14,8 @@ [cljsjs.js-joda-timezone]]) ; For IANA timezone support [quantum.core.collections :as coll :refer [ifor]] - [quantum.core.convert.primitive :as pconv - :refer [->int ->long]] + [quantum.core.data.primitive + :refer [>int >long]] [quantum.core.error :as err :refer [>ex-info TODO throw-unless err!]] [quantum.core.fn :as fn @@ -126,12 +126,12 @@ #?@(:clj [([^long x] x) ([^java.time.Instant x] (-> x (.toEpochMilli))) ([^java.util.Date x] (-> x (.getTime) )) - ([^java.time.LocalDate x] (-> x (.toEpochDay ) (convert :days :millis) ->long)) + ([^java.time.LocalDate x] (-> x (.toEpochDay ) (convert :days :millis) >long)) ([^java.time.LocalDateTime x] (-> x (.toInstant ZoneOffset/UTC) ->epoch-millis)) ([^java.time.ZonedDateTime x] (-> x .toInstant ->epoch-millis)) ([^org.joda.time.DateTime x] (-> x (.getMillis) )) ([^java.util.Calendar x] (-> x (.getTimeInMillis)))] - :cljs [([^number? x] (->long x)) + :cljs [([^number? x] (>long x)) ([^js/Date x] (.getTime x))])) (declare ->local-date-time-protocol) @@ -139,7 +139,7 @@ #?(:clj (defnt ^java.time.Instant ->instant "Coerces to an instantaneous point on an imaginary timeline." - ([#{long? bigint?} x] (-> x ->long (java.time.Instant/ofEpochMilli))) + ([#{long? bigint?} x] (-> x >long (java.time.Instant/ofEpochMilli))) ([x] (-> x ->epoch-millis-protocol ->instant)))) ; ===== DATE ===== ; @@ -154,7 +154,7 @@ (^{:doc "Obtain an instance of LocalDate from a year, month, and dayOfMonth value"} [#?(:cljs ^number? y :clj y) m d] - (#?(:clj LocalDate/of :cljs js/JSJoda.LocalDate.of) (->long y) (->long m) (->long d)))) + (#?(:clj LocalDate/of :cljs js/JSJoda.LocalDate.of) (>long y) (>long m) (>long d)))) #?(:clj (defmacro ->local-date @@ -175,15 +175,15 @@ (^{:doc "Obtain an instance of LocalTime from an hour and minute value"} [#?(:cljs ^number? h :clj h) m] - (#?(:clj LocalTime/of :cljs js/JSJoda.LocalTime.of) (->long h) (->long m))) + (#?(:clj LocalTime/of :cljs js/JSJoda.LocalTime.of) (>long h) (>long m))) (^{:doc "Obtain an instance of LocalTime from an hour, minute, and second value"} [#?(:cljs ^number? h :clj h) m s] - (#?(:clj LocalTime/of :cljs js/JSJoda.LocalTime.of) (->long h) (->long m) (->long s))) + (#?(:clj LocalTime/of :cljs js/JSJoda.LocalTime.of) (>long h) (>long m) (>long s))) (^{:doc "Obtain an instance of LocalTime from an hour, minute, second, and nano value"} [#?(:cljs ^number? h :clj h) m s n] - (#?(:clj LocalTime/of :cljs js/JSJoda.LocalTime.of) (->long h) (->long m) (->long s) (->long n)))) + (#?(:clj LocalTime/of :cljs js/JSJoda.LocalTime.of) (>long h) (>long m) (>long s) (>long n)))) #?(:clj (defmacro ->local-time @@ -205,17 +205,17 @@ [#?(:cljs ^number? y :clj y) mo d h m] (#?(:clj LocalDateTime/of :cljs js/JSJoda.LocalDateTime.of) - (->long y) (->long mo) (->long d) (->long h) (->long m))) + (>long y) (>long mo) (>long d) (>long h) (>long m))) (^{:doc "Obtain an instance of LocalDateTime from a year, month, day, hour, minute, and second value"} [#?(:cljs ^number? y :clj y) mo d h m s] (#?(:clj LocalDateTime/of :cljs js/JSJoda.LocalDateTime.of) - (->long y) (->long mo) (->long d) (->long h) (->long m) (->long s))) + (>long y) (>long mo) (>long d) (>long h) (>long m) (>long s))) (^{:doc "Obtain an instance of LocalDateTime from a year, month, day, hour, minute, second, and nano value"} [#?(:cljs ^number? y :clj y) mo d h m s n] (#?(:clj LocalDateTime/of :cljs js/JSJoda.LocalDateTime.of) - (->long y) (->long mo) (->long d) (->long h) (->long m) (->long s) (->long n) ))) + (>long y) (>long mo) (>long d) (>long h) (>long m) (>long s) (>long n) ))) #?(:clj (defmacro ->local-date-time @@ -246,7 +246,7 @@ [#?(:cljs ^number? y :clj y) mo d h m s n zone] (#?(:clj ZonedDateTime/of :cljs js/JSJoda.ZonedDateTime.of) - (->long y) (->long mo) (->long d) (->long h) (->long m) (->long s) (->long n) (->zone-id zone)))) + (>long y) (>long mo) (>long d) (>long h) (>long m) (>long s) (>long n) (->zone-id zone)))) #?(:clj (defmacro ->zoned-date-time @@ -270,7 +270,7 @@ ([y ] (->period* y 0 0)) ([y mo ] (->period* y mo 0)) ([y mo d] - (#?(:clj Period/of :cljs (TODO)) (->int y) (->int mo) (->int d))))) + (#?(:clj Period/of :cljs (TODO)) (>int y) (>int mo) (>int d))))) ; TODO CLJS #?(:clj (defmacro ->period ([] (case-env :clj `Period/ZERO :cljs (TODO))) @@ -284,13 +284,13 @@ (defnt ^{:tag #?(:clj Duration)} ->duration* ([d ] (#?(:clj Duration/ofDays :cljs (TODO)) d)) ([d h ] (.plus (->duration* d) - (#?(:clj Duration/ofHours :cljs (TODO)) (->long h)))) + (#?(:clj Duration/ofHours :cljs (TODO)) (>long h)))) ([d h m ] (.plus (->duration* d h) - (#?(:clj Duration/ofMinutes :cljs (TODO)) (->long m)))) + (#?(:clj Duration/ofMinutes :cljs (TODO)) (>long m)))) ([d h m s ] (.plus (->duration* d h m) - (#?(:clj Duration/ofSeconds :cljs (TODO)) (->long s)))) + (#?(:clj Duration/ofSeconds :cljs (TODO)) (>long s)))) ([d h m s n] (.plus (->duration* d h m s) - (#?(:clj Duration/ofNanos :cljs (TODO)) (->long n)))))) + (#?(:clj Duration/ofNanos :cljs (TODO)) (>long n)))))) ; TODO CLJS #?(:clj (defmacro ->duration ([] (case-env :clj `Duration/ZERO :cljs (TODO))) diff --git a/src/quantum/db/datomic/core.cljc b/src/quantum/db/datomic/core.cljc index 44d1fe78..3a9fe818 100644 --- a/src/quantum/db/datomic/core.cljc +++ b/src/quantum/db/datomic/core.cljc @@ -17,7 +17,8 @@ [quantum.core.core :as qcore] [quantum.core.async :as async :refer [! >!!]] - [quantum.core.data.primitive :as p] + [quantum.core.data.primitive :as p + :refer [>long]] [quantum.core.data.set :as set] [quantum.core.error :as err :refer [>ex-info >err TODO catch-all]] @@ -29,8 +30,6 @@ [quantum.core.print :as pr] [quantum.core.resources :as res] [quantum.core.process :as proc] - [quantum.core.convert.primitive :as pconv - :refer [->long]] [quantum.core.vars :as var :refer [defalias]] [quantum.core.data.validated :as dv] @@ -342,7 +341,7 @@ dbfn-call?)) ; TODO CLJS |bigdec?| (dv/def -instant (s/or* (fnl instance? #?(:clj java.util.Date :cljs js/Date )) ; TODO time/->instant #?(:clj (s/and string? (s/conformer clojure.instant/read-instant-date))) - (s/and (fn1 t/integer?) (s/conformer #(#?(:clj java.util.Date. :cljs js/Date.) (->long %)))) + (s/and (fn1 t/integer?) (s/conformer #(#?(:clj java.util.Date. :cljs js/Date.) (>long %)))) dbfn-call?)) (dv/def -uri (s/or* (fnl instance? #?(:clj java.net.URI :cljs (TODO) #_paths/URI)) dbfn-call?)) diff --git a/src/quantum/numeric/tensors.cljc b/src/quantum/numeric/tensors.cljc index 8420404c..37e071bd 100644 --- a/src/quantum/numeric/tensors.cljc +++ b/src/quantum/numeric/tensors.cljc @@ -23,8 +23,8 @@ ->objects]] [quantum.core.compare :refer [max]] - [quantum.core.convert.primitive - :refer [->int ->long ->double* ->double]] + [quantum.core.data.primitive + :refer [>int >long >double]] [quantum.core.error :as err :refer [>ex-info TODO]] [quantum.core.fn :as fn @@ -131,9 +131,9 @@ numpy: a[0,1] R: a[1,2]" {:implemented-by '#{smile.math.matrix.Matrix}} - #?(:clj (^double [^RealVector X ^long a ] (->double (real/entry X a )))) + #?(:clj (^double [^RealVector X ^long a ] (>double (real/entry X a )))) ( [ X a ] (TODO)) - #?(:clj (^double [^RealMatrix X ^long a ^long b] (->double (real/entry X a b)))) + #?(:clj (^double [^RealMatrix X ^long a ^long b] (>double (real/entry X a b)))) ( [ X a b] (TODO))) (defnt set-in!* @@ -167,17 +167,17 @@ ([^long m ^long n ] (nat/dge m n)) ([ x ] (nat/dge x)) ([^array-2d? x] - (let [width (-> x c/first ccoll/count& ->long) ; TODO fix where type hints aren't showing up + (let [width (-> x c/first ccoll/count& >long) ; TODO fix where type hints aren't showing up height (c/count x) ret (->dmatrix width height)] (dotimes [i height j width] - (set-in!* ret (-> x (c/get-in* (int i) (int j)) ->double) i j)) ; TODO figure out why `->int` instead of `int` creates verifyerror + (set-in!* ret (-> x (c/get-in* (int i) (int j)) >double) i j)) ; TODO figure out why `>int` instead of `int` creates verifyerror ret)) ([^vector? x] ; TODO lists/seqs are okay too (if (c/empty? x) (->dmatrix 0 0) (let [_ (validate x (fn-> c/first t/sequential?)) - width (-> x c/first c/count ->long) + width (-> x c/first c/count >long) height (c/count x) ret (->dmatrix width height)] (red-fori [row x @@ -185,7 +185,7 @@ ; All rows must be same width (assert (-> row c/count (= width)) (kw-map row width i)) ; TODO cheap `validate` (red-fori [elem row _ nil j] - (set-in!* ret' (->double elem) i j))) + (set-in!* ret' (>double elem) i j))) ret))))) #_"May take either a boxed or unboxed fn: diff --git a/src/quantum/validate/specs.cljc b/src/quantum/validate/specs.cljc index be8f856d..6ecb36de 100644 --- a/src/quantum/validate/specs.cljc +++ b/src/quantum/validate/specs.cljc @@ -15,7 +15,6 @@ :refer [declare-spec]] [quantum.core.spec :as s] [quantum.db.datomic :as db] - [quantum.core.convert.primitive :as pconv] [quantum.core.numeric :as num :refer [percent?]])) diff --git a/test/quantum/test/core/convert/primitive.cljc b/test/quantum/test/core/convert/primitive.cljc deleted file mode 100644 index 87d18c40..00000000 --- a/test/quantum/test/core/convert/primitive.cljc +++ /dev/null @@ -1,54 +0,0 @@ -(ns quantum.test.core.convert.primitive - (:require [quantum.core.convert.primitive :as ns])) - -;_____________________________________________________________________ -;==================={ LONG }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° -(defn test:->long* [x]) -;_____________________________________________________________________ -;==================={ BOOLEAN }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° -(defn test:->boolean [x]) -;_____________________________________________________________________ -;==================={ BYTE }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° -(defn test:->byte [x]) -(defn test:->byte* [x]) -;_____________________________________________________________________ -;==================={ CHAR }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° -(defn test:->char [x]) -(defn test:->char* [x]) -;_____________________________________________________________________ -;==================={ SHORT }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° -(defn test:->short [x]) -(defn test:->short* [x]) -;_____________________________________________________________________ -;==================={ INT }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° -(defn test:->int [x]) -(defn test:->int* [x]) -;_____________________________________________________________________ -;==================={ FLOAT }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° -(defn test:->float [x]) -(defn test:->float* [x]) -;_____________________________________________________________________ -;==================={ DOUBLE }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° -(defn test:->double [x]) -(defn test:->double* [x]) - -(defn test:->boxed [x]) - -(defn test:->unboxed [x]) -;_____________________________________________________________________ -;==================={ UNSIGNED }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° -(defn test:->unsigned [x]) - -(defn test:ubyte->byte [x]) -(defn test:ushort->short [x]) -(defn test:uint->int [x]) -(defn test:ulong->long [x]) \ No newline at end of file From 68d37b84b50a77eecce2b6c189423cf4a9722aaf Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 17 Sep 2018 02:15:12 -0600 Subject: [PATCH 276/810] Add `>boxed` and `>unboxed` --- src/quantum/core/data/primitive.cljc | 26 +++++++++++++++++++++++--- 1 file changed, 23 insertions(+), 3 deletions(-) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index dedec6b1..8abe387b 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -11,8 +11,6 @@ [java.nio ByteBuffer] [quantum.core Numeric Primitive]))) -;; TODO TYPED `>boxed` and `>unboxed` - ;; ===== Predicates ===== ;; #?(:clj (def boolean? (t/isa? #?(:clj Boolean :cljs js/Boolean)))) @@ -38,7 +36,7 @@ ;; Specifically comparable primitives (def comparable? (t/- primitive? boolean?)) -;; ===== Class relationships ===== ;; +;; ===== Boxing/unboxing ===== ;; #?(:clj (def unboxed-class->boxed-class @@ -63,6 +61,28 @@ Double Double/TYPE Void Void/TYPE})) +#?(:clj +(defnt >boxed + ([x boolean? > (t/ref boolean?)] (Boolean/valueOf x)) + ([x byte? > (t/ref byte?)] (Byte/valueOf x)) + ([x char? > (t/ref char?)] (Character/valueOf x)) + ([x short? > (t/ref short?)] (Short/valueOf x)) + ([x int? > (t/ref int?)] (Integer/valueOf x)) + ([x long? > (t/ref long?)] (Long/valueOf x)) + ([x float? > (t/ref float?)] (Float/valueOf x)) + ([x double? > (t/ref double?)] (Double/valueOf x)))) + +#?(:clj +(defnt >unboxed + ([x (t/ref boolean?) > boolean?] (.booleanValue x)) + ([x (t/ref byte?) > byte?] (.byteValue x)) + ([x (t/ref char?) > char?] (.charValue x)) + ([x (t/ref short?) > short?] (.shortValue x)) + ([x (t/ref int?) > int?] (.intValue x)) + ([x (t/ref long?) > long?] (.longValue x)) + ([x (t/ref float?) > float?] (.floatValue x)) + ([x (t/ref double?) > double?] (.doubleValue x)))) + ;; ===== Extreme magnitudes and values ===== ;; (defnt ^:inline >min-magnitude From ec4c562f68bd8aa148e26871d1b9a877beea5a4b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 17 Sep 2018 02:17:34 -0600 Subject: [PATCH 277/810] Cleanup --- src/quantum/core/compare/core.cljc | 2 +- src/quantum/core/convert.cljc | 22 ++++++++++++---------- src/quantum/core/data/primitive.cljc | 4 ++-- 3 files changed, 15 insertions(+), 13 deletions(-) diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index 182e7912..595cff6b 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -67,7 +67,7 @@ {:todo #{"Handle nil values"}} ([^Comparable a ^Comparable b] (int (.compareTo a b))) ([^Comparable a ^prim? b] (int (.compareTo a b))) - ([^prim? a ^Comparable b] (int (.compareTo (p/>boxed a) b))) + ([^prim? a ^Comparable b] (int (.compareTo (p/box a) b))) ([^array-1d? a ^array-1d? b] (compare-1d-arrays-lexicographically a b))) :cljs (defalias compare core/compare)) diff --git a/src/quantum/core/convert.cljc b/src/quantum/core/convert.cljc index 0b0f1e4c..e9315412 100644 --- a/src/quantum/core/convert.cljc +++ b/src/quantum/core/convert.cljc @@ -22,6 +22,7 @@ ; CompilerException java.lang.NoClassDefFoundError: IllegalName: compile__stub.gloss.data.bytes.core.gloss.data.bytes.core/MultiBufferSequence, compiling:(gloss/data/bytes/core.clj:78:1) ; [gloss.core.formats :as gforms] [quantum.core.data.array :as arr] + [quantum.core.data.primitive :as p] [quantum.core.error :as err :refer [TODO]] [quantum.core.numeric :as num] @@ -88,16 +89,17 @@ (log/this-ns) #?(:clj -(defaliases pconv - ->boolean - ->byte* ->byte - ->char* ->short - ->int* ->int - ->long* ->long - ->float* ->float - ->double* ->double - ->boxed ->unboxed ->unsigned - ubyte->byte ushort->short uint->int ulong->long)) +(defaliases p + >boolean + >byte* >byte + >short* >short + >char* >char + >int* >int + >long* >long + >float* >float + >double* >double + box unbox >unsigned + ubyte>byte ushort>short uint>int ulong>long)) (defalias utf8-string conv/utf8-string ) (defalias base64-encode conv/base64-encode) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 8abe387b..83794e17 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -62,7 +62,7 @@ Void Void/TYPE})) #?(:clj -(defnt >boxed +(defnt box ([x boolean? > (t/ref boolean?)] (Boolean/valueOf x)) ([x byte? > (t/ref byte?)] (Byte/valueOf x)) ([x char? > (t/ref char?)] (Character/valueOf x)) @@ -73,7 +73,7 @@ ([x double? > (t/ref double?)] (Double/valueOf x)))) #?(:clj -(defnt >unboxed +(defnt unboxed ([x (t/ref boolean?) > boolean?] (.booleanValue x)) ([x (t/ref byte?) > byte?] (.byteValue x)) ([x (t/ref char?) > char?] (.charValue x)) From 16c7711a43eb2dcadb8ae2be831249fd9919cd29 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 17 Sep 2018 18:54:36 -0600 Subject: [PATCH 278/810] `t/if` --- resources-dev/defnt.cljc | 4 ++++ src-untyped/quantum/untyped/core/data/numeric.cljc | 4 ++-- src-untyped/quantum/untyped/core/type.cljc | 11 +++++++++++ src/quantum/core/type.cljc | 4 ++-- 4 files changed, 19 insertions(+), 4 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index abfb7d2e..7c99dd1e 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -6,6 +6,10 @@ Sometimes you want (byte ) to fail at runtime rather than fail at runtime when you can't know everything +TODO: +- `(or (and pred then) (and (not pred) else))` (which is not correct) +- needs to equal `(t/and (t/or (t/not a) b) (t/or a c))` (which is correct) + #_" LEFT OFF LAST TIME (9/3/2018): diff --git a/src-untyped/quantum/untyped/core/data/numeric.cljc b/src-untyped/quantum/untyped/core/data/numeric.cljc index 4631c3d3..f8d2e5ad 100644 --- a/src-untyped/quantum/untyped/core/data/numeric.cljc +++ b/src-untyped/quantum/untyped/core/data/numeric.cljc @@ -48,7 +48,7 @@ ;; ===== Decimals ===== ;; -#?(:clj (def bigdec? (t/isa? BigDecimal))) ; TODO CLJS may have this +(def bigdec? #?(:clj (t/isa? BigDecimal) :cljs t/none?)) ;; ===== Ratios ===== ;; @@ -86,7 +86,7 @@ ;; ===== General ===== ;; -(def decimal? (or #?(:clj p/float?) p/double? #?(:clj bigdec?))) +(def decimal? (or #?(:clj p/float?) p/double? bigdec?)) ;; ===== Likenesses ===== ;; diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index d9306c0b..e54e5e30 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -147,6 +147,17 @@ (uvar/defalias & and) +;; ----- If ----- ;; + +;; This won't shadow anything because `if` and `def` are non-shadowable +(defns if + "(if a b c) + : (a->b) & (~a->c) + : (~a | b) & (a | c) + : (a & b) | (~a & c)" + [pred utr/type?, then utr/type?, else utr/type? > utr/type?] + (or (and pred then) (and (not pred) else))) + ;; ----- Expression ----- ;; ;; ----- ProtocolType ----- ;; diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index 9e38875e..020aa92e 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -1,7 +1,7 @@ (ns quantum.core.type "This is this the namespace upon which all other fully-typed namespaces rest." (:refer-clojure :exclude - [* - and any? fn fn? isa? or ref seq? symbol? var?]) + [* - and any? fn fn? isa? not or ref seq? symbol? var?]) (:require [quantum.untyped.core.type.defnt :as udefnt] [quantum.untyped.core.type :as ut] @@ -16,7 +16,7 @@ ;; Generators ? * isa? fn ref value ;; Combinators - and or - + and or - if not ;; Predicates any? nil? From b48dca5d9790eb32572b26e638457069e95226d9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 17 Sep 2018 22:23:31 -0600 Subject: [PATCH 279/810] Not every macroexpanded form is a seq --- src-untyped/quantum/untyped/core/analyze.cljc | 139 +++++++++--------- 1 file changed, 69 insertions(+), 70 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 24615e18..b524926e 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -414,7 +414,7 @@ (if (-> body count (not= 1)) (err! "Must supply exactly one input to `throw`; supplied" {:body body}) (let [arg|analyzed (analyze* env arg)] - ;; TODO this is not quite true for CLJS but it's nice at least + ;; TODO this is not quite true for CLJS but it's good practice at least (if-not (-> arg|analyzed :type (t/<= t/throwable?)) (err! "`throw` requires a throwable; received" {:arg arg :type (:type arg|analyzed)}) (uast/throw-node @@ -524,80 +524,79 @@ "Analyze a seq after it has been macro-expanded. The ->`form` is post- incremental macroexpansion." [env ::env, [caller|form _ & body _ :as form] _ > uast/node?] - (ifs (special-symbols caller|form) - (case caller|form - do (analyze-seq|do env form) - let* (analyze-seq|let* env form) - deftype* (TODO "deftype*") - fn* (TODO "fn*") - def (TODO "def") - . (analyze-seq|dot env form) - if (analyze-seq|if env form) - quote (analyze-seq|quote env form) - new (analyze-seq|new env form) - throw (analyze-seq|throw env form)) - (let [caller|node (analyze* env caller|form) - caller|type (:type caller|node) - inputs-ct (count body)] - ;; TODO fix this line of code and extend t/compare so the comparison checks below - ;; will work with t/fn - (case (if (utr/fn-type? caller|type) - -1 - (t/compare caller|type t/callable?)) - (1 2) (err! "It is not known whether form can be called" {:node caller|node}) - 3 (err! "Form cannot be called" {:node caller|node}) - (-1 0) (let [caller-kind - (ifs (utr/fn-type? caller|type) :fnt - (t/<= caller|type t/keyword?) :keyword - (t/<= caller|type t/+map|built-in?) :map - (t/<= caller|type t/+vector|built-in?) :vector - (t/<= caller|type t/+set|built-in?) :set - (t/<= caller|type t/fn?) :fn - ;; If it's callable but not fn, we might have missed something in - ;; this dispatch so for now we throw - (err! "Don't know how how to handle non-fn callable" - {:caller caller|node})) - assert-valid-inputs-ct - (case caller-kind - (:keyword :map) - (when-not (or (= inputs-ct 1) (= inputs-ct 2)) - (err! (str "Keywords and `clojure.core` persistent maps must be " - "provided with exactly one or two inputs when calling " - "them") - {:inputs-ct inputs-ct :caller caller|node})) - - (:vector :set) - (when-not (= inputs-ct 1) - (err! (str "`clojure.core` persistent vectors and `clojure.core` " - "persistent sets must be provided with exactly one " - "input when calling them") - {:inputs-ct inputs-ct :caller caller|node})) - - :fnt - (when-not (-> caller|type utr/fn-type>arities (contains? inputs-ct)) - (err! "Unhandled number of inputs for fnt" - {:inputs-ct inputs-ct :caller caller|node})) - ;; For non-typed fns, unknown; we will have to risk runtime exception - ;; because we can't necessarily rely on metadata to tell us the - ;; whole truth - :fn nil) - {:keys [input-nodes out-type]} - (call>input-nodes+out-type - env caller|node caller|type caller-kind inputs-ct body) - call-node - (uast/call-node - {:env env - :form form - :caller caller|node - :args input-nodes - :type out-type})] - call-node))))) + (case caller|form + do (analyze-seq|do env form) + let* (analyze-seq|let* env form) + deftype* (TODO "deftype*") + fn* (TODO "fn*") + def (TODO "def") + . (analyze-seq|dot env form) + if (analyze-seq|if env form) + quote (analyze-seq|quote env form) + new (analyze-seq|new env form) + throw (analyze-seq|throw env form) + (let [caller|node (analyze* env caller|form) + caller|type (:type caller|node) + inputs-ct (count body)] + ;; TODO fix this line of code and extend t/compare so the comparison checks below + ;; will work with t/fn + (case (if (utr/fn-type? caller|type) + -1 + (t/compare caller|type t/callable?)) + (1 2) (err! "It is not known whether form can be called" {:node caller|node}) + 3 (err! "Form cannot be called" {:node caller|node}) + (-1 0) (let [caller-kind + (ifs (utr/fn-type? caller|type) :fnt + (t/<= caller|type t/keyword?) :keyword + (t/<= caller|type t/+map|built-in?) :map + (t/<= caller|type t/+vector|built-in?) :vector + (t/<= caller|type t/+set|built-in?) :set + (t/<= caller|type t/fn?) :fn + ;; If it's callable but not fn, we might have missed something in + ;; this dispatch so for now we throw + (err! "Don't know how how to handle non-fn callable" + {:caller caller|node})) + assert-valid-inputs-ct + (case caller-kind + (:keyword :map) + (when-not (or (= inputs-ct 1) (= inputs-ct 2)) + (err! (str "Keywords and `clojure.core` persistent maps must be " + "provided with exactly one or two inputs when calling " + "them") + {:inputs-ct inputs-ct :caller caller|node})) + + (:vector :set) + (when-not (= inputs-ct 1) + (err! (str "`clojure.core` persistent vectors and `clojure.core` " + "persistent sets must be provided with exactly one " + "input when calling them") + {:inputs-ct inputs-ct :caller caller|node})) + + :fnt + (when-not (-> caller|type utr/fn-type>arities (contains? inputs-ct)) + (err! "Unhandled number of inputs for fnt" + {:inputs-ct inputs-ct :caller caller|node})) + ;; For non-typed fns, unknown; we will have to risk runtime exception + ;; because we can't necessarily rely on metadata to tell us the + ;; whole truth + :fn nil) + {:keys [input-nodes out-type]} + (call>input-nodes+out-type + env caller|node caller|type caller-kind inputs-ct body) + call-node + (uast/call-node + {:env env + :form form + :caller caller|node + :args input-nodes + :type out-type})] + call-node))))) (defns- analyze-seq [env ::env, form _] (let [expanded-form (ufeval/macroexpand form)] (if (ucomp/== form expanded-form) (analyze-seq* env expanded-form) - (let [expanded (analyze-seq* env expanded-form)] + (let [expanded (analyze* env expanded-form)] (uast/macro-call {:env env :unexpanded-form form From 9d0e03b05625966b0ab99f7f96979128f1e4e14b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 17 Sep 2018 22:25:05 -0600 Subject: [PATCH 280/810] `t/assume` --- src-dev/quantum/core/defnt_equivalences.cljc | 12 ++++++-- src-untyped/quantum/untyped/core/type.cljc | 11 +++++-- .../quantum/untyped/core/type/defnt.cljc | 30 +++++++++---------- 3 files changed, 33 insertions(+), 20 deletions(-) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index f7a92385..fa3d29c8 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -450,7 +450,7 @@ ;; -> (t/- (t/ref (t/isa? Number)) (t/- primitive? boolean?))] (def ~(tag "[Ljava.lang.Object;" '>int*|__1|input0|types) - (*<> ~(with-meta `(t/isa? Number) {:ref? true}))) + (*<> ~(with-meta `(t/isa? Number) {:quantum.core.type/ref? true}))) (def ~'>int*|__1|0 (reify* [Object>int] (~(tag "int" 'invoke) [~'_7__ ~(tag "java.lang.Object" 'x)] @@ -919,7 +919,7 @@ ;; [x (t/ref (t/isa? Number))] (def ~(tag "[Ljava.lang.Object;" '>long*|__1|input0|types) - (*<> ~(with-meta `(t/isa? Number) {:ref? true}))) + (*<> ~(with-meta `(t/isa? Number) {:quantum.core.type/ref? true}))) (def ~'>long*|__1|0 (reify* [Object>long] (~(tag "long" 'invoke) [~'_7__ ~(tag "java.lang.Object" 'x)] @@ -982,6 +982,14 @@ (eval actual) (eval '(do (is (identical? (defnt-reference) 1))))))) +(deftest defnt-assume-test + (throws (eval '(defnt defnt-assume-0 [> (t/assume t/int?)] "asd"))) + (throws (eval '(defnt defnt-assume-1 [> (t/assume t/int?)] nil))) + (is= nil (do (eval '(defnt defnt-assume-2 [> (t/assume t/int?)] (Object.))) + nil)) + (is= nil (do (eval '(defnt defnt-assume-3 [> (t/assume t/int?)] (or (Object.) nil))) + nil))) + (defnt >big-integer > (t/isa? java.math.BigInteger) ([x ratio? > (* (t/isa? java.math.BigInteger))] (.bigIntegerValue x))) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index e54e5e30..fd69c6ed 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -297,17 +297,22 @@ (-def nil? (value nil)) (-def object? (isa? #?(:clj java.lang.Object :cljs js/Object))) -;; ===== Miscellaneous ===== ;; +;; ===== Type metadata ===== ;; + +(defns assume + "Denotes that, whatever the declared output type (to which `assume` is applied) of a function may + be, it is assumed that the output satisfies that type." + [t utr/type? > utr/type?] (update-meta t assoc :quantum.core.type/assume? true)) (defns * "Denote on a type that it must be enforced at runtime. For use with `defnt`." - [t utr/type? > utr/type?] (update-meta t assoc :runtime? true)) + [t utr/type? > utr/type?] (update-meta t assoc :quantum.core.type/runtime? true)) (defns ref "Denote on a type that it must not be expanded to use primitive values. For use with `defnt`." - [t utr/type? > utr/type?] (update-meta t assoc :ref? true)) + [t utr/type? > utr/type?] (update-meta t assoc :quantum.core.type/ref? true)) ;; TODO figure this out #_(do (udt/deftype DeducibleSpec [*spec #_(t/atom-of t/spec?)] diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 32eca502..83966ed9 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -14,6 +14,7 @@ :refer [defns defns- fns]] [quantum.untyped.core.collections :as c :refer [>set >vec]] + [quantum.untyped.core.compare :as ucomp] [quantum.untyped.core.data :refer [kw-map]] [quantum.untyped.core.data.array :as uarr] @@ -222,7 +223,7 @@ [arg-types (s/seq-of t/type?) > (s/seq-of ::expanded-overload|arg-classes)] (->> arg-types (c/lmap (fn [t #_t/type?] - (if (-> t meta :ref?) + (if (-> t meta :quantum.type.core/ref?) (-> t t/type>classes (disj nil) seq) (let [cs (type>most-primitive-classes t) base-classes @@ -262,21 +263,20 @@ lang (c/count arg-bindings) varargs))) - post-type|runtime? (-> post-type meta :runtime?) + post-type|runtime? (-> post-type meta :quantum.core.type/runtime?) + post-type|assume? (-> post-type meta :quantum.core.type/assume?) + err-info {:form (:form analyzed) + :type (:type analyzed) + :declared-output-type post-type} out-type (if post-type - (if post-type|runtime? - (case (t/compare post-type (:type analyzed)) - -1 post-type - 1 (:type analyzed) - 0 post-type - (2 3) (err! "Body and output type comparison not handled" - {:body analyzed :output-type post-type})) - (if (t/<= (:type analyzed) post-type) - (:type analyzed) - (err! "Body type does not match declared output type" - {:form (:form analyzed) - :type (:type analyzed) - :declared-output-type post-type}))) + (case (t/compare (:type analyzed) post-type) + (-1 0) (:type analyzed) + 1 (if (or post-type|runtime? post-type|assume?) + post-type + (err! (str "Body type incompatible with declared output type even" + " when relaxing compile-time type enforcement") + err-info)) + (2 3) (err! "Body type incompatible with declared output type" err-info)) (:type analyzed)) body-form (-> (:form analyzed) From 61f2da08476af4b4d6bf7dcd6889d719d53f947c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 17 Sep 2018 22:29:19 -0600 Subject: [PATCH 281/810] Update todos --- resources-dev/defnt.cljc | 3 +-- src/quantum/core/ns.cljc | 13 +++++++------ src/quantum/core/type.cljc | 4 +++- 3 files changed, 11 insertions(+), 9 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 7c99dd1e..fb15e8f5 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -4,7 +4,7 @@ >boolean is different than `truthy?` -Sometimes you want (byte ) to fail at runtime rather than fail at runtime when you can't know everything +Sometimes you want (byte ) to fail at runtime rather than fail at runtime when you can't know everything about the input's range TODO: - `(or (and pred then) (and (not pred) else))` (which is not correct) @@ -18,7 +18,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - t/... - multi-arity `t/-` - - t/assume - t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. - t/numerically-integer? diff --git a/src/quantum/core/ns.cljc b/src/quantum/core/ns.cljc index fb4cf3c3..bcc4840a 100644 --- a/src/quantum/core/ns.cljc +++ b/src/quantum/core/ns.cljc @@ -43,7 +43,7 @@ #?(:clj (def in in-ns)) -;; TODO TYPED finish `t/of`, `t/assume` +;; TODO TYPED finish `t/of` #_(:clj (defnt all "Returns a sequence of all namespaces." @@ -98,14 +98,14 @@ ;; ===== Mappings ===== ;; -;; TODO TYPED finish `t/assume`, `t/of`, `t/unqualified-symbol?` +;; TODO TYPED finish `t/of`, `t/unqualified-symbol?` #_(:clj (defnt ns>mappings "Supersedes `clojure.core/ns-map`." [x namespace? > (t/assume (t/of ut/+map? t/unqualified-symbol? (t/or t/var? t/class?)))] (.getMappings x))) -;; TODO TYPED finish `t/assume`, `t/of`, `t/unqualified-symbol?` +;; TODO TYPED finish `t/of`, `t/unqualified-symbol?` #_(:clj (defnt ns>alias-map "Outputs the alias->namespace mappings for the namespace. @@ -114,7 +114,7 @@ [x namespace? > (t/assume (t/of ut/+map? t/unqualified-symbol? namespace?))] (.getAliases x))) -;; TODO TYPED finish `t/assume`, `t/of`, `t/unqualified-symbol?`, decide on `filter-vals'`? +;; TODO TYPED finish `t/of`, `t/unqualified-symbol?`, decide on `filter-vals'`? #_(:clj (defnt ns>imports "Outputs the import-mappings for the namespace. @@ -123,7 +123,7 @@ [x namespace? > (t/assume (t/of ut/+map? t/unqualified-symbol? t/class?))] (->> x (filter-vals' t/class?)))) -;; TODO TYPED finish `t/assume`, `t/of`, `t/unqualified-symbol?`, decide on `filter-vals'`? +;; TODO TYPED finish `t/of`, `t/unqualified-symbol?`, decide on `filter-vals'`? #_(:clj (defnt ns>interns "Outputs the intern-mappings for the namespace. @@ -134,6 +134,7 @@ ns>mappings (filter-vals' (fn [^clojure.lang.Var v] (and (t/var? v) (= ns-val (.ns v)))))))) +;; TODO TYPED finish `t/of`, `t/unqualified-symbol?`, decide on `filter-vals'`? #_(:clj (defnt ns>publics "Outputs the public intern-mappings for the namespace. @@ -144,7 +145,7 @@ ns>interns (filter-vals' (fn [^clojure.lang.Var v] (.isPublic v)))))) -;; TODO TYPED finish `t/assume`, `t/of`, `t/unqualified-symbol?`, decide on `remove-vals'`? +;; TODO TYPED finish `t/of`, `t/unqualified-symbol?`, decide on `remove-vals'`? #_(:clj (defnt ns>refers "Outputs the refer-mappings for the namespace. diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index 020aa92e..6bd2766d 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -14,9 +14,11 @@ (defaliases ut ;; Generators - ? * isa? fn ref value + ? * isa? fn value ;; Combinators and or - if not + ;; Metadata suppliers + ref assume ;; Predicates any? nil? From e604dfb1dd89ca6e50b0d6bf864140c5df98f1e7 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 19 Sep 2018 13:44:07 -0600 Subject: [PATCH 282/810] Fix primitivization with t/ref --- src-untyped/quantum/untyped/core/type/defnt.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 83966ed9..558b9d55 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -223,7 +223,7 @@ [arg-types (s/seq-of t/type?) > (s/seq-of ::expanded-overload|arg-classes)] (->> arg-types (c/lmap (fn [t #_t/type?] - (if (-> t meta :quantum.type.core/ref?) + (if (-> t meta :quantum.core.type/ref?) (-> t t/type>classes (disj nil) seq) (let [cs (type>most-primitive-classes t) base-classes From 81f0d3a0f9107fc9819e21122cef1d86188a9fff Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 19 Sep 2018 19:45:12 -0600 Subject: [PATCH 283/810] Comment organization --- src-dev/quantum/core/defnt_equivalences.cljc | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index fa3d29c8..88924edc 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -27,6 +27,9 @@ [quantum.core.data Array] [quantum.core Numeric Primitive])) +;; ===== Type predicates ===== ;; +;; Declared here instead of in `quantum.untyped.core.type` to avoid dependency + #?(:clj (def ratio? (t/isa? clojure.lang.Ratio))) #?(:clj (def boolean? (t/isa? #?(:clj Boolean :cljs js/Boolean)))) @@ -42,6 +45,8 @@ #?(:clj (def comparable-primitive? (t/- primitive? boolean?))) +;; ===== End type predicates ===== ;; + ;; Just in case (clojure.spec.test.alpha/unstrument) (do (require '[orchestra.spec.test :as st]) From 7092cc2076c86da14e7652356950c465c12a0fb9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 19 Sep 2018 19:45:25 -0600 Subject: [PATCH 284/810] Organize some of the todos/notes --- resources-dev/defnt.cljc | 78 ++++++++++++++++++++++++++-------------- 1 file changed, 52 insertions(+), 26 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index fb15e8f5..787f006f 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -16,34 +16,45 @@ LEFT OFF LAST TIME (9/3/2018): Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - - t/... - - multi-arity `t/-` - - t/numerically : e.g. a double representing exactly what a float is able to represent - - and variants thereof: `numerically-long?` etc. - - t/numerically-integer? - - range-of : e.g. a double being between float max values but possibly representing a 'hole' in - possible float values - - dependent types: `[x p/int? > (t/type x)]` - - t/extend-defnt! - - t/of - - (t/of number?) ; implicitly the container is a `traversable?` - - (t/of map/+map? t/symbol? dstr/string?) - - (t/of t/seq? namespace?) - - t/map-of - - t/seq-of - - t/unqualified-symbol? - - expressions (`quantum.untyped.core.analyze.expr`) - - comparison of `t/fn`s is probably possible? - - deft - - fnt (t/fn; current t/fn might transition to t/fn-spec or whatever?) - - declaret + - t/- : multi-arity + - t/value-of + - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` + - t/numerically : e.g. a double representing exactly what a float is able to represent + - and variants thereof: `numerically-long?` etc. + - t/numerically-integer? + - t/range-of : e.g. a double being between float max values but possibly representing a 'hole' in + possible float values + - t/type + - dependent types: `[x arr/array? > (t/type x)]` + - ? : type inference + - use logic programming and variable unification e.g. `?1` `?2` ? + - t/extend-defnt! + - t/input-type + - `(t/input-type >namespace t/?)` meaing the possible input types to the first input to `>namespace` + - t/of + - (t/of number?) ; implicitly the container is a `traversable?` + - (t/of map/+map? symbol? dstr/string?) + - (t/of t/seq? namespace?) + - t/map-of + - t/seq-of + - t/defrecord + - t/def-concrete-type (i.e. `t/deftype`) + - expressions (`quantum.untyped.core.analyze.expr`) + - comparison of `t/fn`s is probably possible? + - t/def + - t/fnt (t/fn; current t/fn might transition to t/fn-spec or whatever?) + - t/declare - declare-fnt (a way to do protocols/interfaces) - extend-fnt! - defnt (t/defn) - (t/and (t/or a b) c) should -> (t/or (t/and a c) (t/and b c)) for purposes of separating dispatches + - t/extend-defn! + - `(t/extend-defn! id/>name (^:inline [x namespace?] (-> x .getName id/>name)))` - ^:inline - if you do (Numeric/bitAnd a b) inline then bitAnd needs to know the primitive type so maybe we do the `let*`-binding approach to typing vars? + - should be able to be per-arity like so: + (^:inline [] ...) - handle varargs - [& args _] shouldn't result in `t/any?` but rather like `t/seqable?` or whatever - do the defnt-equivalences @@ -53,14 +64,17 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - dealing with `apply`... - t/defmacro - t/deftype - - dotyped + - t/dotyped + - lazy compilation especially around `t/input-type` - typed core fns - `apply` - - especially with `defnt` as the caller + - especially with `t/defn` as the caller - `merge` - `str` - `compare` - `get` + - `concat` + - `repeat` - NOTE on namespace organization: - [quantum.untyped.core.ns :refer [namespace?]] instead of @@ -78,6 +92,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - quantum.core.cache - quantum.core.type-old - quantum.core.data.string + - [x] quantum.core.data.map + - [x] quantum.core.data.meta + - [x] quantum.core.ns ; TODO split up into data.ns? - quantum.core.print - quantum.core.log - quantum.core.data.vector @@ -85,6 +102,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - quantum.core.error - quantum.core.data.string — this is where `>str` belongs + - quantum.core.data.array - quantum.core.data.collections - quantum.core.data.tuple @@ -119,9 +137,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - quantum.core.core - TODO delete this namespace? - quantum.core.data.primitive (TODO make it compile) - - quantum.core.ns - - quantum.core.vars - - quantum.core.data.map - quantum.core.data.bits - quantum.core.convert.primitive - List of corresponding untyped namespaces to incorporate: @@ -132,6 +147,17 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] quantum.untyped.core.type.defs - [ ] quantum.untyped.core.data - [ ] quantum.untyped.core.data.bits + - [x] quantum.untyped.core.identifiers + - List of Array fns to implement: + - [ ] count + - [ ] get + - [ ] set + - [ ] new1dObjectArray + - [ ] new1dArray + - [ ] newUninitializeddArray + - [ ] newInitializedNdArray + - [ ] newUninitializedArrayOfType + - [ ] newInitializedArrayOfType - List of Numeric fns to implement: - [ ] isTrue (?) - [ ] isFalse (?) From 45229868c6d8c5a9481fca0038f1991a15f4df1c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 19 Sep 2018 19:45:41 -0600 Subject: [PATCH 285/810] Add 0-arity `new1dObjectArray` --- src-java/quantum/core/data/Array.java | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src-java/quantum/core/data/Array.java b/src-java/quantum/core/data/Array.java index 0455cd0f..595855a6 100644 --- a/src-java/quantum/core/data/Array.java +++ b/src-java/quantum/core/data/Array.java @@ -1151,6 +1151,8 @@ public class Array { // ================================ NEW 1D ARRAY ================================ // + public static Object [] new1dObjectArray() { return new Object [] {}; } + public static Object [] new1dObjectArray(final Object a0 ) { return new Object []{ a0 }; } public static Object [] new1dObjectArray(final Object a0, final Object a1 ) { return new Object []{ a0, a1 }; } public static Object [] new1dObjectArray(final Object a0, final Object a1, final Object a2 ) { return new Object []{ a0, a1, a2 }; } From 4d2e6b31b6a64c96728dd21e742f94eac6182fa7 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 19 Sep 2018 19:48:15 -0600 Subject: [PATCH 286/810] consolidate `quantum.core.data.identifiers` --- src-untyped/quantum/untyped/core/analyze.cljc | 10 +- .../quantum/untyped/core/analyze/ast.cljc | 10 +- .../quantum/untyped/core/analyze/expr.cljc | 2 +- src-untyped/quantum/untyped/core/data.cljc | 2 +- .../quantum/untyped/core/data/map.cljc | 2 +- .../quantum/untyped/core/data/numeric.cljc | 3 +- src-untyped/quantum/untyped/core/defnt.cljc | 2 +- .../untyped/core/form/generate/deftype.cljc | 2 +- .../quantum/untyped/core/form/type_hint.cljc | 2 +- .../{identification.cljc => identifiers.cljc} | 4 +- src-untyped/quantum/untyped/core/log.cljc | 8 +- .../quantum/untyped/core/print/prettier.cljc | 6 +- .../quantum/untyped/core/reducers.cljc | 2 +- src-untyped/quantum/untyped/core/spec.cljc | 2 +- src-untyped/quantum/untyped/core/type.cljc | 24 +-- .../quantum/untyped/core/type/core.cljc | 2 +- .../quantum/untyped/core/type/defnt.cljc | 6 +- .../untyped/core/type/reifications.cljc | 4 +- src-untyped/quantum/untyped/ui/dom.cljc | 2 +- .../quantum/untyped/ui/style/core.cljc | 2 +- src/quantum/core/convert.cljc | 2 +- src/quantum/core/data/identifiers.cljc | 200 ++++++++++++++++++ src/quantum/core/data/validated.cljc | 2 +- src/quantum/core/macros/defnt.cljc | 2 +- src/quantum/core/macros/optimization.cljc | 2 +- src/quantum/core/match.cljc | 2 +- src/quantum/core/refs.cljc | 2 +- src/quantum/db/datomic/core.cljc | 2 +- .../{identification.cljc => identifiers.cljc} | 6 +- test/quantum/test/untyped/core/type.cljc | 69 +++--- .../test/untyped/core/type/compare.cljc | 4 +- 31 files changed, 297 insertions(+), 93 deletions(-) rename src-untyped/quantum/untyped/core/{identification.cljc => identifiers.cljc} (98%) create mode 100644 src/quantum/core/data/identifiers.cljc rename test/quantum/test/untyped/core/{identification.cljc => identifiers.cljc} (91%) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index b524926e..01c61dcd 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -20,7 +20,7 @@ :refer [<- fn-> fn->>]] [quantum.untyped.core.form.evaluate :as ufeval] [quantum.untyped.core.form.type-hint :as ufth] - [quantum.untyped.core.identification :as uident + [quantum.untyped.core.identifers :as uident :refer [>symbol]] [quantum.untyped.core.log :as log :refer [prl!]] @@ -118,7 +118,7 @@ ([v] (->WatchableMutable v nil)) ([v watch] (->WatchableMutable v watch))) -(s/def ::env (s/map-of t/symbol? t/any?)) +(s/def ::env (s/map-of symbol? t/any?)) (declare analyze*) @@ -249,7 +249,7 @@ Unchecked fns could be assumed to actually *want* to shift the range over if the range hits a certain point, but we do not make that assumption here." - [c t/class?, method t/symbol? > (? t/type?)] + [c t/class?, method symbol? > (? t/type?)] (when (identical? c clojure.lang.RT) (case method (uncheckedBooleanCast booleanCast) t/boolean? @@ -604,7 +604,7 @@ :expanded expanded :type (:type expanded)}))))) -(defns ?resolve-with-env [sym t/symbol?, env ::env] +(defns ?resolve-with-env [sym symbol?, env ::env] (if-let [[_ local] (find env sym)] {:value local} (let [resolved (ns-resolve *ns* sym)] @@ -614,7 +614,7 @@ {:value (analyze-seq|dot env (list '. (-> sym namespace symbol) (-> sym name symbol)))} nil)))) -(defns- analyze-symbol [env ::env, form t/symbol? > uast/symbol?] +(defns- analyze-symbol [env ::env, form symbol? > uast/symbol?] (if-not-let [{resolved :value} (?resolve-with-env form env)] (err! "Could not resolve symbol" {:sym form}) (uast/symbol env form resolved diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 2c9ae00a..8dc165c3 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -51,11 +51,11 @@ (defn node? [x] (instance? INode x)) #_(t/def ::node (t/isa? INode)) -#_(t/def ::env (t/map-of t/symbol? ::node)) +#_(t/def ::env (t/map-of symbol? ::node)) ;; ===== Nodes ===== ;; -(defrecord Unbound [env #_::env, form #_t/symbol?, minimum-type #_t/type?, type #_t/type?] ;; TODO `type` should be `t/deducible-type?` +(defrecord Unbound [env #_::env, form #_symbol?, minimum-type #_t/type?, type #_t/type?] ;; TODO `type` should be `t/deducible-type?` INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -82,7 +82,7 @@ (defrecord Symbol [env #_::env - form #_t/symbol? + form #_symbol? value #_t/any? type #_t/type?] INode @@ -176,7 +176,7 @@ [env #_::env form #_::t/form target #_::node - field #_t/unqualified-symbol? + field #_id/unqualified-symbol? type #_t/type?] INode fipp.ednize/IOverride @@ -192,7 +192,7 @@ [env #_::env form #_::t/form target #_::node - method #_::t/unqualified-symbol? + method #_::id/unqualified-symbol? args #_(t/and t/sequential? t/indexed? (t/seq-and ::node)) type #_t/type?] INode diff --git a/src-untyped/quantum/untyped/core/analyze/expr.cljc b/src-untyped/quantum/untyped/core/analyze/expr.cljc index 5d638d93..b6993a44 100644 --- a/src-untyped/quantum/untyped/core/analyze/expr.cljc +++ b/src-untyped/quantum/untyped/core/analyze/expr.cljc @@ -16,7 +16,7 @@ :refer [err! TODO]] [quantum.untyped.core.form :as uform :refer [>form]] - [quantum.untyped.core.identification :as uident + [quantum.untyped.core.identifiers :as uident :refer [>symbol]] [quantum.untyped.core.print :as upr] [quantum.untyped.core.reducers :as ur diff --git a/src-untyped/quantum/untyped/core/data.cljc b/src-untyped/quantum/untyped/core/data.cljc index 9d2a5219..8e83a632 100644 --- a/src-untyped/quantum/untyped/core/data.cljc +++ b/src-untyped/quantum/untyped/core/data.cljc @@ -4,7 +4,7 @@ (:require [quantum.untyped.core.core :as ucore] [quantum.untyped.core.data.array :as uarr] - [quantum.untyped.core.identification + [quantum.untyped.core.identifiers :refer [>keyword]] [quantum.untyped.core.vars :refer [defalias]])) diff --git a/src-untyped/quantum/untyped/core/data/map.cljc b/src-untyped/quantum/untyped/core/data/map.cljc index 3e5187e8..411aacd2 100644 --- a/src-untyped/quantum/untyped/core/data/map.cljc +++ b/src-untyped/quantum/untyped/core/data/map.cljc @@ -13,7 +13,7 @@ [[clojure.data.int-map :as imap] [seqspert.hash-map]]) [quantum.untyped.core.data :as udata] - [quantum.untyped.core.identification + [quantum.untyped.core.identifiers :refer [>keyword]] [quantum.untyped.core.reducers :as ur :refer [reduce-pair]] diff --git a/src-untyped/quantum/untyped/core/data/numeric.cljc b/src-untyped/quantum/untyped/core/data/numeric.cljc index f8d2e5ad..80ca0132 100644 --- a/src-untyped/quantum/untyped/core/data/numeric.cljc +++ b/src-untyped/quantum/untyped/core/data/numeric.cljc @@ -9,6 +9,7 @@ :refer [read-string]] #?(:cljs [com.gfredericks.goog.math.Integer :as int]) [quantum.core.data.primitive :as p] + [quantum.core.data.string :as dstr] [quantum.core.logic :refer [whenf fn-not fn=]] [quantum.core.type :as t @@ -43,7 +44,7 @@ #?(:cljs (defnt >bigint > bigint? ([x bigint?] x) - ([x t/string?] (int/fromString x)) + ([x dstr/string?] (int/fromString x)) ([x p/double?] (-> x (.toString) >bigint)))) ;; ===== Decimals ===== ;; diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index 8cd4f2a7..b260cecd 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -12,7 +12,7 @@ [quantum.untyped.core.data.map :refer [om]] [quantum.untyped.core.form.evaluate :as ufeval] - [quantum.untyped.core.identification + [quantum.untyped.core.identifiers :refer [>keyword ident? qualified-keyword? simple-symbol?]] [quantum.untyped.core.loops :refer [reduce-2]] diff --git a/src-untyped/quantum/untyped/core/form/generate/deftype.cljc b/src-untyped/quantum/untyped/core/form/generate/deftype.cljc index ed647cd2..3e2fc2f3 100644 --- a/src-untyped/quantum/untyped/core/form/generate/deftype.cljc +++ b/src-untyped/quantum/untyped/core/form/generate/deftype.cljc @@ -12,7 +12,7 @@ [quantum.untyped.core.form.generate.definterface] [quantum.untyped.core.form.type-hint :as uth :refer [type-hint with-type-hint un-type-hint]] - [quantum.untyped.core.identification :as uident] + [quantum.untyped.core.identifiers :as uident] [quantum.untyped.core.string :as ustr])) (defn ?Associative [lang] (case lang :clj 'clojure.lang.Associative :cljs 'cljs.core/IAssociative)) diff --git a/src-untyped/quantum/untyped/core/form/type_hint.cljc b/src-untyped/quantum/untyped/core/form/type_hint.cljc index 9c8f83b8..dafd6a13 100644 --- a/src-untyped/quantum/untyped/core/form/type_hint.cljc +++ b/src-untyped/quantum/untyped/core/form/type_hint.cljc @@ -3,7 +3,7 @@ [quantum.untyped.core.collections :as uc] [quantum.untyped.core.error :refer [err!]] - [quantum.untyped.core.identification + [quantum.untyped.core.identifiers :refer [>name]] [quantum.untyped.core.logic :refer [ifs]] diff --git a/src-untyped/quantum/untyped/core/identification.cljc b/src-untyped/quantum/untyped/core/identifiers.cljc similarity index 98% rename from src-untyped/quantum/untyped/core/identification.cljc rename to src-untyped/quantum/untyped/core/identifiers.cljc index ba7b9110..a5d392ec 100644 --- a/src-untyped/quantum/untyped/core/identification.cljc +++ b/src-untyped/quantum/untyped/core/identifiers.cljc @@ -1,5 +1,5 @@ -(ns quantum.untyped.core.identification - "Functions related to variable identification/naming (name, namespace, etc.) and +(ns quantum.untyped.core.identifiers + "Functions related to variable identifiers/names (`name`, `namespace`, etc.) and qualification/unqualification of nameables." (:refer-clojure :exclude [ident? qualified-keyword? simple-symbol?]) diff --git a/src-untyped/quantum/untyped/core/log.cljc b/src-untyped/quantum/untyped/core/log.cljc index b8e8cd9c..734a599f 100644 --- a/src-untyped/quantum/untyped/core/log.cljc +++ b/src-untyped/quantum/untyped/core/log.cljc @@ -12,7 +12,7 @@ [quantum.untyped.core.form.evaluate :refer [compile-if]] [quantum.untyped.core.form.generate :as ufgen] - [quantum.untyped.core.identification :as uident] + [quantum.untyped.core.identifiers :as uident] [quantum.untyped.core.meta.debug :as udebug] [quantum.untyped.core.print :as upr] [quantum.untyped.core.vars @@ -42,13 +42,13 @@ ;; ===== Log levels ===== ;; (defn disable! - ([pr-type #_t/keyword?] (swap! *levels assoc pr-type false)) + ([pr-type #_keyword?] (swap! *levels assoc pr-type false)) ([pr-type & pr-types] (doseq [pr-type-n (conj pr-types pr-type)] (disable! pr-type-n)))) (defn enable! - ([pr-type #_t/keyword?] (swap! *levels assoc pr-type true)) + ([pr-type #_keyword?] (swap! *levels assoc pr-type true)) ([pr-type & pr-types] (doseq [pr-type-n (conj pr-types pr-type)] (enable! pr-type-n)))) @@ -156,7 +156,7 @@ ;; ===== Level-specific macros ===== ;; #?(:clj -(defmacro -gen-from-levels [& levels #_(t/seq-of t/keyword?)] +(defmacro -gen-from-levels [& levels #_(t/seq-of keyword?)] `(do ~@(for [level levels] `(defmacro ~(-> level name symbol) [& ~'args] `(ppr ~~level ~@'args)))))) diff --git a/src-untyped/quantum/untyped/core/print/prettier.cljc b/src-untyped/quantum/untyped/core/print/prettier.cljc index 8615c083..017938b0 100644 --- a/src-untyped/quantum/untyped/core/print/prettier.cljc +++ b/src-untyped/quantum/untyped/core/print/prettier.cljc @@ -7,7 +7,7 @@ :refer [rcomp]] [quantum.untyped.core.ns] [quantum.untyped.core.print] - [quantum.untyped.core.identification] + [quantum.untyped.core.identifiers] [quantum.untyped.core.vars])) #?(:clj @@ -51,12 +51,12 @@ (defn visit-symbol* [x] [:text (cond-> x quantum.untyped.core.print/*collapse-symbols?* - (quantum.untyped.core.identification/collapse-symbol + (quantum.untyped.core.identifiers/collapse-symbol (not quantum.untyped.core.print/*print-as-code?*)))])) #?(:clj (defn visit-fn [visitor x] - [:group "#" "fn" " " (-> x quantum.untyped.core.identification/>symbol visit-symbol*)])) + [:group "#" "fn" " " (-> x quantum.untyped.core.identifiers/>symbol visit-symbol*)])) #?(:clj (defn visit* diff --git a/src-untyped/quantum/untyped/core/reducers.cljc b/src-untyped/quantum/untyped/core/reducers.cljc index 46abafa0..4eb02eda 100644 --- a/src-untyped/quantum/untyped/core/reducers.cljc +++ b/src-untyped/quantum/untyped/core/reducers.cljc @@ -14,7 +14,7 @@ :refer [err!]] [quantum.untyped.core.form.evaluate :refer [case-env]] - [quantum.untyped.core.identification :as uident] + [quantum.untyped.core.identifiers :as uident] [quantum.untyped.core.vars :as uvar :refer [defalias]]) #?(:cljs (:require-macros diff --git a/src-untyped/quantum/untyped/core/spec.cljc b/src-untyped/quantum/untyped/core/spec.cljc index e080d4ee..1a315fd1 100644 --- a/src-untyped/quantum/untyped/core/spec.cljc +++ b/src-untyped/quantum/untyped/core/spec.cljc @@ -16,7 +16,7 @@ :refer [constantly with-do]] [quantum.untyped.core.form.evaluate :as ufeval :refer [case-env]] - [quantum.untyped.core.identification :as uident + [quantum.untyped.core.identifiers :as uident :refer [>keyword ident?]] [quantum.untyped.core.vars :refer [defalias defmalias]]) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index fd69c6ed..93869365 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -13,7 +13,6 @@ array? associative? coll? counted? indexed? iterable? list? map? map-entry? record? seq? seqable? sequential? set? sorted? vector? fn? ifn? - var? meta delay? ref volatile? fn]) @@ -39,7 +38,7 @@ [quantum.untyped.core.fn :as ufn :refer [fn1 rcomp <- fn->]] [quantum.untyped.core.form.generate.deftype :as udt] - [quantum.untyped.core.identification + [quantum.untyped.core.identifiers :refer [>symbol]] [quantum.untyped.core.logic :refer [fn-and ifs whenp->]] @@ -256,15 +255,11 @@ ;; ===== Definition/Registration ===== ;; -(defns register-type! [sym c/symbol?, t utr/type?] - (TODO)) - ;; TODO clean up #?(:clj (defmacro define [sym t] `(~'def ~sym (let [t# ~t] (assert (utr/type? t#) t#) - #_(register-type! '~(uident/qualify sym) t#) t#)))) ;; TODO clean up @@ -671,15 +666,6 @@ (-def list? #?(:clj (isa? java.util.List) :cljs +list?)) -;; ----- String ----- ;; A special wrapper for char array where different encodings, etc. are possible - - ;; Mutable String - (-def !string? (isa? #?(:clj java.lang.StringBuilder :cljs goog.string.StringBuffer))) - ;; Immutable String - (-def string? (isa? #?(:clj java.lang.String :cljs js/String))) - -#?(:clj (-def char-seq? (isa? java.lang.CharSequence))) - ;; ===== Vectors ===== ;; Sequential, Associative (specifically, whose keys are sequential, ;; dense integer values), extensible @@ -924,7 +910,7 @@ ;; ===== Miscellaneous ===== ;; - (-def metable? (isa? #?(:clj clojure.lang.IMeta :cljs cljs.core/IMeta))) + ;; Used by `quantum.untyped.core.analyze.ast` (-def with-metable? (isa? #?(:clj clojure.lang.IObj :cljs cljs.core/IWithMeta))) #?(:clj (-def thread? (isa? java.lang.Thread))) @@ -937,13 +923,11 @@ (-def chan? (isa? #?(:clj clojure.core.async.impl.protocols/Channel :cljs cljs.core.async.impl.protocols/Channel))) + ;; Used by `quantum.untyped.core.analyze` (-def keyword? (isa? #?(:clj clojure.lang.Keyword :cljs cljs.core/Keyword))) - (-def symbol? (isa? #?(:clj clojure.lang.Symbol :cljs cljs.core/Symbol))) #?(:clj (-def namespace? (isa? clojure.lang.Namespace))) -#?(:clj (-def var? (isa? clojure.lang.Var))) - ;; `js/File` isn't always available! Use an abstraction #?(:clj (-def file? (isa? java.io.File))) @@ -957,7 +941,7 @@ #?(:clj (-def tagged-literal? (isa? clojure.lang.TaggedLiteral))) - (-def literal? (or nil? boolean? symbol? keyword? string? #?(:clj long?) double? #?(:clj tagged-literal?))) + (-def literal? (or nil? boolean? symbol? keyword? t/string? #?(:clj long?) double? #?(:clj tagged-literal?))) #_(-def form? (or literal? +list? +vector? ...)) ;; ===== Generic ===== ;; diff --git a/src-untyped/quantum/untyped/core/type/core.cljc b/src-untyped/quantum/untyped/core/type/core.cljc index 96ad7c6f..3b3c2f12 100644 --- a/src-untyped/quantum/untyped/core/type/core.cljc +++ b/src-untyped/quantum/untyped/core/type/core.cljc @@ -15,7 +15,7 @@ :refer [>ex-info]] [quantum.untyped.core.fn :refer [<- fn->>]] - [quantum.untyped.core.identification + [quantum.untyped.core.identifiers :refer [>name]] [quantum.untyped.core.vars :refer [defalias]] diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 558b9d55..f795d5d4 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -29,7 +29,7 @@ [quantum.untyped.core.form.evaluate :as ufeval] [quantum.untyped.core.form.generate :as ufgen] [quantum.untyped.core.form.type-hint :as ufth] - [quantum.untyped.core.identification :as uident + [quantum.untyped.core.identifiers :as uident :refer [>name >symbol]] [quantum.untyped.core.log :as ulog] [quantum.untyped.core.logic :as ul @@ -368,7 +368,7 @@ (def fnt-method-sym 'invoke) -(defns- class>interface-part-name [c t/class? > t/string?] +(defns- class>interface-part-name [c t/class? > string?] (if (= c java.lang.Object) "Object" (let [illegal-pattern #"\|\+"] @@ -376,7 +376,7 @@ (err! "Class cannot contain pattern" {:class c :pattern illegal-pattern}) (-> c >name (str/replace "." "|")))))) -(defns fnt-overload>interface-sym [args-classes (s/seq-of t/class?), out-class t/class? > t/symbol?] +(defns fnt-overload>interface-sym [args-classes (s/seq-of t/class?), out-class t/class? > symbol?] (>symbol (str (->> args-classes (c/lmap class>interface-part-name) (str/join "+")) ">" (class>interface-part-name out-class)))) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 38723cc7..f3b55219 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -164,7 +164,7 @@ ^int ^:unsynchronized-mutable hash-code meta #_(t/? ::meta) p #_t/protocol? - name #_(t/? t/symbol?)] + name #_(t/? symbol?)] {PType nil ?Fn {invoke ([_ x] (satisfies? p x))} ?Meta {meta ([this] meta) @@ -192,7 +192,7 @@ ^int ^:unsynchronized-mutable hash-code meta #_(t/? ::meta) ^Class c #_t/class? - name #_(t/? t/symbol?)] + name #_(t/? symbol?)] {PType nil ?Fn {invoke ([_ x] (instance? c x))} ?Meta {meta ([this] meta) diff --git a/src-untyped/quantum/untyped/ui/dom.cljc b/src-untyped/quantum/untyped/ui/dom.cljc index 15bb1097..5160841e 100644 --- a/src-untyped/quantum/untyped/ui/dom.cljc +++ b/src-untyped/quantum/untyped/ui/dom.cljc @@ -2,7 +2,7 @@ #?(:cljs (:require [quantum.untyped.reactive.core :as re]))) #?(:cljs -(defn append-element! [parent #_dom-element? tag #_t/string? id #_t/string?] +(defn append-element! [parent #_dom-element? tag #_dstr/str? id #_dstr/str?] (or (.getElementById js/document id) (doto (.createElement js/document tag) (-> .-id (set! id)) diff --git a/src-untyped/quantum/untyped/ui/style/core.cljc b/src-untyped/quantum/untyped/ui/style/core.cljc index 63945eee..e348fe44 100644 --- a/src-untyped/quantum/untyped/ui/style/core.cljc +++ b/src-untyped/quantum/untyped/ui/style/core.cljc @@ -5,7 +5,7 @@ [clojure.string :as str] [quantum.untyped.core.collections :as uc] [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.identification + [quantum.untyped.core.identifiers :refer [>?name]] [quantum.untyped.core.system :as usys])) diff --git a/src/quantum/core/convert.cljc b/src/quantum/core/convert.cljc index e9315412..bd064879 100644 --- a/src/quantum/core/convert.cljc +++ b/src/quantum/core/convert.cljc @@ -42,7 +42,7 @@ :refer [case-env]] [quantum.untyped.core.form.type-hint :refer [static-cast]] - [quantum.untyped.core.identification :as uident]) + [quantum.untyped.core.identifiers :as uident]) #?(:cljs (:require-macros [quantum.core.convert :as self])) diff --git a/src/quantum/core/data/identifiers.cljc b/src/quantum/core/data/identifiers.cljc new file mode 100644 index 00000000..bccfb8ec --- /dev/null +++ b/src/quantum/core/data/identifiers.cljc @@ -0,0 +1,200 @@ +(ns quantum.core.data.identifiers + "Functions related to variable identifiers/names (`name`, `namespace`, etc.) and qualification / + unqualification of nameables." + (:refer-clojure :exclude + [keyword? symbol?]) + (:require + [quantum.core.data.meta :as dm + :refer [>meta]] + [quantum.core.data.string :as dstr + :refer [str? >str]] + [quantum.core.type :as t] + [quantum.untyped.core.core :as ucore])) + +(ucore/log-this-ns) + +;; ===== Standard identifiers ===== ;; + +(def keyword? (t/isa? #?(:clj clojure.lang.Keyword :cljs cljs.core/Keyword))) + +(def symbol? (t/isa? #?(:clj clojure.lang.Symbol :cljs cljs.core/Symbol))) + +(def ident? (t/or keyword? symbol?)) + +;; ===== Nameability ===== ;; + +(def named? (t/isa? #?(:clj clojure.lang.Named :cljs cljs.core/INamed))) + +(t/defn demunged>namespace [s str?] TODO TYPED #_(subs s 0 (.lastIndexOf s "/"))) +(t/defn demunged>name [s str?] TODO TYPED #_(subs s (inc (.lastIndexOf s "/")))) + +(defn... ?ns>name [?ns] + (name #?(:clj (if (namespace? ?ns) + (ns-name ?ns) + ?ns) + :cljs ?ns))) + +(t/defn >name + "Computes the nilable name (the unqualified string identifier) of `x`." + > (t/? str?) + (^:inline [x (t/or t/nil? str?)] x) + (^:inline [x named?] #?(:clj (.getName x) :cljs (-name ^not-native x))) +#?(:clj (^:inline [x ??/class?] (.getName x))) + ( [x ??/fn?] + #?(:clj (or (some-> (-> >meta :name) >name) + (-> x ??/>class >name clojure.lang.Compiler/demunge demunged>name)) + :cljs (when-not (-> x .-name ???str/blank?) + (-> x .-name ??/demunge-str demunged>name))))) + +(t/defn >namespace + "Computes the nilable identifier-namespace (the string identifier-qualifier) of `x`." + > (t/? str?) + (^:inline [x (t/or t/nil? str? #?(:clj ??/class?) #?(:clj ??/namespace?))] nil) + (^:inline [x named?] #?(:clj (.getNamespace x) :cljs (-namespace ^not-native x))) + ( [x ??/fn?] + #?(:clj (or (some-> (-> x >meta :ns) >name) + (-> x ??/>class .getName clojure.lang.Compiler/demunge demunged>namespace)) + :cljs (when-not (-> x .-name ???str/blank?) + (-> x .-name ??/demunge-str demunged>namespace))))) + +;; ===== Qualification ===== ;; + +(t/defn qualify > symbol? + #?(:clj ([sym symbol?] (qualify *ns* sym))) + ([?ns (t/? ??/namespace?) sym symbol?] (>symbol (?ns>name ?ns) (>name sym)))) + +(t/defn qualify|dot > symbol? [sym symbol? ns-val ??/namespace?] + (>symbol (>str (?ns>name ns-val) "." (>name sym)))) + +#?(:clj (defn... qualify|class [sym] (symbol (str (-> *ns* ns-name name munge) "." sym)))) + +(t/defn unqualify > symbol? [sym symbol?] (-> sym >name >symbol)) + +(t/defn unqualified? [x (t/input-type >namespace t/?)] (-> x >namespace t/nil?)) +(t/defn qualified? [x (t/input-type >namespace t/?)] (-> x >namespace t/val?)) + +(def unqualified-keyword? (t/and keyword? unqualified?)) +(def qualified-keyword? (t/and keyword? qualified?)) +(def unqualified-symbol? (t/and symbol? unqualified?)) +(def qualified-symbol? (t/and symbol? qualified?)) +(def unqualified-ident? (t/and symbol? unqualified?)) +(def qualified-ident? (t/and symbol? qualified?)) + +#?(:clj +(defn... collapse-symbol + ([sym symbol?] (collapse-symbol sym true)) + ([sym symbol? extra-slash? p/boolean?] + (>symbol + (when-let [n (>namespace sym)] + (when-not (= n (-> *ns* ns-name name)) + (if-let [alias- (do #?(:clj (??/ns-name>alias *ns* (>symbol n)) :cljs false))] + (str alias- (when extra-slash? "/")) + n))) (name sym))))) + +;; ===== Standard identifiers ===== ;; + +(t/defn >keyword + "Outputs a keyword with the given (optional) namespace and name. + Do not use `:` in keyword strings; it will be added automatically." + > keyword? + ([x keyword?] x) + ([x symbol?] #?(:clj (clojure.lang.Keyword/intern x) + :cljs (cljs.core/Keyword. (>namespace x) (>name x) (.-str x) nil))) + ([x str?] #?(:clj (clojure.lang.Keyword/intern x) + ;; TODO TYPED below + :cljs (let [parts (.split x "/")] + (if (== (alength parts) 2) + (cljs.core/Keyword. (aget parts 0) (aget parts 1) x nil) + (cljs.core/Keyword. nil (aget parts 0) x nil))))) + ([ns-str t/nil?, name-str str?] + #?(:clj (clojure.lang.Keyword/intern ns-str name-str) + :cljs (cljs.core/Keyword. ns-str name-str name-str nil))) + ([ns-str str?, name-str str?] + #?(:clj (clojure.lang.Keyword/intern ns-str name-str) + :cljs (cljs.core/Keyword. ns-str name-str (>str ns-str "/" name-str) nil)))) + +(t/defn >symbol + "Outputs a symbol (possibly qualified, meta-able identifier)." + > symbol? + ([x symbol?] x) + ([x str?] #?(:clj (clojure.lang.Symbol/intern x) + ;; TODO TYPED below + :cljs (let [i (.indexOf x "/")] + (if (< i 1) + (>symbol nil x) + (>symbol (.substring x 0 i) + (.substring x (inc i) (.-length x))))))) + ([x keyword?] (>symbol (>namespace x) (>name x))) + ([ns-str t/nil?, name-str str?] + #?(:clj (clojure.lang.Symbol/intern ns-str name-str) + :cljs (cljs.core/Symbol. ns-str name-str name-str nil nil))) + ([ns-str str?, name-str str?] + #?(:clj (clojure.lang.Symbol/intern ns-str name-str) + :cljs (cljs.core/Symbol. ns-str name-str (>str ns-str "/" name-str) nil nil))) + +;; TODO TYPED incorporate this into `>symbol` + (cond +#?@(:clj [(class? x) (-> x >name symbol) + (namespace? x) (ns-name x)]) + (fn? x) #?(:clj (or (when-let [ns- (-> x >meta :ns)] + (symbol (>name ns-) (-> x >meta :name >name))) + (-> x class .getName clojure.lang.Compiler/demunge recur)) + :cljs (when-not (-> x .-name str/blank?) + (-> x .-name demunge-str recur))) + :else (-> x str recur))) + +;; ===== UUIDs ===== ;; + +(def uuid? (t/isa? #?(:clj java.util.UUID :cljs cljs.core/UUID))) + +(t/defn >uuid > uuid? + ([] + #?(:clj (java.util.UUID/randomUUID) + ;; TODO TYPED below + :cljs (letfn [(hex [] (.toString (rand-int 16) 16))] + (let [rhex (.toString (bit-or 0x8 (bit-and 0x3 (rand-int 16))) 16)] + (>uuid + (str (hex) (hex) (hex) (hex) + (hex) (hex) (hex) (hex) "-" + (hex) (hex) (hex) (hex) "-" + "4" (hex) (hex) (hex) "-" + rhex (hex) (hex) (hex) "-" + (hex) (hex) (hex) (hex) + (hex) (hex) (hex) (hex) + (hex) (hex) (hex) (hex))))))) + #?(:cljs ([x str?] (cljs.core/UUID. (.toLowerCase s) nil)))) + +;; ===== Delimited identifiers ===== ;; + +;; TODO TYPED `t/defrecord` +(defrecord + ^{:doc "A delimited identifier. + Defaults to delimiting all qualifiers by the pipe symbol instead of slashes or dots."} + DelimitedIdent [qualifiers #_(t/of (t/and str? (t/not (fn1 contains? \|))))] + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (tagged-literal '| (>symbol (??str/join "|" qualifiers))))) + +(def delim-ident? (t/isa? DelimitedIdent)) + +(t/defn >delim-ident + "Computes the delimited identifier of `x`." + ([x delim-ident?] x) + ([x str?] (-> x (??str/split #"\.|\||/") (DelimitedIdent.))) + ([x named?] (DelimitedIdent. + (??/concat (some-> (>namespace x) (??str/split #"\.|\||/")) + (-> x >name (??str/split #"\.|\||/"))))) +#?(:clj ([x ??/class?] (-> x >name >delim-ident))) + ([x t/val?] (-> x >str >delim-ident))) + +;; TODO TYPED incorporate into `>delim-ident` +(namespace? x) (-> x >name >delim-ident) +(var? x) (DelimitedIdent. + (concat (-> x >namespace (str/split #"\.|\||/")) + (-> x >name (str/split #"\.|\||/")))) +(fn? x) (DelimitedIdent. + #?(:clj (or (some-> (-> x >meta :name) >name (str/split #"\.|\||/")) + (-> x class .getName clojure.lang.Compiler/demunge (str/split #"\.|\||/"))) + :cljs (if (-> x .-name str/blank?) + [""] + (-> x .-name demunge-str (str/split #"\.|\||/"))))) diff --git a/src/quantum/core/data/validated.cljc b/src/quantum/core/data/validated.cljc index 49a5a2f1..c7c56f26 100644 --- a/src/quantum/core/data/validated.cljc +++ b/src/quantum/core/data/validated.cljc @@ -22,7 +22,7 @@ :refer [contains?]] [quantum.untyped.core.collections.tree :as utree :refer [postwalk]] - [quantum.untyped.core.identification :as uident] + [quantum.untyped.core.identifiers :as uident] [quantum.untyped.core.form.evaluate :refer [case-env]]) #?(:cljs diff --git a/src/quantum/core/macros/defnt.cljc b/src/quantum/core/macros/defnt.cljc index 4d181e68..d43b0e35 100644 --- a/src/quantum/core/macros/defnt.cljc +++ b/src/quantum/core/macros/defnt.cljc @@ -40,7 +40,7 @@ [quantum.untyped.core.form.evaluate :refer [case-env case-env*]] [quantum.untyped.core.form.type-hint :as ufth] - [quantum.untyped.core.identification :as uident + [quantum.untyped.core.identifiers :as uident :refer [>name]] [quantum.untyped.core.numeric :refer [>integer]] diff --git a/src/quantum/core/macros/optimization.cljc b/src/quantum/core/macros/optimization.cljc index 457d02bd..889059b5 100644 --- a/src/quantum/core/macros/optimization.cljc +++ b/src/quantum/core/macros/optimization.cljc @@ -8,7 +8,7 @@ [quantum.core.logic :as logic :refer [fn-and]] [quantum.core.vars :as var] - [quantum.untyped.core.identification :as uident])) + [quantum.untyped.core.identifiers :as uident])) ; ===== EXTERN ===== diff --git a/src/quantum/core/match.cljc b/src/quantum/core/match.cljc index 7b667fbb..d8e85f5e 100644 --- a/src/quantum/core/match.cljc +++ b/src/quantum/core/match.cljc @@ -16,7 +16,7 @@ :refer [macroexpand-all]] [quantum.core.collections.tree :as tree] [quantum.core.collections.zippers :as zip] - [quantum.untyped.core.identification :as uident])) + [quantum.untyped.core.identifiers :as uident])) ; Regex seq matching diff --git a/src/quantum/core/refs.cljc b/src/quantum/core/refs.cljc index 28e73cae..eca10a20 100644 --- a/src/quantum/core/refs.cljc +++ b/src/quantum/core/refs.cljc @@ -18,7 +18,7 @@ [quantum.core.type-old :as t :refer [val?]] [quantum.core.type.defs :as tdefs] - [quantum.untyped.core.identification :as uident] + [quantum.untyped.core.identifiers :as uident] [quantum.untyped.core.refs :refer [atom?]] [quantum.core.vars :as var diff --git a/src/quantum/db/datomic/core.cljc b/src/quantum/db/datomic/core.cljc index 3a9fe818..8c0b252d 100644 --- a/src/quantum/db/datomic/core.cljc +++ b/src/quantum/db/datomic/core.cljc @@ -36,7 +36,7 @@ [quantum.core.spec :as s :refer [validate]] [quantum.core.type-old :as t] - [quantum.untyped.core.identification + [quantum.untyped.core.identifiers :refer [>?name]]) #?(:clj (:import diff --git a/test/quantum/test/untyped/core/identification.cljc b/test/quantum/test/untyped/core/identifiers.cljc similarity index 91% rename from test/quantum/test/untyped/core/identification.cljc rename to test/quantum/test/untyped/core/identifiers.cljc index e10c0286..aa62e73b 100644 --- a/test/quantum/test/untyped/core/identification.cljc +++ b/test/quantum/test/untyped/core/identifiers.cljc @@ -1,10 +1,10 @@ -(ns quantum.test.untyped.core.identification +(ns quantum.test.untyped.core.identifiers (:require - [quantum.untyped.core.identification :as this + [quantum.untyped.core.identifiers :as this #?@(:cljs [:refer [DelimitedIdent]])] [quantum.untyped.core.test :as test :refer [deftest testing is is= throws]]) - #?(:clj (:import quantum.untyped.core.identification.DelimitedIdent))) + #?(:clj (:import quantum.untyped.core.identifiers.DelimitedIdent))) (deftest test|>ident (is= (this/>delim-ident "a|b|c|d") (DelimitedIdent. ["a" "b" "c" "d"])) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index d0d2effc..63fb1ba6 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -27,6 +27,25 @@ ProtocolType ClassType ValueType]))) +;; ===== Type predicates ===== ;; +;; Declared here instead of in `quantum.untyped.core.type` to avoid dependency + +#?(:clj (def boolean? (t/isa? #?(:clj Boolean :cljs js/Boolean)))) +#?(:clj (def byte? (t/isa? Byte))) +#?(:clj (def short? (t/isa? Short))) +#?(:clj (def char? (t/isa? Character))) +#?(:clj (def int? (t/isa? Integer))) +#?(:clj (def long? (t/isa? Long))) +#?(:clj (def float? (t/isa? Float))) + (def double? (t/isa? #?(:clj Double :cljs js/Number))) + + (def primitive? (t/or boolean? #?@(:clj [byte? short? char? int? long? float?]) double?)) + +#?(:clj (def char-seq? (t/isa? CharSequence))) + (def string? (t/isa? #?(:clj String :cljs js/String))) + +;; ===== End type predicates ===== ;; + (defn test-equality [genf] (let [a (genf) b (genf)] (testing "structural equality (`c/=`)" @@ -80,8 +99,8 @@ (testing ">" (is= (t/- (| a b) a) b) - (is= (t/- (| a b t/long?) a) - (| b t/long?))) + (is= (t/- (| a b long?) a) + (| b long?))) (testing "><" )) @@ -125,15 +144,15 @@ (is= (| a b (| (! a) (! b))) t/universal-set)) (testing "nested" - (is= (utr/or-type>args (| (| t/string? t/double?) - t/char-seq?)) - [t/double? t/char-seq?]) - (is= (utr/or-type>args (| (| t/string? t/double?) - (| t/double? t/char-seq?))) - [t/double? t/char-seq?]) - (is= (utr/or-type>args (| (| t/string? t/double?) - (| t/char-seq? t/number?))) - [t/char-seq? t/number?])) + (is= (utr/or-type>args (| (| string? double?) + char-seq?)) + [double? char-seq?]) + (is= (utr/or-type>args (| (| string? double?) + (| double? char-seq?))) + [double? char-seq?]) + (is= (utr/or-type>args (| (| string? double?) + (| char-seq? t/number?))) + [char-seq? t/number?])) (testing "#{<+ =} -> #{<+}" (is= (utr/or-type>args (| i|>a+b i|>a0 i|a)) [i|>a+b i|>a0])) @@ -167,17 +186,17 @@ t/empty-set) (is= (& t/universal-set t/empty-set t/universal-set) t/empty-set) - (is= (& t/universal-set t/string?) - t/string?) - (is= (& t/universal-set t/char-seq? t/string?) - t/string?) - (is= (& t/universal-set t/string? t/char-seq?) - t/string?) - (is= (& t/empty-set t/string?) + (is= (& t/universal-set string?) + string?) + (is= (& t/universal-set char-seq? string?) + string?) + (is= (& t/universal-set string? char-seq?) + string?) + (is= (& t/empty-set string?) t/empty-set) - (is= (& t/empty-set t/char-seq? t/string?) + (is= (& t/empty-set char-seq? string?) t/empty-set) - (is= (& t/empty-set t/string? t/char-seq?) + (is= (& t/empty-set string? char-seq?) t/empty-set)) (testing "simplification" (testing "via single-arg" @@ -192,8 +211,8 @@ a) (is= (& a (& a a)) a) - (is= (& (| t/string? t/byte?) (| t/byte? t/string?)) - (| t/string? t/byte?)) + (is= (& (| string? byte?) (| byte? string?)) + (| string? byte?)) (is= (& (| a b) (| b a)) (| a b)) (is= (& (| a b ><0) (| a ><0 b)) @@ -204,7 +223,7 @@ (testing "empty-set" (is= (& a b) t/empty-set) - (is= (& t/string? t/byte?) + (is= (& string? byte?) t/empty-set) (is= (& a ><0) t/empty-set) @@ -238,8 +257,8 @@ a) (is= (& (| a b) (! b) (| ><0 b)) t/empty-set)) - (is= (& t/primitive? (! t/boolean?)) - (| t/byte? t/short? t/char? t/int? t/long? t/float? t/double?))) + (is= (& primitive? (! boolean?)) + (| byte? short? char? int? long? float? double?))) (testing "#{<+ =} -> #{=}" (is= (& i|>a+b i|>a0 i|a) i|a)) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 41386879..f3c83af5 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -834,7 +834,7 @@ - `(t/<> (t/tuple sheep? wheat?) animal?) - `(t/<> (t/map :requirement sheep? :extra0 wheat?) animal?) - `(t/<= (t/closed-map :requirement sheep? :extra0 wheat?) - (t/merge (t/closed-map :requirement animal?) (t/map-of t/keyword? t/any?))) + (t/merge (t/closed-map :requirement animal?) (t/map-of id/keyword? t/any?))) - `(t/<= (t/map :requirement sheep? :extra0 wheat?) (t/map :requirement animal?)) - Outputs @@ -846,7 +846,7 @@ - `(t/<> (t/tuple sheep? wheat?) animal?) - `(t/<> (t/map :guarantee sheep? :extra0 wheat?) animal?) - `(t/<= (t/closed-map :guarantee sheep? :extra0 wheat?) - (t/merge (t/closed-map :requirement animal?) (t/map-of t/keyword? t/any?))) + (t/merge (t/closed-map :requirement animal?) (t/map-of id/keyword? t/any?))) Contract non-satisfaction ('Breakage') is `>=|input` (input covariance) and `t/<=|output` (output contravariance) - Inputs From 0e05a78c675965ca82c765135127b204a9547ef0 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 19 Sep 2018 19:48:34 -0600 Subject: [PATCH 287/810] Move some code to quantum.core.data.array --- src/quantum/core/collections/core.cljc | 43 ---- src/quantum/core/data/array.cljc | 344 ++++++++++++------------- 2 files changed, 160 insertions(+), 227 deletions(-) diff --git a/src/quantum/core/collections/core.cljc b/src/quantum/core/collections/core.cljc index cc5c4d96..4afae350 100644 --- a/src/quantum/core/collections/core.cljc +++ b/src/quantum/core/collections/core.cljc @@ -499,49 +499,6 @@ #?(:clj (defalias ->!array-list ->!vector)) - -; TODO: `newUninitializeddArray` -; TODO boolean array doesn't work... ? -#?(:clj -(defmacro gen-arr<> [] - `(defnt' ~'arr<> - "Creates a 1-D array" - ~@(for [arglength (range 1 11) - kind '#{boolean byte char short int long float double Object}] - (let [arglist (vec (repeatedly arglength gensym)) - hints (vec (repeat arglength kind ))] - `(~(ufth/hint-arglist-with arglist hints) - (. quantum.core.data.Array ~(symbol (str "new1dArray")) ~@arglist))))))) - -#?(:clj (gen-arr<>)) - -; TODO generalize -#?(:clj -(defmacro gen-object<> [] - `(defnt' ~'object<> - "Creates a 1-D object array from the provided arguments" - ~@(for [arglength (range 1 11)] - (let [arglist (vec (repeatedly arglength gensym))] - `(~arglist - (. quantum.core.data.Array ~(symbol (str "new1dObjectArray")) ~@arglist))))))) - -#?(:clj (gen-object<>)) - -#?(:clj -(defmacro gen-array-nd [] - `(do ~@(for [kind '#{boolean byte char short int long float double object}] - `(defnt ~(symbol (str "->" kind "s-nd")) - ~(str "Creates an n-D " kind " array with the provided dims") - ~@(for [dim (range 1 11)] - (let [arglist (vec (repeatedly dim gensym)) - hints (apply core/vector 'long (repeat (dec dim) 'int))] ; first one should be long for protocol dispatch purposes - `(~(ufth/hint-arglist-with arglist hints) - (. quantum.core.data.Array - ~(symbol (str "newInitializedNd" (str/capitalize kind) "Array")) - ~@arglist))))))))) - -#?(:clj (gen-array-nd)) - (defnt elem->array ; TODO generate this #?(:clj ([^boolean x ^long n0 ] (->booleans-nd n0 ))) #?(:clj ([^boolean x ^long n0 ^long n1 ] (->booleans-nd n0 n1 ))) diff --git a/src/quantum/core/data/array.cljc b/src/quantum/core/data/array.cljc index 7825cb77..ff686c0a 100644 --- a/src/quantum/core/data/array.cljc +++ b/src/quantum/core/data/array.cljc @@ -7,45 +7,40 @@ quantum.core.data.array (:refer-clojure :exclude [== reverse boolean-array byte-array char-array short-array - int-array long-array float-array double-array - empty count get doseq assoc!]) + int-array long-array float-array double-array]) (:require [clojure.core :as core] -#?(:clj +#_(:clj [loom.alg-generic :as alg]) ; temporarily - [quantum.core.collections.core :as ccoll - :refer [empty count get assoc!]] - [quantum.core.type.core :as tcore] - [quantum.core.fn :as fn + #_[quantum.core.type.core :as tcore] + #_[quantum.core.fn :as fn :refer [fn->]] - [quantum.core.log :as log] - [quantum.core.logic :as logic - :refer [whenc whenc->]] - [quantum.core.error - :refer [TODO]] - [quantum.core.loops :as loops - :refer [doseqi doseq]] - [quantum.core.macros :as macros - :refer [defnt defnt']] - [quantum.core.macros.type-hint :as th] - [quantum.core.compare :as comp] - [quantum.core.numeric :as num] + #_[quantum.core.log :as log] + #_[quantum.core.macros.type-hint :as th] + #_[quantum.core.compare :as comp] + #_[quantum.core.numeric :as num] + [quantum.core.data.identifiers :as id] + [quantum.core.type :as t + :refer [defnt]] [quantum.core.vars :as var - :refer [defalias]]) + :refer [defalias]] + ;; TODO TYPED (?) + [quantum.untyped.core.form.generate :as ufgen]) #?(:cljs (:require-macros [quantum.core.data.array :as self])) #?(:clj (:import + [quantum.core.data Array] [java.io File FileInputStream BufferedInputStream InputStream ByteArrayOutputStream] [java.nio ByteBuffer] - java.util.ArrayList))) + [java.util ArrayList]))) (log/this-ns) #?(:clj -(defns >array-nd-type [kind c/symbol?, n unum/pos-int? > utr/class-type?] - (let [prefix (apply str (repeat n \[)) +(defnt >array-nd-type [kind id/symbol?, n num/pos-int? > t/class-type?] + (let [prefix (apply >str (repeat n \[)) letter (case kind boolean "Z" byte "B" @@ -56,80 +51,80 @@ float "F" double "D" object "Ljava.lang.Object;")] - (isa? (Class/forName (str prefix letter)))))) + (t/isa? (Class/forName (str prefix letter)))))) #?(:clj -(defns >array-nd-types [n unum/pos-int? > utr/type?] +(defnt >array-nd-types [n num/pos-int? > t/type?] (->> '[boolean byte char short int long float double object] (map #(>array-nd-type % n)) (apply or)))) - (-def booleans? #?(:clj (>array-nd-type 'boolean 1) :cljs none?)) - (-def bytes? #?(:clj (>array-nd-type 'byte 1) :cljs (isa? js/Int8Array))) - (-def ubytes? #?(:clj none? :cljs (isa? js/Uint8Array))) - (-def ubytes-clamped? #?(:clj none? :cljs (isa? js/Uint8ClampedArray))) - (-def chars? #?(:clj (>array-nd-type 'char 1) :cljs (isa? js/Uint16Array))) ; kind of - (-def shorts? #?(:clj (>array-nd-type 'short 1) :cljs (isa? js/Int16Array))) - (-def ushorts? #?(:clj none? :cljs (isa? js/Uint16Array))) - (-def ints? #?(:clj (>array-nd-type 'int 1) :cljs (isa? js/Int32Array))) - (-def uints? #?(:clj none? :cljs (isa? js/Uint32Array))) - (-def longs? #?(:clj (>array-nd-type 'long 1) :cljs none?)) - (-def floats? #?(:clj (>array-nd-type 'float 1) :cljs (isa? js/Float32Array))) - (-def doubles? #?(:clj (>array-nd-type 'double 1) :cljs (isa? js/Float64Array))) - (-def objects? #?(:clj (>array-nd-type 'object 1) :cljs (isa? js/Array))) - - (-def numeric-1d? (or bytes? ubytes? ubytes-clamped? - chars? - shorts? ushorts? ints? uints? longs? - floats? doubles?)) - - (-def array-1d? (or booleans? bytes? ubytes? ubytes-clamped? - chars? - shorts? ushorts? ints? uints? longs? - floats? doubles? objects?)) - -#?(:clj (-def booleans-2d? (>array-nd-type 'boolean 2))) -#?(:clj (-def bytes-2d? (>array-nd-type 'byte 2))) -#?(:clj (-def chars-2d? (>array-nd-type 'char 2))) -#?(:clj (-def shorts-2d? (>array-nd-type 'short 2))) -#?(:clj (-def ints-2d? (>array-nd-type 'int 2))) -#?(:clj (-def longs-2d? (>array-nd-type 'long 2))) -#?(:clj (-def floats-2d? (>array-nd-type 'float 2))) -#?(:clj (-def doubles-2d? (>array-nd-type 'double 2))) -#?(:clj (-def objects-2d? (>array-nd-type 'object 2))) - -#?(:clj (-def numeric-2d? (or bytes-2d? - chars-2d? - shorts-2d? ints-2d? longs-2d? - floats-2d? doubles-2d?))) - -#?(:clj (-def array-2d? (>array-nd-types 2 ))) - -#?(:clj (-def array-3d? (>array-nd-types 3 ))) -#?(:clj (-def array-4d? (>array-nd-types 4 ))) -#?(:clj (-def array-5d? (>array-nd-types 5 ))) -#?(:clj (-def array-6d? (>array-nd-types 6 ))) -#?(:clj (-def array-7d? (>array-nd-types 7 ))) -#?(:clj (-def array-8d? (>array-nd-types 8 ))) -#?(:clj (-def array-9d? (>array-nd-types 9 ))) -#?(:clj (-def array-10d? (>array-nd-types 10))) +(def booleans? #?(:clj (>array-nd-type 'boolean 1) :cljs t/none?)) +(def bytes? #?(:clj (>array-nd-type 'byte 1) :cljs (t/isa? js/Int8Array))) +(def ubytes? #?(:clj t/none? :cljs (t/isa? js/Uint8Array))) +(def ubytes-clamped? #?(:clj t/none? :cljs (t/isa? js/Uint8ClampedArray))) +(def chars? #?(:clj (>array-nd-type 'char 1) :cljs (t/isa? js/Uint16Array))) ; kind of +(def shorts? #?(:clj (>array-nd-type 'short 1) :cljs (t/isa? js/Int16Array))) +(def ushorts? #?(:clj t/none? :cljs (t/isa? js/Uint16Array))) +(def ints? #?(:clj (>array-nd-type 'int 1) :cljs (t/isa? js/Int32Array))) +(def uints? #?(:clj t/none? :cljs (t/isa? js/Uint32Array))) +(def longs? #?(:clj (>array-nd-type 'long 1) :cljs t/none?)) +(def floats? #?(:clj (>array-nd-type 'float 1) :cljs (t/isa? js/Float32Array))) +(def doubles? #?(:clj (>array-nd-type 'double 1) :cljs (t/isa? js/Float64Array))) +(def objects? #?(:clj (>array-nd-type 'object 1) :cljs (t/isa? js/Array))) + +(def numeric-1d? (t/or bytes? ubytes? ubytes-clamped? + chars? + shorts? ushorts? ints? uints? longs? + floats? doubles?)) + +(def array-1d? (t/or booleans? bytes? ubytes? ubytes-clamped? + chars? + shorts? ushorts? ints? uints? longs? + floats? doubles? objects?)) + +#?(:clj (def booleans-2d? (>array-nd-type 'boolean 2))) +#?(:clj (def bytes-2d? (>array-nd-type 'byte 2))) +#?(:clj (def chars-2d? (>array-nd-type 'char 2))) +#?(:clj (def shorts-2d? (>array-nd-type 'short 2))) +#?(:clj (def ints-2d? (>array-nd-type 'int 2))) +#?(:clj (def longs-2d? (>array-nd-type 'long 2))) +#?(:clj (def floats-2d? (>array-nd-type 'float 2))) +#?(:clj (def doubles-2d? (>array-nd-type 'double 2))) +#?(:clj (def objects-2d? (>array-nd-type 'object 2))) + +#?(:clj (def numeric-2d? (t/or bytes-2d? + chars-2d? + shorts-2d? ints-2d? longs-2d? + floats-2d? doubles-2d?))) + +#?(:clj (def array-2d? (>array-nd-types 2 ))) + +#?(:clj (def array-3d? (>array-nd-types 3 ))) +#?(:clj (def array-4d? (>array-nd-types 4 ))) +#?(:clj (def array-5d? (>array-nd-types 5 ))) +#?(:clj (def array-6d? (>array-nd-types 6 ))) +#?(:clj (def array-7d? (>array-nd-types 7 ))) +#?(:clj (def array-8d? (>array-nd-types 8 ))) +#?(:clj (def array-9d? (>array-nd-types 9 ))) +#?(:clj (def array-10d? (>array-nd-types 10))) ;; TODO differentiate between "all supported n-D arrays" and "all n-D arrays" - (-def objects-nd? (or objects? - #?@(:clj [(>array-nd-type 'object 2) - (>array-nd-type 'object 3) - (>array-nd-type 'object 4) - (>array-nd-type 'object 5) - (>array-nd-type 'object 6) - (>array-nd-type 'object 7) - (>array-nd-type 'object 8) - (>array-nd-type 'object 9) - (>array-nd-type 'object 10)]))) + (def objects-nd? (t/or objects? + #?@(:clj [(>array-nd-type 'object 2) + (>array-nd-type 'object 3) + (>array-nd-type 'object 4) + (>array-nd-type 'object 5) + (>array-nd-type 'object 6) + (>array-nd-type 'object 7) + (>array-nd-type 'object 8) + (>array-nd-type 'object 9) + (>array-nd-type 'object 10)]))) ;; TODO differentiate between "all supported n-D arrays" and "all n-D arrays" - (-def array? (or array-1d? - #?@(:clj [array-2d? array-3d? array-4d? array-5d? - array-6d? array-7d? array-8d? array-9d? array-10d?]))) + (def array? (t/or array-1d? + #?@(:clj [array-2d? array-3d? array-4d? array-5d? + array-6d? array-7d? array-8d? array-9d? array-10d?]))) ; TODO look at http://fastutil.di.unimi.it to complete this namespace ; TODO `fill!` <~> `Arrays/fill`, `lodash/fill` @@ -155,110 +150,91 @@ n-sym (-> 'n gensym (th/with-type-hint 'nat-int?))] `(defnt ~fn-sym ([~n-sym] (core-sym ~n-sym))))))) -; ----- BOOLEAN ARRAY ----- ; +; TODO: `newUninitializeddArray` +; TODO boolean array doesn't work... ? #?(:clj -(defnt boolean-array [^int n] - (if (> n Integer/MAX_VALUE) - (it.unimi.dsi.fastutil.booleans.BooleanBigArrays/newBigArray 1) - (core/boolean-array n)))) - -; ----- BYTE ARRAY ----- ; - -#?(:clj (defalias byte-array core/byte-array) - :cljs (defn byte-array [length] (js/Int8Array. length))) +(defmacro gen-arr<> [] + `(defnt' ~'arr<> + "Creates a 1-D array" + ~@(for [arglength (range 1 11) + kind '#{boolean byte char short int long float double Object}] + (let [arglist (vec (repeatedly arglength gensym)) + hints (vec (repeat arglength kind ))] + `(~(ufth/hint-arglist-with arglist hints) + (. quantum.core.data.Array ~(symbol (str "new1dArray")) ~@arglist))))))) + +#?(:clj (gen-arr<>)) #?(:clj - (defn ^"[B" - byte-array+ - "Like /byte-array/ but allows for array initializers a la Java: - byte[] arr = byte[]{12, 8, 10}" - {:attribution "alexandergunnarson" - :todo ["Make less repetitive via macro"]} - ([size] - (byte-array (long size))) - ([size & args] - (let [^"[B" arr (byte-array (long size))] - (doseqi [arg args n] - (assoc! arr n (-> arg first byte))) - arr)))) - -; ----- INT ARRAY ----- ; +(defmacro gen-array-nd [] + `(do ~@(for [kind '#{boolean byte char short int long float double object}] + `(defnt ~(symbol (str "->" kind "s-nd")) + ~(str "Creates an n-D " kind " array with the provided dims") + ~@(for [dim (range 1 11)] + (let [arglist (vec (repeatedly dim gensym)) + hints (apply core/vector 'long (repeat (dec dim) 'int))] ; first one should be long for protocol dispatch purposes + `(~(ufth/hint-arglist-with arglist hints) + (. quantum.core.data.Array + ~(symbol (str "newInitializedNd" (str/capitalize kind) "Array")) + ~@arglist))))))))) + +#?(:clj (gen-array-nd)) + +;; ----- Booleans ----- ;; #?(:clj - (defn ^ints int-array+ - "Like /int-array/ but allows for array initializers a la Java: - int[] arr = int[]{12, 8, 10}" - {:attribution "alexandergunnarson" - :todo ["Make less repetitive via macro"]} - ([size] - (core/int-array (long size))) - ([size & args] - (let [^ints arr (core/int-array (long size))] - (doseqi [arg args n] - (assoc! arr (long n) (-> arg first int))) - arr)))) - -; TODO: Use a macro for this +(defnt ^:inline >boolean-array + ([n num/numerically-int? > booleans?] (Array/newUninitialized1dBooleanArray (>int n))) + ([n num/numerically-long? > big-booleans?] + (it.unimi.dsi.fastutil.booleans.BooleanBigArrays/newBigArray (>long n))))) + +;; ----- Bytes ----- ;; + +(defnt ^:inline >byte-array + ([n num/numerically-int? > bytes?] + (#?(:clj Array/newUninitialized1dByteArray :cljs js/Int8Array.) (>int n))) + #?(:clj ([n num/numerically-long? > big-bytes?] + (it.unimi.dsi.fastutil.bytes.ByteBigArrays/newBigArray (>long n))))) + +;; ----- Shorts ----- ;; + +;; TODO + +;; ----- Chars ----- ;; + +;; TODO + +;; ----- Ints ----- ;; + +;; TODO + +;; ----- Longs ----- ;; + +;; TODO + +;; ----- Floats ----- ;; + +;; TODO + +;; ----- Doubles ----- ;; + +;; TODO + +;; ----- Objects ----- ;; + #?(:clj - (defn long-array-of - "Creates a long array with the specified values." - {:attribution "mikera.cljutils.arrays"} - (^longs [] (core/long-array 0)) - (^longs [a] - (let [arr (core/long-array 1)] - (assoc! arr 0 (long a)) - arr)) - ([a b] - (let [arr (core/long-array 2)] - (assoc! arr 0 (long a)) - (assoc! arr 1 (long b)) - arr)) - ; ([a b & more] - ; (let [arr (long-array (+ 2 (count more)))] - ; (assoc! arr 0 (long a)) - ; (assoc! arr 1 (long b)) - ; (doseqi [x more i] (assoc! arr (+ 2 i) (long x))) - ; arr)) - )) - -; ----- OBJECT ARRAY ----- ; - -; TODO: Use a macro for this -#_(:clj - (defn object-array-of - "Creates an object array with the specified values." - {:attribution "mikera.cljutils.arrays"} - ([] (ccoll/->object-array 0)) - ([a] - (let [arr (ccoll/->object-array 1)] - (assoc! arr 0 a) - arr)) - ([a b] - (let [arr (ccoll/->object-array 2)] - (assoc! arr 0 a) - (assoc! arr 1 b) - arr)) - ([a b c] - (let [arr (ccoll/->object-array 3)] - (assoc! arr 0 a) - (assoc! arr 1 b) - (assoc! arr 2 c) - arr)) - ([a b c d] - (let [arr (ccoll/->object-array 4)] - (assoc! arr 0 a) - (assoc! arr 1 b) - (assoc! arr 2 c) - (assoc! arr 3 d) - arr)) - ; ([a b & more] - ; (let [arr (object-array (+ 2 (count more)))] - ; (assoc! arr 0 a) - ; (assoc! arr 1 b) - ; (doseqi [x more i] (assoc! arr (+ 2 i) x)) - ; arr)) - )) +(defmacro gen-object<> [] + `(defnt ~'object<> + "Creates a 1-D object array from the provided arguments" + ~'> objects? + ~@(for [arglength (range 0 1)] + (let [arglist (ufgen/gen-args 0 arglength "x" symbol)] + `(~arglist (. Array ~'new1dObjectArray ~@arglist))))))) + + + +(gen-object<>) ; ===== BITMAPS ===== ; From c08ef01041805301d89ebfeb2259e8a52851c67a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 19 Sep 2018 19:48:49 -0600 Subject: [PATCH 288/810] simplify `quantum.core.data.map` code --- src/quantum/core/data/map.cljc | 35 +++++++++++++++------------------- 1 file changed, 15 insertions(+), 20 deletions(-) diff --git a/src/quantum/core/data/map.cljc b/src/quantum/core/data/map.cljc index 2376c7d4..299ed439 100644 --- a/src/quantum/core/data/map.cljc +++ b/src/quantum/core/data/map.cljc @@ -8,13 +8,14 @@ ;; TODO TYPED #_[quantum.core.reducers :as r :refer [reduce-pair]] - [quantum.core.type :as t] + [quantum.core.type :as t + :refer [defnt]] [quantum.untyped.core.data.map :as umap] + ;; TODO TYPED [quantum.untyped.core.defnt :refer [defns-]] [quantum.untyped.core.type :as ut] - [quantum.untyped.core.type.defnt - :refer [defnt]] + ;; TODO TYPED [quantum.untyped.core.vars :refer [defalias def- defmacro-]]) (:import @@ -113,38 +114,34 @@ On JS, this is a `js/Map` (ECMAScript 6 Map)." > !identity-map? ([] #?(:clj (IdentityHashMap.) :cljs (js/Map.))) - ([k0 (t/ref t/any?), v0 (t/ref t/any?)] + ([k0 t/ref?, v0 t/ref?] (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0))) - ([k0 (t/ref t/any?), v0 (t/ref t/any?), k1 (t/ref t/any?), v1 (t/ref t/any?)] + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?] (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0) (#?(:clj .put :cljs .set) k1 v1))) - ([k0 (t/ref t/any?), v0 (t/ref t/any?), k1 (t/ref t/any?), v1 (t/ref t/any?) - k2 (t/ref t/any?), v2 (t/ref t/any?)] + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?] (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0) (#?(:clj .put :cljs .set) k1 v1) (#?(:clj .put :cljs .set) k2 v2))) - ([k0 (t/ref t/any?), v0 (t/ref t/any?), k1 (t/ref t/any?), v1 (t/ref t/any?) - k2 (t/ref t/any?), v2 (t/ref t/any?), k3 (t/ref t/any?), v3 (t/ref t/any?)] + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?, k3 t/ref?, v3 t/ref?] (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0) (#?(:clj .put :cljs .set) k1 v1) (#?(:clj .put :cljs .set) k2 v2) (#?(:clj .put :cljs .set) k3 v3))) - ([k0 (t/ref t/any?), v0 (t/ref t/any?), k1 (t/ref t/any?), v1 (t/ref t/any?) - k2 (t/ref t/any?), v2 (t/ref t/any?), k3 (t/ref t/any?), v3 (t/ref t/any?) - k4 (t/ref t/any?), v4 (t/ref t/any?)] + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?, k3 t/ref?, v3 t/ref? + k4 t/ref?, v4 t/ref?] (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0) (#?(:clj .put :cljs .set) k1 v1) (#?(:clj .put :cljs .set) k2 v2) (#?(:clj .put :cljs .set) k3 v3) (#?(:clj .put :cljs .set) k4 v4))) - ([k0 (t/ref t/any?), v0 (t/ref t/any?), k1 (t/ref t/any?), v1 (t/ref t/any?) - k2 (t/ref t/any?), v2 (t/ref t/any?), k3 (t/ref t/any?), v3 (t/ref t/any?) - k4 (t/ref t/any?), v4 (t/ref t/any?), k5 (t/ref t/any?), v5 (t/ref t/any?)] + ([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?, k3 t/ref?, v3 t/ref? + k4 t/ref?, v4 t/ref?, k5 t/ref?, v5 t/ref?] (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) (#?(:clj .put :cljs .set) k0 v0) (#?(:clj .put :cljs .set) k1 v1) @@ -153,10 +150,8 @@ (#?(:clj .put :cljs .set) k4 v4) (#?(:clj .put :cljs .set) k5 v5))) ;; TODO TYPED handle varargs -#_([k0 (t/ref t/any?), v0 (t/ref t/any?), k1 (t/ref t/any?), v1 (t/ref t/any?) - k2 (t/ref t/any?), v2 (t/ref t/any?), k3 (t/ref t/any?), v3 (t/ref t/any?) - k4 (t/ref t/any?), v4 (t/ref t/any?), k5 (t/ref t/any?), v5 (t/ref t/any?) - k6 (t/ref t/any?), v6 (t/ref t/any?) & kvs _] +#_([k0 t/ref?, v0 t/ref?, k1 t/ref?, v1 t/ref?, k2 t/ref?, v2 t/ref?, k3 t/ref?, v3 t/ref? + k4 t/ref?, v4 t/ref?, k5 t/ref?, v5 t/ref?, k6 t/ref?, v6 t/ref? & kvs _] (reduce-pair (fn [#?(:clj ^IdentityHashMap m :cljs m) k v] (doto m (#?(:clj .put :cljs .set) k v))) (doto #?(:clj (IdentityHashMap.) :cljs (js/Map.)) @@ -1075,7 +1070,7 @@ ([] (clojure.data.int_map.PersistentIntMap. clojure.data.int_map.Nodes$Empty/EMPTY 0 nil)) ;; TODO TYPED handle varargs ;; TODO TYPED `assoc`, `t/nneg-int?` -#_([k t/nneg-int? v (t/ref t/any?)] (assoc (>unsorted-map|long->ref) k v)) +#_([k t/nneg-int? v t/ref?] (assoc (>unsorted-map|long->ref) k v)) ;; TODO TYPED handle calling other typed fns #_([kv & kvs] (apply assoc (>hash-map|long->ref) k v kvs)))) From 056c3d385ec497b94bb25955983109ca40524c40 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 19 Sep 2018 19:48:56 -0600 Subject: [PATCH 289/810] Add `quantum.core.data.meta` --- src/quantum/core/data/meta.cljc | 51 +++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) create mode 100644 src/quantum/core/data/meta.cljc diff --git a/src/quantum/core/data/meta.cljc b/src/quantum/core/data/meta.cljc new file mode 100644 index 00000000..c5ed681a --- /dev/null +++ b/src/quantum/core/data/meta.cljc @@ -0,0 +1,51 @@ +(ns quantum.core.data.meta + "Functions related to metadata." + (:refer-clojure :exclude + [reset-meta! with-meta]) + (:require + [quantum.core.data.map :as map] + [quantum.core.type :as t + :refer [defnt]])) + +(def meta? (t/? map/+map?)) +(def metable? (t/isa? #?(:clj clojure.lang.IMeta :cljs cljs.core/IMeta))) +(def with-metable? (t/isa? #?(:clj clojure.lang.IObj :cljs cljs.core/IWithMeta))) + +(defnt >meta + "Returns the (possibly nil) metadata of ->`x`." + > meta? + [x metable?] (#?(:clj .meta :cljs cljs.core/-meta) x)) + +(defnt with-meta + "Returns an object of the same type and value as ->`x`, with ->`meta'` as its metadata." + > with-metable? + ([x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))] + (#?(:clj .withMeta :cljs cljs.core/-with-meta) x meta')) + #?(:cljs ([x goog/isFunction, meta' meta?] + (cljs.core/MetaFn. x meta')))) + +(defnt reset-meta! + "Atomically resets ->`x`'s metadata to be ->`meta'`." + > meta? + [x (t/isa? #?(:clj clojure.lang.IReference :cljs (TODO))) meta' meta?] + (#?(:clj .resetMeta :cljs (set! (.-meta x) m)) x meta')) + +;; TODO TYPED +#_(defnt update-meta + "Returns an object of the same type and value as ->`x`, with its metadata updated by ->`f`." + ;; TODO `f` should more specifically be able to handle the args arity and specs + [x (t/and with-metable? metable?) f (t/fn meta? [& (t/type-of %args)]) & args _] + (with-meta x (apply f (meta x) args))) + +;; TODO TYPED +#_(defnt merge-meta + {:alternate-implementations #{'cljs.tools.reader/merge-meta}} + [x (t/and with-metable? metable?) meta- meta? > (t/spec-of x)] + (update-meta x merge meta-)) + +;; TODO TYPED +#_(defnt merge-meta-from [to (t/and with-metable? metable?), from metable?] + (update-meta to merge (>meta from))) + +(defnt replace-meta-from > with-metable? [to with-metable?, from metable?] + (with-meta to (>meta from))) From a4b96f0a409d431bd7c32becb0d3470c2408a8f1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 19 Sep 2018 19:49:03 -0600 Subject: [PATCH 290/810] quantum.core.ns -> quantum.core.vars --- src/quantum/core/ns.cljc | 178 ---------------------- src/quantum/core/vars.cljc | 297 +++++++++++++++++++++++++++---------- 2 files changed, 216 insertions(+), 259 deletions(-) delete mode 100644 src/quantum/core/ns.cljc diff --git a/src/quantum/core/ns.cljc b/src/quantum/core/ns.cljc deleted file mode 100644 index bcc4840a..00000000 --- a/src/quantum/core/ns.cljc +++ /dev/null @@ -1,178 +0,0 @@ -(ns - ^{:doc "Functions related to namespace access and manipulation." - :attribution "alexandergunnarson"} - quantum.core.ns - (:refer-clojure :exclude - [ns loaded-libs]) - (:require - ;; TODO TYPED remove reference to `clojure.core` - [clojure.core :as core] - [quantum.core.type :as t - :refer [defnt]] - ;; TODO TYPED remove reference to `quantum.untyped.core.ns` - [quantum.untyped.core.ns :as uns] - ;; TODO TYPED remove reference to `quantum.untyped.core.vars` - [quantum.untyped.core.vars :as uvar - :refer [defalias defaliases]])) - -#?(:clj (def namespace? (t/isa? clojure.lang.Namespace))) - -;; TODO TYPED -#?(:clj (defalias core/ns)) - -#?(:clj -(defnt >?ns - "Supersedes `clojure.core/find-ns`." - [x t/symbol? > (t/? namespace?)] (clojure.lang.Namespace/find x))) - -#?(:clj -(defnt >ns - "Supersedes `clojure.core/the-ns`." - ([x namespace? > namespace?] x) - ([x t/symbol? > (t/* namespace?)] (>?ns x)))) - -;; TODO TYPED finish `t/unqualified-symbol?` -#_(:clj -(defnt unmap! - "Removes the mapping for the symbol from the namespace and outputs the namespace. - - Supersedes `clojure.core/ns-unmap`." - [ns-val namespace?, sym t/unqualified-symbol? > namespace?] - (.unmap ns-val sym) - ns-val)) - -#?(:clj (def in in-ns)) - -;; TODO TYPED finish `t/of` -#_(:clj -(defnt all - "Returns a sequence of all namespaces." - [> (t/assume (t/of t/seq? namespace?))] (clojure.lang.Namespace/all))) - -;; ===== Creation/Destruction ===== ;; - -#?(:clj -(defnt create! - "Creates a new namespace named by the symbol if one doesn't already exist. Returns it or the - already-existing namespace of the same name. - - Supersedes `clojure.core/create-ns`." - [x t/symbol? > (t/* namespace?)] (clojure.lang.Namespace/findOrCreate x))) - -#?(:clj -(defnt remove! - "Removes the namespace named by the symbol. Use with caution. Cannot be used to remove the - `clojure.core` namespace." - [x t/symbol? > (t/* namespace?)] (clojure.lang.Namespace/remove x))) - -;; ===== Modification ===== ;; - -#?(:clj -(defnt alias! - "Add an alias to another namespace in the destination namespace. Returns the destination - namespace. This corresponds roughly to the `:as` directive in the ns macro. - - Supersedes `clojure.core/alias`." - [dest-ns namespace?, alias-sym t/symbol?, ns-to-alias namespace?] - (.addAlias dest-ns alias-sym ns-to-alias) - dest-ns)) - -#?(:clj -(defnt unalias! - "Removes the alias as designated by `alias-sym` from the namespace." - [ns-val namespace?, alias-sym t/symbol?] - (.removeAlias ns-val alias-sym) - ns-val)) - -;; TODO TYPED -#?(:clj (defalias require! core/require)) - -;; TODO TYPED -#?(:clj (defalias import! core/import)) - -;; TODO TYPED -#?(:clj (defalias refer! core/refer)) - -;; TODO TYPED -#?(:clj (defalias refer-clojure! core/refer-clojure)) - -;; ===== Mappings ===== ;; - -;; TODO TYPED finish `t/of`, `t/unqualified-symbol?` -#_(:clj -(defnt ns>mappings - "Supersedes `clojure.core/ns-map`." - [x namespace? > (t/assume (t/of ut/+map? t/unqualified-symbol? (t/or t/var? t/class?)))] - (.getMappings x))) - -;; TODO TYPED finish `t/of`, `t/unqualified-symbol?` -#_(:clj -(defnt ns>alias-map - "Outputs the alias->namespace mappings for the namespace. - - Supersedes `clojure.core/ns-aliases`." - [x namespace? > (t/assume (t/of ut/+map? t/unqualified-symbol? namespace?))] - (.getAliases x))) - -;; TODO TYPED finish `t/of`, `t/unqualified-symbol?`, decide on `filter-vals'`? -#_(:clj -(defnt ns>imports - "Outputs the import-mappings for the namespace. - - Supersedes `clojure.core/ns-imports`." - [x namespace? > (t/assume (t/of ut/+map? t/unqualified-symbol? t/class?))] - (->> x (filter-vals' t/class?)))) - -;; TODO TYPED finish `t/of`, `t/unqualified-symbol?`, decide on `filter-vals'`? -#_(:clj -(defnt ns>interns - "Outputs the intern-mappings for the namespace. - - Supersedes `clojure.core/ns-interns`." - [ns-val namespace? > (t/assume (t/of ut/+map? t/unqualified-symbol? t/var?))] - (->> ns-val - ns>mappings - (filter-vals' (fn [^clojure.lang.Var v] (and (t/var? v) (= ns-val (.ns v)))))))) - -;; TODO TYPED finish `t/of`, `t/unqualified-symbol?`, decide on `filter-vals'`? -#_(:clj -(defnt ns>publics - "Outputs the public intern-mappings for the namespace. - - Supersedes `clojure.core/ns-publics`." - [ns-val namespace? > (t/assume (t/of ut/+map? t/unqualified-symbol? t/var?))] - (->> ns-val - ns>interns - (filter-vals' (fn [^clojure.lang.Var v] (.isPublic v)))))) - -;; TODO TYPED finish `t/of`, `t/unqualified-symbol?`, decide on `remove-vals'`? -#_(:clj -(defnt ns>refers - "Outputs the refer-mappings for the namespace. - - Supersedes `clojure.core/ns-refers`." - [ns-val namespace? > (t/assume (t/of ut/+map? t/unqualified-symbol? t/var?))] - (->> ns-val - ns>mappings - (remove-vals' (fn [^clojure.lang.Var v] (and (t/var? v) (= ns-val (.ns v)))))))) - -#?(:clj -(defnt alias>?ns [src-ns namespace?, sym t/symbol? > (t/? namespace?)] (.lookupAlias src-ns sym))) - -;; TODO TYPED -#?(:clj -(defaliases uns - ns>alias ns-name>alias clear-ns-interns! search-var ns-exclude with-ns with-temp-ns import-static - load-ns load-nss loaded-libs load-lib! load-package! load-dep! assert-ns-aliased)) - -;; TODO TYPED — enable -#_(:clj -(defn alias-ns - "Create vars in the current namespace to alias each of the public vars in - the supplied namespace. - Takes a symbol." - {:attribution "flatland.useful.ns"} - [ns-name-] - (require ns-name-) - (doseq [[name var] (ns>publics (the-ns ns-name-))] - (uvar/alias-var name var)))) diff --git a/src/quantum/core/vars.cljc b/src/quantum/core/vars.cljc index 6e164489..94abd061 100644 --- a/src/quantum/core/vars.cljc +++ b/src/quantum/core/vars.cljc @@ -1,105 +1,159 @@ (ns quantum.core.vars - "Functions related to vars and metadata." - (:refer-clojure :exclude - [binding defonce intern meta reset-meta! var? with-local-vars with-meta]) - (:require - ;; TODO TYPED remove reference to `clojure.core` - [clojure.core :as c] - [quantum.core.data.map :as map] - [quantum.core.ns :as ns] - [quantum.core.type :as t - :refer [defnt]] - ;; TODO TYPED remove reference to `quantum.untyped.core.vars` - [quantum.untyped.core.type :as ut] - [quantum.untyped.core.vars :as uvar]) -#?(:cljs (:require-macros - [quantum.core.vars :as this]))) - -#?(:clj (def var? t/var?)) - -;; ===== Meta ===== ;; - -(def meta? (t/? map/+map?)) - -(defnt meta - "Returns the (possibly nil) metadata of ->`x`." - > meta? - [x t/metable?] (#?(:clj .meta :cljs cljs.core/-meta) x)) - -(defnt with-meta - "Returns an object of the same type and value as ->`x`, with ->`meta'` as its metadata." - > t/with-metable? - ([x t/with-metable?, meta' meta? > (t/* t/with-metable?) #_(TODO TYPED (t/value-of x))] - (#?(:clj .withMeta :cljs cljs.core/-with-meta) x meta')) - #?(:cljs ([x goog/isFunction, meta' meta?] - (cljs.core/MetaFn. x meta')))) - -(defnt reset-meta! - "Atomically resets ->`x`'s metadata to be ->`meta'`." - > meta? - [x (t/isa? #?(:clj clojure.lang.IReference :cljs (TODO))) meta' meta?] - (#?(:clj .resetMeta :cljs (set! (.-meta x) m)) x meta')) + "Functions related to vars and their enclosing namespaces. + + We colocate namespace and var functions because namespaces cannot exist separately from vars: + for instance, namespace-mapping values are either vars or classes, and vars exist only in the + context of an enclosing namespace." + (:refer-clojure :exclude + [binding defonce intern loaded-libs ns var? with-local-vars]) + (:require + ;; TODO TYPED remove reference to `clojure.core` + [clojure.core :as core] + [quantum.core.data.identifiers :as id] + [quantum.core.data.meta :as dm + :refer [>meta]] + [quantum.core.type :as t] + ;; TODO TYPED remove reference to `quantum.untyped.core.ns` + [quantum.untyped.core.ns :as uns] + ;; TODO TYPED remove reference to `quantum.untyped.core.vars` + [quantum.untyped.core.vars :as uvar])) + +;; ===== Namespaces ===== ;; + +#?(:clj (def namespace? (t/isa? clojure.lang.Namespace))) + +;; TODO TYPED +#?(:clj (defalias core/ns)) + +#?(:clj +(t/defn >?ns + "Supersedes `clojure.core/find-ns`." + [x id/symbol? > (t/? namespace?)] (clojure.lang.Namespace/find x))) + +#?(:clj +(t/defn >ns + "Supersedes `clojure.core/the-ns`." + ([x namespace? > namespace?] x) + ([x id/symbol? > (t/* namespace?)] (>?ns x)))) + +#?(:clj (t/extend-defn! id/>name (^:inline [x namespace?] (-> x .getName id/>name)))) + +;; TODO TYPED finish `id/unqualified-symbol?` +#_(:clj +(t/defn unmap! + "Removes the mapping for the symbol from the namespace and outputs the namespace. + + Supersedes `clojure.core/ns-unmap`." + [ns-val namespace?, sym id/unqualified-symbol? > namespace?] + (.unmap ns-val sym) + ns-val)) + +;; `in-ns` cannot be shadowed +#?(:clj (def in-ns in-ns)) + +;; TODO TYPED finish `t/of` +#_(:clj +(t/defn all-ns + "Returns a `traversable?` of all namespaces." + [> (t/assume (t/of namespace?))] (clojure.lang.Namespace/all))) + +;; ===== Creation/Destruction ===== ;; + +#?(:clj +(t/defn create-ns! + "Creates a new namespace named by the symbol if one doesn't already exist. Returns it or the + already-existing namespace of the same name. + + Supersedes `clojure.core/create-ns`." + [x id/symbol? > (t/* namespace?)] (clojure.lang.Namespace/findOrCreate x))) + +#?(:clj +(t/defn remove-ns! + "Removes the namespace named by the symbol. Use with caution. Cannot be used to remove the + `clojure.core` namespace." + [x id/symbol? > (t/* namespace?)] (clojure.lang.Namespace/remove x))) + +;; ===== Modification ===== ;; + +#?(:clj +(t/defn alias! + "Add an alias to another namespace in the destination namespace. Returns the destination + namespace. This corresponds roughly to the `:as` directive in the ns macro. + + Supersedes `clojure.core/alias`." + [dest-ns namespace?, alias-sym id/symbol?, ns-to-alias namespace?] + (.addAlias dest-ns alias-sym ns-to-alias) + dest-ns)) + +#?(:clj +(t/defn unalias! + "Removes the alias as designated by `alias-sym` from the namespace." + [ns-val namespace?, alias-sym id/symbol?] + (.removeAlias ns-val alias-sym) + ns-val)) ;; TODO TYPED -#_(defnt update-meta - "Returns an object of the same type and value as ->`x`, with its metadata updated by ->`f`." - ;; TODO `f` should more specifically be able to handle the args arity and specs - [x (t/and t/with-metable? t/metable?) f (t/fn meta? [& (t/type-of %args)]) & args _] - (with-meta x (apply f (meta x) args))) +#?(:clj (defalias require! core/require)) ;; TODO TYPED -#_(defnt merge-meta - {:alternate-implementations #{'cljs.tools.reader/merge-meta}} - [x (t/and t/with-metable? t/metable?) meta- meta? > (t/spec-of x)] - (update-meta x merge meta-)) +#?(:clj (defalias import! core/import)) ;; TODO TYPED -#_(defnt merge-meta-from [to (t/and t/with-metable? t/metable?), from t/metable?] - (update-meta to merge (meta from))) +#?(:clj (defalias refer! core/refer)) -(defnt replace-meta-from > t/with-metable? [to t/with-metable?, from t/metable?] - (with-meta to (meta from))) +;; TODO TYPED +#?(:clj (defalias refer-clojure! core/refer-clojure)) -;; ===== Declaration/Interning ===== ;; +;; ===== Vars ===== ;; + +(def var? (t/isa? #?(:clj clojure.lang.Var :cljs cljs.core/Var))) + +#?(:clj (t/extend-defn! id/>name (^:inline [x var?] (-> x >meta :name id/>name)))) +#?(:clj (t/extend-defn! id/>namespace (^:inline [x var?] (-> x >meta :ns id/>name)))) +#?(:clj (t/extend-defn! id/>symbol (^:inline [x var?] + (id/>symbol (id/>namespace x) (id/>name x))))) + +;; ---- Var declaration/interning ----- ;; #?(:clj -(defnt intern +(t/defn intern "Finds or creates a var named by the symbol name in ->`ns-val`, setting its root binding to ->`v` if supplied. The namespace must exist. The var will adopt any metadata from ->`name-val`. Returns the var." - > t/var? - ([ns-val (t/or t/symbol? ns/namespace?), var-name t/symbol? > (t/* t/var?)] - (let [var-ref (clojure.lang.Var/intern (ns/>ns ns-val) var-name)] - (when (meta var-name) (.setMeta var-ref (meta var-name))) + > var? + ([ns-val (t/or id/symbol? namespace?), var-name id/symbol? > (t/* var?)] + (let [var-ref (clojure.lang.Var/intern (>ns ns-val) var-name)] + (when (>meta var-name) (.setMeta var-ref (>meta var-name))) var-ref)) - ([ns-val (t/or t/symbol? ns/namespace?), var-name t/symbol?, var-val (t/ref t/any?) > (t/* t/var?)] - (let [var-ref (clojure.lang.Var/intern (ns/>ns ns-val) var-name var-val)] - (when (meta var-name) (.setMeta var-ref (meta var-name))) + ([ns-val (t/or id/symbol? namespace?), var-name id/symbol?, var-val t/ref? > (t/* var?)] + (let [var-ref (clojure.lang.Var/intern (>ns ns-val) var-name var-val)] + (when (>meta var-name) (.setMeta var-ref (>meta var-name))) var-ref)))) ;; TODO TYPED +;; Note that `def` can never be shadowed #?(:clj (uvar/defalias uvar/def)) ;; TODO TYPED #?(:clj (uvar/defaliases uvar defalias defaliases defaliases')) -#?(:clj (defnt defined? [x t/var?] (.hasRoot x))) +#?(:clj (t/defn var-defined? [x var?] (.hasRoot x))) -;; TODO TYPED — need to do `apply`, and `apply` with defnt; also `merge`, `str`, `deref` +;; TODO TYPED — need to do `apply`, and `apply` with t/defn; also `merge`, `str`, `deref` #_(:clj -(defnt alias-var +(t/defn alias-var "Create a var with the supplied name in the current namespace, having the same metadata and root-binding as the supplied var." {:attribution "flatland.useful.ns" :contributors ["Alex Gunnarson"]} - [sym t/symbol?, var-val t/var?] + [sym id/symbol?, var-val var?] (apply intern *ns* - (with-meta sym + (dm/with-meta sym (merge {:dont-test - (str "Alias of " (-> var-val meta :name))} - (meta var-0) - (meta sym))) + (str "Alias of " (-> var-val >meta :name))} + (>meta var-0) + (>meta sym))) (when (defined? var-) [(deref var-val)])))) ;; TODO TYPED @@ -108,39 +162,120 @@ ;; TODO TYPED #?(:clj (defaliases uvar defonce def- defmacro-)) -;; ===== Modification ===== ;; +;; ----- Var modification ----- ;; ;; TODO TYPED — need to do `fnt` #_(:clj -(defnt reset-var! +(t/defn reset-var! "Like `reset!` but for vars. Atomically sets the root binding of ->`var-` to ->`v`." {:attribution "alexandergunnarson"} - [var-val t/var?, v (t/ref t/any?) > t/var?] + [var-val var?, v t/ref? > var?] (.alterRoot var-val (fnt [_] v)))) ;; TODO TYPED — need to do `fnt`, `apply` #_(:clj -(defnt update-var! +(t/defn update-var! {:attribution "alexandergunnarson"} - ([var- t/var?, f (t/fn [_]) > t/var?] + ([var- var?, f (t/fn [_]) > var?] (do (.alterRoot var- f) var-)) ;; TODO we need to be able to conditionalize `f`'s arity based on the count of `args` - ([var- f t/fn? & args (? t/seq?) > t/var?] + ([var- f t/fn? & args (? t/seq?) > var?] (do (.alterRoot var- (fnt [v' _] (apply f v' args))) var-)))) ;; TODO TYPED — `doseq` #_(:clj -(defnt clear-vars! +(t/defn clear-vars! "Sets each var in ->`vars` to nil." {:attribution "alexandergunnarson"} - [& vars (? (t/seq-of t/var?))] + [& vars (? (t/seq-of var?))] (doseq [v vars] (reset-var! v nil)))) -;; ===== Thread-local ===== ;; +;; ----- Thread-local ----- ;; ;; TODO TYPED -#?(:clj (defalias binding c/binding)) +#?(:clj (defalias binding core/binding)) ;; TODO TYPED -#?(:clj (defalias with-local-vars c/with-local-vars)) +#?(:clj (defalias with-local-vars core/with-local-vars)) + +;; ----- Mappings ----- ;; + +;; TODO TYPED finish `t/of`, `id/unqualified-symbol?` +#_(:clj +(t/defn ns>mappings + "Supersedes `clojure.core/ns-map`." + [x namespace? > (t/assume (t/of ut/+map? id/unqualified-symbol? (t/or var? t/class?)))] + (.getMappings x))) + +;; TODO TYPED finish `t/of`, `id/unqualified-symbol?` +#_(:clj +(t/defn ns>alias-map + "Outputs the alias->namespace mappings for the namespace. + + Supersedes `clojure.core/ns-aliases`." + [x namespace? > (t/assume (t/of ut/+map? id/unqualified-symbol? namespace?))] + (.getAliases x))) + +;; TODO TYPED finish `t/of`, `id/unqualified-symbol?`, decide on `filter-vals'`? +#_(:clj +(t/defn ns>imports + "Outputs the import-mappings for the namespace. + + Supersedes `clojure.core/ns-imports`." + [x namespace? > (t/assume (t/of ut/+map? id/unqualified-symbol? t/class?))] + (->> x (filter-vals' t/class?)))) + +;; TODO TYPED finish `t/of`, `id/unqualified-symbol?`, decide on `filter-vals'`? +#_(:clj +(t/defn ns>interns + "Outputs the intern-mappings for the namespace. + + Supersedes `clojure.core/ns-interns`." + [ns-val namespace? > (t/assume (t/of ut/+map? id/unqualified-symbol? var?))] + (->> ns-val + ns>mappings + (filter-vals' (fn [^clojure.lang.Var v] (and (var? v) (= ns-val (.ns v)))))))) + +;; TODO TYPED finish `t/of`, `id/unqualified-symbol?`, decide on `filter-vals'`? +#_(:clj +(t/defn ns>publics + "Outputs the public intern-mappings for the namespace. + + Supersedes `clojure.core/ns-publics`." + [ns-val namespace? > (t/assume (t/of ut/+map? id/unqualified-symbol? var?))] + (->> ns-val + ns>interns + (filter-vals' (fn [^clojure.lang.Var v] (.isPublic v)))))) + +;; TODO TYPED finish `t/of`, `id/unqualified-symbol?`, decide on `remove-vals'`? +#_(:clj +(t/defn ns>refers + "Outputs the refer-mappings for the namespace. + + Supersedes `clojure.core/ns-refers`." + [ns-val namespace? > (t/assume (t/of ut/+map? id/unqualified-symbol? var?))] + (->> ns-val + ns>mappings + (remove-vals' (fn [^clojure.lang.Var v] (and (var? v) (= ns-val (.ns v)))))))) + +#?(:clj +(t/defn alias>?ns [src-ns namespace?, sym id/symbol? > (t/? namespace?)] (.lookupAlias src-ns sym))) + +;; TODO TYPED — enable +#_(:clj +(defn alias-ns + "Create vars in the current namespace to alias each of the public vars in + the supplied namespace. + Takes a symbol." + {:attribution "flatland.useful.ns"} + [ns-name-] + (require ns-name-) + (doseq [[name var] (ns>publics (the-ns ns-name-))] + (uvar/alias-var name var)))) + +;; TODO TYPED +#?(:clj +(defaliases uns + ns>alias ns-name>alias clear-ns-interns! search-var ns-exclude with-ns with-temp-ns import-static + load-ns load-nss loaded-libs load-lib! load-package! load-dep! assert-ns-aliased)) From 00622c5f23618eef5e9c55e11082e3fe3d1cb6e2 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 19 Sep 2018 19:49:09 -0600 Subject: [PATCH 291/810] Rename fn --- src/quantum/core/data/primitive.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 83794e17..ae857f73 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -73,7 +73,7 @@ ([x double? > (t/ref double?)] (Double/valueOf x)))) #?(:clj -(defnt unboxed +(defnt unbox ([x (t/ref boolean?) > boolean?] (.booleanValue x)) ([x (t/ref byte?) > byte?] (.byteValue x)) ([x (t/ref char?) > char?] (.charValue x)) From c22cdbb7380ec502e3f6d60b40b5eadee0143575 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 19 Sep 2018 19:49:18 -0600 Subject: [PATCH 292/810] Clean up test ns --- test/quantum/test/core/defnt.cljc | 388 ++---------------------------- 1 file changed, 26 insertions(+), 362 deletions(-) diff --git a/test/quantum/test/core/defnt.cljc b/test/quantum/test/core/defnt.cljc index addaaeb9..30ac4f70 100644 --- a/test/quantum/test/core/defnt.cljc +++ b/test/quantum/test/core/defnt.cljc @@ -6,10 +6,10 @@ :refer [fn->]] [quantum.core.logic :refer [fn-and]] - [quantum.core.defnt :as this + [quantum.core.defnt :as this :refer [!ref analyze defnt]] - [quantum.core.macros.type-hint :as th] - [quantum.core.type.defs :as tdef] + [quantum.core.macros.type-hint :as th] + [quantum.core.type.defs :as tdef] [quantum.untyped.core.analyze.ast :as ast] [quantum.untyped.core.analyze.expr :as xp] [quantum.untyped.core.form @@ -21,16 +21,32 @@ :refer [istr]] [quantum.untyped.core.test :as test :refer [deftest testing is is= throws]] - [quantum.untyped.core.type :as t]) + [quantum.untyped.core.type :as t]) #?(:clj (:import [clojure.lang Keyword Symbol] [quantum.core Numeric]))) +;; ===== Type predicates ===== ;; +;; Declared here instead of in `quantum.untyped.core.type` to avoid dependency + +#?(:clj (def boolean? (t/isa? #?(:clj Boolean :cljs js/Boolean)))) +#?(:clj (def byte? (t/isa? Byte))) +#?(:clj (def short? (t/isa? Short))) +#?(:clj (def char? (t/isa? Character))) +#?(:clj (def int? (t/isa? Integer))) +#?(:clj (def long? (t/isa? Long))) +#?(:clj (def float? (t/isa? Float))) + (def double? (t/isa? #?(:clj Double :cljs js/Number))) + +(def string? (t/isa? #?(:clj java.lang.String :cljs js/String))) + +;; ===== End type predicates ===== ;; + (deftest test|arg-types>split (is= (this/arg-types>split - [(t/or t/byte? t/double? t/string?) - (t/or t/map? t/byte?)]) + [(t/or byte? double? string?) + (t/or t/map? byte?)]) [[(t/isa? Byte) (t/isa? clojure.lang.ITransientMap)] [(t/isa? Byte) (t/isa? clojure.lang.IPersistentMap)] [(t/isa? Byte) (t/isa? java.util.Map)] @@ -46,316 +62,18 @@ ;; ============== OLD TESTS ============== ;; -;; # args | ret | ? arg specs (delimited by `,`) -;; abstract > concrete > concrete -#?(:clj (def t0> java.io.OutputStream)) -#?(:clj (def t0 java.io.FilterOutputStream)) -#?(:clj (def t0< java.io.PrintStream)) -;; Object > interface > concrete final -#?(:clj (def t1> java.lang.Object)) -#?(:clj (def t1 java.lang.CharSequence)) -#?(:clj (def t1< java.lang.String)) -;; Object > abstract > concrete final dual as primitive -#?(:clj (def t2> java.lang.Object)) -#?(:clj (def t2 java.lang.Number)) -#?(:clj (def t2< java.lang.Long)) -#?(:clj (def t2

tag th/class->str) - -;; arity 0 -(def defnt|code|0 - `(defnt ~'abc [])) - -;; arity 1: empty input, nil return -(def defnt|code|1|empty - `(defnt ~'abc [~'a ~'_])) - -;; arity 1: nil return -(def defnt|code|1|nil - `(defnt ~'abc [~'a t0])) - -;; arity 1 -(def defnt|code|1 - `(defnt ~'abc [~'a t0] ~'a)) - -;; arity 2 -(def defnt|code|2 - `(defnt ~'abc [~'a t0 ~'b t0] ~'a)) - -;; dispatch classes =; arity 1; arg 0 -> error: ambiguous dispatch -(def defnt|code|class|=|1|0 - `(defnt ~'abc - ([~'a t0] ~'a) - ([~'b t0] ~'b))) - -;; dispatch classes !=; arity 1; arg 0 -(def defnt|code|class|!=|1|0 - `(defnt ~'abc - ([~'a t0 ] ~'a) - ([~'b t2; arity 2; arg 0 -(def defnt|code|class|>|2|0 - `(defnt ~'abc - ([~'a t0 ~'b t0] ~'a) - ([~'c t0> ~'d t0] ~'c))) - -;; next dispatch class <; arity 2; arg 0 -;; -> error: specs in the same arity and position must be ordered in monotonically -;; increasing order in terms of `t/compare` -(def defnt|code|class|<|2|0 - `(defnt ~'abc - ([~'a t0 ~'b t0] ~'a) - ([~'c t0< ~'d t0] ~'c))) - -;; dispatch differs by spec <, not class; arity 1; arg 0 -(def defnt|code|spec|<|1|0 - `(defnt ~'abc - ([~'a t0] ~'a) - ([~'b (t/and t0 (fn-> count (= 1)))] ~'b))) - -;; dispatch differs by spec <, not class; arity 2; arg 0 -(def defnt|code|spec|<|2|0 - `(defnt ~'abc - ([~'a t0 - ~'b t0] ~'a) - ([~'c (t/and t0 (fn-> count (= 1))) - ~'d t0] ~'c))) - -;; arity 2; -> error: ambiguous dispatch -(def defnt|code|... - `(defnt ~'abc - ([~'a t0 ~'b t0] ~'a) - ([~'c t0 ~'d t0] ~'c))) - -;; concrete and primitive mix -(def defnt|code|concrete+primitive - `(defnt ~'abc - ([~'a t0 ~'b t0 ] ~'a) - ([~'c t2

overloads [code lang] - (->> (s/validate (rest code) ::this/defnt) - :overloads - (mapv #(this/fnt|overload-data>overload % {:lang lang})))) - -(def defnt|code>overloads|ret|1 - [{:arg-classes [t0] - :arg-specs [(t/isa? t0)] - :arglist-code|fn|hinted [(tag (>tag t0) 'a)] - :arglist-code|reify|unhinted ['a] - :body-codelist ['a] - :positional-args-ct 1 - :spec (t/isa? t0) - :variadic? false}]) - -(def defnt|code>overloads|ret|2 - [{:arg-classes [t0 t0] - :arg-specs [(t/isa? t0) (t/isa? t0)] - :arglist-code|fn|hinted [(tag (>tag t0) 'a) (tag (>tag t0) 'b)] - :arglist-code|reify|unhinted ['a 'b] - :body-codelist ['a] - :positional-args-ct 2 - :spec (t/isa? t0) - :variadic? false}]) - -(deftest fnt|overload-data>overload - (is (code= (defnt|code>overloads defnt|code|0 :clj) - [{:arg-classes [] - :arg-specs [] - :arglist-code|fn|hinted [] - :arglist-code|reify|unhinted [] - :body-codelist [] - :positional-args-ct 0 - :spec (t/value nil) - :variadic? false}])) - (is (code= (defnt|code>overloads defnt|code|1|empty :clj) - [{:arg-classes [java.lang.Object] - :arg-specs [(t/? t/object?)] - :arglist-code|fn|hinted [(tag "java.lang.Object" 'a)] - :arglist-code|reify|unhinted ['a] - :body-codelist [] - :positional-args-ct 1 - :spec (t/value nil) - :variadic? false}])) - (is (code= (defnt|code>overloads defnt|code|1|nil :clj) - [{:arg-classes [t0] - :arg-specs [(t/isa? t0)] - :arglist-code|fn|hinted [(tag (>tag t0) 'a)] - :arglist-code|reify|unhinted ['a] - :body-codelist [] - :positional-args-ct 1 - :spec (t/value nil) - :variadic? false}])) - (is (code= (defnt|code>overloads defnt|code|1 :clj) - defnt|code>overloads|ret|1)) - (is (code= (defnt|code>overloads defnt|code|class|!=|1|0 :clj) - [(first defnt|code>overloads|ret|1) - {:arg-classes [t2tag t2overloads defnt|code|2 :clj) - defnt|code>overloads|ret|2)) - (is (code= (defnt|code>overloads defnt|code|concrete+primitive :clj) - [(first defnt|code>overloads|ret|2) - {:arg-classes [t2

tag t2tag t2overloads defnt|code|class|=|2|0 :clj) - [(first defnt|code>overloads|ret|2) - {:arg-classes [t0 t2tag t0) 'c) (tag (>tag t2protocols [fn|name code lang] - (this/fnt|overloads>protocols - {:fn|name fn|name :overloads (defnt|code>overloads code lang)})) - -(deftest fnt|overloads>protocol - (is (code= (defnt|code>protocols 'abc defnt|code|0 :clj) - [{:defprotocol nil - :extend-protocols nil - :defn ($ (defn ~'abc [] (.invoke ~'abc|__0)))}])) - (is (code= (defnt|code>protocols 'abc defnt|code|1|empty :clj) - [{:defprotocol nil - :extend-protocols nil - :defn ($ (defn ~'abc [~(tag "java.lang.Object" 'x0)] (.invoke ~'abc|__0 ~'x0)))}])) - (is (code= (defnt|code>protocols 'abc defnt|code|1|nil :clj) - [{:defprotocol nil - :extend-protocols nil - :defn ($ (defn ~'abc [~(tag (>tag t0) 'x0)] (.invoke ~'abc|__0 ~'x0)))}])) - (is (code= (defnt|code>protocols 'abc defnt|code|1 :clj) - [{:defprotocol nil - :extend-protocols nil - :defn ($ (defn ~'abc [~(tag (>tag t0) 'x0)] (.invoke ~'abc|__0 ~'x0)))}])) - (is (code= (defnt|code>protocols 'abc defnt|code|class|!=|1|0 :clj) - [{:defprotocol - ($ (defprotocol ~'abc__Protocol__0 - (~'abc [~'x0]))) - :extend-protocols - [($ (extend-protocol ~'abc - java.io.FilterOutputStream (~'abc [~(tag "java.io.FilterOutputStream" 'x0)] (.invoke ~'abc|__0 ~'x0)) - java.lang.Long (~'abc [~(tag "long" 'x0)] (.invoke ~'abc|__1 ~'x0))))] - :defn nil}])) - (is (code= (defnt|code>protocols 'abc defnt|code|2 :clj) - [{:defprotocol nil - :extend-protocols nil - :defn ($ (defn ~'abc [~(tag (>tag t0) 'x0) - ~(tag (>tag t0) 'x1)] - (.invoke ~'abc|__0 ~'x0 ~'x1)))}])) - (is (code= (defnt|code>protocols 'abc (do defnt|code|concrete+primitive) :clj) - [{:defprotocol - ($ (defprotocol ~'abc|__Protocol - (~'abc [~'x0 ~'x1]))) - :extend-protocols - [($ (extend-protocol ~'abc - java.io.FilterOutputStream - (~'abc [~(tag "java.io.FilterOutputStream" 'x0) ~(tag "java.io.FilterOutputStream" 'x1)] - (.invoke ~'abc|__0 ~'x0 ~'x1)) - java.lang.Long - (~'abc [~(tag "long" 'x0) ~(tag "long" 'x1)] - (.invoke ~'abc|__1 ~'x0 ~'x1))))] - :defn nil}])) - (is (code= (defnt|code>protocols 'abc (do defnt|code|class|=|2|0) :clj) - [{:defprotocol - ($ (defprotocol ~'abc|__Protocol__java|io|FilterOutputStream - (~'abc|__protofn__java|io|FilterOutputStream [~'x0 ~'x1]))) - :extend-protocols - [($ (extend-protocol ~'abc|__Protocol__java|io|FilterOutputStream - java.io.FilterOutputStream - (~'abc|__protofn__java|io|FilterOutputStream - [~(tag "java.io.FilterOutputStream" 'x1) ~(tag "java.io.FilterOutputStream" 'x0)] - (.invoke ~'abc|__0 ~'x0 ~'x1)) - java.lang.Long - (~'abc|__protofn__java|io|FilterOutputStream - [~(tag "long" 'x1) ~(tag "java.io.FilterOutputStream" 'x0)] - (.invoke ~'abc|__1 ~'x0 ~'x1))))] - :defn nil} - {:defprotocol - ($ (defprotocol ~'abc|__Protocol - (~'abc [~'x0 ~'x1]))) - :extend-protocols - [($ (extend-protocol ~'abc - java.io.FilterOutputStream - (~'abc [~(tag "java.io.FilterOutputStream" 'x0) ~'x1] - (~'abc|__protofn__java|io|FilterOutputStream ~'x1 ~'x0))))] - :defn nil}])) - (is (code= (defnt|code>protocols 'abc (do defnt|code|class|=|2|1) :clj) - [{:defprotocol - ($ (defprotocol ~'abc|__Protocol__java|io|FilterOutputStream - (~'abc|__protofn__java|io|FilterOutputStream [~'x0 ~'x1]))) - :extend-protocols - [($ (extend-protocol ~'abc|__Protocol__java|io|FilterOutputStream - java.io.FilterOutputStream - (~'abc|__protofn__java|io|FilterOutputStream - [~(tag "java.io.FilterOutputStream" 'x1) ~(tag "java.io.FilterOutputStream" 'x0)] - (.invoke ~'abc|__0 ~'x0 ~'x1))))] - :defn nil} - {:defprotocol - ($ (defprotocol ~'abc|__Protocol__long - (~'abc|__protofn__long [~'x0 ~'x1]))) - :extend-protocols - [($ (extend-protocol ~'abc|__Protocol__long - java.io.FilterOutputStream - (~'abc|__protofn__long - [~(tag "java.io.FilterOutputStream" 'x1) ~(tag "long" 'x0)] - (.invoke ~'abc|__0 ~'x0 ~'x1))))] - :defn nil} - {:defprotocol - ($ (defprotocol ~'abc|__Protocol - (~'abc [~'x0 ~'x1]))) - :extend-protocols - [($ (extend-protocol ~'abc|__Protocol - java.io.FilterOutputStream - (~'abc - [~(tag "java.io.FilterOutputStream" 'x0) ~'x1] - (~'abc|__protofn__java|io|FilterOutputStream ~'x1 ~'x0)) - java.lang.Long - (~'abc - [~(tag "long" 'x0) ~'x1] - (~'abc|__protofn__long ~'x1 ~'x0))))] - :defn nil}]))) - (deftest test|methods->spec (testing "Class hierarchy" (is= (this/methods->spec - [{:rtype Object :argtypes [t/int? t/char?]} + [{:rtype Object :argtypes [int? char?]} {:rtype Object :argtypes [String]} {:rtype Object :argtypes [CharSequence]} {:rtype Object :argtypes [Object]} {:rtype Object :argtypes [Comparable]}]) (xp/casef count 1 (xp/condpf-> t/<= (xp/get 0) - (t/? t/string?) (t/? t/object?) + (t/? string?) (t/? t/object?) (t/? t/char-seq?) (t/? t/object?) (t/? t/comparable?) (t/? t/object?) (t/? t/object?) (t/? t/object?)) @@ -441,11 +159,9 @@ ;; ----- Overload resolution ----- -; TODO use logic programming and variable unification e.g. `?1` `?2` ? - (defnt +* "Lax `+`. Continues on overflow/underflow." - {:variadic-proxy true} + {:variadic-proxy? true} ([] 0) ;; Here `Number`, determined to be a class, is treated like an `instance?` predicate ([a (t/or numeric-primitive? Number)] a) @@ -463,7 +179,7 @@ (defnt +' "Strict `+`. Throws exception on overflow/underflow." - {:variadic-proxy true} + {:variadic-proxy? true} ([a int? , b int? ] (Math/addExact a b)) ([a long?, b long?] (Math/addExact x y)) ; TODO do the rest @@ -570,58 +286,6 @@ ... [IPersistentVector long long]] -(defnt example - ([a (s/and even? #(< 5 % 100)) - b t/any? - c ::number-between-6-and-20 - d {:req-un [e (default t/boolean? true) - :f t/number? - g (default (s/or t/number? t/sequential?) 0)]} - | (< a @c) ; pre - > (s/and (s/coll odd? :kind t/array?) ; post - #(= (first %) c))] - ...) - ([a string? - b (s/coll bigdec? :kind vector?) - c t/any? - d t/any? - ...)) - -;; expands to: - -(dv/def ::example:a (s/and even? #(< 5 % 100))) -(dv/def ::example:b t/any) -(dv/def ::example:c ::number-between-6-and-20) -(dv/def-map ::example:d - :conformer (fn [m#] (assoc-when-not-contains m# :e true :g 0)) - :req-un [[:e t/boolean?] - [:f t/number?] - [:g (s/or* t/number? t/sequential?)]]) -(dv/def ::example|__ret - (s/and (s/coll-of odd? :kind t/array?) - #(= (first %) (:c ...)))) ; TODO fix `...` - -;; -> TODO should it be: -(defnt example - [^example:a a ^:example|b b ^example|c c ^example|d d] - (let [ret (do ...)] - (validate ret ::example|__ret))) -;; -> OR -(defnt example - [^number? a b ^number? c ^map? d] - (let [ret (do ...)] - (validate ret ::example|__ret))) -;; ? The issue is one of performance. Maybe we don't want boxed values all over the place. - -(s/fdef example - :args (s/cat :a ::example|a - :b ::example|b - :c ::example|c - :d ::example|d) - :fn ::example|__ret) - - - ;; ===== Dynamicity ===== ;; (definterface Abcde (^long abcdemethod [^int a ^byte b])) From 0656667b0412a459d840e2c82e294dbf62d5d01e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 19 Sep 2018 19:49:33 -0600 Subject: [PATCH 293/810] Reorganize `quantum.core.data.string` --- src/quantum/core/data/string.cljc | 110 +++++++++++++++++++----------- 1 file changed, 71 insertions(+), 39 deletions(-) diff --git a/src/quantum/core/data/string.cljc b/src/quantum/core/data/string.cljc index 7731bb15..f7e71003 100644 --- a/src/quantum/core/data/string.cljc +++ b/src/quantum/core/data/string.cljc @@ -1,24 +1,81 @@ (ns quantum.core.data.string - (:import #?(:clj com.carrotsearch.hppc.CharArrayDeque) - #?(:cljs goog.string.StringBuffer))) + "A String is a special wrapper for a char array where different encodings, etc. are possible." + (:require + [quantum.core.type :as t + :refer [defnt]] + [quantum.untyped.core.core :as ucore]) + (:import +#?(:clj [com.carrotsearch.hppc CharArrayDeque]) +#?(:cljs [goog.string StringBuffer]))) -; TODO investigate http://ahmadsoft.org/ropes/ : A rope is a high performance replacement for Strings. The datastructure, described in detail in "Ropes: an Alternative to Strings", provides asymptotically better performance than both String and StringBuffer +(ucore/log-this-ns) -(defn !str +;; TODO investigate http://ahmadsoft.org/ropes/ : A rope is a high performance replacement for Strings. The datastructure, described in detail in "Ropes: an Alternative to Strings", provides asymptotically better performance than both String and StringBuffer +;; What about structural sharing with strings? +;; Wouldn't there have to be some sort of compact immutable bit map or something to diff it rather +;; than just making an entirely new string? + +;; ===== General string-like entities ===== ;; + +#?(:clj (def char-seq? (t/isa? java.lang.CharSequence))) + +;; ===== Immutable strings ===== ;; + +(def str? (t/isa? #?(:clj java.lang.String :cljs js/String))) + +#_(defnt str ...) ; TODO TYPED + +;; ----- Metable immutable strings ----- ;; + +;; TODO TYPED `deftypet` +#?(:clj +(deftype MetableString [^String s ^clojure.lang.IPersistentMap _meta] + clojure.lang.IObj + (meta [this] _meta) + (withMeta [this meta'] (MetableString. s meta')) + CharSequence + (charAt [this i] (.charAt s i)) + (length [this] (.length s)) + (subSequence [this a b] (.subSequence s a b)) + Object + (toString [this] s) + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] s))) + +#?(:clj +(defmethod print-method MetableString [^MetableString x ^java.io.Writer w] + (print-method (.toString x) w))) + +(def metable-str? #?(:clj (t/isa? MetableString) :cljs str?)) + +(defnt >metable-str + > metable-str? + ([s str?] #?(:clj (MetableString. s nil) :cljs s)) + ([s str?, meta' ??/meta?] #?(:clj (MetableString. s meta') :cljs (??/with-meta s new-meta)))) + +;; ===== Mutable strings ===== ;; + +(def !str? (t/isa? #?(:clj java.lang.StringBuilder :cljs StringBuffer))) + +(defnt !str "Creates a mutable string." - ([ ] #?(:clj (StringBuilder. ) :cljs (StringBuffer. ))) - ([a0] #?(:clj (StringBuilder. a0) :cljs (StringBuffer. a0)))) + > !str? + ([] #?(:clj (StringBuilder.) :cljs (StringBuffer.))) + ;; TODO + #_([x0] #?(:clj (StringBuilder. x0) :cljs (StringBuffer. x0)))) + +;; ----- Synchronously mutable strings ----- ;; + +#?(:clj (def !sync-str? (t/isa? java.lang.StringBuffer))) #?(:clj -(defn !sync-str +(defnt !sync-str "Creates a synchronized mutable string." - [] - (StringBuffer.))) + > !sync-str? + [] (StringBuffer.))) -; What about structural sharing with strings? -; Wouldn't there have to be some sort of compact immutable bit -; map or something to diff it rather than just making -; an entirely new string? +;; ----- Mutable char deques ----- ;; ; TODO rework. Instead of |condf|, use records to represent ; parsed types and dispatch in |defnt| accordingly @@ -26,7 +83,7 @@ ; Currently only for strings #_(:clj (defn rreduce [f init ^String s] - (loop [ret init i (-> s lasti int)] ; int because charAt requires int, I think + (loop [ret init i (-> s lasti int)] ; int because charAt requires int (if (>= i 0) (recur (f ret (.charAt s i)) (unchecked-dec i)) ret)))) @@ -76,7 +133,6 @@ ;(conjl! "(") ;(conjl! "abc") - #_(:clj (defn sp+ [& args] (fn [sb] @@ -84,27 +140,3 @@ (conjl! sb arg) (when (< n (-> args count dec)) (conjl! sb " ")))))) - -#?(:clj -(deftype StringWithMeta [^String s ^clojure.lang.IPersistentMap _meta] - clojure.lang.IObj - (meta [this] _meta) - (withMeta [this meta'] (StringWithMeta. s meta')) - CharSequence - (charAt [this i] (get s i)) - (length [this] (count s)) - (subSequence [this a b] (.subSequence s a b)) - Object - (toString [this] s) - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] s))) - -#?(:clj -(defmethod print-method StringWithMeta [^StringWithMeta x ^java.io.Writer w] - (print-method (.toString x) w))) - -#?(:clj -(defn string-with-meta - ([s] #?(:clj (StringWithMeta. s nil) :cljs s)) - ([s meta'] #?(:clj (StringWithMeta. s meta') :cljs (with-meta s new-meta))))) From f0c11ee6339ed9db718890c8ec503d93747995ac Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 22 Sep 2018 21:06:24 -0600 Subject: [PATCH 294/810] More transitioning to types; add support for `t/ref` output types --- resources-dev/defnt.cljc | 98 ++++---- src-dev/quantum/core/defnt_equivalences.cljc | 206 +++++++++------- src-untyped/quantum/untyped/core/analyze.cljc | 2 +- .../quantum/untyped/core/analyze/ast.cljc | 4 +- src-untyped/quantum/untyped/core/core.cljc | 2 +- .../quantum/untyped/core/data/hash.cljc | 4 +- .../quantum/untyped/core/data/numeric.cljc | 13 +- src-untyped/quantum/untyped/core/defnt.cljc | 8 +- .../quantum/untyped/core/reducers.cljc | 2 +- src-untyped/quantum/untyped/core/specs.cljc | 2 +- src-untyped/quantum/untyped/core/type.cljc | 11 +- .../quantum/untyped/core/type/defnt.cljc | 139 ++++++----- src-untyped/quantum/untyped/core/vars.cljc | 2 +- src/quantum/core/compare.cljc | 2 +- src/quantum/core/compare/core.cljc | 2 + src/quantum/core/core.cljc | 1 - src/quantum/core/data/identifiers.cljc | 2 +- src/quantum/core/data/map.cljc | 35 ++- src/quantum/core/data/meta.cljc | 17 +- src/quantum/core/data/primitive.cljc | 59 +++-- src/quantum/core/data/string.cljc | 16 +- src/quantum/core/numeric.cljc | 47 ++-- src/quantum/core/numeric/exponents.cljc | 20 +- src/quantum/core/numeric/operators.cljc | 233 ++++++++---------- src/quantum/core/numeric/predicates.cljc | 112 ++++----- src/quantum/core/numeric/trig.cljc | 12 +- src/quantum/core/numeric/types.cljc | 9 +- src/quantum/core/refs.cljc | 38 +-- src/quantum/core/type.cljc | 16 +- test-dev/cljc/quantum/test/ir/classify.cljc | 14 +- test/quantum/test/core/defnt.cljc | 20 +- test/quantum/test/core/type/core.cljc | 24 +- .../test/untyped/core/analyze/expr.cljc | 38 +-- .../test/untyped/core/collections.cljc | 8 +- test/quantum/test/untyped/core/defnt.cljc | 36 +-- .../test/untyped/core/identifiers.cljc | 40 +-- 36 files changed, 654 insertions(+), 640 deletions(-) delete mode 100644 src/quantum/core/core.cljc diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 787f006f..9741227e 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -4,8 +4,14 @@ >boolean is different than `truthy?` +We should not rely on the value of dynamic vars e.g. `*math-context*` unless specifically typed + Sometimes you want (byte ) to fail at runtime rather than fail at runtime when you can't know everything about the input's range +These two should be defined in the (whatever) data namespace: +- `>(whatever)` +- `(whatever)>` + TODO: - `(or (and pred then) (and (not pred) else))` (which is not correct) - needs to equal `(t/and (t/or (t/not a) b) (t/or a c))` (which is correct) @@ -84,57 +90,57 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - Same with the `core.convert` namespace too - Conversion functions belong in the namespace that their destination types belong in - TODO transition the quantum.core.* namespaces: + ->>>>>> TODO need to add *all* quantum namespaces in here - List of semi-approximately topologically ordered namespaces to make typed: - - quantum.core.type.core - - quantum.core.type.defs - - quantum.core.logic - - quantum.core.fn - - quantum.core.cache - - quantum.core.type-old - - quantum.core.data.string + - [ ] quantum.core.core -> TODO just need to delete this from all references + - [ ] quantum.core.type.core + - [ ] quantum.core.type.defs + - [ ] quantum.core.refs -> quantum.core.data.refs + - [ ] quantum.core.logic + - (def nneg? (l/fn-not neg?)) + - (def pos-int? (l/fn-and dnum/integer? pos?)) + - [ ] quantum.core.fn + - [ ] quantum.core.cache + - [ ] quantum.core.type-old + - [ ] quantum.core.data.string - [x] quantum.core.data.map - [x] quantum.core.data.meta - [x] quantum.core.ns ; TODO split up into data.ns? - - quantum.core.print - - quantum.core.log - - quantum.core.data.vector - - quantum.core.spec - - quantum.core.error - - quantum.core.data.string — this is where `>str` belongs - - - quantum.core.data.array - - quantum.core.data.collections - - quantum.core.data.tuple - - - quantum.core.numeric.convert - - quantum.core.numeric.misc - - quantum.core.numeric.operators - - quantum.core.numeric.predicates - - quantum.core.numeric.trig - - quantum.core.numeric.truncate - - quantum.core.data.numeric - - quantum.core.numeric - - - quantum.core.string.regex - - quantum.core.data.set - - quantum.core.macros.type-hint - - quantum.core.analyze.clojure.core - - quantum.core.analyze.clojure.predicates - - quantum.core.macros.optimization - - quantum.core.macros.fn - - quantum.core.macros.transform - - quantum.core.macros.protocol - - quantum.core.macros.reify - - quantum.core.macros.defnt - - quantum.core.macros - - - quantum.core.refs - - quantum.core.reducers.reduce - - quantum.core.collections.logic - - quantum.core.collections.core + - [ ] quantum.core.print + - [ ] quantum.core.log + - [ ] quantum.core.data.vector + - [ ] quantum.core.spec + - [ ] quantum.core.error + - [ ] quantum.core.data.string — this is where `>str` belongs + - [ ] quantum.core.data.array + - [ ] quantum.core.data.collections + - [ ] quantum.core.data.tuple + - [ ] quantum.core.numeric.predicates + - [ ] quantum.core.numeric.convert + - [ ] quantum.core.numeric.misc + - [ ] quantum.core.numeric.operators + - [ ] quantum.core.numeric.trig + - [ ] quantum.core.numeric.truncate + - [ ] quantum.core.data.numeric + - [ ] quantum.core.numeric + - [ ] quantum.core.string.regex + - [ ] quantum.core.data.set + - [ ] quantum.core.macros.type-hint + - [ ] quantum.core.analyze.clojure.core + - [ ] quantum.core.analyze.clojure.predicates + - [ ] quantum.core.macros.optimization + - [ ] quantum.core.macros.fn + - [ ] quantum.core.macros.transform + - [ ] quantum.core.macros.protocol + - [ ] quantum.core.macros.reify + - [ ] quantum.core.macros.defnt + - [ ] quantum.core.macros + - [ ] quantum.core.reducers.reduce + - [ ] quantum.core.collections.logic + - [ ] quantum.core.collections.core - Worked through all we can for now: - - quantum.core.core + - - TODO delete this namespace? - quantum.core.data.primitive (TODO make it compile) - quantum.core.data.bits @@ -180,7 +186,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] isZero - [ ] isNeg - [ ] isPos - - [ ] add + - [x] add - [ ] subtract - [ ] negate - [ ] multiply diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 88924edc..c8572fed 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -4,8 +4,8 @@ (:refer-clojure :exclude [* boolean? char? count double? float? get int? ratio? seq zero?]) (:require - [quantum.untyped.core.type.defnt - :refer [defnt fnt unsupported!]] + [quantum.untyped.core.type.defnt :as self + :refer [fnt unsupported!]] [quantum.untyped.core.data.array :refer [*<>]] [quantum.untyped.core.form @@ -59,7 +59,7 @@ (deftest test|pid (let [actual (macroexpand ' - (defnt pid|test [> (? t/string?)] + (self/defn pid|test [> (? t/str?)] (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) (.getName)))) expected @@ -69,13 +69,13 @@ ~(STR '(. (. java.lang.management.ManagementFactory getRuntimeMXBean) getName))))) (defn ~'pid|test - {:quantum.core.type/type (t/fn t/any? ~'[:> (? t/string?)])} + {:quantum.core.type/type (t/fn t/any? ~'[:> (? t/str?)])} ([] (.invoke ~(tag (str `>Object) 'pid|test|__0|0))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) - (eval '(do (is (string? (pid|test))) + (eval '(do (is (t/str? (pid|test))) (throws (pid|test 1)))))))) ;; TODO test `:inline` @@ -83,7 +83,7 @@ (deftest test|identity|uninlined (let [actual (macroexpand ' - (defnt identity|uninlined ([x t/any?] x))) + (self/defn identity|uninlined ([x t/any?] x))) expected (case (env-lang) :clj @@ -135,10 +135,10 @@ (deftest test|name (let [actual (macroexpand ' - (defnt #_:inline name|test > t/string? - ([x t/string?] x) - #?(:clj ([x (t/isa? Named) > (* t/string?)] (.getName x)) - :cljs ([x (t/isa? INamed) > (* t/string?)] (-name x))))) + (self/defn #_:inline name|test > t/str? + ([x t/str?] x) + #?(:clj ([x (t/isa? Named) > (* t/str?)] (.getName x)) + :cljs ([x (t/isa? INamed) > (* t/str?)] (-name x))))) expected (case (env-lang) :clj @@ -146,7 +146,7 @@ ;; Return value can be primitive; in this case it's not ;; The macro in a typed context will find the right dispatch at compile time - ;; [t/string?] + ;; [t/str?] (def ~(tag "[Ljava.lang.Object;" 'name|test|__0|input0|types) (*<> (t/isa? java.lang.String))) @@ -164,13 +164,13 @@ (~(tag "java.lang.Object" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] (let* [~(tag "clojure.lang.Named" 'x) ~'x] (t/validate ~(STR '(. x getName)) - ~'(* t/string?)))))) + ~'(* t/str?)))))) (defn ~'name|test {:quantum.core.type/type - (t/fn ~'t/string? - ~'[t/string?] - ~'[(t/isa? Named) :> (* t/string?)])} + (t/fn ~'t/str? + ~'[t/str?] + ~'[(t/isa? Named) :> (* t/str?)])} ([~'x00__] (ifs ((Array/get ~'name|test|__0|input0|types 0) ~'x00__) (.invoke ~(tag (str `Object>Object) @@ -181,7 +181,7 @@ (unsupported! `name|test [~'x00__] 0)))))) :cljs ($ (do (defn ~'name|test [~'x00__] - (ifs (t/string? x) x + (ifs (t/str? x) x (satisfies? INamed x) (-name x) (unsupported! `name|test [~'x00__] 0))))))] (testing "code equivalence" (is-code= actual expected)) @@ -200,7 +200,7 @@ (let [actual ;; Perhaps silly in ClojureScript, but avoids boxing in Clojure (macroexpand ' - (defnt #_:inline some?|test + (self/defn #_:inline some?|test ([x t/nil?] false) ;; Implicitly, `(- t/any? t/nil?)`, so `t/val?` ([x t/any?] true))) @@ -261,7 +261,7 @@ (let [actual ;; Perhaps silly in ClojureScript, but avoids boxing in Clojure (macroexpand ' - (defnt #_:inline reduced?|test + (self/defn #_:inline reduced?|test ([x (t/isa? Reduced)] true) ;; Implicitly, `(- t/any? (t/isa? Reduced))` ([x t/any? ] false))) @@ -325,7 +325,7 @@ (deftest test|>boolean (let [actual (macroexpand ' - (defnt #_:inline >boolean + (self/defn #_:inline >boolean ([x boolean?] x) ([x t/nil?] false) ([x t/any?] true))) @@ -394,7 +394,7 @@ (is= (>boolean nil) (boolean nil)) (is= (>boolean 123) (boolean 123))))))) -;; Let's say you have (t/| t/string? t/number?) in one `fnt` overload. +;; Let's say you have (t/| t/str? t/number?) in one `fnt` overload. ;; This means that you *can't* have a reify with two Object>Object overloads and expect it to work ;; at all. ;; Therefore, each `fnt` overload necessarily has a one-to-many relationship with `reify`s. @@ -405,7 +405,7 @@ (macroexpand ' ;; Auto-upcasts to long or double (because 64-bit) unless you tell it otherwise ;; Will error if not all return values can be safely converted to the return spec - (defnt #_:inline >int* > int? + (self/defn #_:inline >int* > int? ([x (t/- primitive? boolean?)] (Primitive/uncheckedIntCast x)) ([x (t/ref (t/isa? Number))] (.intValue x)))) expected @@ -463,7 +463,7 @@ (defn ~'>int* {:quantum.core.type/type - (t/fn ~'t/int? + (t/fn ~'int? ~'[(t/- primitive? boolean?)] ~'[(t/ref (t/isa? Number))])} ([~'x00__] @@ -501,7 +501,7 @@ (deftest test|> (let [actual (macroexpand ' - (defnt #_:inline >|test + (self/defn #_:inline >|test ;; This is admittedly a place where inference might be nice, but luckily ;; there are no "sparse" combinations #?(:clj ([a comparable-primitive? b comparable-primitive? > boolean?] @@ -875,9 +875,9 @@ (deftest test|>long* (let [actual (macroexpand ' - (defnt #_:inline >long* + (self/defn #_:inline >long* {:source "clojure.lang.RT.uncheckedLongCast"} - long? + > long? ([x (t/- primitive? boolean?)] (Primitive/uncheckedLongCast x)) ([x (t/ref (t/isa? Number))] (.longValue x)))) expected @@ -970,10 +970,50 @@ (is (identical? (>long* -1.1) (clojure.lang.RT/uncheckedLongCast -1.1))) (is (identical? (>long* (byte 1)) (clojure.lang.RT/uncheckedLongCast (byte 1))))))))) +(deftest ref-output-type-test + (let [actual + (macroexpand ' + (self/defn ref-output-type + ([x boolean? > (t/ref boolean?)] (Boolean. x)) + ([x byte? > (t/ref byte?)] (Byte. x)))) + expected + (case (env-lang) + :clj ($ (do ;; [x boolean? > (t/ref boolean?)] + + (def ~(tag "[Ljava.lang.Object;" 'ref-output-type|__0|input0|types) + (*<> (t/isa? java.lang.Boolean))) + (def ~'ref-output-type|__0|0 + (reify* [boolean>Object] + (~(O 'invoke) [~'_0__ ~(tag "boolean" 'x)] (new ~'Boolean ~'x)))) + + ;; [x byte? > (t/ref byte?)] + + (def ~(tag "[Ljava.lang.Object;" 'ref-output-type|__1|input0|types) + (*<> (t/isa? java.lang.Byte))) + (def ~'ref-output-type|__1|0 + (reify* [byte>Object] + (~(O 'invoke) [~'_1__ ~(tag "byte" 'x)] (new ~'Byte ~'x)))) + + (defn ~'ref-output-type + {:quantum.core.type/type + (t/fn t/any? + ~'[boolean? :> (t/ref boolean?)] + ~'[byte? :> (t/ref byte?)])} + ([~'x00__] + (ifs + ((Array/get ~'ref-output-type|__0|input0|types 0) ~'x00__) + (.invoke ~(tag (str `boolean>Object) 'ref-output-type|__0|0) + ~'x00__) + ((Array/get ~'ref-output-type|__1|input0|types 0) ~'x00__) + (.invoke ~(tag (str `byte>Object) 'ref-output-type|__1|0) + ~'x00__) + (unsupported! `ref-output-type [~'x00__] 0)))))))] + (testing "code equivalence" (is-code= actual expected)))) + (deftest defnt-reference-test (let [actual (macroexpand ' - (defnt defnt-reference + (self/defn defnt-reference ([] (>long* 1)))) expected (case (env-lang) @@ -988,21 +1028,21 @@ (eval '(do (is (identical? (defnt-reference) 1))))))) (deftest defnt-assume-test - (throws (eval '(defnt defnt-assume-0 [> (t/assume t/int?)] "asd"))) - (throws (eval '(defnt defnt-assume-1 [> (t/assume t/int?)] nil))) - (is= nil (do (eval '(defnt defnt-assume-2 [> (t/assume t/int?)] (Object.))) + (throws (eval '(self/defn defnt-assume-0 [> (t/assume t/int?)] "asd"))) + (throws (eval '(self/defn defnt-assume-1 [> (t/assume t/int?)] nil))) + (is= nil (do (eval '(self/defn defnt-assume-2 [> (t/assume t/int?)] (Object.))) nil)) - (is= nil (do (eval '(defnt defnt-assume-3 [> (t/assume t/int?)] (or (Object.) nil))) + (is= nil (do (eval '(self/defn defnt-assume-3 [> (t/assume t/int?)] (or (Object.) nil))) nil))) -(defnt >big-integer > (t/isa? java.math.BigInteger) +(self/defn >big-integer > (t/isa? java.math.BigInteger) ([x ratio? > (* (t/isa? java.math.BigInteger))] (.bigIntegerValue x))) ;; NOTE would use `>long` but that's already an interface (deftest test|>long-checked (let [actual (macroexpand ' - (defnt >long-checked + (self/defn >long-checked {:source "clojure.lang.RT.longCast"} > long? ;; TODO multi-arity `t/-` @@ -1022,8 +1062,8 @@ ([x ratio?] (-> x >big-integer >long-checked)) ([x (t/value true)] 1) ([x (t/value false)] 0) - ([x t/string?] (Long/parseLong x)) - ([x t/string?, radix int?] (Long/parseLong x radix)))) + ([x t/str?] (Long/parseLong x)) + ([x t/str?, radix int?] (Long/parseLong x radix)))) expected (case (env-lang) :clj ($ (do #_[x (t/- primitive? boolean? float? double?)] @@ -1128,7 +1168,7 @@ ;; - `ratio?` -> t/<> ;; - `(t/value true)` -> t/<> ;; - `(t/value false)` -> t/<> - ;; - `t/string?` -> t/<> + ;; - `t/str?` -> t/<> ;; ;; Since there is no overload that results in t/<, no compile-time match can ;; be found, but a possible runtime match lies in the overload that results in @@ -1156,19 +1196,19 @@ (reify boolean>long (~(tag "long" 'invoke) [_## ~(tag "boolean" 'x)] 0))) - #_[x t/string?] + #_[x t/str?] #_(def ~'>long|__12|input-types - (*<> t/string?)) + (*<> t/str?)) (def ~'>long|__12 (reify Object>long (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] ~'(Long/parseLong x)))) - #_[x t/string?] + #_[x t/str?] #_(def ~'>long|__13|input-types - (*<> t/string? int?)) + (*<> t/str? int?)) (def ~'>long|__13 (reify Object+int>long (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x) ~(tag "int" 'radix)] @@ -1188,8 +1228,8 @@ [ratio?] [(t/value true)] [(t/value false)] - [t/string?] - [t/string? int?])} + [t/str?] + [t/str? int?])} ([x0##] (ifs ((Array/get >long|__0|input-types 0) x0##) (.invoke >long|__0 x0##) ((Array/get >long|__1|input-types 0) x0##) @@ -1216,12 +1256,12 @@ (deftest test|!str (let [actual (macroexpand ' - (defnt !str > #?(:clj (t/isa? StringBuilder) + (self/defn !str > #?(:clj (t/isa? StringBuilder) :cljs (t/isa? StringBuffer)) ([] #?(:clj (StringBuilder.) :cljs (StringBuffer.))) - ;; If we had combined this arity, `t/or`ing the `t/string?` means it wouldn't have been + ;; If we had combined this arity, `t/or`ing the `t/str?` means it wouldn't have been ;; handled any differently than `t/char-seq?` - #?(:clj ([x t/string?] (StringBuilder. x))) + #?(:clj ([x t/str?] (StringBuilder. x))) ([x #?(:clj (t/or t/char-seq? int?) :cljs t/val?)] #?(:clj (StringBuilder. x) :cljs (StringBuffer. x))))) @@ -1260,7 +1300,7 @@ {:quantum.core.type/type (t/fn ~'(t/isa? StringBuilder) ~'[] - ~'[t/string?] + ~'[t/str?] ~'[(t/or t/char-seq? int?)])} ([] (.invoke ~(tag "quantum.core.test.defnt_equivalences.>Object" '!str|__0|0))) @@ -1291,7 +1331,7 @@ (t/fn :> #?(:clj (t/isa? StringBuilder) :cljs (t/isa? StringBuffer)) [] - #?(:clj [t/string?]) + #?(:clj [t/str?]) [#?(:clj (t/or t/char-seq? t/int?) :cljs t/val?)])) @@ -1300,8 +1340,8 @@ (reify >Object (^java.lang.Object invoke [_#] (StringBuilder.)))) - ;; `t/string?` - (def ^Object>Object !str|__1 ; `t/string?` + ;; `t/str?` + (def ^Object>Object !str|__1 ; `t/str?` (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'x] (let* [^String x x] (StringBuilder. x))))) @@ -1315,7 +1355,7 @@ (StringBuilder. x)))) (defn !str ([ ] (.invoke !str|__0)) - ([a0] (ifs (t/string? a0) (.invoke !str|__1 a0) + ([a0] (ifs (t/str? a0) (.invoke !str|__1 a0) (t/char-seq? a0) (.invoke !str|__2 a0) (t/int? a0) (.invoke !str|__3 a0))))) :cljs `(do (defn !str ([] (StringBuffer.)) @@ -1325,20 +1365,20 @@ ;; TODO handle inline (macroexpand ' -(defnt #_:inline str|test > t/string? +(self/defn #_:inline str|test > t/str? ([] "") ([x t/nil?] "") ;; could have inferred but there may be other objects who have overridden .toString - #?(#_:clj #_([x (t/isa? Object) > (* t/string?)] (.toString x)) + #?(#_:clj #_([x (t/isa? Object) > (* t/str?)] (.toString x)) ;; Can't infer that it returns a string (without a pre-constructed list of built-in fns) ;; As such, must explicitly mark - :cljs ([x t/any? > (t/assume t/string?)] (.join #js [x] ""))) + :cljs ([x t/any? > (t/assume t/str?)] (.join #js [x] ""))) ;; TODO only one variadic arity allowed currently; theoretically could dispatch on at ;; least pre-variadic args, if not variadic ;; TODO should have automatic currying? ;; TODO need to handle varargs #_([x (t/fn> str|test t/any?) & xs (? (t/seq-of t/any?)) - #?@(:cljs [> (t/assume t/string?)])] + #?@(:cljs [> (t/assume t/str?)])] (let* [sb (-> x str|test !str)] ; determined to be StringBuilder ;; TODO is `doseq` the right approach, or using reduction? (doseq [x' xs] (.append sb (str x'))) @@ -1357,12 +1397,12 @@ (defn str {:quantum.core.type/type - (t/fn :> t/string? + (t/fn :> t/str? [] [t/nil?] #?(:clj [(t/isa? Object)]) - #?(:cljs [t/any? :> (t/assume t/string?)]) - [(t/fn> str t/any?) :& (? (t/seq-of t/any?)) #?@(:cljs [:> (t/assume t/string?)])])} + #?(:cljs [t/any? :> (t/assume t/str?)]) + [(t/fn> str t/any?) :& (? (t/seq-of t/any?)) #?@(:cljs [:> (t/assume t/str?)])])} ([ ] (.invoke !str|__0)) ([a0] (ifs (nil? x) (.invoke !str|__1) (.invoke !str|__2 a0))) @@ -1383,9 +1423,9 @@ ;; TODO enable the disabled parts of this (macroexpand ' -(defnt #_:inline count #_> #_t/nneg-integer? +(self/defn #_:inline count #_> #_t/nneg-integer? ([xs t/array? #_> #_t/nneg-int?] (.length xs)) - #_([xs t/string? > #?(:clj t/nneg-int? :cljs (t/assume t/nneg-int?))] + #_([xs t/str? > #?(:clj t/nneg-int? :cljs (t/assume t/nneg-int?))] (#?(:clj .length :cljs .-length) xs)) #_([xs !+vector? > t/nneg-int?] (#?(:clj count :cljs (do (TODO) 0)) xs))) ) @@ -1395,7 +1435,7 @@ `(do (swap! fn->spec assoc #'count (t/fn :> t/pos-integer? [t/array? :> t/nneg-int?] - [t/string? :> #?(:clj t/nneg-int? :cljs (t/assume t/nneg-int?))] + [t/str? :> #?(:clj t/nneg-int? :cljs (t/assume t/nneg-int?))] [!+vector? :> t/nneg-int?])) ~(case-env @@ -1407,10 +1447,10 @@ ;; =====|=====|=====|=====|===== ;; (macroexpand ' -(defnt #_:inline get +(self/defn #_:inline get ;; TODO `t/numerically ([xs t/array? , k #_(t/numerically t/int?)] (#?(:clj Array/get :cljs aget) xs k)) - ([xs t/string?, k #_(t/numerically t/int?)] (.charAt xs k)) + ([xs t/str? , k #_(t/numerically t/int?)] (.charAt xs k)) ([xs !+vector?, k t/any?] #?(:clj (.valAt xs k) :cljs (TODO)))) ) ;; ----- expanded code ----- ;; @@ -1418,20 +1458,20 @@ `(do (swap! fn->spec assoc #'count (t/fn :> t/pos-integer? [t/array? (t/numerically t/int?)] - [t/string? (t/numerically t/int?)] + [t/str? (t/numerically t/int?)] [!+vector? t/any?])) ...) ;; =====|=====|=====|=====|===== ;; -(defnt zero? > boolean? +(self/defn zero? > boolean? ([x (t/- primitive? boolean?)] (Numeric/isZero x))) ; TODO CLJS version will come after #?(:clj (macroexpand ' -(defnt seq +(self/defn seq "Taken from `clojure.lang.RT/seq`" > (t/? (t/isa? ISeq)) ([xs t/nil?] nil) @@ -1559,7 +1599,7 @@ ;; =====|=====|=====|=====|===== ;; (macroexpand ' -(defnt first +(self/defn first ([xs t/nil? ] nil) ([xs (t/and t/sequential? t/indexed?)] (get xs 0)) ([xs (t/isa? ISeq) ] (.first xs)) @@ -1582,7 +1622,7 @@ ;; =====|=====|=====|=====|===== ;; (macroexpand ' -(defnt next > (? ISeq) +(self/defn next > (? ISeq) "Taken from `clojure.lang.RT/next`" ([xs t/nil?] nil) ([xs (t/isa? ISeq)] (.next xs)) @@ -1608,7 +1648,7 @@ "completing arity" [_] "reducing arity" [_ _])) -(defnt reduce +(self/defn reduce "Much of this content taken from clojure.core.protocols for inlining and type-checking purposes." {:attribution "alexandergunnarson"} @@ -1623,7 +1663,7 @@ (recur (zip/right xs) ret))) v))) ;; TODO look at CLJS `array-reduce` - ([f rf?, init _, xs (t/or t/array? t/string? t/!+vector?)] ; because transient vectors aren't reducible + ([f rf?, init _, xs (t/or t/array? t/str? t/!+vector?)] ; because transient vectors aren't reducible (let [ct (count xs)] (loop [i 0 v init] (if (< i ct) @@ -1718,7 +1758,7 @@ (do (t/def xf? "Transforming function" (t/fn [rf? :> rf?])) - (defnt transduce + (self/defn transduce ([ f rf?, xs t/reducible?] (transduce identity f xs)) ([xf xf?, f rf?, xs t/reducible?] (transduce xf f (f) xs)) ([xf xf?, f rf?, init _, xs t/reducible?] @@ -1731,7 +1771,7 @@ (do -; (optional) function — only when the `defnt` has an arity with 0 arguments +; (optional) function — only when the `t/defn` has an arity with 0 arguments ; (optional) inline macros — invoked only if in a typed context and not used as a function (do #?(:clj (defmacro clj:name:java:lang:String [a0] `(let [~'x ~a0] ~'x))) @@ -1740,14 +1780,14 @@ #?(:clj (defmacro cljs:name:cljs:core:INamed [a0] `(let [~'x ~a0] ~'(.getName x))))) ) -(extend-defnt abc/name ; for use outside of ns +(self/extend-defn! abc/name ; for use outside of ns ([a ?, b ?] (...))) ;; This is necessarily dynamic dispatch (name (read )) (do -; (optional) function — only when the `defnt` has an arity with 0 arguments +; (optional) function — only when the `t/defn` has an arity with 0 arguments ; (optional) inline macros — invoked only if in a typed context and not used as a function (do #?(:clj (defmacro clj:name:java:lang:String [a0] `(let* [~'x ~a0] ~'x))) @@ -1758,11 +1798,11 @@ ; ================================================ ; -(defnt ^:inline custom +(self/defn ^:inline custom [x (s/if double? (t/or (s/fnt [x ?] (> x 3)) ; uses the above-defined `>` (s/fnt [x ?] (< x 0.1))) - (t/or string? !string?)) + (t/or str? !str?)) y ?] (str x (name y))) ; uses the above-defined `name` @@ -1774,32 +1814,32 @@ ;; For instance, this is only able to be checked in CLJS, because `js-object?` is not implemented ;; in CLJ: -(defnt abcde1 - [x #?(:clj string? :cljs js-object?)] ...) +(self/defn abcde1 + [x #?(:clj str? :cljs js-object?)] ...) ;; This could be checked in CLJ, but it would be an error to do so: (defn my-spec [x] #?(:clj (check-this) :cljs (check-that))) -(defnt abcde2 +(self/defn abcde2 [x my-spec] ...) ;; So what is the solution? One solution is to forgo some functionality in ClojureScript and ;; instead rely fundamentally on the aggregative relationships among predicates created using the -;; `defnt` spec system. +;; `t/defn` spec system. ;; For instance: -(defnt abcde1 [x (t/pc :clj string? :cljs js-object?)] ...) +(self/defn abcde1 [x (t/pc :clj str? :cljs js-object?)] ...) ;; Or: -(t/def abcde1|x? :clj string? :cljs js-object?) +(t/def abcde1|x? :clj str? :cljs js-object?) -(defnt abcde1 [x abcde1|x?] ...) +(self/defn abcde1 [x abcde1|x?] ...) -;; Because the spec was registered using the `defnt` spec system, the quoted forms can be analyzed and +;; Because the spec was registered using the `t/defn` spec system, the quoted forms can be analyzed and ;; at least some things can be deduced. ;; In this case, the spec of `x` is deducible: `abcde1|x?` (`js-object?` deeper down). The return spec is also deducible as being the return spec of `abcde1`: -(defnt abcde2 [x ?] (abcde1 x)) +(self/defn abcde2 [x ?] (abcde1 x)) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 01c61dcd..d81ac747 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -20,7 +20,7 @@ :refer [<- fn-> fn->>]] [quantum.untyped.core.form.evaluate :as ufeval] [quantum.untyped.core.form.type-hint :as ufth] - [quantum.untyped.core.identifers :as uident + [quantum.untyped.core.identifiers :as uident :refer [>symbol]] [quantum.untyped.core.log :as log :refer [prl!]] diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 8dc165c3..ec124e29 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -176,7 +176,7 @@ [env #_::env form #_::t/form target #_::node - field #_id/unqualified-symbol? + field #_unqualified-symbol? type #_t/type?] INode fipp.ednize/IOverride @@ -192,7 +192,7 @@ [env #_::env form #_::t/form target #_::node - method #_::id/unqualified-symbol? + method #_::unqualified-symbol? args #_(t/and t/sequential? t/indexed? (t/seq-and ::node)) type #_t/type?] INode diff --git a/src-untyped/quantum/untyped/core/core.cljc b/src-untyped/quantum/untyped/core/core.cljc index 7a92d94d..edd287fd 100644 --- a/src-untyped/quantum/untyped/core/core.cljc +++ b/src-untyped/quantum/untyped/core/core.cljc @@ -7,7 +7,7 @@ [cuerdas.core :as str+] #?@(:clj [[environ.core :as env]])) #?(:cljs (:require-macros - [quantum.untyped.core.core :as this]))) + [quantum.untyped.core.core :as self]))) ;; ===== Environment ===== ;; diff --git a/src-untyped/quantum/untyped/core/data/hash.cljc b/src-untyped/quantum/untyped/core/data/hash.cljc index 0feafd6f..201f05ff 100644 --- a/src-untyped/quantum/untyped/core/data/hash.cljc +++ b/src-untyped/quantum/untyped/core/data/hash.cljc @@ -2,9 +2,9 @@ (:refer-clojure :exclude [hash]) (:require - [clojure.core :as core]) + [clojure.core :as core]) #?(:cljs (:require-macros - [quantum.untyped.core.data.hash :as this]))) + [quantum.untyped.core.data.hash :as self]))) (def ^:const default -1) diff --git a/src-untyped/quantum/untyped/core/data/numeric.cljc b/src-untyped/quantum/untyped/core/data/numeric.cljc index 80ca0132..bf79fe13 100644 --- a/src-untyped/quantum/untyped/core/data/numeric.cljc +++ b/src-untyped/quantum/untyped/core/data/numeric.cljc @@ -1,12 +1,9 @@ (ns quantum.core.data.numeric (:refer-clojure :exclude - [#?@(:cljs [-compare]) decimal? denominator integer? number? numerator ratio? - read-string]) + [#?@(:cljs [-compare]) decimal? denominator integer? number? numerator ratio?]) (:require [clojure.core :as core] [clojure.string :as str] - [clojure.tools.reader - :refer [read-string]] #?(:cljs [com.gfredericks.goog.math.Integer :as int]) [quantum.core.data.primitive :as p] [quantum.core.data.string :as dstr] @@ -14,7 +11,7 @@ :refer [whenf fn-not fn=]] [quantum.core.type :as t :refer [defnt]] - [quantum.core.vars + [quantum.core.vars :as var :refer [defalias]]) (:import [clojure.lang BigInt Numbers] @@ -127,3 +124,9 @@ (def number? (t/or #?@(:clj [(t/isa? java.lang.Number)] :cljs [integer? decimal? ratio?]))) + +(var/def numeric? + "Something 'numeric' is something that may be treated as a number but may not actually *be* one." + (t/or number? #?(:clj p/char?))) + +(def numeric-primitive? (t/- p/primitive? p/boolean?)) diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index b260cecd..d31d753f 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -21,7 +21,7 @@ [quantum.untyped.core.specs :as uss]) #?(:cljs (:require-macros - [quantum.untyped.core.defnt :as this]))) + [quantum.untyped.core.defnt :as self]))) ;; ===== Specs ===== ;; @@ -383,11 +383,11 @@ (case ~arity-kind-sym ~@spec-form|fn))))) fn|name|with-meta (with-meta fn|name fn|meta) fn-form (case kind - :fn (list* 'fn (concat (when (contains? args' :quantum.core.specs/fn|name) + :fn (list* 'clojure.core/fn (concat (when (contains? args' :quantum.core.specs/fn|name) [fn|name|with-meta]) overload-forms)) - :defn (list* 'defn fn|name|with-meta overload-forms) - :defn- (list* 'defn- fn|name|with-meta overload-forms)) + :defn (list* 'clojure.core/defn fn|name|with-meta overload-forms) + :defn- (list* 'clojure.core/defn- fn|name|with-meta overload-forms)) code `(do ~spec-form ~fn-form)] code)) diff --git a/src-untyped/quantum/untyped/core/reducers.cljc b/src-untyped/quantum/untyped/core/reducers.cljc index 4eb02eda..b9e8b401 100644 --- a/src-untyped/quantum/untyped/core/reducers.cljc +++ b/src-untyped/quantum/untyped/core/reducers.cljc @@ -18,7 +18,7 @@ [quantum.untyped.core.vars :as uvar :refer [defalias]]) #?(:cljs (:require-macros - [quantum.untyped.core.reducers :as this]))) + [quantum.untyped.core.reducers :as self]))) (ucore/log-this-ns) diff --git a/src-untyped/quantum/untyped/core/specs.cljc b/src-untyped/quantum/untyped/core/specs.cljc index ec2482a4..77211d59 100644 --- a/src-untyped/quantum/untyped/core/specs.cljc +++ b/src-untyped/quantum/untyped/core/specs.cljc @@ -12,7 +12,7 @@ [quantum.untyped.core.spec :as s]) #?(:cljs (:require-macros - [quantum.untyped.core.specs :as this + [quantum.untyped.core.specs :as self :refer [quotable]]))) ;;;; GENERAL diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 93869365..d9269aec 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -9,7 +9,7 @@ isa? nil? any? class? tagged-literal? #?(:cljs object?) number? decimal? bigdec? integer? ratio? - true? false? keyword? string? symbol? + true? false? keyword? symbol? array? associative? coll? counted? indexed? iterable? list? map? map-entry? record? seq? seqable? sequential? set? sorted? vector? fn? ifn? @@ -926,6 +926,12 @@ ;; Used by `quantum.untyped.core.analyze` (-def keyword? (isa? #?(:clj clojure.lang.Keyword :cljs cljs.core/Keyword))) + ;; Used by `quantum.untyped.core.analyze` via `t/literal?` + (-def str? (isa? #?(:clj java.lang.String :cljs js/String))) + + ;; Used by `quantum.untyped.core.analyze` via `t/literal?` + (-def symbol? (isa? #?(:clj clojure.lang.Symbol :cljs cljs.core/Symbol))) + #?(:clj (-def namespace? (isa? clojure.lang.Namespace))) ;; `js/File` isn't always available! Use an abstraction @@ -941,7 +947,8 @@ #?(:clj (-def tagged-literal? (isa? clojure.lang.TaggedLiteral))) - (-def literal? (or nil? boolean? symbol? keyword? t/string? #?(:clj long?) double? #?(:clj tagged-literal?))) + ;; Used in `quantum.untyped.core.analyze` + (-def literal? (or nil? boolean? symbol? keyword? str? #?(:clj long?) double? #?(:clj tagged-literal?))) #_(-def form? (or literal? +list? +vector? ...)) ;; ===== Generic ===== ;; diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index f795d5d4..102f872b 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -1,4 +1,6 @@ (ns quantum.untyped.core.type.defnt + (:refer-clojure :exclude + [defn]) (:require [clojure.core :as core] [clojure.string :as str] @@ -29,7 +31,7 @@ [quantum.untyped.core.form.evaluate :as ufeval] [quantum.untyped.core.form.generate :as ufgen] [quantum.untyped.core.form.type-hint :as ufth] - [quantum.untyped.core.identifiers :as uident + [quantum.untyped.core.identifiers :as uid :refer [>name >symbol]] [quantum.untyped.core.log :as ulog] [quantum.untyped.core.logic :as ul @@ -50,56 +52,12 @@ [quantum.core Numeric] [quantum.core.data Array])) -;; TODO probably move -(def index? #(and (integer? %) (>= % 0))) - -#?(:clj -(defns class>simplest-class - "This ensures that special overloads are not created for non-primitive subclasses - of java.lang.Object (e.g. String, etc.)." - [c (? t/class?) > (? t/class?)] - (if (t/primitive-class? c) - c - (or (tcore/boxed->unboxed c) java.lang.Object)))) - -#?(:clj -(defns class>most-primitive-class [c (? t/class?), nilable? t/boolean? > (? t/class?)] - (if nilable? c (or (tcore/boxed->unboxed c) c)))) - -#?(:clj -(defns type>most-primitive-classes [t t/type? > (s/set-of (? t/class?))] - (let [cs (t/type>classes t) nilable? (contains? cs nil)] - (->> cs - (c/map+ #(class>most-primitive-class % nilable?)) - (r/join #{}))))) - -#?(:clj -(defns type>most-primitive-class [t t/type? > (? t/class?)] - (let [cs (type>most-primitive-classes t)] - (if (-> cs count (not= 1)) - (err! "Not exactly 1 class found" (kw-map t cs)) - (first cs))))) - -#?(:clj -(defns out-type>class [t t/type? > (? t/class?)] - (let [cs (t/type>classes t) cs' (disj cs nil)] - (if (-> cs' count (not= 1)) - ;; NOTE: we don't need to vary the output class if there are multiple output possibilities - ;; or just nil - java.lang.Object - (-> (class>most-primitive-class (first cs') (contains? cs nil)) - class>simplest-class))))) - -; ----- TYPED PART ----- ; - (defonce *fn->type (atom {})) (defonce defnt-cache (atom {})) ; TODO For now — but maybe lock-free concurrent hash map to come (defonce *interfaces (atom {})) -;; ===== (DE)FNT ===== ;; - ;; Internal specs (s/def ::expanded-overload|arg-classes (s/vec-of t/class?)) @@ -187,13 +145,13 @@ :overload-data ::overload-data})) #_(:clj -(defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] +(core/defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] (cond (not= k :spec) java.lang.Object; default class (symbol? spec) (pred->class lang spec)))) ;; TODO optimize such that `post-type|form` doesn't create a new type-validator wholesale every ;; time the function gets run; e.g. extern it -(defn >with-post-type|form [body post-type|form] `(t/validate ~body ~post-type|form)) +(core/defn >with-post-type|form [body post-type|form] `(t/validate ~body ~post-type|form)) #?(:clj (uvar/def sort-guide "for use in arity sorting, in increasing conceptual (and bit) size" @@ -207,6 +165,57 @@ tdef/float 7 tdef/double 8})) +;; TODO move +(def index? #(and (integer? %) (>= % 0))) + +;; TODO simplify this class computation + +#?(:clj +(defns class>simplest-class + "This ensures that special overloads are not created for non-primitive subclasses + of java.lang.Object (e.g. String, etc.)." + [c (? t/class?) > (? t/class?)] + (if (t/primitive-class? c) c java.lang.Object))) + +#?(:clj +(defns class>most-primitive-class [c (? t/class?), nilable? t/boolean? > (? t/class?)] + (if nilable? c (or (tcore/boxed->unboxed c) c)))) + +#?(:clj +(defns type>most-primitive-classes [t t/type? > (s/set-of (? t/class?))] + (let [cs (t/type>classes t) + nilable? (or (-> t meta :quantum.core.type/ref?) (contains? cs nil))] + (->> cs + (c/map+ #(class>most-primitive-class % nilable?)) + (r/join #{}))))) + +#?(:clj +(defns out-type>class [t t/type? > (? t/class?)] + (if (-> t meta :quantum.core.type/ref?) + java.lang.Object + (let [cs (t/type>classes t) + cs' (disj cs nil)] + (if (-> cs' count (not= 1)) + ;; NOTE: we don't need to vary the output class if there are multiple output possibilities + ;; or just nil + java.lang.Object + (-> (class>most-primitive-class (first cs') (contains? cs nil)) + class>simplest-class)))))) + +#?(:clj +(defns arg-type>arg-classes-seq|primitivized [arg-type t/type? > (s/seq-of class?)] + (if (-> arg-type meta :quantum.core.type/ref?) + (-> arg-type t/type>classes (disj nil) seq) + (let [cs (type>most-primitive-classes arg-type) + base-classes + (cond-> cs + (contains? cs nil) (-> (disj nil) (conj java.lang.Object)))] + (->> cs + (c/map+ tcore/class>prim-subclasses) + (educe (aritoid nil identity uset/union) base-classes) + ;; for purposes of cleanliness and reproducibility in tests + (sort-by sort-guide)))))) + #?(:clj (defns arg-types>arg-classes-seq|primitivized "'primitivized' meaning given an arglist whose types are `[t/any?]` this will output: @@ -222,18 +231,7 @@ which includes all primitive subclasses of the type." [arg-types (s/seq-of t/type?) > (s/seq-of ::expanded-overload|arg-classes)] (->> arg-types - (c/lmap (fn [t #_t/type?] - (if (-> t meta :quantum.core.type/ref?) - (-> t t/type>classes (disj nil) seq) - (let [cs (type>most-primitive-classes t) - base-classes - (cond-> (>set cs) - (contains? cs nil) (-> (disj nil) (conj java.lang.Object)))] - (->> cs - (c/map+ tcore/class>prim-subclasses) - (educe (aritoid nil identity uset/union) base-classes) - ;; for purposes of cleanliness and reproducibility in tests - (sort-by sort-guide)))))) + (c/lmap arg-type>arg-classes-seq|primitivized) (apply ucombo/cartesian-product) (c/lmap >vec)))) @@ -263,21 +261,22 @@ lang (c/count arg-bindings) varargs))) - post-type|runtime? (-> post-type meta :quantum.core.type/runtime?) post-type|assume? (-> post-type meta :quantum.core.type/assume?) + post-type|ref? (-> post-type meta :quantum.core.type/ref?) + post-type|runtime? (-> post-type meta :quantum.core.type/runtime?) err-info {:form (:form analyzed) :type (:type analyzed) :declared-output-type post-type} out-type (if post-type (case (t/compare (:type analyzed) post-type) - (-1 0) (:type analyzed) + (-1 0) (cond-> (:type analyzed) post-type|ref? t/ref) 1 (if (or post-type|runtime? post-type|assume?) post-type (err! (str "Body type incompatible with declared output type even" " when relaxing compile-time type enforcement") err-info)) (2 3) (err! "Body type incompatible with declared output type" err-info)) - (:type analyzed)) + (cond-> (:type analyzed) post-type|ref? t/ref)) body-form (-> (:form analyzed) (cond-> post-type|runtime? (>with-post-type|form post-type|form)) @@ -307,8 +306,8 @@ (mapv (fn [arg-classes #_::expanded-overload|arg-classes] (let [arg-types|satisfying-primitivization (c/mergev-with - (fn [_ s #_t/type? c #_t/class?] - (cond-> s (t/primitive-class? c) (t/and c))) + (fn [_ t #_t/type? c #_t/class?] + (cond-> t (t/primitive-class? c) (t/and c))) arg-types|expanded arg-classes)] (>expanded-overload overload-data fnt-globals opts arg-bindings arg-types|satisfying-primitivization arg-classes @@ -469,7 +468,7 @@ (def min-shorthand-tag-length 1) (def max-shorthand-tag-length 64) ; for now -(defn >all-shorthand-tags [] +(core/defn >all-shorthand-tags [] (->> (range min-shorthand-tag-length (inc max-shorthand-tag-length)) c/unchunk (c/lmap (fn [n] (apply ucombo/cartesian-product (repeat n allowed-shorthand-tag-chars)))) @@ -492,7 +491,7 @@ (get c)))) ;; TODO spec -(defn assert-monotonically-increasing-types! +(core/defn assert-monotonically-increasing-types! "Asserts that each type in an overload of the same arity and arg-position are in monotonically increasing order in terms of `t/compare`." [overloads|grouped-by-arity] @@ -572,7 +571,7 @@ [fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?), i|arg index?, body _] (if (-> body count (= 1)) (first body) - `(ifs ~@body (unsupported! (quote ~(uident/qualify fn|name)) [~@arglist] ~i|arg)))) + `(ifs ~@body (unsupported! (quote ~(uid/qualify fn|name)) [~@arglist] ~i|arg)))) (defns >dynamic-dispatch|body-for-arity ([fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?) @@ -611,7 +610,7 @@ {:as opts :keys [gen-gensym _, lang _]} ::opts expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups) i-overload->direct-dispatch-data ::i-overload->direct-dispatch-data] - `(defn ~fn|name + `(core/defn ~fn|name ~(assoc fn|meta :quantum.core.type/type (>dynamic-dispatch-fn|type-decl fnt-globals expanded-overload-groups-by-fnt-overload)) ~@(->> i-overload->direct-dispatch-data @@ -696,5 +695,5 @@ :defn `(~'do ~@fn-codelist))] code)) -#?(:clj (defmacro fnt [& args] (fnt|code :fn (ufeval/env-lang) args))) -#?(:clj (defmacro defnt [& args] (fnt|code :defn (ufeval/env-lang) args))) +#?(:clj (defmacro fnt [& args] (fnt|code :fn (ufeval/env-lang) args))) +#?(:clj (defmacro defn [& args] (fnt|code :defn (ufeval/env-lang) args))) diff --git a/src-untyped/quantum/untyped/core/vars.cljc b/src-untyped/quantum/untyped/core/vars.cljc index d3d0e913..f9421e31 100644 --- a/src-untyped/quantum/untyped/core/vars.cljc +++ b/src-untyped/quantum/untyped/core/vars.cljc @@ -7,7 +7,7 @@ :refer [case-env case-env*]] [quantum.untyped.core.form.generate :as ufgen]) #?(:cljs (:require-macros - [quantum.untyped.core.vars :as this]))) + [quantum.untyped.core.vars :as self]))) (ucore/log-this-ns) diff --git a/src/quantum/core/compare.cljc b/src/quantum/core/compare.cljc index 598fc90d..2171629c 100644 --- a/src/quantum/core/compare.cljc +++ b/src/quantum/core/compare.cljc @@ -147,7 +147,7 @@ (red/reducei-sentinel (fn [a b i] (when-not (neg? (#?@(:clj [.compare ^java.util.Comparator comparef] - :cljs [comparef]) + :cljs [comparef]) (kf a) (kf b))) (conj! xs' [i b])) b) xs) diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index 595cff6b..b096fb1d 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -27,6 +27,8 @@ (:import clojure.lang.BigInt quantum.core.Numeric))) +;; TODO `==` from Numeric/equals + ; Some of the ideas here adapted from gfredericks/compare ; TODO include diffing ; TODO use -compare in CLJS diff --git a/src/quantum/core/core.cljc b/src/quantum/core/core.cljc deleted file mode 100644 index e075db6b..00000000 --- a/src/quantum/core/core.cljc +++ /dev/null @@ -1 +0,0 @@ -(ns quantum.core.core) diff --git a/src/quantum/core/data/identifiers.cljc b/src/quantum/core/data/identifiers.cljc index bccfb8ec..4fd33b87 100644 --- a/src/quantum/core/data/identifiers.cljc +++ b/src/quantum/core/data/identifiers.cljc @@ -4,7 +4,7 @@ (:refer-clojure :exclude [keyword? symbol?]) (:require - [quantum.core.data.meta :as dm + [quantum.core.data.meta :refer [>meta]] [quantum.core.data.string :as dstr :refer [str? >str]] diff --git a/src/quantum/core/data/map.cljc b/src/quantum/core/data/map.cljc index 299ed439..318e7adb 100644 --- a/src/quantum/core/data/map.cljc +++ b/src/quantum/core/data/map.cljc @@ -8,8 +8,7 @@ ;; TODO TYPED #_[quantum.core.reducers :as r :refer [reduce-pair]] - [quantum.core.type :as t - :refer [defnt]] + [quantum.core.type :as t] [quantum.untyped.core.data.map :as umap] ;; TODO TYPED [quantum.untyped.core.defnt @@ -73,7 +72,7 @@ (def +map-entry? (t/isa? #?(:clj clojure.lang.MapEntry :cljs cljs.core.MapEntry))) -(defnt >map-entry +(t/defn ^:inline >map-entry "A performant replacement for creating 2-tuples (vectors), e.g., as return values in a `kv-reduce` function. @@ -92,7 +91,7 @@ 310.335998 ms (dotimes [n 1000000] (into m0 ms))" {:attribution "alexandergunnarson"} > +map-entry? - [k _, v _] + [k t/ref?, v t/ref?] #?(:clj (clojure.lang.MapEntry. k v) :cljs (cljs.core.MapEntry. k v nil))) @@ -108,7 +107,7 @@ (def identity-map? (t/or !identity-map? #?(:clj !!identity-map?))) ;; TODO generate this via macro? -(defnt >!identity-map +(t/defn >!identity-map "Creates a single-threaded, mutable identity map. On the JVM, this is a `java.util.IdentityHashMap`. On JS, this is a `js/Map` (ECMAScript 6 Map)." @@ -348,7 +347,7 @@ (def array-map? (t/or ?!+array-map? !array-map? #?(:clj !!array-map?))) -(defnt >array-map +(t/defn >array-map "Creates a persistent array map. If any keys are equal, they are handled as if by repeated applications of `assoc`." > +array-map? @@ -480,7 +479,7 @@ (def ?!+hash-map? (t/or !+hash-map? +hash-map?)) -(defnt >hash-map +(t/defn >hash-map "Creates a persistent hash map. If any keys are equal, they are handled as if by repeated applications of `assoc`. @@ -811,7 +810,7 @@ (def hash-map? (t/or ?!+hash-map? !hash-map? #?(:clj !!hash-map?))) ;; TODO generate this function via macro? -(defnt >!hash-map +(t/defn >!hash-map "Creates a single-threaded, mutable hash map. On the JVM, this is a `java.util.HashMap`. On JS, this is a `quantum.untyped.core.data.map.HashMap`." @@ -869,11 +868,11 @@ ;; TODO generate these functions via macros ;; TODO this is incomplete -#?(:clj (defnt >!hash-map|int->ref > !hash-map|int->ref? [] (Int2ReferenceOpenHashMap.))) -#?(:clj (defnt >!hash-map|long->long > !hash-map|long->long? [] (Long2LongOpenHashMap.))) -#?(:clj (defnt >!hash-map|long->ref > !hash-map|long->ref? [] (Long2ReferenceOpenHashMap.))) -#?(:clj (defnt >!hash-map|double->ref > !hash-map|double->ref? [] (Double2ReferenceOpenHashMap.))) -#?(:clj (defnt >!hash-map|ref->long > !hash-map|ref->long? [] (Reference2LongOpenHashMap.))) +#?(:clj (t/defn >!hash-map|int->ref > !hash-map|int->ref? [] (Int2ReferenceOpenHashMap.))) +#?(:clj (t/defn >!hash-map|long->long > !hash-map|long->long? [] (Long2LongOpenHashMap.))) +#?(:clj (t/defn >!hash-map|long->ref > !hash-map|long->ref? [] (Long2ReferenceOpenHashMap.))) +#?(:clj (t/defn >!hash-map|double->ref > !hash-map|double->ref? [] (Double2ReferenceOpenHashMap.))) +#?(:clj (t/defn >!hash-map|ref->long > !hash-map|ref->long? [] (Reference2LongOpenHashMap.))) ;; ----- Unsorted Maps ----- ;; TODO Perhaps the concept of unsortedness is `(- map sorted?)`? @@ -1064,7 +1063,7 @@ (def unsorted-map? (t/or ?!+unsorted-map? !unsorted-map? #?(:clj !!unsorted-map?))) #?(:clj -(defnt >unsorted-map|long->ref +(t/defn >unsorted-map|long->ref "Creates a persistent integer map that can only have non-negative integers as keys." > +unsorted-map|long->ref? ([] (clojure.data.int_map.PersistentIntMap. clojure.data.int_map.Nodes$Empty/EMPTY 0 nil)) @@ -1102,7 +1101,7 @@ #?(:clj !!insertion-ordered-map?))) ;; TODO generate this function via macro -(defnt >!insertion-ordered-map +(t/defn >!insertion-ordered-map "Creates a single-threaded, mutable insertion-ordered map. On the JVM, this is a `java.util.LinkedHashMap`. On JS, this is a `goog.structs.LinkedMap`." @@ -1351,7 +1350,7 @@ ;; TODO generate this function via macro ;; TODO TYPED replaced `t/fn?` with a more specific `(t/fn [...])` named as e.g. `fn/comparator?` -(defnt >!sorted-map-by +(t/defn >!sorted-map-by "Creates a single-threaded, mutable sorted map with the specified comparator. On the JVM, this is a `java.util.TreeMap`. On JS, this is a `goog.structs.AvlTree`." @@ -1410,7 +1409,7 @@ ;; TODO generate this function via macro ;; TODO TYPED replace `compare` with typed version -(defnt >!sorted-map +(t/defn >!sorted-map "Creates a single-threaded, mutable sorted map. On the JVM, this is a `java.util.TreeMap`. On JS, this is a `goog.structs.AvlTree`." @@ -1435,7 +1434,7 @@ (apply >!sorted-map-by compare k0 v0 k1 v1 k2 v2 k3 v3 k4 v4 k5 v5 k6 v6 kvs))) ;; TODO TYPED `apply`, variadic -#_(defnt !sorted-map-by-val > !sorted-map|ref->ref? [m & kvs] +#_(t/defn !sorted-map-by-val > !sorted-map|ref->ref? [m & kvs] (apply !sorted-map-by (gen-compare-by-val m) kvs)) ;; ----- General Maps ----- ;; diff --git a/src/quantum/core/data/meta.cljc b/src/quantum/core/data/meta.cljc index c5ed681a..c00cb726 100644 --- a/src/quantum/core/data/meta.cljc +++ b/src/quantum/core/data/meta.cljc @@ -4,19 +4,18 @@ [reset-meta! with-meta]) (:require [quantum.core.data.map :as map] - [quantum.core.type :as t - :refer [defnt]])) + [quantum.core.type :as t])) (def meta? (t/? map/+map?)) (def metable? (t/isa? #?(:clj clojure.lang.IMeta :cljs cljs.core/IMeta))) (def with-metable? (t/isa? #?(:clj clojure.lang.IObj :cljs cljs.core/IWithMeta))) -(defnt >meta +(t/defn ^:inline >meta "Returns the (possibly nil) metadata of ->`x`." > meta? [x metable?] (#?(:clj .meta :cljs cljs.core/-meta) x)) -(defnt with-meta +(t/defn ^:inline with-meta "Returns an object of the same type and value as ->`x`, with ->`meta'` as its metadata." > with-metable? ([x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))] @@ -24,28 +23,28 @@ #?(:cljs ([x goog/isFunction, meta' meta?] (cljs.core/MetaFn. x meta')))) -(defnt reset-meta! +(t/defn ^:inline reset-meta! "Atomically resets ->`x`'s metadata to be ->`meta'`." > meta? [x (t/isa? #?(:clj clojure.lang.IReference :cljs (TODO))) meta' meta?] (#?(:clj .resetMeta :cljs (set! (.-meta x) m)) x meta')) ;; TODO TYPED -#_(defnt update-meta +#_(t/defn update-meta "Returns an object of the same type and value as ->`x`, with its metadata updated by ->`f`." ;; TODO `f` should more specifically be able to handle the args arity and specs [x (t/and with-metable? metable?) f (t/fn meta? [& (t/type-of %args)]) & args _] (with-meta x (apply f (meta x) args))) ;; TODO TYPED -#_(defnt merge-meta +#_(t/defn merge-meta {:alternate-implementations #{'cljs.tools.reader/merge-meta}} [x (t/and with-metable? metable?) meta- meta? > (t/spec-of x)] (update-meta x merge meta-)) ;; TODO TYPED -#_(defnt merge-meta-from [to (t/and with-metable? metable?), from metable?] +#_(t/defn merge-meta-from [to (t/and with-metable? metable?), from metable?] (update-meta to merge (>meta from))) -(defnt replace-meta-from > with-metable? [to with-metable?, from metable?] +(t/defn replace-meta-from > with-metable? [to with-metable?, from metable?] (with-meta to (>meta from))) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index ae857f73..26db5dc5 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -3,10 +3,7 @@ [boolean? char? comparable? decimal? double? float? int? integer?]) (:require #?(:cljs [com.gfredericks.goog.math.Integer :as int]) - [quantum.core.type :as t - :refer [defnt]] - [quantum.core.vars - :refer [def-]]) + [quantum.core.type :as t]) #?(:clj (:import [java.nio ByteBuffer] [quantum.core Numeric Primitive]))) @@ -62,18 +59,18 @@ Void Void/TYPE})) #?(:clj -(defnt box - ([x boolean? > (t/ref boolean?)] (Boolean/valueOf x)) - ([x byte? > (t/ref byte?)] (Byte/valueOf x)) - ([x char? > (t/ref char?)] (Character/valueOf x)) - ([x short? > (t/ref short?)] (Short/valueOf x)) - ([x int? > (t/ref int?)] (Integer/valueOf x)) - ([x long? > (t/ref long?)] (Long/valueOf x)) - ([x float? > (t/ref float?)] (Float/valueOf x)) - ([x double? > (t/ref double?)] (Double/valueOf x)))) +(t/defn ^:inline box + ([x boolean? > (t/assume (t/ref boolean?))] (Boolean/valueOf x)) + ([x byte? > (t/assume (t/ref byte?))] (Byte/valueOf x)) + ([x char? > (t/assume (t/ref char?))] (Character/valueOf x)) + ([x short? > (t/assume (t/ref short?))] (Short/valueOf x)) + ([x int? > (t/assume (t/ref int?))] (Integer/valueOf x)) + ([x long? > (t/assume (t/ref long?))] (Long/valueOf x)) + ([x float? > (t/assume (t/ref float?))] (Float/valueOf x)) + ([x double? > (t/assume (t/ref double?))] (Double/valueOf x)))) #?(:clj -(defnt unbox +(t/defn ^:inline unbox ([x (t/ref boolean?) > boolean?] (.booleanValue x)) ([x (t/ref byte?) > byte?] (.byteValue x)) ([x (t/ref char?) > char?] (.charValue x)) @@ -85,7 +82,7 @@ ;; ===== Extreme magnitudes and values ===== ;; -(defnt ^:inline >min-magnitude +(t/defn ^:inline >min-magnitude #?(:clj ([x byte? > byte?] (byte 0))) #?(:clj ([x short? > short?] (short 0))) #?(:clj ([x char? > char?] (char 0))) @@ -95,11 +92,11 @@ ([x double? > double?] #?(:clj Double/MIN_VALUE :cljs js/Number.MIN_VALUE))) -#?(:clj (def- min-float (- Float/MAX_VALUE))) - (def- min-double (- #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) +#?(:clj (def ^:private min-float (- Float/MAX_VALUE))) + (def ^:private min-double (- #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) ;; TODO TYPED for some reason it's not figuring out the type of `min-float` and `min-double` -#_(defnt ^:inline >min-value +#_(t/defn ^:inline >min-value #?(:clj ([x byte? > byte?] Byte/MIN_VALUE)) #?(:clj ([x short? > short?] Short/MIN_VALUE)) #?(:clj ([x char? > char?] Character/MIN_VALUE)) @@ -108,7 +105,7 @@ #?(:clj ([x float? > float?] min-float)) ([x double? > double?] min-double)) -(defnt ^:inline >max-value +(t/defn ^:inline >max-value #?@(:clj [([x byte? > byte?] Byte/MAX_VALUE) ([x short? > short?] Short/MAX_VALUE) ([x char? > char?] Character/MAX_VALUE) @@ -119,17 +116,17 @@ ;; ===== Primitive type properties ===== ;; -(defnt ^:inline signed? +(t/defn ^:inline signed? ([x (t/or char? (t/value Character))] false) #?@(:clj [([x (t/or byte? (t/value Byte) short? (t/value Short) int? (t/value Integer) long? (t/value Long) float? (t/value Float) - double? #?(:clj Double :cljs js/Number))] true))) + double? #?(:clj Double :cljs js/Number))] true)])) ;; TODO TYPED `t/numerically-integer?` -(defnt ^:inline >bit-size ; > t/numerically-integer? +(t/defn ^:inline >bit-size ; > t/numerically-integer? ([x (t/or boolean? (t/value #?(:clj Boolean :cljs js/Boolean)))] 1) ; kind of #?@(:clj [([x (t/or byte? (t/value Byte))] 8) ([x (t/or short? (t/value Short))] 16) @@ -142,11 +139,11 @@ ;; ===== Conversion ===== ;; (def radix? (fnt [x integer?] - (<= #?(:clj Character/MIN_RADIX :cljs 2) x #?(:clj Character/MAX_RADIX :cljs 36))) + (<= #?(:clj Character/MIN_RADIX :cljs 2) x #?(:clj Character/MAX_RADIX :cljs 36)))) ;; ----- Boolean ----- ;; -(defnt ^:inline >boolean > boolean? +(t/defn ^:inline >boolean > boolean? ([x boolean?] x) ([x (t/value "true")] true) ([x (t/value "false")] false) ;; For purposes of intrinsics @@ -157,12 +154,12 @@ ;; Forward-declared so `radix?` coercion to `int` works #?(:clj -(defnt ^:inline >int* > int? +(t/defn ^:inline >int* > int? "May involve non-out-of-range truncation" ([x int?] x) ;; For purposes of intrinsics ([x (t/- primitive? int? boolean?)] (clojure.lang.RT/uncheckedIntCast x)))) -(defnt ^:inline >int > #?(:clj int? :cljs numerically-int?) +(t/defn ^:inline >int > #?(:clj int? :cljs numerically-int?) "May involve non-out-of-range truncation" ([x #?(:clj int? :cljs numerically-int?)] x) #?(:clj ([x (t/and (t/- primitive? int? boolean?) (range-of int?))] (>int* x)) @@ -333,14 +330,14 @@ ;; ===== Unsigned ===== ;; #?(:clj -(defnt >unsigned +(t/defn >unsigned {:adapted-from #{'ztellman/primitive-math 'gloss.data.primitives}} ([x byte?] (Numeric/bitAnd (short 0xFF) x)) ([x short?] (Numeric/bitAnd (int 0xFFFF) x)) ([x int?] (Numeric/bitAnd (long 0xFFFFFFFF) x)) ([x long?] (BigInteger. 1 (-> (ByteBuffer/allocate 8) (.putLong x) .array))))) ; TODO reflection -#?(:clj (defnt ubyte>byte [x long? > long?] (>long (>byte x)))) -#?(:clj (defnt ushort>short [x long? > long?] (>long (>short x)))) -#?(:clj (defnt uint>int [x long? > long?] (>long (>int x)))) -#?(:clj (defnt ulong>long [x bigint? > long?] (>long (>bigint x)))) +#?(:clj (t/defn ubyte>byte [x long? > long?] (>long (>byte x)))) +#?(:clj (t/defn ushort>short [x long? > long?] (>long (>short x)))) +#?(:clj (t/defn uint>int [x long? > long?] (>long (>int x)))) +#?(:clj (t/defn ulong>long [x bigint? > long?] (>long (>bigint x)))) diff --git a/src/quantum/core/data/string.cljc b/src/quantum/core/data/string.cljc index f7e71003..50f1725d 100644 --- a/src/quantum/core/data/string.cljc +++ b/src/quantum/core/data/string.cljc @@ -1,8 +1,8 @@ (ns quantum.core.data.string "A String is a special wrapper for a char array where different encodings, etc. are possible." (:require - [quantum.core.type :as t - :refer [defnt]] + [quantum.core.data.meta :as meta] + [quantum.core.type :as t] [quantum.untyped.core.core :as ucore]) (:import #?(:clj [com.carrotsearch.hppc CharArrayDeque]) @@ -23,11 +23,11 @@ (def str? (t/isa? #?(:clj java.lang.String :cljs js/String))) -#_(defnt str ...) ; TODO TYPED +#_(t/defn >str ...) ; TODO TYPED ;; ----- Metable immutable strings ----- ;; -;; TODO TYPED `deftypet` +;; TODO TYPED `t/deftype` #?(:clj (deftype MetableString [^String s ^clojure.lang.IPersistentMap _meta] clojure.lang.IObj @@ -49,16 +49,16 @@ (def metable-str? #?(:clj (t/isa? MetableString) :cljs str?)) -(defnt >metable-str +(t/defn >metable-str > metable-str? ([s str?] #?(:clj (MetableString. s nil) :cljs s)) - ([s str?, meta' ??/meta?] #?(:clj (MetableString. s meta') :cljs (??/with-meta s new-meta)))) + ([s str?, meta' meta/meta?] #?(:clj (MetableString. s meta') :cljs (meta/with-meta s new-meta)))) ;; ===== Mutable strings ===== ;; (def !str? (t/isa? #?(:clj java.lang.StringBuilder :cljs StringBuffer))) -(defnt !str +(t/defn ^:inline >!str "Creates a mutable string." > !str? ([] #?(:clj (StringBuilder.) :cljs (StringBuffer.))) @@ -70,7 +70,7 @@ #?(:clj (def !sync-str? (t/isa? java.lang.StringBuffer))) #?(:clj -(defnt !sync-str +(t/defn ^:inline >!sync-str "Creates a synchronized mutable string." > !sync-str? [] (StringBuffer.))) diff --git a/src/quantum/core/numeric.cljc b/src/quantum/core/numeric.cljc index 0be48632..b62d11c6 100644 --- a/src/quantum/core/numeric.cljc +++ b/src/quantum/core/numeric.cljc @@ -1,7 +1,6 @@ -(ns - ^{:doc "Useful numeric functions. Floor, ceil, round, sin, abs, neg, etc." - :attribution "alexandergunnarson"} - quantum.core.numeric +(ns quantum.core.numeric + "Numeric functions. + Aliases all subnamespaces." (:refer-clojure :exclude [* *' + +' - -' / < > <= >= == rem inc dec zero? neg? pos? pos-int? min max quot mod format @@ -13,25 +12,23 @@ [quantum.core.data.numeric :as dnum] [quantum.core.data.primitive :refer [#?(:clj >long)]] - [quantum.core.error :as err - :refer [>err err! TODO]] - [quantum.core.fn - :refer [aritoid fn1 fn-> fn']] [quantum.core.log :as log] - [quantum.core.logic :as logic + [quantum.untyped.core.logic :refer [fn-and whenf1]] - [quantum.core.macros :as macros - :refer [defnt #?@(:clj [defnt'])]] - [quantum.core.vars :as var - :refer [defalias defaliases]] - [quantum.core.numeric.convert ] - [quantum.core.numeric.misc ] - [quantum.core.numeric.operators :as op - :include-macros true] + [quantum.core.numeric.convert] + [quantum.core.numeric.misc] + [quantum.core.numeric.operators :as op] [quantum.core.numeric.predicates] - [quantum.core.numeric.trig ] - [quantum.core.numeric.truncate :as trunc - :include-macros true]) + [quantum.core.numeric.trig] + [quantum.core.numeric.truncate :as trunc] + [quantum.core.type :as t] + [quantum.core.vars + :refer [defalias defaliases]] + ;; TODO TYPED excise + [quantum.untyped.core.error + :refer [TODO]] + [quantum.untyped.core.fn + :refer [aritoid fn1 fn-> fn']]) #?(:cljs (:require-macros [quantum.core.numeric :as self])) @@ -181,8 +178,6 @@ ([form1 form2 & more] (cons 'do (map type-convert-form (list* form1 form2 more)))))) -(def num-ex (>err :overflow "Numeric overflow")) - ; ===== NON-TRANSFORMATIVE OPERATIONS ===== ; (defalias numerator dnum/numerator) @@ -312,7 +307,7 @@ ~@body) :nils (binding [*+* nils+ *-* nils- *** nils* *div* nils-div ] ~@body) - (err! "Numeric operation not recognized" {:op k#}))))) + (throw (ex-info "Numeric operation not recognized" {:op k#})))))) (defn whole-number? [n] (= n (trunc/floor n))) ; TODO use == @@ -347,7 +342,7 @@ complex functions"} [f] (or (get inverse-map f) - (err! :undefined "|inverse| not defined for function" f))) + (throw (ex-info "|inverse| not defined for function" {:f f})))) (def ^{:doc "Base values for operators." :const true} base-map @@ -366,7 +361,7 @@ (base *) 1}} [f] (or (get base-map f) - (err! :undefined "|base| not defined for function" f))) + (throw (ex-info "|base| not defined for function" {:f f})))) (defn range? {:tests `{((range? 1 4) 3) @@ -391,7 +386,7 @@ :dollar (->> n display-num (str "$")) ;:accounting - (err! "Unrecognized format" type))) + (throw (ex-info "Unrecognized format" {:type type})))) (defn percentage-of [of total-n] (-> of (op// total-n) double (c/* 100) display-num (str "%"))) ; TODO use *-2 diff --git a/src/quantum/core/numeric/exponents.cljc b/src/quantum/core/numeric/exponents.cljc index ec70c56a..848e6aa0 100644 --- a/src/quantum/core/numeric/exponents.cljc +++ b/src/quantum/core/numeric/exponents.cljc @@ -1,15 +1,13 @@ (ns quantum.core.numeric.exponents - (:refer-clojure :exclude [+ *]) (:require - [clojure.core :as core] - [quantum.core.error :as err - :refer [TODO]] - [quantum.core.macros - :refer [defnt #?@(:clj [defnt'])]] + [clojure.core :as core] + [quantum.core.numeric.operators :as no] + [quantum.core.type :as t] [quantum.core.vars - :refer [defalias #?@(:clj [defmalias])]] - [quantum.core.numeric.operators - :refer [+ * dec* div*]]) + :refer [defalias]] + ;; TODO TYPED excise this reference + [quantum.untyped.core.error + :refer [TODO]]) #?(:clj (:import [quantum.core Numeric] @@ -22,7 +20,7 @@ [#{byte #_char short int float double} x #{long? double?} n] (loop [acc (Long. 1) nn n] (if (<= (double nn) 0) acc - (recur (* x acc) (dec* nn))))) + (recur (no/* x acc) (no/dec* nn))))) :cljs (defn pow- [x n] (TODO))) (defn pow' @@ -141,7 +139,7 @@ {:todo ["Need to intelligently determine, at compile time if possible, whether @x is e, 2, or 10 and choose the appropriate fn."]} ([#?(:clj #{double}) x #?(:clj #{double}) base] ; arbitrary to choose ln vs. log-10 - (div* (ln x) (ln base)))) + (no/div* (ln x) (ln base)))) #?(:clj (defmacro log [base x] ; TODO do ln' diff --git a/src/quantum/core/numeric/operators.cljc b/src/quantum/core/numeric/operators.cljc index 0c7d1bb9..9191f27c 100644 --- a/src/quantum/core/numeric/operators.cljc +++ b/src/quantum/core/numeric/operators.cljc @@ -1,104 +1,104 @@ (ns quantum.core.numeric.operators - (:refer-clojure :exclude - [+ +' - -' * *' / - inc inc' dec dec' - numerator denominator]) - (:require - [clojure.core :as core] - #?(:cljs - [com.gfredericks.goog.math.Integer :as int]) - [quantum.core.data.numeric :as dnum - :refer [numerator denominator]] - [quantum.core.error :as err - :refer [TODO]] - [quantum.core.log :as log] - [quantum.core.macros - :refer [defnt defntp #?@(:clj [defnt' variadic-proxy])]] - [quantum.core.numeric.convert :as conv - :refer [->bigint #?@(:clj [->big-integer])]] - [quantum.core.type-old :as t - :refer [val?]] - [quantum.core.vars - :refer [defalias #?@(:clj [defmalias])]] - [quantum.untyped.core.form - :refer [#?(:clj core-symbol)]]) -#?(:cljs - (:require-macros - [quantum.core.numeric.operators :as self - :refer [+ - *]])) -#?(:clj - (:import - (quantum.core Numeric) - (java.math BigInteger BigDecimal) - (clojure.lang BigInt Ratio)))) + (:refer-clojure :exclude + [+ +' - -' * *' / + inc inc' dec dec' + numerator denominator]) + (:require + [clojure.core :as core] + #?(:cljs [com.gfredericks.goog.math.Integer :as int]) + ;; TODO TYPED re-enable + #_[quantum.core.data.numeric :as dnum + :refer [bigdec? clj-bigint? numerator numeric? denominator]] + [quantum.core.data.primitive :as p] + [quantum.core.data.refs :as ref] + ;; TODO TYPED re-enable + #_[quantum.core.numeric.convert :as conv + :refer [>bigint #?@(:clj [>big-integer])]] + [quantum.core.type :as t] + [quantum.core.vars + :refer [defalias]] + ;; TODO TYPED excise reference + [quantum.untyped.core.error + :refer [TODO]] + ;; TODO TYPED excise reference + [quantum.untyped.core.form + :refer [#?(:clj core-symbol)]] + [quantum.untyped.core.log :as log]) +#?(:cljs (:require-macros + [quantum.core.numeric.operators :as self + :refer [+ - *]])) +#?(:clj (:import + [clojure.lang BigInt Ratio] + [quantum.core Numeric] + [java.math BigInteger BigDecimal]))) (log/this-ns) -; Auto-unboxes; no boxed combinations necessary -; TODO right now: multiple typed arguments in |defnt|, even in protocols -; TODO `==` from Numeric/equals - -; ===== ADD ===== ; - -(defn num-ex [] (throw (#?(:clj ArithmeticException. :cljs js/Error.) "Out of range"))) - -#?(:clj #_(defalias +*-bin unchecked-add) - (defnt' +*-bin "Lax `+`. Continues on overflow/underflow." - ([] 0) - ([#{byte char short int long float double Number} x] x) - ([#{byte char short int long float double} #_(- prim? boolean) x - #{byte char short int long float double} #_(- prim? boolean) y] - (Numeric/add x y)) - (^BigInt [^BigInt x ^BigInt y] (.add x y)) - (^BigDecimal [^BigDecimal x ^BigDecimal y] - (if (nil? *math-context*) - (.add x y) - (.add x y *math-context*))) - #?(:cljs ([x y] (TODO) (dnum/-add x y)))) - :cljs (defalias +*-bin unchecked-add)) - -#?(:clj (variadic-proxy +* quantum.core.numeric.operators/+*-bin )) -#?(:clj (variadic-proxy +*& quantum.core.numeric.operators/+*-bin&)) - -#?(:clj (defnt' +'-bin "Strict `+`. Throws exception on overflow/underflow." - (^int ^:intrinsic [^int x ^int y] (Math/addExact x y)) - (^long ^:intrinsic [^long x ^long y] (Math/addExact x y)) - ( [#{byte char short int long float double Number} x] x)) ; TODO do the rest - :cljs (defalias +'-bin core/+)) - -#?(:clj (variadic-proxy +' quantum.core.numeric.operators/+'-bin )) -#?(:clj (variadic-proxy +'& quantum.core.numeric.operators/+'-bin&)) - -; "Natural |+|; promotes on overflow/underflow" -#?(:clj (defalias +-bin core/+) ; TODO port - :cljs (defalias +-bin core/+)) - -#?(:clj (variadic-proxy + quantum.core.numeric.operators/+-bin)) -#?(:clj (variadic-proxy +& quantum.core.numeric.operators/+-bin&)) - -; ===== SUBTRACT ===== ; - -#?(:clj (defnt' -*-bin "Lax `-`. Continues on overflow/underflow." - #?(:clj ([#{byte char short int long float double} x] - (Numeric/negate x)) - :cljs (^first [^double? x] (TODO "fix") (dnum/-negate x))) - ([#{byte char short int long float double} #_(- prim? boolean) x - #{byte char short int long float double} #_(- prim? boolean) y] - (Numeric/subtract x y)) - (^BigInteger [^BigInteger x] (-> x .negate)) - (^BigInt [^BigInt x] - (-> x ->big-integer -*-bin ->bigint))) ; TODO reflection - :cljs (defalias -*-bin unchecked-subtract)) - -#?(:clj (variadic-proxy -* quantum.core.numeric.operators/-*-bin )) -#?(:clj (variadic-proxy -*& quantum.core.numeric.operators/-*-bin&)) - -#?(:clj #_(defalias -'-bin core/-) - (defnt' -'-bin "Strict `-`. Throws exception on overflow/underflow." - (^int ^:intrinsic [^int x ^int y] (Math/subtractExact x y)) - (^long ^:intrinsic [^long x ^long y] (Math/subtractExact x y)) - (^int ^:intrinsic [^int x] (Math/negateExact x)) - (^long ^:intrinsic [^long x] (Math/negateExact x)) +;; ===== (Up-to-)binary operators ===== ;; + +;; ----- Addition ----- ;; + + ;; TODO we're missing CLJS bigdec/bigint (`dnum/-add`) as well as other type combos + (t/defn ^:inline +* + "Lax `+`. Continues on overflow/underflow." + > numeric? + ([] 0) + ([x numeric?] x) + ([x numeric-primitive?, y numeric-primitive? > ?] + (#?(:clj Numeric/add :cljs cljs.core/+) x y)) +#?(:clj ([x clj-bigint?, y clj-bigint? > clj-bigint?] (.add x y))) +#?(:clj ([x bigdec? , y bigdec? > bigdec?] + (if (p/nil? *math-context*) + (.add x y) + (.add x y *math-context*))))) + + ;; TODO we're missing CLJS bigdec/bigint (`dnum/-add`) as well as other type combos + (t/defn ^:inline +' + "Strict `+`. Throws exception on overflow/underflow." + > numeric? + ([] (+*)) + ([x numeric?] (+* x)) + ;; A Java intrinsic, so we keep this arity + ([x p/int? , y p/int? > p/int?] (Math/addExact x y)) + ;; A Java intrinsic, so we keep this arity +#?(:clj ([x p/long?, y p/long? > p/long?] (Math/addExact x y)))) + + ;; TODO we're missing CLJS bigdec/bigint (`dnum/-add`) as well as other type combos + (t/defn ^:inline + + "Natural `+`. Promotes on overflow/underflow." + > numeric? + ;; TODO TYPED port from CLJ and CLJS core nss/classes + ) + +;; ----- Subtraction ----- ;; + + ;; TODO we're missing CLJS bigdec/bigint (`dnum/-subtract`, `dnum/-negate`) as well as other + ;; type combos + (t/defn ^:inline -* + "Lax `-`. Continues on overflow/underflow." + > numeric? + ([] 0) + ([x numeric-primitive? > (t/type x)] (#?(:clj Numeric/negate :cljs cljs.core/-) x)) +#?(:clj ([x clj-bigint? > (t/type x)] ...)) +#?(:clj ([x big-integer? > (t/type x)] (.negate x))) + ([x numeric-primitive?, y numeric-primitive? > ?] + (#?(:clj Numeric/subtract :cljs cljs.core/-) x y)))) + + ;; TODO we're missing CLJS bigdec/bigint (`dnum/-subtract`, `dnum/-negate`) as well as other + ;; type combos + (t/defn ^:inline -' + "Strict `-`. Throws exception on overflow/underflow." + > numeric? + ([] (-*)) + ;; A Java intrinsic, so we keep this arity +#?(:clj ([x p/int? > p/int?] (Math/negateExact x))) +#?(:clj ([x p/long? > p/long?] (Math/negateExact x))) +#?(:clj ([x p/int? , y p/int? > p/int?] (Math/subtractExact x y))) +#?(:clj ([x p/long?, y p/long? > p/long?] (Math/subtractExact x y)))) + +;; TODO TYPED continue to port +#?(:clj + (defnt' -'-bin (^byte [^byte x] (if (Numeric/eq x Byte/MIN_VALUE ) (num-ex) (-* x))) (^char [^char x] (if (Numeric/eq x 0 ) 0 (num-ex))) (^short [^short x] (if (Numeric/eq x Short/MIN_VALUE ) (num-ex) (-* x))) @@ -106,18 +106,15 @@ (^long [^long x] (if (Numeric/eq x Long/MIN_VALUE ) (num-ex) (-* x)))) :cljs (defalias -'-bin core/-)) -#?(:clj (variadic-proxy -' quantum.core.numeric.operators/-'-bin )) -#?(:clj (variadic-proxy -'& quantum.core.numeric.operators/-'-bin&)) - -#?(:cljs (defn --bin- [x y] (core/- x y))) ; TODO only to fix CLJS arithmetic warning here + ;; TODO we're missing CLJS bigdec/bigint (`dnum/-subtract`, `dnum/-negate`) as well as other + ;; type combos + (t/defn ^:inline - + "Natural `-`. Promotes on overflow/underflow." + > numeric? + ;; TODO TYPED port from CLJ and CLJS core nss/classes + ) -(defnt --bin "Natural `-`. Promotes on overflow/underflow." - ([#?(:clj x :cljs ^double? x) y] (#?(:clj core/- :cljs --bin-) x y))) - -#?(:clj (variadic-proxy - quantum.core.numeric.operators/--bin )) -#?(:clj (variadic-proxy -& quantum.core.numeric.operators/--bin&)) - -; ===== MULTIPLY ===== ; +;; ----- Multiplication ----- ;; ; (js/Math.imul x y) ; 32-bit int multiplication @@ -135,9 +132,6 @@ ([x] x) ([x y] (TODO "fix") (dnum/-multiply x y)))) -#?(:clj (variadic-proxy ** quantum.core.numeric.operators/**-bin )) -#?(:clj (variadic-proxy **& quantum.core.numeric.operators/**-bin&)) - #?(:cljs (defn *'-bin- [x y] (TODO))) ; TODO only to fix CLJS arithmetic warning here #?(:clj (defnt' *'-bin "Strict `*`. Throws exception on overflow/underflow." @@ -146,17 +140,11 @@ :cljs (defnt *'-bin ([x y] (*'-bin- x y)))) -#?(:clj (variadic-proxy *' quantum.core.numeric.operators/*'-bin )) -#?(:clj (variadic-proxy *'& quantum.core.numeric.operators/*'-bin&)) - ; "Natural |*|; promotes on overflow/underflow" #?(:clj (defalias *-bin core/*) :cljs (defalias *-bin core/*)) -#?(:clj (variadic-proxy * quantum.core.numeric.operators/*-bin )) -#?(:clj (variadic-proxy *& quantum.core.numeric.operators/*-bin&)) - -; ===== DIVIDE ===== ; +;; ----- Division ----- ;; #?(:cljs (defn div*-bin- [x y] (core// x y))) ; TODO only to fix CLJS arithmetic warning here @@ -197,9 +185,6 @@ ([^double? x ] (core// x)) ([^double? x y] (div*-bin- x y)))) -#?(:clj (variadic-proxy div* div*-bin )) -#?(:clj (variadic-proxy div*& div*-bin&)) - ; "Strict |/|. Throws exception on overflow/underflow." #?(:clj (defalias div'-bin core//) ; TODO port :cljs (defalias div'-bin core//)) @@ -224,9 +209,7 @@ ; TODO integer division via div:int ; TODO div:nil which returns nil if dividing by 0 -;_____________________________________________________________________ -;==================={ UNARY MATH OPERATORS }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° +;; ===== (Up-to-)unary operators ===== ;; #?(:clj (defnt' dec* "Lax `dec`. Continues on overflow/underflow." ([#{byte char short long float double} x] (Numeric/dec x)) @@ -339,4 +322,4 @@ ([a# b# c#] (when (and a# b# c#) (~core-op a# b# c#))) ([a# b# c# & args#] (let [argsf# (conj args# c# b# a#)] - (when (every? val? argsf#) (reduce ~core-op argsf#)))))))) + (when (every? t/val? argsf#) (reduce ~core-op argsf#)))))))) diff --git a/src/quantum/core/numeric/predicates.cljc b/src/quantum/core/numeric/predicates.cljc index 3bef215f..16fe792e 100644 --- a/src/quantum/core/numeric/predicates.cljc +++ b/src/quantum/core/numeric/predicates.cljc @@ -1,64 +1,60 @@ (ns quantum.core.numeric.predicates - (:refer-clojure :exclude - [neg? pos? zero? pos-int?]) - (:require [#?(:clj clojure.core - :cljs cljs.core ) :as core ] - #?(:cljs [com.gfredericks.goog.math.Integer :as int ]) - [quantum.core.error :as err - :refer [TODO]] - [quantum.core.logic - :refer [#?@(:clj [fn-and fn-not])] - :refer-macros [fn-and fn-not]] - [quantum.core.macros - :refer [#?@(:clj [defnt defnt'])] - :refer-macros [defnt defntp]]) - #?(:clj (:import - [java.math BigInteger BigDecimal] - [clojure.lang Ratio BigInt] - [quantum.core Numeric]))) + (:refer-clojure :exclude + [neg? pos? pos-int? zero?]) + (:require + #?(:cljs [com.gfredericks.goog.math.Integer :as int]) + [quantum.core.compare.core :as comp] + [quantum.core.data.numeric :as dnum + :refer [big-integer? bigdec? bigint? clj-bigint? numeric-primitive?]] + [quantum.core.data.primitive :as p] + [quantum.core.logic :as l] + [quantum.core.type :as t] + ;; TODO TYPED excise reference + [quantum.core.untyped.error + :refer [TODO]]) +#?(:clj (:import + [quantum.core Numeric]))) -#?(:clj (defnt ^boolean neg? - ([#{byte char short int long float double} x] (Numeric/isNeg x)) - ([#{BigInteger - BigDecimal} x] (-> x .signum neg?)) - ([^Ratio x] (-> x .numerator .signum neg?)) - ([^BigInt x] (if (-> x .bipart nil?) - (-> x .lpart neg?) - (-> x .bipart .signum neg?)))) - :cljs (defnt neg? - ([^double? x] (core/neg? x)) - ([^bigint? x] (.isNegative x)))) + ;; TODO TYPED add CLJS ratio impl + (t/defn ^:inline neg? > p/boolean? + ([x numeric-primitive?] #?(:clj (Numeric/isNeg x) :cljs (comp/< x 0))) +#?(:clj ([x (t/or big-integer? bigdec?)] (-> x .signum neg?))) +#?(:clj ([x clj-bigint?] (if (-> x .bipart p/nil?) + (-> x .lpart neg?) + (-> x .bipart .signum neg?)))) +#?(:cljs ([x bigint?] (.isNegative x))) +#?(:clj ([x dnum/ratio?] (-> x .numerator .signum neg?)))) -#?(:clj (defnt ^boolean pos? - ([#{byte char short int long float double} x] (Numeric/isPos x)) - ([#{BigInteger - BigDecimal} x] (-> x .signum pos?)) - ([^Ratio x] (-> x .numerator .signum pos?)) - ([^BigInt x] (if (-> x .bipart nil?) - (-> x .lpart pos?) - (-> x .bipart .signum pos?)))) - :cljs (defnt pos? - ([^double? x] (core/pos? x)) - ([^com.gfredericks.goog.math.Integer x] (not (.isNegative x))))) + ;; TODO TYPED add CLJS ratio impl + (t/defn ^:inline pos? > p/boolean? + ([x numeric-primitive?] #?(:clj (Numeric/isPos x) :cljs (comp/> x 0))) +#?(:clj ([x (t/or big-integer? bigdec?)] (-> x .signum pos?))) +#?(:clj ([x clj-bigint?] (if (-> x .bipart p/nil?) + (-> x .lpart pos?) + (-> x .bipart .signum pos?)))) +#?(:cljs ([x bigint?] (l/not (.isNegative x)))) +#?(:clj ([x dnum/ratio?] (-> x .numerator .signum pos?)))) -#?(:clj (defnt ^boolean zero? - ([#{byte char short int long float double} x] (Numeric/isZero x)) - ([^Ratio x] (-> x .numerator .signum zero?)) - ([^BigInt x] (if (nil? (.bipart x)) - (zero? (.lpart x)) - (-> x .bipart .signum zero?))) - ([#{BigInteger - BigDecimal} x] (-> x .signum zero?))) - :cljs (defnt zero? - ([^double? x] (core/zero? x)) - ([^bigint? x] (.isZero x)))) + ;; TODO TYPED add CLJS ratio impl + (t/defn ^:inline zero? > p/boolean? + ([x numeric-primitive?] #?(:clj (Numeric/isZero x) :cljs (comp/== x 0))) +#?(:clj ([x (t/or big-integer? bigdec?)] (-> x .signum zero?))) +#?(:clj ([x clj-bigint?] (if (-> x .bipart p/nil?) + (-> x .lpart zero?) + (-> x .bipart .signum zero?)))) +#?(:cljs ([x bigint?] (.isZero x))) +#?(:clj ([x dnum/ratio?] (-> x .numerator .signum zero?)))) -#?(:clj (defnt nan? - ([^double? x] (Double/isNaN x)) - ([^float? x] (Float/isNaN x))) - :cljs (defn nan? [x] (TODO "fix") (identical? x js/NaN))) + (t/defnt ^:inline nan? > p/boolean? +#?(:clj ([x p/float?] (Float/isNaN x))) + ([x p/double?] (#?(:clj Double/isNaN :cljs js/Number.isNaN) x)) + ([x t/any?] false)) -(def nneg? (fn-not neg?)) -(def pos-int? (fn-and integer? pos?)) -(def nneg-int? (fn-and integer? nneg?)) -(defn exact? [x] (TODO)) +(def npos? (l/fn-not pos?)) +(def nneg? (l/fn-not neg?)) +(def pos-int? (l/fn-and dnum/integer? pos?)) +(def neg-int? (l/fn-and dnum/integer? neg?)) +(def npos-int? (l/fn-and dnum/integer? npos?)) +(def nneg-int? (l/fn-and dnum/integer? nneg?)) + +(t/defn exact? > p/boolean? [x p/numeric?] (TODO)) diff --git a/src/quantum/core/numeric/trig.cljc b/src/quantum/core/numeric/trig.cljc index 31e6937c..57542b3d 100644 --- a/src/quantum/core/numeric/trig.cljc +++ b/src/quantum/core/numeric/trig.cljc @@ -3,16 +3,12 @@ [+ * /]) (:require [quantum.core.error :as err - :refer [TODO] ] - [quantum.core.macros - :refer [#?@(:clj [defnt defnt'])] - :refer-macros [defnt]] + :refer [TODO]] + [quantum.core.type :as t] [quantum.core.numeric.exponents :as exp - :refer [#?@(:clj [log-e sqrt pow])] - :refer-macros [log-e sqrt pow]] + :refer [log-e sqrt pow]] [quantum.core.numeric.operators - :refer [#?@(:clj [+ * / inc* dec*])] - :refer-macros [+ * / inc* dec*]]) + :refer [+ * / inc* dec*]]) #?(:clj (:import [net.jafama FastMath]))) ; ===== SINE ===== ; diff --git a/src/quantum/core/numeric/types.cljc b/src/quantum/core/numeric/types.cljc index ce1fa7ed..da1e8f8a 100644 --- a/src/quantum/core/numeric/types.cljc +++ b/src/quantum/core/numeric/types.cljc @@ -71,8 +71,7 @@ ;; "Ratios should not be constructed directly by user code; we assume n and d are ;; canonical; i.e., they are coprime and at most n is negative." Object - (toString [_] - (str "#ratio [" n " " d "]")) + (toString [_] (str "#ratio [" n " " d "]")) Add (-add [x y] (-add-with-ratio y x)) AddWithInteger (-add-with-integer [x y] (-add-with-ratio x (->ratio y))) AddWithRatio @@ -108,11 +107,9 @@ (core/= n (.-n other)) (core/= d (.-d other)))) IHash - (-hash [_] - (bit-xor 124790411 (-hash n) (-hash d))) + (-hash [_] (bit-xor 124790411 (-hash n) (-hash d))) IComparable - (-compare [x y] - (-compare x y)))) + (-compare [x y] (-compare x y)))) #?(:cljs (defn- normalize diff --git a/src/quantum/core/refs.cljc b/src/quantum/core/refs.cljc index eca10a20..b49f9ac4 100644 --- a/src/quantum/core/refs.cljc +++ b/src/quantum/core/refs.cljc @@ -1,4 +1,4 @@ -(ns quantum.core.refs +(ns quantum.core.refs ; TODO TYPED move to `quantum.core.data.refs` and incorporate `nil?` and `val?` here (:refer-clojure :exclude [deref volatile! @@ -36,7 +36,7 @@ (set [#?(:cljs this) v]) (getAndSet [#?(:cljs this) v])) -; TODO create for every primitive datatype as well +;; TODO create for every primitive datatype as well (deftype MutableReference [#?(:clj ^:unsynchronized-mutable val :cljs ^:mutable val)] IMutableReference (get [this] val) @@ -120,16 +120,16 @@ #?(:clj (defnt deref ([#{clojure.lang.IDeref} x] (.deref x)) ([#{AtomicBoolean - #_AtomicByte - #_AtomicChar - #_AtomicShort + #_AtomicByte + #_AtomicChar + #_AtomicShort AtomicInteger AtomicLong - #_AtomicFloat + #_AtomicFloat AtomicDouble AtomicReference java.util.concurrent.Future - #_IMutableReference + #_IMutableReference IMutableBoolean IMutableByte IMutableChar @@ -237,12 +237,12 @@ ; ===== AGENTS ===== ; -#?(:clj (defalias agent core/agent)) -#?(:Clj (defalias restart-agent core/restart-agent)) -#?(:clj (defalias agent-error core/agent-error)) -#?(:clj (defalias await core/await)) -#?(:clj (defalias await-for core/await-for)) -#?(:clj (defalias commute core/commute)) +#?(:clj (defalias agent core/agent)) +#?(:Clj (defalias restart-agent core/restart-agent)) +#?(:clj (defalias agent-error core/agent-error)) +#?(:clj (defalias await core/await)) +#?(:clj (defalias await-for core/await-for)) +#?(:clj (defalias commute core/commute)) #?(:clj (defalias send core/send)) #?(:clj (defalias set-agent-send-executor! core/set-agent-send-executor!)) #?(:clj (defalias send-off core/send-off)) @@ -251,12 +251,12 @@ ; ===== REFS ===== ; -#?(:clj (defalias ref core/ref )) -#?(:clj (defalias alter core/alter )) -#?(:clj (defalias io! core/io! )) -#?(:clj (defalias sync core/sync )) -#?(:clj (defalias dosync core/dosync )) -#?(:clj (defalias ensure core/ensure )) +#?(:clj (defalias ref core/ref)) +#?(:clj (defalias alter core/alter)) +#?(:clj (defalias io! core/io!)) +#?(:clj (defalias sync core/sync)) +#?(:clj (defalias dosync core/dosync)) +#?(:clj (defalias ensure core/ensure)) #?(:clj (defalias ref-set core/ref-set)) #?(:clj (defalias error-handler core/error-handler)) #?(:clj (defalias set-error-handler! core/set-error-handler!)) diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index 6bd2766d..e5c6a8b9 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -1,7 +1,7 @@ (ns quantum.core.type "This is this the namespace upon which all other fully-typed namespaces rest." (:refer-clojure :exclude - [* - and any? fn fn? isa? not or ref seq? symbol? var?]) + [* - and any? defn fn fn? isa? not or ref seq? symbol? var?]) (:require [quantum.untyped.core.type.defnt :as udefnt] [quantum.untyped.core.type :as ut] @@ -9,12 +9,14 @@ [quantum.untyped.core.vars :refer [defalias defaliases]])) -(defalias udefnt/fnt) -(defalias udefnt/defnt) +(defalias udefnt/fnt) ; TODO TYPED rename +(defalias udefnt/defn) (defaliases ut ;; Generators - ? * isa? fn value + ? * isa? + fn ; TODO TYPED rename + value ;; Combinators and or - if not ;; Metadata suppliers @@ -25,11 +27,7 @@ none? ref? fn? - metable? - seq? - symbol? - var? - with-metable?) + seq?) ;; TODO TYPED move diff --git a/test-dev/cljc/quantum/test/ir/classify.cljc b/test-dev/cljc/quantum/test/ir/classify.cljc index f02cf638..27f9ab73 100644 --- a/test-dev/cljc/quantum/test/ir/classify.cljc +++ b/test-dev/cljc/quantum/test/ir/classify.cljc @@ -21,10 +21,10 @@ #?@(:clj [:refer-macros [condpc]])] [quantum.numeric.core :refer [∏ ∑ sum]] - [quantum.ir.classify :as this] - [quantum.core.log :as log]) + [quantum.ir.classify :as self] + [quantum.core.log :as log]) #?(:cljs (:require-macros - [quantum.core.log :as log]))) + [quantum.core.log :as log]))) (log/enable! :test) (log/pr :test "===== TESTING ======") @@ -42,12 +42,12 @@ test-doc ["Taiwan" "Taiwan" "Sapporo"] d' test-doc] (log/ppr :test "MULTINOMIAL IS" - [(->> (this/classifier-score+ D :multinomial d') + [(->> (self/classifier-score+ D :multinomial d') (join []) (sort-by second)) - (this/multinomial-naive-bayes-classifier D d')]) + (self/multinomial-naive-bayes-classifier D d')]) (log/ppr :test "MULTIPLE BERNOULLI IS" - [(->> (this/classifier-score+ D :bernoulli d') + [(->> (self/classifier-score+ D :bernoulli d') (join []) (sort-by second)) - (this/multiple-bernoulli-naive-bayes-classifier D d')])) + (self/multiple-bernoulli-naive-bayes-classifier D d')])) (log/pr :test "===== END TESTING ======") diff --git a/test/quantum/test/core/defnt.cljc b/test/quantum/test/core/defnt.cljc index 30ac4f70..443e7664 100644 --- a/test/quantum/test/core/defnt.cljc +++ b/test/quantum/test/core/defnt.cljc @@ -6,7 +6,7 @@ :refer [fn->]] [quantum.core.logic :refer [fn-and]] - [quantum.core.defnt :as this + [quantum.core.defnt :as self :refer [!ref analyze defnt]] [quantum.core.macros.type-hint :as th] [quantum.core.type.defs :as tdef] @@ -44,7 +44,7 @@ ;; ===== End type predicates ===== ;; (deftest test|arg-types>split - (is= (this/arg-types>split + (is= (self/arg-types>split [(t/or byte? double? string?) (t/or t/map? byte?)]) [[(t/isa? Byte) (t/isa? clojure.lang.ITransientMap)] @@ -65,7 +65,7 @@ (deftest test|methods->spec (testing "Class hierarchy" (is= - (this/methods->spec + (self/methods->spec [{:rtype Object :argtypes [int? char?]} {:rtype Object :argtypes [String]} {:rtype Object :argtypes [CharSequence]} @@ -82,7 +82,7 @@ t/char? (t/? t/object?)))))) (testing "Complex dispatch based off of `Numeric/bitAnd`" (is= - (this/methods->spec + (self/methods->spec [{:rtype t/int? :argtypes [t/int? t/char?]} {:rtype t/int? :argtypes [t/int? t/byte?]} {:rtype t/int? :argtypes [t/int? t/short?]} @@ -358,7 +358,7 @@ ;; ----- Implicit compilation tests ----- ;; -(this/defnt abcde "Documentation" {:metadata "fhgjik"} +(self/defnt abcde "Documentation" {:metadata "fhgjik"} ([a number? > number?] (inc a)) ([a pos-int?, b pos-int? | (> a b) @@ -382,23 +382,23 @@ a b c ca cb cc cca ccaa ccab ccabaa ccabab ccababa ccabb ccabc d da db ea f fa) > number?] 0)) -(this/defns basic [a number? > number?] (rand)) +(self/defns basic [a number? > number?] (rand)) (defspec-test test|basic `basic) -(this/defns equality [a number? > #(= % a)] a) +(self/defns equality [a number? > #(= % a)] a) (defspec-test test|equality `equality) -(this/defns pre-post [a number? | (> a 3) > #(> % 4)] (inc a)) +(self/defns pre-post [a number? | (> a 3) > #(> % 4)] (inc a)) (defspec-test test|pre-post `pre-post) -(this/defns gen|seq|0 [[a number? b number? :as b] ^:gen? (s/tuple double? double?)]) +(self/defns gen|seq|0 [[a number? b number? :as b] ^:gen? (s/tuple double? double?)]) (defspec-test test|gen|seq|0 `gen|seq|0) -(this/defns gen|seq|1 +(self/defns gen|seq|1 [[a number? b number? :as b] ^:gen? (s/nonconforming (s/cat :a double? :b double?))]) (defspec-test test|gen|seq|1 `gen|seq|1) diff --git a/test/quantum/test/core/type/core.cljc b/test/quantum/test/core/type/core.cljc index 553d72d4..ace63072 100644 --- a/test/quantum/test/core/type/core.cljc +++ b/test/quantum/test/core/type/core.cljc @@ -1,19 +1,19 @@ (ns quantum.test.core.type.core (:require - [quantum.core.type.core :as this] + [quantum.core.type.core :as self] [quantum.core.test :refer [deftest is testing]])) #?(:clj (deftest test|nth-elem-type|clj - (is (= "[D" (this/nth-elem-type|clj "[D" 0))) - (is (= 'double (this/nth-elem-type|clj "[D" 1))) - (is (= 'long (this/nth-elem-type|clj "[J" 1))) - (is (= "[Z" (this/nth-elem-type|clj "[[Z" 1))) - (is (= 'boolean (this/nth-elem-type|clj "[[Z" 2))) - (is (= "[Ljava.lang.Object;" (this/nth-elem-type|clj "[[Ljava.lang.Object;" 1))) - (is (= 'java.lang.Object (this/nth-elem-type|clj "[Ljava.lang.Object;" 1))) - (is (thrown? Throwable (this/nth-elem-type|clj "[[Z" 3))) - (is (thrown? Throwable (this/nth-elem-type|clj 'boolean 0))) - (is (thrown? Throwable (this/nth-elem-type|clj Boolean 0))) - (is (thrown? Throwable (this/nth-elem-type|clj "Boolean" 0))))) + (is (= "[D" (self/nth-elem-type|clj "[D" 0))) + (is (= 'double (self/nth-elem-type|clj "[D" 1))) + (is (= 'long (self/nth-elem-type|clj "[J" 1))) + (is (= "[Z" (self/nth-elem-type|clj "[[Z" 1))) + (is (= 'boolean (self/nth-elem-type|clj "[[Z" 2))) + (is (= "[Ljava.lang.Object;" (self/nth-elem-type|clj "[[Ljava.lang.Object;" 1))) + (is (= 'java.lang.Object (self/nth-elem-type|clj "[Ljava.lang.Object;" 1))) + (is (thrown? Throwable (self/nth-elem-type|clj "[[Z" 3))) + (is (thrown? Throwable (self/nth-elem-type|clj 'boolean 0))) + (is (thrown? Throwable (self/nth-elem-type|clj Boolean 0))) + (is (thrown? Throwable (self/nth-elem-type|clj "Boolean" 0))))) diff --git a/test/quantum/test/untyped/core/analyze/expr.cljc b/test/quantum/test/untyped/core/analyze/expr.cljc index 9391792b..afe099f8 100644 --- a/test/quantum/test/untyped/core/analyze/expr.cljc +++ b/test/quantum/test/untyped/core/analyze/expr.cljc @@ -3,67 +3,67 @@ [quantum.core.test :as test :refer [deftest testing is is= throws]] [quantum.core.untyped.analyze.ast :as ast] - [quantum.core.untyped.analyze.expr :as this] + [quantum.core.untyped.analyze.expr :as self] [quantum.core.untyped.type :as t])) (deftest test|casef (testing "equality" (testing "self-equality" - (is= (this/casef count 1 nil 2 nil) - (this/casef count 1 nil 2 nil))) + (is= (self/casef count 1 nil 2 nil) + (self/casef count 1 nil 2 nil))) (testing "different case orders are equal" - (is= (this/casef count 1 nil 2 nil) - (this/casef count 2 nil 1 nil)) - (is= (this/casef count "1" nil "2" nil) - (this/casef count "2" nil "1" nil)))) + (is= (self/casef count 1 nil 2 nil) + (self/casef count 2 nil 1 nil)) + (is= (self/casef count "1" nil "2" nil) + (self/casef count "2" nil "1" nil)))) (testing "inequality" (testing "inequality of different cases" - (is (not= (this/casef count 1 nil 2 nil) - (this/casef count "1" nil 2 nil))))) + (is (not= (self/casef count 1 nil 2 nil) + (self/casef count "1" nil 2 nil))))) (testing "function call" (let [dispatch - (this/casef count - 2 (this/condpf-> t/>= (this/get 0) + (self/casef count + 2 (self/condpf-> t/>= (self/get 0) t/int - (this/condpf-> t/>= (this/get 1) + (self/condpf-> t/>= (self/get 1) t/char? t/int? t/byte? t/int? t/short? t/int? t/int? t/int? t/long? t/long?) t/short - (this/condpf-> t/>= (this/get 1) + (self/condpf-> t/>= (self/get 1) t/long? t/long? t/int? t/int? t/short? t/short? t/char? t/short? t/byte? t/short?) t/long - (this/condpf-> t/>= (this/get 1) + (self/condpf-> t/>= (self/get 1) t/long? t/long? t/int? t/long? t/short? t/long? t/char? t/long? t/byte? t/long?) t/char - (this/condpf-> t/>= (this/get 1) + (self/condpf-> t/>= (self/get 1) t/byte? t/char? t/long? t/long? t/char? t/char? t/short? t/short? t/int? t/int?) t/byte - (this/condpf-> t/>= (this/get 1) + (self/condpf-> t/>= (self/get 1) t/long? t/long? t/int? t/int? t/short? t/short? t/char? t/char? t/byte? t/byte?)) - 3 (this/condpf-> t/>= (this/get 0) + 3 (self/condpf-> t/>= (self/get 0) t/char? - (this/condpf-> t/>= (this/get 1) + (self/condpf-> t/>= (self/get 1) t/long? - (this/condpf-> t/>= (this/get 2) + (self/condpf-> t/>= (self/get 2) t/long? t/long?))))] (testing "Success" (is= (dispatch [t/long? t/long?]) diff --git a/test/quantum/test/untyped/core/collections.cljc b/test/quantum/test/untyped/core/collections.cljc index e7cde4b3..1e8bc30c 100644 --- a/test/quantum/test/untyped/core/collections.cljc +++ b/test/quantum/test/untyped/core/collections.cljc @@ -2,14 +2,14 @@ (:require [quantum.core.test :refer [deftest is is= testing]] - [quantum.untyped.core.collections :as this])) + [quantum.untyped.core.collections :as self])) (deftest test|flatten - (is= (this/flatten [[0 1] [2 3 4]] 0) + (is= (self/flatten [[0 1] [2 3 4]] 0) [[0 1] [2 3 4]]) - (is= (this/flatten [[0 1] [2 3 4]] 1) + (is= (self/flatten [[0 1] [2 3 4]] 1) [0 1 2 3 4]) - (is= (this/flatten [[[0 1]] [[2 3 4]]] 2) + (is= (self/flatten [[[0 1]] [[2 3 4]]] 2) [0 1 2 3 4])) diff --git a/test/quantum/test/untyped/core/defnt.cljc b/test/quantum/test/untyped/core/defnt.cljc index 4d0c61e7..5ca768c7 100644 --- a/test/quantum/test/untyped/core/defnt.cljc +++ b/test/quantum/test/untyped/core/defnt.cljc @@ -5,13 +5,13 @@ [clojure.spec.test.alpha :as stest] [clojure.test.check.clojure-test :refer [defspec]] - [quantum.untyped.core.defnt :as this] + [quantum.untyped.core.defnt :as self] [quantum.untyped.core.spec :as us] [quantum.untyped.core.test :refer [defspec-test]])) ;; Implicit compilation tests -(this/defns abcde "Documentation" {:metadata "fhgjik"} +(self/defns abcde "Documentation" {:metadata "fhgjik"} ([a number? > number?] (inc a)) ([a pos-int?, b pos-int? | (> a b) @@ -35,28 +35,28 @@ a b c ca cb cc cca ccaa ccab ccabaa ccabab ccababa ccabb ccabc d da db ea f fa) > number?] 0)) -(this/defns basic [a number? > number?] (rand)) +(self/defns basic [a number? > number?] (rand)) (defspec-test test|basic `basic) -(this/defns equality [a number? > #(= % a)] a) +(self/defns equality [a number? > #(= % a)] a) (defspec-test test|equality `equality) -(this/defns pre-post [a number? | (> a 3) > #(> % 4)] (inc a)) +(self/defns pre-post [a number? | (> a 3) > #(> % 4)] (inc a)) (defspec-test test|pre-post `pre-post) -(this/defns gen|seq|0 [[a number? b number? :as b] ^:gen? (s/tuple double? double?)]) +(self/defns gen|seq|0 [[a number? b number? :as b] ^:gen? (s/tuple double? double?)]) (defspec-test test|gen|seq|0 `gen|seq|0) -(this/defns gen|seq|1 +(self/defns gen|seq|1 [[a number? b number? :as b] ^:gen? (s/nonconforming (s/cat :a double? :b double?))]) (defspec-test test|gen|seq|1 `gen|seq|1) -(this/defns fn-wide-and-overload-specific-post +(self/defns fn-wide-and-overload-specific-post > number? [> integer?] 123) @@ -64,7 +64,7 @@ ;; TODO assert that the below 2 things are equivalent -#_(this/defns abcde "Documentation" {:metadata "abc"} +#_(self/defns abcde "Documentation" {:metadata "abc"} ([a number? > number?] (inc a)) ([a pos-int?, b pos-int? | (> a b) @@ -100,21 +100,21 @@ (s/cat :a #{"a" "b" "c"} :b boolean? - :c (this/map-destructure #(-> % count (= 3)) + :c (self/map-destructure #(-> % count (= 3)) {:ca keyword? :cb string? - :cc (this/map-destructure map? - {:cca (this/map-destructure map? + :cc (self/map-destructure map? + {:cca (self/map-destructure map? {:ccaa keyword? - :ccab (this/seq-destructure seq? - [:arg-0 (this/seq-destructure some? + :ccab (self/seq-destructure seq? + [:arg-0 (self/seq-destructure some? [:ccabaa some? - :ccabab (this/map-destructure some? {:ccababa some?})]) + :ccabab (self/map-destructure some? {:ccababa some?})]) :ccabb some?] [:ccabc some?])})})}) - :d (this/seq-destructure sequential? [:da double?] [:db seq?]) - :arg-4# (this/seq-destructure ^{:gen? true} (s/coll-of symbol? :kind vector?) [:ea symbol?] ) - :f (this/seq-destructure seq? [:fa #{"a" "b" "c"}])) + :d (self/seq-destructure sequential? [:da double?] [:db seq?]) + :arg-4# (self/seq-destructure ^{:gen? true} (s/coll-of symbol? :kind vector?) [:ea symbol?] ) + :f (self/seq-destructure seq? [:fa #{"a" "b" "c"}])) (fn [{a :a b :b {:as c diff --git a/test/quantum/test/untyped/core/identifiers.cljc b/test/quantum/test/untyped/core/identifiers.cljc index aa62e73b..c5d350cd 100644 --- a/test/quantum/test/untyped/core/identifiers.cljc +++ b/test/quantum/test/untyped/core/identifiers.cljc @@ -1,37 +1,37 @@ (ns quantum.test.untyped.core.identifiers (:require - [quantum.untyped.core.identifiers :as this + [quantum.untyped.core.identifiers :as self #?@(:cljs [:refer [DelimitedIdent]])] [quantum.untyped.core.test :as test :refer [deftest testing is is= throws]]) #?(:clj (:import quantum.untyped.core.identifiers.DelimitedIdent))) (deftest test|>ident - (is= (this/>delim-ident "a|b|c|d") (DelimitedIdent. ["a" "b" "c" "d"])) + (is= (self/>delim-ident "a|b|c|d") (DelimitedIdent. ["a" "b" "c" "d"])) - (is= (this/>delim-ident String) (DelimitedIdent. ["java" "lang" "String"])) + (is= (self/>delim-ident String) (DelimitedIdent. ["java" "lang" "String"])) (testing "Symbol" - (is= (this/>delim-ident 'a) (DelimitedIdent. ["a"])) - (is= (this/>delim-ident 'a/b) (DelimitedIdent. ["a" "b"])) - (is= (this/>delim-ident 'a|b/c) (DelimitedIdent. ["a" "b" "c"])) - (is= (this/>delim-ident 'a|b|c) (DelimitedIdent. ["a" "b" "c"])) - (is= (this/>delim-ident 'a/b|c) (DelimitedIdent. ["a" "b" "c"])) - (is= (this/>delim-ident 'a|b/c|d) (DelimitedIdent. ["a" "b" "c" "d"])) - (is= (this/>delim-ident 'a.b/c.d) (DelimitedIdent. ["a" "b" "c" "d"]))) + (is= (self/>delim-ident 'a) (DelimitedIdent. ["a"])) + (is= (self/>delim-ident 'a/b) (DelimitedIdent. ["a" "b"])) + (is= (self/>delim-ident 'a|b/c) (DelimitedIdent. ["a" "b" "c"])) + (is= (self/>delim-ident 'a|b|c) (DelimitedIdent. ["a" "b" "c"])) + (is= (self/>delim-ident 'a/b|c) (DelimitedIdent. ["a" "b" "c"])) + (is= (self/>delim-ident 'a|b/c|d) (DelimitedIdent. ["a" "b" "c" "d"])) + (is= (self/>delim-ident 'a.b/c.d) (DelimitedIdent. ["a" "b" "c" "d"]))) (testing "Keyword" - (is= (this/>delim-ident :a) (DelimitedIdent. ["a"])) - (is= (this/>delim-ident :a/b) (DelimitedIdent. ["a" "b"])) - (is= (this/>delim-ident :a|b/c) (DelimitedIdent. ["a" "b" "c"])) - (is= (this/>delim-ident :a|b|c) (DelimitedIdent. ["a" "b" "c"])) - (is= (this/>delim-ident :a/b|c) (DelimitedIdent. ["a" "b" "c"])) - (is= (this/>delim-ident :a|b/c|d) (DelimitedIdent. ["a" "b" "c" "d"])) - (is= (this/>delim-ident :a.b/c.d) (DelimitedIdent. ["a" "b" "c" "d"]))) + (is= (self/>delim-ident :a) (DelimitedIdent. ["a"])) + (is= (self/>delim-ident :a/b) (DelimitedIdent. ["a" "b"])) + (is= (self/>delim-ident :a|b/c) (DelimitedIdent. ["a" "b" "c"])) + (is= (self/>delim-ident :a|b|c) (DelimitedIdent. ["a" "b" "c"])) + (is= (self/>delim-ident :a/b|c) (DelimitedIdent. ["a" "b" "c"])) + (is= (self/>delim-ident :a|b/c|d) (DelimitedIdent. ["a" "b" "c" "d"])) + (is= (self/>delim-ident :a.b/c.d) (DelimitedIdent. ["a" "b" "c" "d"]))) - (is= (this/>delim-ident (find-ns 'quantum.untyped.core.test)) + (is= (self/>delim-ident (find-ns 'quantum.untyped.core.test)) (DelimitedIdent. ["quantum" "untyped" "core" "test"])) - (is= (this/>delim-ident #'count) + (is= (self/>delim-ident #'count) (DelimitedIdent. ["clojure" "core" "count"])) - (is= (this/>delim-ident count) + (is= (self/>delim-ident count) (DelimitedIdent. ["clojure" "core" "count"]))) From d98c9cff09a81e1c48982d34bafbd9a30891dda9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 25 Sep 2018 10:13:20 -0600 Subject: [PATCH 295/810] This will teach me to always always commit `git reset --hard` is the worst :( --- src/quantum/core/collections/core.cljc | 42 ---- src/quantum/core/collections_typed.cljc | 311 ++++++++++++++++++++++++ src/quantum/core/data/async.cljc | 9 + 3 files changed, 320 insertions(+), 42 deletions(-) create mode 100644 src/quantum/core/collections_typed.cljc create mode 100644 src/quantum/core/data/async.cljc diff --git a/src/quantum/core/collections/core.cljc b/src/quantum/core/collections/core.cljc index 4afae350..361f7b6b 100644 --- a/src/quantum/core/collections/core.cljc +++ b/src/quantum/core/collections/core.cljc @@ -98,26 +98,6 @@ (log/this-ns) -; FastUtil is the best -; http://java-performance.info/hashmap-overview-jdk-fastutil-goldman-sachs-hppc-koloboke-trove-january-2015/ - -; TODO notify of changes to: -; https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/RT.java -; https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/Util.java -; https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/Numbers.java -; TODO Queues need support - -; TODO implement all these using wagjo/data-cljs -; split-at [o index] - clojure.core/split-at -; splice [o index n val] - fast remove and insert in one go -; splice-arr [o index n val-arr] - fast remove and insert in one go -; insert-before [o index val] - insert one item inside coll -; insert-before-arr [o index val] - insert array of items inside coll -; remove-at [o index] - remove one itfem from index pos -; remove-n [o index n] - remove n items starting at index pos -; rip [o index] - rips coll and returns [pre-coll item-at suf-coll] -; sew [pre-coll item-arr suf-coll] - opposite of rip, but with arr - ; Arbitrary. ; TODO test this on every permutation for inflection point. (def- parallelism-threshold 10000) @@ -268,28 +248,6 @@ `reduce-count` is 36.824665 ms - twice as fast"} [xs] (reduce count:rf xs)) -(defnt ^long count - "Incorporated `clojure.lang.RT/count` and `clojure.lang.RT/countFrom`" - {:todo #{"handle persistent maps"}} - ([^array? x] (#?(:clj Array/count :cljs .-length) x)) - ([^tuple? x] (count (.-vs x))) - #?(:cljs ([^string? x] (.-length x))) - #?(:cljs ([^!string? x] (.getLength x))) - #?(:clj ([^char-seq? x] (.length x))) - ([^keyword? x] (count ^String (name x))) - ([^m2m-chan? x] (count (#?(:clj .buf :cljs .-buf) x))) - ([^+vector? x] (#?(:clj .count :cljs core/count) x)) - #?(:clj ([#{Collection Map} x] (.size x))) - #?(:clj ([^Counted x] (.count x))) - #?(:clj ([^Map$Entry x] (if (nil? x) 0 2))) ; TODO fix this potential null issue - ([^transformer? x] (reduce-count x)) - ([^default x] (if (nil? x) - 0 - (core/count x) ; TODO need to fix this so certain interfaces are preferred - #_(throw (>ex-info "`count` not supported on type" {:type (type x)}))))) - -; TODO `pcount` - (defnt empty? {:todo #{"import clojure.lang.RT/seq"}} ([#{array? ; TODO anything that `count` accepts diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc new file mode 100644 index 00000000..00dc94d2 --- /dev/null +++ b/src/quantum/core/collections_typed.cljc @@ -0,0 +1,311 @@ +(ns quantum.core.collections-typed + (:refer-clojure :exclude + [count empty? get reduce]) + (:require + [quantum.core.data.array :as arr] + [quantum.core.data.async :as dasync] + [quantum.core.data.collections :as dcoll] + [quantum.core.data.identifiers :as id] + [quantum.core.data.map :as map] + [quantum.core.data.numeric :as dnum] + [quantum.core.data.primitive :as p] + [quantum.core.data.string :as dstr] + [quantum.core.data.vector :as vec] + [quantum.core.data.tuple :as tup] + [quantum.core.type :as t] + [quantum.core.vars :as var])) + +#_" +- TODO incorporate FastUtil + - FastUtil is the fastest collections library according to http://java-performance.info/hashmap-overview-jdk-fastutil-goldman-sachs-hppc-koloboke-trove-january-2015/ +- TODO notify of changes to: + - https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/RT.java + - https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/Util.java + - https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/Numbers.java +- TODO queues need support +- TODO implement all these using wagjo/data-cljs + - split-at [o index] - clojure.core/split-at + - splice [o index n val] - fast remove and insert in one go + - splice-arr [o index n val-arr] - fast remove and insert in one go + - insert-before [o index val] - insert one item inside coll + - insert-before-arr [o index val] - insert array of items inside coll + - remove-at [o index] - remove one item from index pos + - remove-n [o index n] - remove n items starting at index pos + - rip [o index] - rips coll and returns [pre-coll item-at suf-coll] + - sew [pre-coll item-arr suf-coll] - opposite of rip, but with arr +- TODO `pcount` +- TODO `(rreduce [f init o]) - like reduce but in reverse order = Equivalent to Scheme's `foldr` +" + +;; ===== Reductive functions ===== ;; + +#?(:cljs + (defn- -reduce-seq + "For some reason |reduce| is not implemented in ClojureScript for certain types. + This is a |loop|-|recur| replacement for it." + {:todo #{"Check if this is really the case..." + "Improve performance with chunking, etc."}} + [xs f init] + (loop [xs (seq xs) v init] + (if xs + (let [ret (f v (first xs))] + (if (reduced? ret) + @ret + (recur (next xs) ret))) + v)))) + +;; TODO: conditionally optional arities etc. for t/fn + +(var/def rf? "Reducing function" + (t/ftype "seed arity" [] + "completing arity" [t/any?] + "reducing arity" [t/any? t/any?] + "reducing arity for kvs" [t/any? t/any? t/any?])) + +(defnt reduce + "Like `core/reduce` except: + When init is not provided, (f) is used. + Maps are reduced with reduce-kv. + + Equivalent to Scheme's `foldl`. + + Much of this content taken from clojure.core.protocols for inlining and + type-checking purposes." + ([f init ^fast_zip.core.ZipperLocation z] + (loop [xs (zip/down z) v init] + (if (val? z) + (let [ret (f v z)] + (if (reduced? ret) + @ret + (recur (zip/right xs) ret))) + v))) + ([f init ^array? arr] ; Adapted from `areduce` + #?(:clj (let [ct (Array/count arr)] + (loop [i 0 v init] + (if (< i ct) + (let [ret (f v (Array/get arr i))] + (if (reduced? ret) + @ret + (recur (unchecked-inc i) ret))) + v))) + :cljs (array-reduce arr f init))) + ([f init ^!+vector? xs] ; because transient vectors aren't reducible + (let [ct (#?(:clj .count :cljs count) xs)] ; TODO fix for CLJS + (loop [i 0 v init] + (if (< i ct) + (let [ret (f v (#?(:clj .valAt :cljs get) xs i))] ; TODO fix for CLJS + (if (reduced? ret) + @ret + (recur (unchecked-inc i) ret))) + v)))) + ([f init ^string? s] + (let [ct (#?(:clj .length :cljs .-length) s)] + (loop [i 0 v init] + (if (< i ct) + (let [ret (f v (.charAt s i))] + (if (reduced? ret) + @ret + (recur (unchecked-inc i) ret))) + v)))) +#?(:clj ([f init ^clojure.lang.StringSeq xs ] + (let [s (.s xs)] + (loop [i (.i xs) v init] + (if (< i (.length s)) + (let [ret (f v (.charAt s i))] + (if (reduced? ret) + @ret + (recur (unchecked-inc i) ret))) + v))))) +#?(:clj ([f + #{clojure.lang.PersistentVector ; vector's chunked seq is faster than its iter + clojure.lang.LazySeq ; for range + clojure.lang.ASeq} xs] ; aseqs are iterable, masking internal-reducers + (if-let [s (seq xs)] + (clojure.core.protocols/internal-reduce (next s) f (first s)) + (f)))) +#?(:clj ([f init + #{clojure.lang.PersistentVector ; vector's chunked seq is faster than its iter + clojure.lang.LazySeq ; for range + clojure.lang.ASeq} xs] ; aseqs are iterable, masking internal-reducers + (let [s (seq xs)] + (clojure.core.protocols/internal-reduce s f init)))) + ([f ^transformer? x] + (let [rf ((.-xf x) f)] + (rf (reduce* (.-prev x) rf (rf))))) + ([f init ^transformer? x] + (let [rf ((.-xf x) f)] + (rf (reduce* (.-prev x) rf init)))) + ([f init ^chan? x ] (async/reduce f init x)) +#?(:cljs ([f init ^+map? xs] (#_(:clj clojure.core.protocols/kv-reduce + :cljs -kv-reduce) ; in order to use transducers... + -reduce-seq xs f init))) +#?(:cljs ([f init ^+set? xs ] (-reduce-seq xs f init))) + ([f init #{#?(:clj integer? :cljs double?)} n] + (loop [i 0 v init] + (if (< i n) + (let [ret (f v i)] + (if (reduced? ret) + @ret + (recur (unchecked-inc i) ret))) + v))) + ;; `iter-reduce` +#?(:clj ([f #{clojure.lang.APersistentMap$KeySeq + clojure.lang.APersistentMap$ValSeq + Iterable} xs] + (let [iter (.iterator xs)] + (if (.hasNext iter) + (loop [ret (.next iter)] + (if (.hasNext iter) + (let [ret (f ret (.next iter))] + (if (reduced? ret) + @ret + (recur ret))) + ret)) + (f))))) + ;; `iter-reduce` +#?(:clj ([f init + #{clojure.lang.APersistentMap$KeySeq + clojure.lang.APersistentMap$ValSeq + Iterable} xs] + (let [iter (.iterator xs)] + (loop [ret init] + (if (.hasNext iter) + (let [ret (f ret (.next iter))] + (if (reduced? ret) + @ret + (recur ret))) + ret))))) +#?(:clj ([f ^clojure.lang.IReduce xs ] (.reduce xs f))) +#?(:clj ([f init ^clojure.lang.IKVReduce xs ] (.kvreduce xs f init))) +#?(:clj ([f init ^clojure.lang.IReduceInit xs ] (.reduce xs f init))) + ([f ^default xs] (if (val? xs) + (#?(:clj clojure.core.protocols/coll-reduce + :cljs -reduce) xs f) + (f))) + ([f init ^default xs] + (if (val? xs) + (#?(:clj clojure.core.protocols/coll-reduce + :cljs -reduce) xs f init) + init))) + +(var/def rfi? "Reducing function, indexed" + (t/ftype "seed arity" [] + "completing arity" [t/any?] + "reducing arity" [t/any? t/any? t/any?] + "reducing arity for kvs" [t/any? t/any? t/any? t/any?])) + +(t/defn reducei + "`reduce`, indexed. + Uses an unsynchronized mutable counter internally, but this cannot cause race conditions if + `reduce` is implemented correctly (this includes single-threadedness)." + [f rfi?, init t/any?, xs dcoll/reducible?] + (let [f' (let [!i (! -1)] + (fn ([ret x] (f ret x (ref/reset! !i (num/inc* (ref/deref !i))))) + ([ret k v] (f ret k v (ref/reset! !i (num/inc* (ref/deref !i)))))))] + (reduce f' init xs))) + +#?(:clj +; TODO unmacro when type inference is available +(defmacro transduce + ([ f xs] `(transduce identity ~f ~xs)) + ([xf f xs] `(transduce ~xf ~f (~f) ~xs)) + ([xf f init xs] + `(let [f'# (~xf ~f)] + (f'# (reduce f'# ~init ~xs)))))) +; TODO `transducei` ? + +;; ===== End reductive functions ===== ;; + +(t/defn count > dnum/integer? + {:todo #{"handle persistent maps"} + :incorporated #{'clojure.lang.RT/count + 'clojure.lang.RT/countFrom + 'cljs.core/count}} + ;; Concrete classes + ([x p/nil? > #?(:clj p/long? :cljs dnum/nip?)] 0) + ([x ?/transformer? > ????] (reduce-count x)) +#?(:cljs ([x dstr/str? > (t/assume dnum/nip?)] (.-length x))) +#?(:cljs ([x dstr/!str? > (t/assume dnum/nip?)] (.getLength x))) + ([x tup/tuple? > p/int?] (-> x .-vs count)) + ([x arr/std-array? > #?(:clj p/int? :cljs (t/assume dnum/nip?))] + (#?(:clj Array/count :cljs .-length) x)) + ;; TODO `cljs.core/count` is not right here + ([x vec/+vector?] (#?(:clj .count :cljs core/count) x)) + ([x dasync/m2m-chan?] (-> x #?(:clj .buf :cljs .-buf) count)) + ;; Abstract classes + ([x dcoll/icounted? > #?(:clj p/int? :cljs (t/* dnum/nip?))] + #?(:clj (.count x) + :cljs (-count ^not-native x))) +#?(:cljs ([x dcoll/iseqable? > p/int?] + ;; TODO TYPED + (loop [s (seq coll) acc 0] + (if (counted? s) ; assumes nil is counted, which it currently is + (+ acc (-count s)) + (recur (next s) (inc acc)))))) +#?(:clj ([x dcoll/ipersistentcollection? > p/int?] + ;; TODO TYPED + ISeq s = seq(o); + o = null; + int i = 0; + for(/ s != null / s = s.next()) { + if(s instanceof Counted) + return i + s.count(); + i++; + } + return i; + + )) +#?(:clj ([x dstr/char-seq? > p/int?] (.length x))) +#?(:clj ([x dcoll/java-coll? > p/int?] (.size x))) +#?(:clj ([x map/java-map? > p/int?] (.size x))) +#?(:clj ([x tup/map-entry? > p/long?] 2)) +#?(:clj ([x arr/array? > p/int?] (java.lang.reflect.Array/getLength x)))) + +(t/defn empty? > p/boolean? + {:todo #{"import clojure.lang.RT/seq"}} + ;; TODO re-evaluate this arity + #_([x ?] (-> x count num/zero?)) + ([x p/nil?] true) + ([x ?/transformer?] (->> x (reduce (fn' (reduced false)) true))) +#?(:clj ([x dcoll/java-coll?] (.isEmpty x))) +#?(:clj ([x map/java-map?] (.isEmpty x))) + ;; TODO TYPED + ([^default x] (core/empty? x))) + + +(t/defn get + {:todo {0 "Need to excise non-O(1) `nth`"} + :incorporated #{'clojure.lang.RT/get}} + #?(:clj ([^clojure.lang.ILookup x k ] (.valAt x k))) + #?(:clj ([^clojure.lang.ILookup x k if-not-found] (.valAt x k if-not-found))) + #?(:clj ([#{java.util.Map clojure.lang.IPersistentSet} + x k ] (.get x k))) + #?(:clj ([#{!map|byte->any?} x ^byte k ] (.get x k))) + #?(:clj ([#{!map|char->any?} x ^char k ] (.get x k))) + #?(:clj ([#{!map|short->any?} x ^short k ] (.get x k))) + #?(:clj ([#{!map|int->any?} x ^int k ] (.get x k))) + #?(:clj ([#{!map|long->any?} x ^long k ] (.get x k))) + #?(:clj ([#{!map|float->ref?} x ^float k ] (.get x k))) + #?(:clj ([#{!map|double->ref?} x ^double k ] (.get x k))) + ([^string? x ^nat-long? i if-not-found] (if (>= i (count x)) if-not-found (.charAt x i))) + #?(:clj ([^!array-list? x ^nat-long? i if-not-found] (if (>= i (count x)) if-not-found (.get x i)))) + ([#{string? #?(:clj !array-list?)} x ^nat-long? i ] (get x i nil)) + + ([^array-1d? x #?(:clj #{int}) i1] + (#?(:clj Array/get + :cljs core/aget) x i1)) + #?(:clj ([#{array-2d? array-3d? array-4d? array-5d? array-6d? array-7d? array-8d? array-9d? array-10d?} x + ^int i1] + (Array/get x i1))) + ([^tuple? x ^nat-long? i ] (get (.-vs x) i)) + ([^seq? x i ] (core/nth x i nil )) + ([^seq? x i if-not-found] (core/nth x i if-not-found)) + ; TODO look at clojure.lang.RT/get for how to handle these edge cases efficiently + #?(:cljs ([^nil? x i ] (core/get x i nil ))) + #?(:cljs ([^nil? x i ] (core/get x i nil ))) + #?(:cljs ([^nil? x i if-not-found] (core/get x i if-not-found))) + ([^default x i ] + (if (nil? x) + nil + (throw (ex-info "`get` not supported on" {:type (type x)})))) + #_([ x i if-not-found] (core/get x i if-not-found))) diff --git a/src/quantum/core/data/async.cljc b/src/quantum/core/data/async.cljc new file mode 100644 index 00000000..79cf92fb --- /dev/null +++ b/src/quantum/core/data/async.cljc @@ -0,0 +1,9 @@ +(ns quantum.core.data.async + (:require + [quantum.core.type :as t])) + +(def chan? (t/isa? #?(:clj clojure.core.async.impl.protocols/Channel + :cljs cljs.core.async.impl.protocols/Channel))) + +(def m2m-chan? (t/isa? #?(:clj clojure.core.async.impl.channels.ManyToManyChannel + :cljs cljs.core.async.impl.channels/ManyToManyChannel))) From 544a3294a653939f527be525b346fcab36b3ec09 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 25 Sep 2018 20:05:01 -0600 Subject: [PATCH 296/810] Start to work through `reduce` and `transduce` --- resources-dev/defnt.cljc | 8 +++- src-dev/quantum/core/defnt_equivalences.cljc | 4 +- src/quantum/core/collections_typed.cljc | 47 ++++++++++---------- 3 files changed, 31 insertions(+), 28 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 9741227e..43e3d08f 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -16,12 +16,16 @@ TODO: - `(or (and pred then) (and (not pred) else))` (which is not correct) - needs to equal `(t/and (t/or (t/not a) b) (t/or a c))` (which is correct) -#_" -LEFT OFF LAST TIME (9/3/2018): +- conditionally optional arities etc. for t/fn +#_" Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: + - (if (dcoll/reduced? ret) + ;; TODO TYPED `(ref/deref ret)` should realize it's dealing with a `reduced?` + (ref/deref ret) + ...) - t/- : multi-arity - t/value-of - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index c8572fed..4495570d 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -1645,8 +1645,8 @@ (t/def rf? "Reducing function" (t/fn "seed arity" [] - "completing arity" [_] - "reducing arity" [_ _])) + "completing arity" [t/any?] + "reducing arity" [t/any? t/any?])) (self/defn reduce "Much of this content taken from clojure.core.protocols for inlining and diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index 00dc94d2..eae226ca 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -12,6 +12,7 @@ [quantum.core.data.string :as dstr] [quantum.core.data.vector :as vec] [quantum.core.data.tuple :as tup] + [quantum.core.fn :as fn] [quantum.core.type :as t] [quantum.core.vars :as var])) @@ -34,6 +35,7 @@ - rip [o index] - rips coll and returns [pre-coll item-at suf-coll] - sew [pre-coll item-arr suf-coll] - opposite of rip, but with arr - TODO `pcount` +- TODO `transducei` ? - TODO `(rreduce [f init o]) - like reduce but in reverse order = Equivalent to Scheme's `foldr` " @@ -62,21 +64,24 @@ "reducing arity" [t/any? t/any?] "reducing arity for kvs" [t/any? t/any? t/any?])) -(defnt reduce +(t/defn reduce "Like `core/reduce` except: - When init is not provided, (f) is used. - Maps are reduced with reduce-kv. + - When init is not provided, (f) is used. + - Maps are reduced with `reduce-kv`. Equivalent to Scheme's `foldl`. Much of this content taken from clojure.core.protocols for inlining and type-checking purposes." - ([f init ^fast_zip.core.ZipperLocation z] - (loop [xs (zip/down z) v init] + ([rf rf?, xs ?] (reduce rf (rf) xs)) + ([rf rf?, init t/any?, xs p/nil?] init) + ([rf rf?, init t/any?, z (t/isa? fast_zip.core.ZipperLocation)] + (loop [xs (zip/down z), v init] (if (val? z) - (let [ret (f v z)] - (if (reduced? ret) - @ret + (let [ret (rf v z)] + (if (dcoll/reduced? ret) + ;; TODO TYPED `(ref/deref ret)` should realize it's dealing with a `reduced?` + (ref/deref ret) (recur (zip/right xs) ret))) v))) ([f init ^array? arr] ; Adapted from `areduce` @@ -178,10 +183,6 @@ #?(:clj ([f ^clojure.lang.IReduce xs ] (.reduce xs f))) #?(:clj ([f init ^clojure.lang.IKVReduce xs ] (.kvreduce xs f init))) #?(:clj ([f init ^clojure.lang.IReduceInit xs ] (.reduce xs f init))) - ([f ^default xs] (if (val? xs) - (#?(:clj clojure.core.protocols/coll-reduce - :cljs -reduce) xs f) - (f))) ([f init ^default xs] (if (val? xs) (#?(:clj clojure.core.protocols/coll-reduce @@ -199,20 +200,18 @@ Uses an unsynchronized mutable counter internally, but this cannot cause race conditions if `reduce` is implemented correctly (this includes single-threadedness)." [f rfi?, init t/any?, xs dcoll/reducible?] - (let [f' (let [!i (! -1)] - (fn ([ret x] (f ret x (ref/reset! !i (num/inc* (ref/deref !i))))) - ([ret k v] (f ret k v (ref/reset! !i (num/inc* (ref/deref !i)))))))] + (let [f' (let [!i (ref/! -1)] + (t/fn ([ret ? x ...] (f ret x (ref/reset! !i (num/inc* (ref/deref !i))))) + ([ret ? k ... v ...] (f ret k v (ref/reset! !i (num/inc* (ref/deref !i)))))))] (reduce f' init xs))) -#?(:clj -; TODO unmacro when type inference is available -(defmacro transduce - ([ f xs] `(transduce identity ~f ~xs)) - ([xf f xs] `(transduce ~xf ~f (~f) ~xs)) - ([xf f init xs] - `(let [f'# (~xf ~f)] - (f'# (reduce f'# ~init ~xs)))))) -; TODO `transducei` ? +(var/def xf? "Transforming function" + (t/ftype [rf? :> rf?])) + +(t/defn transduce > + ([ f rf?, xs dcoll/reducible?] (transduce fn/identity f xs)) + ([xf xf?, f rf?, xs dcoll/reducible?] (transduce xf f (f) xs)) + ([xf xf?, f rf?, init t/any?, xs dcoll/reducible?] (let [f' (xf f)] (f' (reduce f' init xs))))) ;; ===== End reductive functions ===== ;; From a52932a644a7203849265f0e17ffeec19f9ba3df Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 25 Sep 2018 23:03:04 -0600 Subject: [PATCH 297/810] Overhaul `reduce`; not quite done with it yet --- resources-dev/defnt.cljc | 20 +- src/quantum/core/collections_typed.cljc | 344 ++++++++++++++++-------- 2 files changed, 250 insertions(+), 114 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 43e3d08f..9343cc6b 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -22,10 +22,20 @@ TODO: Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - - (if (dcoll/reduced? ret) - ;; TODO TYPED `(ref/deref ret)` should realize it's dealing with a `reduced?` - (ref/deref ret) - ...) + - Analysis + - (if (dcoll/reduced? ret) + ;; TODO TYPED `(ref/deref ret)` should realize it's dealing with a `reduced?` + (ref/deref ret) + ...) + - (let [ct (count arr)] + (loop [i 0 v init] + (if (comp/< i ct) + (let [ret (f v (get arr i))] + (if (reduced? ret) + @ret + ;; TODO TYPED automatically figure out that `inc` will never go out of bounds here + (recur (inc* i) ret))) + v))) - t/- : multi-arity - t/value-of - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` @@ -57,6 +67,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - declare-fnt (a way to do protocols/interfaces) - extend-fnt! - defnt (t/defn) + - t/defn- - (t/and (t/or a b) c) should -> (t/or (t/and a c) (t/and b c)) for purposes of separating dispatches - t/extend-defn! - `(t/extend-defn! id/>name (^:inline [x namespace?] (-> x .getName id/>name)))` @@ -213,6 +224,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - :todo #{} - :attribution - :doc + - :incorporated #{} - Instead of e.g. `ns-` or `var-` we can do `ns-val` and `var-val` - Should we type `when`, `let`? diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index eae226ca..d7c11556 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -1,10 +1,11 @@ (ns quantum.core.collections-typed (:refer-clojure :exclude - [count empty? get reduce]) + [count empty? get nth reduce]) (:require [quantum.core.data.array :as arr] [quantum.core.data.async :as dasync] [quantum.core.data.collections :as dcoll] + [quantum.core.data.compare :as dcomp] [quantum.core.data.identifiers :as id] [quantum.core.data.map :as map] [quantum.core.data.numeric :as dnum] @@ -13,6 +14,8 @@ [quantum.core.data.vector :as vec] [quantum.core.data.tuple :as tup] [quantum.core.fn :as fn] + [quantum.core.numeric + :refer [inc*]] [quantum.core.type :as t] [quantum.core.vars :as var])) @@ -39,6 +42,62 @@ - TODO `(rreduce [f init o]) - like reduce but in reverse order = Equivalent to Scheme's `foldr` " +;; ===== Access functions ===== ;; + +;; TODO for CLJS we should do !+vector +(t/defn get + "Retrieve the value in `xs` associated with the key `k`. + + The expectation, which is not enforced, is that this retrieval will take place in sublinear time. + O(1) is best; O(log32(n)) is common; and O(log(n)) is acceptable." + {:todo {0 "Need to excise non-O(1) `nth`"} + :incorporated #{'clojure.lang.RT/get}} + #?(:clj ([^clojure.lang.ILookup x k ] (.valAt x k))) + #?(:clj ([^clojure.lang.ILookup x k if-not-found] (.valAt x k if-not-found))) + #?(:clj ([#{java.util.Map clojure.lang.IPersistentSet} + x k ] (.get x k))) + #?(:clj ([#{!map|byte->any?} x ^byte k ] (.get x k))) + #?(:clj ([#{!map|char->any?} x ^char k ] (.get x k))) + #?(:clj ([#{!map|short->any?} x ^short k ] (.get x k))) + #?(:clj ([#{!map|int->any?} x ^int k ] (.get x k))) + #?(:clj ([#{!map|long->any?} x ^long k ] (.get x k))) + #?(:clj ([#{!map|float->ref?} x ^float k ] (.get x k))) + #?(:clj ([#{!map|double->ref?} x ^double k ] (.get x k))) + ([^string? x ^nat-long? i if-not-found] (if (>= i (count x)) if-not-found (.charAt x i))) + #?(:clj ([^!array-list? x ^nat-long? i if-not-found] (if (>= i (count x)) if-not-found (.get x i)))) + ([#{string? #?(:clj !array-list?)} x ^nat-long? i ] (get x i nil)) + + ([^array-1d? x #?(:clj #{int}) i1] + (#?(:clj Array/get + :cljs core/aget) x i1)) + #?(:clj ([#{array-2d? array-3d? array-4d? array-5d? array-6d? array-7d? array-8d? array-9d? array-10d?} x + ^int i1] + (Array/get x i1))) + ([^tuple? x ^nat-long? i ] (get (.-vs x) i)) + ([^seq? x i ] (core/nth x i nil )) + ([^seq? x i if-not-found] (core/nth x i if-not-found)) + ; TODO look at clojure.lang.RT/get for how to handle these edge cases efficiently + #?(:cljs ([^nil? x i ] (core/get x i nil ))) + #?(:cljs ([^nil? x i ] (core/get x i nil ))) + #?(:cljs ([^nil? x i if-not-found] (core/get x i if-not-found))) + ([^default x i ] + (if (nil? x) + nil + (throw (ex-info "`get` not supported on" {:type (type x)})))) + #_([ x i if-not-found] (core/get x i if-not-found))) + +;; TODO implement +(t/defn nth + "Retrieve the element from `xs` at the index `i`. + + In contrast to `get`, this may or may not happen in sublinear time, but it is expected (though + not enforced) that a type-specialization of `nth` will provide the most efficient implementation + possible. + + Prefer to `get` when retrieving elements at indices unless expectations of sublinear time are + necessary." + ...) + ;; ===== Reductive functions ===== ;; #?(:cljs @@ -64,109 +123,185 @@ "reducing arity" [t/any? t/any?] "reducing arity for kvs" [t/any? t/any? t/any?])) +(t/defn- ^:inline string-seq>underlying-string + [xs (t/isa? clojure.lang.StringSeq) > (t/assume dstr/str?)] (.s xs)) + +(defn- seq-reduce + ([coll f] + (if-let [s (seq coll)] + (internal-reduce (next s) f (first s)) + (f))) + ([coll f val] + (let [s (seq coll)] + (internal-reduce s f val)))) + +(defn- naive-seq-reduce + "Reduces a seq, ignoring any opportunities to switch to a more + specialized implementation." + [s f val] + (loop [s (seq s) + val val] + (if s + (let [ret (f val (first s))] + (if (reduced? ret) + @ret + (recur (next s) ret))) + val))) + +(extend-protocol InternalReduce + nil + (internal-reduce + [s f val] + val) + + ;; handles vectors and ranges + clojure.lang.IChunkedSeq + (internal-reduce + [s f val] + (if-let [s (seq s)] + (if (chunked-seq? s) + (let [ret (.reduce (chunk-first s) f val)] + (if (reduced? ret) + @ret + (recur (chunk-next s) + f + ret))) + (if (instance? clojure.lang.IReduceInit s) + (.reduce ^clojure.lang.IReduceInit s f val) + (naive-seq-reduce s f val))) + val)) + + clojure.lang.StringSeq + (internal-reduce + [str-seq f val] + (let [s (.s str-seq) + len (.length s)] + (loop [i (.i str-seq) + val val] + (if (< i len) + (let [ret (f val (.charAt s i))] + (if (reduced? ret) + @ret + (recur (inc i) ret))) + val)))) + + java.lang.Object + (internal-reduce + [s f val] + (loop [cls (class s) + s s + f f + val val] + (if-let [s (seq s)] + (if (identical? (class s) cls) + (let [ret (f val (first s))] + (if (reduced? ret) + @ret + (recur cls (next s) f ret))) + (if (instance? clojure.lang.IReduceInit s) + (.reduce ^clojure.lang.IReduceInit s f val) + (naive-seq-reduce s f val))) + val)))) + +(extend-protocol CollReduce + Object ; (default) + ;;aseqs are iterable, masking internal-reducers + clojure.lang.ASeq + ;;vector's chunked seq is faster than its iter + clojure.lang.PersistentVector + ;;for range + clojure.lang.LazySeq + (coll-reduce + ([coll f] (seq-reduce coll f)) + ([coll f val] (seq-reduce coll f val))) +) + +;; TODO TYPED do type inference based on the rf's. We can sometimes figure out what gets returned +;; based on what is passed in (t/defn reduce "Like `core/reduce` except: - When init is not provided, (f) is used. - - Maps are reduced with `reduce-kv`. - - Equivalent to Scheme's `foldl`. + - Maps are reduced as if with `reduce-kv`. - Much of this content taken from clojure.core.protocols for inlining and - type-checking purposes." + Equivalent to Scheme's `foldl`." + {:incorporated '{clojure.core/reduce "9/25/2018" + clojure.core/reduce-kv "9/25/2018" + clojure.core.protocols "9/25/2018" + cljs.core/reduce-kv "9/25/2018" + cljs.core/array-reduce "9/25/2018"}} ([rf rf?, xs ?] (reduce rf (rf) xs)) ([rf rf?, init t/any?, xs p/nil?] init) ([rf rf?, init t/any?, z (t/isa? fast_zip.core.ZipperLocation)] (loop [xs (zip/down z), v init] - (if (val? z) + (if (p/val? z) (let [ret (rf v z)] (if (dcoll/reduced? ret) ;; TODO TYPED `(ref/deref ret)` should realize it's dealing with a `reduced?` (ref/deref ret) (recur (zip/right xs) ret))) v))) - ([f init ^array? arr] ; Adapted from `areduce` - #?(:clj (let [ct (Array/count arr)] - (loop [i 0 v init] - (if (< i ct) - (let [ret (f v (Array/get arr i))] - (if (reduced? ret) - @ret - (recur (unchecked-inc i) ret))) - v))) - :cljs (array-reduce arr f init))) - ([f init ^!+vector? xs] ; because transient vectors aren't reducible - (let [ct (#?(:clj .count :cljs count) xs)] ; TODO fix for CLJS + ;; - Adapted from `areduce` + ;; - `!+vector?` included because transient vectors aren't reducible + ([rf rf?, init t/any?, xs (t/or dstr/str? arr/array? vec/!+vector?)] + ;; TODO forward-declare `count` + (let [ct (count xs)] (loop [i 0 v init] - (if (< i ct) - (let [ret (f v (#?(:clj .valAt :cljs get) xs i))] ; TODO fix for CLJS - (if (reduced? ret) - @ret - (recur (unchecked-inc i) ret))) + (if (comp/< i ct) + (let [ret (rf v (get xs i))] + (if (dcoll/reduced? ret) + (ref/deref ret) + ;; TODO TYPED automatically figure out that `inc` will never go out of bounds here + (recur (inc* i) ret))) v)))) - ([f init ^string? s] - (let [ct (#?(:clj .length :cljs .-length) s)] - (loop [i 0 v init] - (if (< i ct) - (let [ret (f v (.charAt s i))] - (if (reduced? ret) - @ret - (recur (unchecked-inc i) ret))) - v)))) -#?(:clj ([f init ^clojure.lang.StringSeq xs ] - (let [s (.s xs)] - (loop [i (.i xs) v init] - (if (< i (.length s)) - (let [ret (f v (.charAt s i))] - (if (reduced? ret) - @ret - (recur (unchecked-inc i) ret))) +#?(:clj ([rf rf? init t/any?, xs (t/isa? clojure.lang.StringSeq)] + (let [s (string-seq>underlying-string xs)] + (loop [i (.index xs) v init] + (if (comp/< i (count s)) + (let [ret (rf v (get s i))] + (if (dcoll/reduced? ret) + (ref/deref ret) + (recur (inc* i) ret))) v))))) -#?(:clj ([f + ;; TODO refine +#?(:clj ([rf rf? #{clojure.lang.PersistentVector ; vector's chunked seq is faster than its iter clojure.lang.LazySeq ; for range clojure.lang.ASeq} xs] ; aseqs are iterable, masking internal-reducers (if-let [s (seq xs)] (clojure.core.protocols/internal-reduce (next s) f (first s)) (f)))) + ;; TODO refine #?(:clj ([f init #{clojure.lang.PersistentVector ; vector's chunked seq is faster than its iter clojure.lang.LazySeq ; for range clojure.lang.ASeq} xs] ; aseqs are iterable, masking internal-reducers (let [s (seq xs)] (clojure.core.protocols/internal-reduce s f init)))) + ;; TODO refine ([f ^transformer? x] (let [rf ((.-xf x) f)] (rf (reduce* (.-prev x) rf (rf))))) + ;; TODO refine ([f init ^transformer? x] (let [rf ((.-xf x) f)] (rf (reduce* (.-prev x) rf init)))) - ([f init ^chan? x ] (async/reduce f init x)) + ;; TODO refine + ([f init ^chan? x] (async/reduce f init x)) + ;; TODO refine #?(:cljs ([f init ^+map? xs] (#_(:clj clojure.core.protocols/kv-reduce :cljs -kv-reduce) ; in order to use transducers... -reduce-seq xs f init))) -#?(:cljs ([f init ^+set? xs ] (-reduce-seq xs f init))) - ([f init #{#?(:clj integer? :cljs double?)} n] + ;; TODO refine +#?(:cljs ([f init ^+set? xs] (-reduce-seq xs f init))) + ([rf rf?, init t/any?, n dnum/numerically-integer?] (loop [i 0 v init] - (if (< i n) - (let [ret (f v i)] - (if (reduced? ret) - @ret - (recur (unchecked-inc i) ret))) + (if (comp/< i n) + (let [ret (rf v i)] + (if (dcoll/reduced? ret) + (ref/deref ret) + (recur (inc* i) ret))) v))) - ;; `iter-reduce` -#?(:clj ([f #{clojure.lang.APersistentMap$KeySeq - clojure.lang.APersistentMap$ValSeq - Iterable} xs] - (let [iter (.iterator xs)] - (if (.hasNext iter) - (loop [ret (.next iter)] - (if (.hasNext iter) - (let [ret (f ret (.next iter))] - (if (reduced? ret) - @ret - (recur ret))) - ret)) - (f))))) + ;; TODO refine ;; `iter-reduce` #?(:clj ([f init #{clojure.lang.APersistentMap$KeySeq @@ -180,14 +315,40 @@ @ret (recur ret))) ret))))) -#?(:clj ([f ^clojure.lang.IReduce xs ] (.reduce xs f))) -#?(:clj ([f init ^clojure.lang.IKVReduce xs ] (.kvreduce xs f init))) -#?(:clj ([f init ^clojure.lang.IReduceInit xs ] (.reduce xs f init))) - ([f init ^default xs] - (if (val? xs) - (#?(:clj clojure.core.protocols/coll-reduce - :cljs -reduce) xs f init) - init))) +#?(:clj ([rf rf?, init t/any?, xs (t/isa? clojure.lang.IKVReduce)] (.kvreduce xs rf init))) +#?(:clj ([rf rf?, init t/any?, xs (t/isa? clojure.lang.IReduceInit)] (.reduce xs rf init))) + ;; TODO CLJS might be able to be done more efficiently with more specializations? + ([rf rf?, init t/any?, xs (t/isa? #?(:clj clojure.core.protocols/IKVReduce + :cljs cljs.core/IKVReduce))] + (#?(:clj clojure.core.protocols/kv-reduce + :cljs cljs.core/-kv-reduce) xs rf init)) + ;; TODO CLJS might be able to be done more efficiently with more specializations? + ([rf rf?, init t/any?, xs (t/isa? #?(:clj clojure.core.protocols/CollReduce + :cljs cljs.core/IReduce))] + (#?(:clj clojure.core.protocols/coll-reduce + :cljs cljs.core/-reduce) xs rf init))) + +`cljs.core/reduce` +;; TODO this probably shows that I need to research `^not-native`, `implements?`, `native-satisfies?`, and `satisfies?` in CLJS in order to do dispatch correctly +([f val coll] + (cond + (implements? IReduce coll) + (-reduce ^not-native coll f val) + + (array? coll) + (array-reduce coll f val) + + (string? coll) + (array-reduce coll f val) + + (native-satisfies? IReduce coll) + (-reduce coll f val) + + (iterable? coll) + (iter-reduce coll f val) + + :else + (seq-reduce f val coll))) (var/def rfi? "Reducing function, indexed" (t/ftype "seed arity" [] @@ -215,6 +376,7 @@ ;; ===== End reductive functions ===== ;; +;; TODO make sure !+vector is handled for CLJS (t/defn count > dnum/integer? {:todo #{"handle persistent maps"} :incorporated #{'clojure.lang.RT/count @@ -270,41 +432,3 @@ #?(:clj ([x map/java-map?] (.isEmpty x))) ;; TODO TYPED ([^default x] (core/empty? x))) - - -(t/defn get - {:todo {0 "Need to excise non-O(1) `nth`"} - :incorporated #{'clojure.lang.RT/get}} - #?(:clj ([^clojure.lang.ILookup x k ] (.valAt x k))) - #?(:clj ([^clojure.lang.ILookup x k if-not-found] (.valAt x k if-not-found))) - #?(:clj ([#{java.util.Map clojure.lang.IPersistentSet} - x k ] (.get x k))) - #?(:clj ([#{!map|byte->any?} x ^byte k ] (.get x k))) - #?(:clj ([#{!map|char->any?} x ^char k ] (.get x k))) - #?(:clj ([#{!map|short->any?} x ^short k ] (.get x k))) - #?(:clj ([#{!map|int->any?} x ^int k ] (.get x k))) - #?(:clj ([#{!map|long->any?} x ^long k ] (.get x k))) - #?(:clj ([#{!map|float->ref?} x ^float k ] (.get x k))) - #?(:clj ([#{!map|double->ref?} x ^double k ] (.get x k))) - ([^string? x ^nat-long? i if-not-found] (if (>= i (count x)) if-not-found (.charAt x i))) - #?(:clj ([^!array-list? x ^nat-long? i if-not-found] (if (>= i (count x)) if-not-found (.get x i)))) - ([#{string? #?(:clj !array-list?)} x ^nat-long? i ] (get x i nil)) - - ([^array-1d? x #?(:clj #{int}) i1] - (#?(:clj Array/get - :cljs core/aget) x i1)) - #?(:clj ([#{array-2d? array-3d? array-4d? array-5d? array-6d? array-7d? array-8d? array-9d? array-10d?} x - ^int i1] - (Array/get x i1))) - ([^tuple? x ^nat-long? i ] (get (.-vs x) i)) - ([^seq? x i ] (core/nth x i nil )) - ([^seq? x i if-not-found] (core/nth x i if-not-found)) - ; TODO look at clojure.lang.RT/get for how to handle these edge cases efficiently - #?(:cljs ([^nil? x i ] (core/get x i nil ))) - #?(:cljs ([^nil? x i ] (core/get x i nil ))) - #?(:cljs ([^nil? x i if-not-found] (core/get x i if-not-found))) - ([^default x i ] - (if (nil? x) - nil - (throw (ex-info "`get` not supported on" {:type (type x)})))) - #_([ x i if-not-found] (core/get x i if-not-found))) From fd842754a6ed50032f19a8c483603cdb0d3c68df Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 26 Sep 2018 09:18:45 -0600 Subject: [PATCH 298/810] Continue to overhaul `reduce` --- src/quantum/core/collections_typed.cljc | 321 +++++++++++------------- src/quantum/core/data/collections.cljc | 36 +++ src/quantum/core/reducers/reduce.cljc | 176 ------------- 3 files changed, 180 insertions(+), 353 deletions(-) diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index d7c11556..c1130184 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -1,10 +1,10 @@ (ns quantum.core.collections-typed (:refer-clojure :exclude - [count empty? get nth reduce]) + [chunk-first chunk-rest count empty? get nth reduce]) (:require [quantum.core.data.array :as arr] [quantum.core.data.async :as dasync] - [quantum.core.data.collections :as dcoll] + [quantum.core.data.collections :as dc] [quantum.core.data.compare :as dcomp] [quantum.core.data.identifiers :as id] [quantum.core.data.map :as map] @@ -98,22 +98,41 @@ necessary." ...) + + +;; ----- Chunking ----- ;; + +(t/defn chunk-buffer > chunk-buffer? [capacity num/numerically-int?] + (clojure.lang.ChunkBuffer. (p/>int capacity))) + +(t/defn chunk [b dc/chunk-buffer? > dc/chunk?] (.chunk b)) +(t/defn chunk-append [b dc/chunk-buffer?, x p/ref? > dc/chunk?] (.add b x)) + +(t/defn chunk-first [xs dc/chunked-seq? > dc/chunk?] (.chunkedFirst xs)) +(t/defn chunk-rest [xs dc/chunked-seq? > dc/chunk?] (.chunkedMore xs)) +(t/defn chunk-next [xs dc/chunked-seq? > dc/chunk?] (.chunkedNext xs)) + +(t/defn chunk-cons [chunk dc/chunk?, the-rest dc/iseq?] + (if (num/zero? (count chunk)) ;; TODO TYPED replace this condition with `empty` + the-rest + (clojure.lang.ChunkedCons. chunk the-rest))) + ;; ===== Reductive functions ===== ;; #?(:cljs - (defn- -reduce-seq - "For some reason |reduce| is not implemented in ClojureScript for certain types. - This is a |loop|-|recur| replacement for it." - {:todo #{"Check if this is really the case..." - "Improve performance with chunking, etc."}} - [xs f init] - (loop [xs (seq xs) v init] - (if xs - (let [ret (f v (first xs))] - (if (reduced? ret) - @ret - (recur (next xs) ret))) - v)))) +(defn- -reduce-seq + "For some reason |reduce| is not implemented in ClojureScript for certain types. + This is a |loop|-|recur| replacement for it." + {:todo #{"Check if this is really the case..." + "Improve performance with chunking, etc."}} + [xs f init] + (loop [xs (seq xs) v init] + (if xs + (let [ret (f v (first xs))] + (if (reduced? ret) + @ret + (recur (next xs) ret))) + v)))) ;; TODO: conditionally optional arities etc. for t/fn @@ -126,96 +145,55 @@ (t/defn- ^:inline string-seq>underlying-string [xs (t/isa? clojure.lang.StringSeq) > (t/assume dstr/str?)] (.s xs)) -(defn- seq-reduce - ([coll f] - (if-let [s (seq coll)] - (internal-reduce (next s) f (first s)) - (f))) - ([coll f val] - (let [s (seq coll)] - (internal-reduce s f val)))) - -(defn- naive-seq-reduce - "Reduces a seq, ignoring any opportunities to switch to a more - specialized implementation." - [s f val] - (loop [s (seq s) - val val] - (if s - (let [ret (f val (first s))] - (if (reduced? ret) - @ret - (recur (next s) ret))) - val))) - -(extend-protocol InternalReduce - nil - (internal-reduce - [s f val] - val) - - ;; handles vectors and ranges - clojure.lang.IChunkedSeq - (internal-reduce - [s f val] - (if-let [s (seq s)] - (if (chunked-seq? s) - (let [ret (.reduce (chunk-first s) f val)] - (if (reduced? ret) - @ret - (recur (chunk-next s) - f - ret))) - (if (instance? clojure.lang.IReduceInit s) - (.reduce ^clojure.lang.IReduceInit s f val) - (naive-seq-reduce s f val))) - val)) - - clojure.lang.StringSeq - (internal-reduce - [str-seq f val] - (let [s (.s str-seq) - len (.length s)] - (loop [i (.i str-seq) - val val] - (if (< i len) - (let [ret (f val (.charAt s i))] - (if (reduced? ret) - @ret - (recur (inc i) ret))) - val)))) - - java.lang.Object - (internal-reduce - [s f val] - (loop [cls (class s) - s s - f f - val val] - (if-let [s (seq s)] - (if (identical? (class s) cls) - (let [ret (f val (first s))] - (if (reduced? ret) - @ret - (recur cls (next s) f ret))) - (if (instance? clojure.lang.IReduceInit s) - (.reduce ^clojure.lang.IReduceInit s f val) - (naive-seq-reduce s f val))) - val)))) - (extend-protocol CollReduce Object ; (default) - ;;aseqs are iterable, masking internal-reducers + ;; aseqs are iterable, masking internal-reducers clojure.lang.ASeq - ;;vector's chunked seq is faster than its iter - clojure.lang.PersistentVector - ;;for range + ;; for range clojure.lang.LazySeq (coll-reduce - ([coll f] (seq-reduce coll f)) - ([coll f val] (seq-reduce coll f val))) + ([coll f init] + (let [s (seq coll)] + (cond ) + ))) ) +#?(:clj +(t/defn reduce-chunked + "Made public in case future specializations want to use it" + [rf rf?, init t/any?, xs dc/chunked-seq?] + (let [ret (.reduce (chunk-first xs) rf init)] + (if (dc/reduced? ret) + (ref/deref ret) + (recur (chunk-next xs) rf ret))))) + +#?(:clj +(t/defn reduce-iter + "Made public in case future specializations want to use it" + [rf rf?, init t/any?, xs (t/isa? java.lang.Iterable)] + (let [iter (.iterator xs)] + (loop [ret init] + (if (.hasNext iter) + (let [ret' (rf ret (.next iter))] + (if (dc/reduced? ret') + (ref/deref ret') + (recur ret'))) + ret))))) + +#?(:clj +(t/defn reduce-indexed + "Made public in case future specializations want to use it" + ([rf rf?, init t/any?, xs (t/or dstr/str? vec/!+vector? arr/array?), i0 t/numerically-integer?] + (let [ct (count xs)] + (loop [i (p/>int i0) ret init] + (if (comp/< i ct) + (let [ret' (rf ret (get xs i))] + (if (dc/reduced? ret') + (ref/deref ret') + ;; TODO TYPED automatically figure out that `inc` will never go out of bounds here + (recur (inc* i) ret'))) + v)))))) + ;; TODO TYPED do type inference based on the rf's. We can sometimes figure out what gets returned ;; based on what is passed in (t/defn reduce @@ -231,52 +209,26 @@ cljs.core/array-reduce "9/25/2018"}} ([rf rf?, xs ?] (reduce rf (rf) xs)) ([rf rf?, init t/any?, xs p/nil?] init) - ([rf rf?, init t/any?, z (t/isa? fast_zip.core.ZipperLocation)] - (loop [xs (zip/down z), v init] - (if (p/val? z) - (let [ret (rf v z)] - (if (dcoll/reduced? ret) + ;; - Adapted from `areduce` + ;; - `!+vector?` included because they aren't reducible or seqable by default + ([rf rf?, init t/any?, xs (t/or dstr/str? vec/!+vector? arr/array?)] + (reduce-indexed rf init xs 0)) +#?(:clj ([rf rf?, init t/any?, xs dc/string-seq?] + (reduce-indexed rf init (string-seq>underlying-string xs) (.index xs)))) +#?(:clj ([rf rf?, init t/any?, xs dc/array-seq?] + (reduce-indexed rf init (.array xs) (.index xs)))) + ([rf rf?, init t/any?, xs (t/isa? fast_zip.core.ZipperLocation)] + (loop [xs' (zip/down xs), ret init] + (if (p/val? xs') + (let [ret' (rf ret xs')] + (if (dc/reduced? ret') ;; TODO TYPED `(ref/deref ret)` should realize it's dealing with a `reduced?` - (ref/deref ret) - (recur (zip/right xs) ret))) + (ref/deref ret') + (recur (zip/right xs') ret'))) v))) - ;; - Adapted from `areduce` - ;; - `!+vector?` included because transient vectors aren't reducible - ([rf rf?, init t/any?, xs (t/or dstr/str? arr/array? vec/!+vector?)] - ;; TODO forward-declare `count` - (let [ct (count xs)] - (loop [i 0 v init] - (if (comp/< i ct) - (let [ret (rf v (get xs i))] - (if (dcoll/reduced? ret) - (ref/deref ret) - ;; TODO TYPED automatically figure out that `inc` will never go out of bounds here - (recur (inc* i) ret))) - v)))) -#?(:clj ([rf rf? init t/any?, xs (t/isa? clojure.lang.StringSeq)] - (let [s (string-seq>underlying-string xs)] - (loop [i (.index xs) v init] - (if (comp/< i (count s)) - (let [ret (rf v (get s i))] - (if (dcoll/reduced? ret) - (ref/deref ret) - (recur (inc* i) ret))) - v))))) - ;; TODO refine -#?(:clj ([rf rf? - #{clojure.lang.PersistentVector ; vector's chunked seq is faster than its iter - clojure.lang.LazySeq ; for range - clojure.lang.ASeq} xs] ; aseqs are iterable, masking internal-reducers - (if-let [s (seq xs)] - (clojure.core.protocols/internal-reduce (next s) f (first s)) - (f)))) - ;; TODO refine -#?(:clj ([f init - #{clojure.lang.PersistentVector ; vector's chunked seq is faster than its iter - clojure.lang.LazySeq ; for range - clojure.lang.ASeq} xs] ; aseqs are iterable, masking internal-reducers - (let [s (seq xs)] - (clojure.core.protocols/internal-reduce s f init)))) + ;; Vector's chunked seq is faster than its iterator +#?(:clj ([rf rf?, init t/any?, xs (t/or (t/isa? clojure.lang.PersistentVector) chunked-seq?)] + (reduce-chunked rf init xs))) ;; TODO refine ([f ^transformer? x] (let [rf ((.-xf x) f)] @@ -286,37 +238,48 @@ (let [rf ((.-xf x) f)] (rf (reduce* (.-prev x) rf init)))) ;; TODO refine - ([f init ^chan? x] (async/reduce f init x)) - ;; TODO refine -#?(:cljs ([f init ^+map? xs] (#_(:clj clojure.core.protocols/kv-reduce - :cljs -kv-reduce) ; in order to use transducers... - -reduce-seq xs f init))) + ([f init ^chan? x] (async/reduce f init x)) ;; TODO refine -#?(:cljs ([f init ^+set? xs] (-reduce-seq xs f init))) +#?(:clj ([rf rf?, init t/any? + xs (t/or (t/isa? clojure.lang.LazySeq) + (t/isa? clojure.lang.ASeq))] + (loop [c (class s), s s, rf rf, val init] + (if-let [s (seq s)] + (if (identical? (class s) c) + (let [ret (rf val (first s))] + (if (reduced? ret) + @ret + (recur c (next s) rf ret))) + (if (instance? clojure.lang.IReduceInit s) + (.reduce ^clojure.lang.IReduceInit s rf val) + ;; Naive seq reduce + ;; "Reduces a seq, ignoring any opportunities to switch to a more + ;; specialized implementation." + (loop [s (seq s), val val] + (if s + (let [ret (rf val (first s))] + (if (reduced? ret) + @ret + (recur (next s) ret))) + val)))) + val)))) ([rf rf?, init t/any?, n dnum/numerically-integer?] - (loop [i 0 v init] + (loop [i 0, ret init] (if (comp/< i n) - (let [ret (rf v i)] - (if (dcoll/reduced? ret) - (ref/deref ret) - (recur (inc* i) ret))) - v))) + (let [ret' (rf ret i)] + (if (dc/reduced? ret') + (ref/deref ret') + ;; TODO TYPED automatically figure out that `inc` will never go out of bounds ;; depending on the type of `n` + (recur (inc i) ret'))) + ret))) + ([rf rf?, init t/any?, ]) ;; TODO refine - ;; `iter-reduce` -#?(:clj ([f init - #{clojure.lang.APersistentMap$KeySeq - clojure.lang.APersistentMap$ValSeq - Iterable} xs] - (let [iter (.iterator xs)] - (loop [ret init] - (if (.hasNext iter) - (let [ret (f ret (.next iter))] - (if (reduced? ret) - @ret - (recur ret))) - ret))))) +#?(:clj ([rf rf?, init t/any? + xs (t/or (t/isa? clojure.lang.APersistentMap$KeySeq) + (t/isa? clojure.lang.APersistentMap$ValSeq))] (reduce-iter xs rf init))) #?(:clj ([rf rf?, init t/any?, xs (t/isa? clojure.lang.IKVReduce)] (.kvreduce xs rf init))) #?(:clj ([rf rf?, init t/any?, xs (t/isa? clojure.lang.IReduceInit)] (.reduce xs rf init))) +#?(:clj ([rf rf?, init t/any?, xs (t/isa? java.lang.Iterable)] (reduce-iter xs rf init))) ;; TODO CLJS might be able to be done more efficiently with more specializations? ([rf rf?, init t/any?, xs (t/isa? #?(:clj clojure.core.protocols/IKVReduce :cljs cljs.core/IKVReduce))] @@ -326,7 +289,11 @@ ([rf rf?, init t/any?, xs (t/isa? #?(:clj clojure.core.protocols/CollReduce :cljs cljs.core/IReduce))] (#?(:clj clojure.core.protocols/coll-reduce - :cljs cljs.core/-reduce) xs rf init))) + :cljs cljs.core/-reduce) xs rf init)) + ;; TODO things that are `seq`-able not already covered + ([rf rf?, init t/any?, xs ????] (reduce rf init (???/seq xs)))) + +;; TODO clojure.lang.Range, clojure.lang.LongRange `cljs.core/reduce` ;; TODO this probably shows that I need to research `^not-native`, `implements?`, `native-satisfies?`, and `satisfies?` in CLJS in order to do dispatch correctly @@ -360,7 +327,7 @@ "`reduce`, indexed. Uses an unsynchronized mutable counter internally, but this cannot cause race conditions if `reduce` is implemented correctly (this includes single-threadedness)." - [f rfi?, init t/any?, xs dcoll/reducible?] + [f rfi?, init t/any?, xs dc/reducible?] (let [f' (let [!i (ref/! -1)] (t/fn ([ret ? x ...] (f ret x (ref/reset! !i (num/inc* (ref/deref !i))))) ([ret ? k ... v ...] (f ret k v (ref/reset! !i (num/inc* (ref/deref !i)))))))] @@ -370,9 +337,9 @@ (t/ftype [rf? :> rf?])) (t/defn transduce > - ([ f rf?, xs dcoll/reducible?] (transduce fn/identity f xs)) - ([xf xf?, f rf?, xs dcoll/reducible?] (transduce xf f (f) xs)) - ([xf xf?, f rf?, init t/any?, xs dcoll/reducible?] (let [f' (xf f)] (f' (reduce f' init xs))))) + ([ f rf?, xs dc/reducible?] (transduce fn/identity f xs)) + ([xf xf?, f rf?, xs dc/reducible?] (transduce xf f (f) xs)) + ([xf xf?, f rf?, init t/any?, xs dc/reducible?] (let [f' (xf f)] (f' (reduce f' init xs))))) ;; ===== End reductive functions ===== ;; @@ -394,16 +361,16 @@ ([x vec/+vector?] (#?(:clj .count :cljs core/count) x)) ([x dasync/m2m-chan?] (-> x #?(:clj .buf :cljs .-buf) count)) ;; Abstract classes - ([x dcoll/icounted? > #?(:clj p/int? :cljs (t/* dnum/nip?))] + ([x dc/icounted? > #?(:clj p/int? :cljs (t/* dnum/nip?))] #?(:clj (.count x) :cljs (-count ^not-native x))) -#?(:cljs ([x dcoll/iseqable? > p/int?] +#?(:cljs ([x dc/iseqable? > p/int?] ;; TODO TYPED (loop [s (seq coll) acc 0] (if (counted? s) ; assumes nil is counted, which it currently is (+ acc (-count s)) (recur (next s) (inc acc)))))) -#?(:clj ([x dcoll/ipersistentcollection? > p/int?] +#?(:clj ([x dc/ipersistentcollection? > p/int?] ;; TODO TYPED ISeq s = seq(o); o = null; @@ -417,7 +384,7 @@ )) #?(:clj ([x dstr/char-seq? > p/int?] (.length x))) -#?(:clj ([x dcoll/java-coll? > p/int?] (.size x))) +#?(:clj ([x dc/java-coll? > p/int?] (.size x))) #?(:clj ([x map/java-map? > p/int?] (.size x))) #?(:clj ([x tup/map-entry? > p/long?] 2)) #?(:clj ([x arr/array? > p/int?] (java.lang.reflect.Array/getLength x)))) @@ -428,7 +395,7 @@ #_([x ?] (-> x count num/zero?)) ([x p/nil?] true) ([x ?/transformer?] (->> x (reduce (fn' (reduced false)) true))) -#?(:clj ([x dcoll/java-coll?] (.isEmpty x))) +#?(:clj ([x dc/java-coll?] (.isEmpty x))) #?(:clj ([x map/java-map?] (.isEmpty x))) ;; TODO TYPED ([^default x] (core/empty? x))) diff --git a/src/quantum/core/data/collections.cljc b/src/quantum/core/data/collections.cljc index 03d9007f..fbc2f9f2 100644 --- a/src/quantum/core/data/collections.cljc +++ b/src/quantum/core/data/collections.cljc @@ -12,6 +12,41 @@ (def record? (t/isa? #?(:clj clojure.lang.IRecord :cljs cljs.core/IRecord))) +;; TODO CLJS +(def iseq? (t/isa? #?(:clj clojure.lang.ISeq :cljs ...))) + +;; TODO CLJS +(def chunk-buffer? #?(:clj (t/isa? clojure.lang.ChunkBuffer) + :cljs ...)) + +;; TODO CLJS +(def chunk? #?(:clj (t/isa? clojure.lang.IChunk) + :cljs ...)) + +;; TODO CLJS +(def chunked-seq? #?(:clj (t/isa? clojure.lang.IChunkedSeq) + :cljs ...)) + +;; TODO CLJS +#?(:clj +(def string-seq? (t/isa? clojure.lang.StringSeq))) + +;; TODO CLJS +#?(:clj +(def range? (t/or (t/isa? clojure.lang.Range) (t/isa? clojure.lang.LongRange)))) + +;; TODO CLJS +#?(:clj +(def array-seq? + (t/or (t/isa? clojure.lang.ArraySeq) + (t/isa? clojure.lang.ArraySeq$ArraySeq_byte) + (t/isa? clojure.lang.ArraySeq$ArraySeq_short) + (t/isa? clojure.lang.ArraySeq$ArraySeq_char) + (t/isa? clojure.lang.ArraySeq$ArraySeq_int) + (t/isa? clojure.lang.ArraySeq$ArraySeq_long) + (t/isa? clojure.lang.ArraySeq$ArraySeq_float) + (t/isa? clojure.lang.ArraySeq$ArraySeq_double)))) + (def sorted? (t/or (t/isa? #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) #?@(:clj [(t/isa? java.util.SortedMap) @@ -44,6 +79,7 @@ (t/or (t/isa? #?(:clj clojure.lang.Sequential :cljs cljs.core/ISequential)) list? indexed?)) +;; If something is `counted?`, it implements a constant-time `count` (def counted? (t/or (t/isa? #?(:clj clojure.lang.Counted :cljs cljs.core/ICounted)) #?(:clj dstr/char-seq? :cljs dstr/string?) vec/vector? map/map? set/set? arr/array?)) diff --git a/src/quantum/core/reducers/reduce.cljc b/src/quantum/core/reducers/reduce.cljc index 349cc1f7..b4ad32cc 100644 --- a/src/quantum/core/reducers/reduce.cljc +++ b/src/quantum/core/reducers/reduce.cljc @@ -55,182 +55,6 @@ ; Fixing it so the seqs are headless. ; Christophe Grand - https://groups.google.com/forum/#!searchin/clojure-dev/reducer/clojure-dev/t6NhGnYNH1A/2lXghJS5HywJ -;___________________________________________________________________________________________________________________________________ -;=================================================={ REDUCE }===================================================== -;=================================================={ }===================================================== -; TODO rreduce [f init o] - like reduce but in reverse order = Equivalent to Scheme's `foldr` -#?(:cljs - (defn- -reduce-seq - "For some reason |reduce| is not implemented in ClojureScript for certain types. - This is a |loop|-|recur| replacement for it." - {:attribution "alexandergunnarson" - :todo ["Check if this is really the case..." - "Improve performance with chunking, etc."]} - [xs f init] - (loop [xs (seq xs) v init] - (if xs - (let [ret (f v (first xs))] - (if (reduced? ret) - @ret - (recur (next xs) ret))) - v)))) - -(defnt reduce* - "Much of this content taken from clojure.core.protocols for inlining and - type-checking purposes." - {:attribution "alexandergunnarson"} - ([^fast_zip.core.ZipperLocation z f init] - (loop [xs (zip/down z) v init] - (if (val? z) - (let [ret (f v z)] - (if (reduced? ret) - @ret - (recur (zip/right xs) ret))) - v))) - ([^array? arr f init] ; Adapted from `areduce` - #?(:clj (let [ct (Array/count arr)] - (loop [i 0 v init] - (if (< i ct) - (let [ret (f v (Array/get arr i))] - (if (reduced? ret) - @ret - (recur (unchecked-inc i) ret))) - v))) - :cljs (array-reduce arr f init))) - ([^!+vector? xs f init] ; because transient vectors aren't reducible - (let [ct (#?(:clj .count :cljs count) xs)] ; TODO fix for CLJS - (loop [i 0 v init] - (if (< i ct) - (let [ret (f v (#?(:clj .valAt :cljs get) xs i))] ; TODO fix for CLJS - (if (reduced? ret) - @ret - (recur (unchecked-inc i) ret))) - v)))) - ([^string? s f init] - (let [ct (#?(:clj .length :cljs .-length) s)] - (loop [i 0 v init] - (if (< i ct) - (let [ret (f v (.charAt s i))] - (if (reduced? ret) - @ret - (recur (unchecked-inc i) ret))) - v)))) -#?(:clj ([^clojure.lang.StringSeq xs f init] - (let [s (.s xs)] - (loop [i (.i xs) v init] - (if (< i (.length s)) - (let [ret (f v (.charAt s i))] - (if (reduced? ret) - @ret - (recur (unchecked-inc i) ret))) - v))))) -#?(:clj ([#{clojure.lang.PersistentVector ; vector's chunked seq is faster than its iter - clojure.lang.LazySeq ; for range - clojure.lang.ASeq} xs f] ; aseqs are iterable, masking internal-reducers - (if-let [s (seq xs)] - (clojure.core.protocols/internal-reduce (next s) f (first s)) - (f)))) -#?(:clj ([#{clojure.lang.PersistentVector ; vector's chunked seq is faster than its iter - clojure.lang.LazySeq ; for range - clojure.lang.ASeq} xs f init] ; aseqs are iterable, masking internal-reducers - (let [s (seq xs)] - (clojure.core.protocols/internal-reduce s f init)))) - ([^transformer? x f] - (let [rf ((.-xf x) f)] - (rf (reduce* (.-prev x) rf (rf))))) - ([^transformer? x f init] - (let [rf ((.-xf x) f)] - (rf (reduce* (.-prev x) rf init)))) - ([^chan? x f init] (async/reduce f init x)) -#?(:cljs ([^+map? xs f init] (#_(:clj clojure.core.protocols/kv-reduce - :cljs -kv-reduce) ; in order to use transducers... - -reduce-seq xs f init))) -#?(:cljs ([^+set? xs f init] (-reduce-seq xs f init))) - ([#{#?(:clj integer? :cljs double?)} n f init] - (loop [i 0 v init] - (if (< i n) - (let [ret (f v i)] - (if (reduced? ret) - @ret - (recur (unchecked-inc i) ret))) - v))) - ;; `iter-reduce` -#?(:clj ([#{clojure.lang.APersistentMap$KeySeq - clojure.lang.APersistentMap$ValSeq - Iterable} xs f] - (let [iter (.iterator xs)] - (if (.hasNext iter) - (loop [ret (.next iter)] - (if (.hasNext iter) - (let [ret (f ret (.next iter))] - (if (reduced? ret) - @ret - (recur ret))) - ret)) - (f))))) - ;; `iter-reduce` -#?(:clj ([#{clojure.lang.APersistentMap$KeySeq - clojure.lang.APersistentMap$ValSeq - Iterable} xs f init] - (let [iter (.iterator xs)] - (loop [ret init] - (if (.hasNext iter) - (let [ret (f ret (.next iter))] - (if (reduced? ret) - @ret - (recur ret))) - ret))))) -#?(:clj ([^clojure.lang.IReduce xs f ] (.reduce xs f))) -#?(:clj ([^clojure.lang.IKVReduce xs f init] (.kvreduce xs f init))) -#?(:clj ([^clojure.lang.IReduceInit xs f init] (.reduce xs f init))) - ([^default xs f] (if (val? xs) - (#?(:clj clojure.core.protocols/coll-reduce - :cljs -reduce) xs f) - (f))) - ([^default xs f init] - (if (val? xs) - (#?(:clj clojure.core.protocols/coll-reduce - :cljs -reduce) xs f init) - init))) - -#?(:clj -(defmacro reduce - "Like `core/reduce` except: - When init is not provided, (f) is used. - Maps are reduced with reduce-kv. - - Entry point for internal reduce (in order to switch the args - around to dispatch on type). - - Equivalent to Scheme's `foldl`." - {:attribution "alexandergunnarson" - :todo ["definline"]} - ([f xs] `(reduce* ~xs ~f)) - ([f init xs] `(reduce* ~xs ~f ~init)))) - -#?(:clj -(defmacro reducei ; TODO unmacro when type inference is available - "`reduce`, indexed. - Uses an unsynchronized mutable counter internally, but this cannot cause race conditions." - {:attribution "alexandergunnarson"} - [f init xs] - `(let [f# ~f - f'# (let [*i# (! -1)] - (fn ([ret# x#] - (f# ret# x# (reset! *i# (unchecked-inc (deref *i#))))) ; TODO use `inc*!` - ([ret# k# v#] - (f# ret# k# v# (reset! *i# (unchecked-inc (deref *i#)))))))] - (reduce f'# ~init ~xs)))) - -#?(:clj -; TODO unmacro when type inference is available -(defmacro transduce - ([ f xs] `(transduce identity ~f ~xs)) - ([xf f xs] `(transduce ~xf ~f (~f) ~xs)) - ([xf f init xs] - `(let [f'# (~xf ~f)] - (f'# (reduce f'# ~init ~xs)))))) -; TODO `transducei` ? ;___________________________________________________________________________________________________________________________________ ;=================================================={ REDUCING FUNCTIONS }===================================================== ;=================================================={ (Generalized) }===================================================== From 126a524c0fbc8128b2572600affa6eb9151677be Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 26 Sep 2018 09:55:26 -0600 Subject: [PATCH 299/810] More refinements to `reduce` --- resources-dev/defnt.cljc | 4 + src/quantum/core/collections_typed.cljc | 100 ++++++++++++++---------- src/quantum/core/data/async.cljc | 10 ++- 3 files changed, 71 insertions(+), 43 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 9343cc6b..32a3b83c 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -87,6 +87,10 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - t/deftype - t/dotyped - lazy compilation especially around `t/input-type` + - equivalence of typed predicates (i.e. that which is `t/<=` `(t/fn [x t/any? :> p/boolean?])`) + to types: + - [xs (t/fn [x (t/isa? clojure.lang.Range)] ...)] + - No return value means that it should infer - typed core fns - `apply` - especially with `t/defn` as the caller diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index c1130184..881da810 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -197,11 +197,17 @@ ;; TODO TYPED do type inference based on the rf's. We can sometimes figure out what gets returned ;; based on what is passed in (t/defn reduce - "Like `core/reduce` except: + "Prefer `transduce` to calling only `reduce`, as otherwise the completing arity of the reducing + function will not get called, which for certain transducers yields unexpected results. + + Like `core/reduce` except: - When init is not provided, (f) is used. - Maps are reduced as if with `reduce-kv`. - Equivalent to Scheme's `foldl`." + Equivalent to Scheme's `foldl`. + + We would specialize on `clojure.lang.Range` and `clojure.lang.LongRange` but they do not expose + their `step` field." {:incorporated '{clojure.core/reduce "9/25/2018" clojure.core/reduce-kv "9/25/2018" clojure.core.protocols "9/25/2018" @@ -229,57 +235,58 @@ ;; Vector's chunked seq is faster than its iterator #?(:clj ([rf rf?, init t/any?, xs (t/or (t/isa? clojure.lang.PersistentVector) chunked-seq?)] (reduce-chunked rf init xs))) - ;; TODO refine - ([f ^transformer? x] - (let [rf ((.-xf x) f)] - (rf (reduce* (.-prev x) rf (rf))))) - ;; TODO refine - ([f init ^transformer? x] - (let [rf ((.-xf x) f)] - (rf (reduce* (.-prev x) rf init)))) - ;; TODO refine - ([f init ^chan? x] (async/reduce f init x)) - ;; TODO refine -#?(:clj ([rf rf?, init t/any? - xs (t/or (t/isa? clojure.lang.LazySeq) - (t/isa? clojure.lang.ASeq))] - (loop [c (class s), s s, rf rf, val init] - (if-let [s (seq s)] - (if (identical? (class s) c) - (let [ret (rf val (first s))] - (if (reduced? ret) - @ret - (recur c (next s) rf ret))) - (if (instance? clojure.lang.IReduceInit s) - (.reduce ^clojure.lang.IReduceInit s rf val) - ;; Naive seq reduce - ;; "Reduces a seq, ignoring any opportunities to switch to a more - ;; specialized implementation." - (loop [s (seq s), val val] - (if s - (let [ret (rf val (first s))] - (if (reduced? ret) - @ret - (recur (next s) ret))) - val)))) - val)))) ([rf rf?, init t/any?, n dnum/numerically-integer?] (loop [i 0, ret init] (if (comp/< i n) (let [ret' (rf ret i)] (if (dc/reduced? ret') (ref/deref ret') - ;; TODO TYPED automatically figure out that `inc` will never go out of bounds ;; depending on the type of `n` + ;; TODO TYPED automatically figure out that `inc` will never go out of bounds + ;; depending on the type of `n` (recur (inc i) ret'))) ret))) - ([rf rf?, init t/any?, ]) ;; TODO refine + ([f init ^transformer? x] + (let [rf ((.-xf x) f)] + (rf (reduce* (.-prev x) rf init)))) #?(:clj ([rf rf?, init t/any? xs (t/or (t/isa? clojure.lang.APersistentMap$KeySeq) - (t/isa? clojure.lang.APersistentMap$ValSeq))] (reduce-iter xs rf init))) + (t/isa? clojure.lang.APersistentMap$ValSeq))] (reduce-iter rf init xs))) + ;; TODO refine +#?(:clj ([rf rf?, init t/any?, xs (t/or (t/isa? clojure.lang.LazySeq) (t/isa? clojure.lang.ASeq))] + (let [c (class xs)] + (loop [s xs, ret init] + (if-let [s (seq s)] + (if (identical? (class s) c) + (let [ret' (rf ret (first s))] + (if (reduced? ret') + @ret' + (recur (next s) ret'))) + (if (instance? clojure.lang.IReduceInit s) + (.reduce ^clojure.lang.IReduceInit s rf ret) + ;; Naive seq reduce + ;; "Reduces a seq, ignoring any opportunities to switch to a more + ;; specialized implementation." + (loop [s (seq s), ret ret] + (if s + (let [ret (rf ret (first s))] + (if (reduced? ret) + @ret + (recur (next s) ret))) + ret)))) + ret))))) + ([rf rf?, init t/any?, x dasync/read-chan?] + (async/go-loop [ret init] + (let [v (async/ rf?])) -(t/defn transduce > +(t/defn ^:inline transduce > ([ f rf?, xs dc/reducible?] (transduce fn/identity f xs)) ([xf xf?, f rf?, xs dc/reducible?] (transduce xf f (f) xs)) ([xf xf?, f rf?, init t/any?, xs dc/reducible?] (let [f' (xf f)] (f' (reduce f' init xs))))) +;; TODO incorporate +(... async-transduce + "async/reduces a channel with a transformation (xform f). + Returns a channel containing the result. ch must close before + transduce produces a result." + [xform f init ch] + (let [f (xform f)] + (go + (let [ret ( Date: Wed, 26 Sep 2018 10:23:30 -0600 Subject: [PATCH 300/810] Clean up `reduce` more and move sequence type decls --- src-untyped/quantum/untyped/core/type.cljc | 25 ------ src/quantum/core/collections_typed.cljc | 91 ++++++++++------------ src/quantum/core/data/collections.cljc | 68 +++++++++++----- 3 files changed, 88 insertions(+), 96 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index d9269aec..4cbcd5c8 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -641,31 +641,6 @@ (isa? #?(:clj clojure.lang.PersistentArrayMap :cljs cljs.core/PersistentArrayMap)) (isa? #?(:clj clojure.lang.PersistentTreeMap :cljs cljs.core/PersistentTreeMap)))) -;; ===== Sequences ===== ;; Sequential (generally not efficient Lookup / RandomAccess) - - (-def seq? (isa? #?(:clj clojure.lang.ISeq :cljs cljs.core/ISeq))) - (-def cons? (isa? #?(:clj clojure.lang.Cons :cljs cljs.core/Cons))) - (-def lseq? (isa? #?(:clj clojure.lang.LazySeq :cljs cljs.core/LazySeq))) - (-def misc-seq? (or (isa? #?(:clj clojure.lang.APersistentMap$KeySeq :cljs cljs.core/KeySeq)) - (isa? #?(:clj clojure.lang.APersistentMap$ValSeq :cljs cljs.core/ValSeq)) - (isa? #?(:clj clojure.lang.PersistentVector$ChunkedSeq :cljs cljs.core/ChunkedSeq)) - (isa? #?(:clj clojure.lang.IndexedSeq :cljs cljs.core/IndexedSeq)))) - - (-def non-list-seq? (or cons? lseq? misc-seq?)) - -;; ----- Lists ----- ;; Not extremely different from Sequences ; TODO clean this up - - (-def cdlist? none? #_(:clj (or (isa? clojure.data.finger_tree.CountedDoubleList) - (isa? quantum.core.data.finger_tree.CountedDoubleList)) - :cljs (isa? quantum.core.data.finger-tree/CountedDoubleList))) - (-def dlist? none? #_(:clj (or (isa? clojure.data.finger_tree.CountedDoubleList) - (isa? quantum.core.data.finger_tree.CountedDoubleList)) - :cljs (isa? quantum.core.data.finger-tree/CountedDoubleList))) - (-def +list? (isa? #?(:clj clojure.lang.IPersistentList :cljs cljs.core/IList))) - (-def !list? #?(:clj (isa? java.util.LinkedList) :cljs none?)) - (-def list? #?(:clj (isa? java.util.List) - :cljs +list?)) - ;; ===== Vectors ===== ;; Sequential, Associative (specifically, whose keys are sequential, ;; dense integer values), extensible diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index 881da810..d8518f62 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -1,6 +1,6 @@ (ns quantum.core.collections-typed (:refer-clojure :exclude - [chunk-first chunk-rest count empty? get nth reduce]) + [chunk-first chunk-rest count empty? first get nth reduce seq]) (:require [quantum.core.data.array :as arr] [quantum.core.data.async :as dasync] @@ -145,19 +145,6 @@ (t/defn- ^:inline string-seq>underlying-string [xs (t/isa? clojure.lang.StringSeq) > (t/assume dstr/str?)] (.s xs)) -(extend-protocol CollReduce - Object ; (default) - ;; aseqs are iterable, masking internal-reducers - clojure.lang.ASeq - ;; for range - clojure.lang.LazySeq - (coll-reduce - ([coll f init] - (let [s (seq coll)] - (cond ) - ))) -) - #?(:clj (t/defn reduce-chunked "Made public in case future specializations want to use it" @@ -167,19 +154,6 @@ (ref/deref ret) (recur (chunk-next xs) rf ret))))) -#?(:clj -(t/defn reduce-iter - "Made public in case future specializations want to use it" - [rf rf?, init t/any?, xs (t/isa? java.lang.Iterable)] - (let [iter (.iterator xs)] - (loop [ret init] - (if (.hasNext iter) - (let [ret' (rf ret (.next iter))] - (if (dc/reduced? ret') - (ref/deref ret') - (recur ret'))) - ret))))) - #?(:clj (t/defn reduce-indexed "Made public in case future specializations want to use it" @@ -194,6 +168,30 @@ (recur (inc* i) ret'))) v)))))) +#?(:clj +(t/defn reduce-iter + "Made public in case future specializations want to use it" + [rf rf?, init t/any?, xs (t/isa? java.lang.Iterable)] + (let [iter (.iterator xs)] + (loop [ret init] + (if (.hasNext iter) + (let [ret' (rf ret (.next iter))] + (if (dc/reduced? ret') + (ref/deref ret') + (recur ret'))) + ret))))) + +(t/defn reduce-seq + "Reduces a seq, ignoring any opportunities to switch to a more specialized implementation." + [rf rf?, init t/any?, xs iseq?] + (loop [s (seq s), ret ret] + (if (nil? s) + ret + (let [ret (rf ret (first s))] + (if (reduced? ret) + @ret + (recur (next s) ret)))))) + ;; TODO TYPED do type inference based on the rf's. We can sometimes figure out what gets returned ;; based on what is passed in (t/defn reduce @@ -252,40 +250,31 @@ #?(:clj ([rf rf?, init t/any? xs (t/or (t/isa? clojure.lang.APersistentMap$KeySeq) (t/isa? clojure.lang.APersistentMap$ValSeq))] (reduce-iter rf init xs))) + ([rf rf?, init t/any?, x dasync/read-chan?] + (async/go-loop [ret init] + (let [v (async/ Date: Wed, 26 Sep 2018 13:24:10 -0600 Subject: [PATCH 301/810] In the middle of `>seq`; I think done with `reduce`?? --- resources-dev/defnt.cljc | 14 ++ src-untyped/quantum/untyped/core/type.cljc | 9 ++ src/quantum/core/collections_typed.cljc | 164 +++++++++++---------- 3 files changed, 107 insertions(+), 80 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 32a3b83c..81d6e1d9 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -36,7 +36,21 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative ;; TODO TYPED automatically figure out that `inc` will never go out of bounds here (recur (inc* i) ret))) v))) + - (let [xs' (seq xs)] + (if (dcomp/== (class xs') (class xs)) + (reduce-seq rf ret xs') + ;; TODO TYPED automatically figure out that: + ;; - `(not (dcomp/== (class xs') (class xs)))` + ;; - What the possible types of xs' are as a result + (reduce rf init xs'))) + - ([rf rf?, init t/any?, xs #?(:clj (t/isa? clojure.core.protocols/CollReduce) + :cljs (t/isa|direct? cljs.core/IReduce))] + ;; TODO add `^not-native` to `xs` for CLJS + (#?(:clj clojure.core.protocols/coll-reduce + :cljs cljs.core/-reduce) xs rf init)) - t/- : multi-arity + - t/isa|direct? + - For CLJ, this is `instance?`; for CLJS, this is `instance?` for classes and `implements?` for protocols - t/value-of - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` - t/numerically : e.g. a double representing exactly what a float is able to represent diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 4cbcd5c8..24f2c251 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -622,6 +622,15 @@ #?(:clj (-def float? (isa? Float))) (-def double? (isa? #?(:clj Double :cljs js/Number))) + ;; These are special for CLJS protocols +#?(:cljs (-def native? (or (isa? js/Boolean) + (isa? js/Number) + (isa? js/Object) + (isa? js/Array) + (isa? js/String) + (isa? js/Function) + nil?))) + ;; ===== Booleans ===== ;; (-def true? (value true)) diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index d8518f62..ba44b5c1 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -1,6 +1,6 @@ (ns quantum.core.collections-typed (:refer-clojure :exclude - [chunk-first chunk-rest count empty? first get nth reduce seq]) + [chunk-first chunk-rest count empty? first get next nth reduce]) (:require [quantum.core.data.array :as arr] [quantum.core.data.async :as dasync] @@ -98,27 +98,52 @@ necessary." ...) +;; ----- Iterators ----- ;; +(t/defn ^:inline >iterator [x (t/isa|direct? #?(:clj java.lang.Iterable :cljs cljs.core/IIterable))] + #?(:clj (.iterator x) + :cljs (cljs.core/-iterator ^not-native x))) ;; ----- Chunking ----- ;; (t/defn chunk-buffer > chunk-buffer? [capacity num/numerically-int?] (clojure.lang.ChunkBuffer. (p/>int capacity))) -(t/defn chunk [b dc/chunk-buffer? > dc/chunk?] (.chunk b)) -(t/defn chunk-append [b dc/chunk-buffer?, x p/ref? > dc/chunk?] (.add b x)) +(t/defn ^:inline chunk [b dc/chunk-buffer? > dc/chunk?] (.chunk b)) +(t/defn ^:inline chunk-append [b dc/chunk-buffer?, x p/ref? > dc/chunk?] (.add b x)) -(t/defn chunk-first [xs dc/chunked-seq? > dc/chunk?] (.chunkedFirst xs)) -(t/defn chunk-rest [xs dc/chunked-seq? > dc/chunk?] (.chunkedMore xs)) -(t/defn chunk-next [xs dc/chunked-seq? > dc/chunk?] (.chunkedNext xs)) +(t/defn ^:inline chunk-first [xs dc/chunked-seq? > dc/chunk?] (.chunkedFirst xs)) +(t/defn ^:inline chunk-rest [xs dc/chunked-seq? > dc/chunk?] (.chunkedMore xs)) +(t/defn ^:inline chunk-next [xs dc/chunked-seq? > dc/chunk?] (.chunkedNext xs)) (t/defn chunk-cons [chunk dc/chunk?, the-rest dc/iseq?] (if (num/zero? (count chunk)) ;; TODO TYPED replace this condition with `empty` the-rest (clojure.lang.ChunkedCons. chunk the-rest))) +;; ----- Sequences ----- ;; + +(t/defn ^:inline >seq + {:incorporated '{clojure.lang.RT/seq "9/26/2018"}} + > (t/? dc/iseq?) + ([x p/nil?] nil) +#?(:clj ([x dc/aseq?] x)) + ([x #?(:clj (t/isa? clojure.lang.Seqable) + :cljs (t/isa|direct? cljs.core/ISeqable))] + (#?(:clj .seq :cljs cljs.core/-seq) x)) +#?(:clj ([x (t/isa? java.lang.Iterable)] (-> x >iterator clojure.lang.RT/chunkIteratorSeq))) +#?(:clj ([x dstr/char-seq?] (clojure.lang.StringSeq/create x))) +#?(:clj ([x dc/java-map?] (-> x .entrySet >seq))) + ;; NOTE `ArraySeq/createFromObject` is the slow path but has to be that way because the + ;; specialized ArraySeq constructors are private +#?(:clj ([x arr/array?] (ArraySeq/createFromObject x)))) + +(t/defn- ^:inline string-seq>underlying-string + [xs (t/isa? clojure.lang.StringSeq) > (t/assume dstr/str?)] (.s xs)) + ;; ===== Reductive functions ===== ;; +;; TODO excise #?(:cljs (defn- -reduce-seq "For some reason |reduce| is not implemented in ClojureScript for certain types. @@ -126,7 +151,7 @@ {:todo #{"Check if this is really the case..." "Improve performance with chunking, etc."}} [xs f init] - (loop [xs (seq xs) v init] + (loop [xs (>seq xs) v init] (if xs (let [ret (f v (first xs))] (if (reduced? ret) @@ -142,12 +167,9 @@ "reducing arity" [t/any? t/any?] "reducing arity for kvs" [t/any? t/any? t/any?])) -(t/defn- ^:inline string-seq>underlying-string - [xs (t/isa? clojure.lang.StringSeq) > (t/assume dstr/str?)] (.s xs)) - #?(:clj (t/defn reduce-chunked - "Made public in case future specializations want to use it" + "Made public in case future specializations want to use it." [rf rf?, init t/any?, xs dc/chunked-seq?] (let [ret (.reduce (chunk-first xs) rf init)] (if (dc/reduced? ret) @@ -156,7 +178,7 @@ #?(:clj (t/defn reduce-indexed - "Made public in case future specializations want to use it" + "Made public in case future specializations want to use it." ([rf rf?, init t/any?, xs (t/or dstr/str? vec/!+vector? arr/array?), i0 t/numerically-integer?] (let [ct (count xs)] (loop [i (p/>int i0) ret init] @@ -168,29 +190,30 @@ (recur (inc* i) ret'))) v)))))) -#?(:clj (t/defn reduce-iter - "Made public in case future specializations want to use it" - [rf rf?, init t/any?, xs (t/isa? java.lang.Iterable)] - (let [iter (.iterator xs)] + "Made public in case future specializations want to use it." + [rf rf?, init t/any?, xs (t/isa|direct? #?(:clj java.lang.Iterable :cljs cljs.core/IIterable))] + (let [iter (>iterator xs)] (loop [ret init] - (if (.hasNext iter) + (if #?(:clj (.hasNext iter) :cljs ^boolean (.hasNext iter)) (let [ret' (rf ret (.next iter))] (if (dc/reduced? ret') (ref/deref ret') (recur ret'))) - ret))))) + ret)))) (t/defn reduce-seq - "Reduces a seq, ignoring any opportunities to switch to a more specialized implementation." + "Reduces a seq, ignoring any opportunities to switch to a more specialized implementation. + + Made public in case future specializations want to use it." [rf rf?, init t/any?, xs iseq?] - (loop [s (seq s), ret ret] - (if (nil? s) + (loop [xs' xs, ret init] + (if (nil? xs') ret - (let [ret (rf ret (first s))] - (if (reduced? ret) - @ret - (recur (next s) ret)))))) + (let [ret' (rf ret (first xs'))] + (if (dc/reduced? ret') + (ref/deref ret') + (recur (next xs') ret')))))) ;; TODO TYPED do type inference based on the rf's. We can sometimes figure out what gets returned ;; based on what is passed in @@ -205,12 +228,15 @@ Equivalent to Scheme's `foldl`. We would specialize on `clojure.lang.Range` and `clojure.lang.LongRange` but they do not expose - their `step` field." + their `step` field so we have to use their implementation of `reduce`." {:incorporated '{clojure.core/reduce "9/25/2018" clojure.core/reduce-kv "9/25/2018" clojure.core.protocols "9/25/2018" + cljs.core/reduce "9/26/2018" cljs.core/reduce-kv "9/25/2018" - cljs.core/array-reduce "9/25/2018"}} + cljs.core/array-reduce "9/25/2018" + cljs.core/iter-reduce "9/26/2018" + cljs.core/seq-reduce "9/26/2018"}} ([rf rf?, xs ?] (reduce rf (rf) xs)) ([rf rf?, init t/any?, xs p/nil?] init) ;; - Adapted from `areduce` @@ -221,15 +247,6 @@ (reduce-indexed rf init (string-seq>underlying-string xs) (.index xs)))) #?(:clj ([rf rf?, init t/any?, xs dc/array-seq?] (reduce-indexed rf init (.array xs) (.index xs)))) - ([rf rf?, init t/any?, xs (t/isa? fast_zip.core.ZipperLocation)] - (loop [xs' (zip/down xs), ret init] - (if (p/val? xs') - (let [ret' (rf ret xs')] - (if (dc/reduced? ret') - ;; TODO TYPED `(ref/deref ret)` should realize it's dealing with a `reduced?` - (ref/deref ret') - (recur (zip/right xs') ret'))) - v))) ;; Vector's chunked seq is faster than its iterator #?(:clj ([rf rf?, init t/any?, xs (t/or (t/isa? clojure.lang.PersistentVector) chunked-seq?)] (reduce-chunked rf init xs))) @@ -247,9 +264,6 @@ ([f init ^transformer? x] (let [rf ((.-xf x) f)] (rf (reduce* (.-prev x) rf init)))) -#?(:clj ([rf rf?, init t/any? - xs (t/or (t/isa? clojure.lang.APersistentMap$KeySeq) - (t/isa? clojure.lang.APersistentMap$ValSeq))] (reduce-iter rf init xs))) ([rf rf?, init t/any?, x dasync/read-chan?] (async/go-loop [ret init] (let [v (async/seq xs), ret init] + (if (dcomp/== (class xs') c) + (let [ret' (rf ret (first xs'))] + (if (dc/reduced? ret') + (ref/deref ret') + (recur (next xs') ret'))) + ;; TODO TYPED automatically figure out that: + ;; - `(not (dcomp/== (class xs') (class xs)))` + ;; - What the possible types of xs' are as a result + (reduce rf init xs')))))) #?(:clj ([rf rf?, init t/any?, xs (t/isa? java.lang.Iterable)] (reduce-iter rf init xs))) ;; TODO CLJS might be able to be done more efficiently with more specializations? - ([rf rf?, init t/any?, xs (t/isa? #?(:clj clojure.core.protocols/IKVReduce - :cljs cljs.core/IKVReduce))] + ([rf rf?, init t/any?, xs #?(:clj (t/isa? clojure.core.protocols/IKVReduce) + :cljs (t/isa|direct? cljs.core/IKVReduce))] (#?(:clj clojure.core.protocols/kv-reduce :cljs cljs.core/-kv-reduce) xs rf init)) ;; TODO CLJS might be able to be done more efficiently with more specializations? - ([rf rf?, init t/any?, xs (t/isa? #?(:clj clojure.core.protocols/CollReduce - :cljs cljs.core/IReduce))] + ([rf rf?, init t/any?, xs #?(:clj (t/isa? clojure.core.protocols/CollReduce) + :cljs (t/isa|direct? cljs.core/IReduce))] (#?(:clj clojure.core.protocols/coll-reduce - :cljs cljs.core/-reduce) xs rf init))) - -;; TODO clojure.lang.Range, clojure.lang.LongRange - -`cljs.core/reduce` -;; TODO this probably shows that I need to research `^not-native`, `implements?`, `native-satisfies?`, and `satisfies?` in CLJS in order to do dispatch correctly -([f val coll] - (cond - (implements? IReduce coll) - (-reduce ^not-native coll f val) - - (array? coll) - (array-reduce coll f val) - - (string? coll) - (array-reduce coll f val) - - (native-satisfies? IReduce coll) - (-reduce coll f val) - - (iterable? coll) - (iter-reduce coll f val) - - :else - (seq-reduce f val coll))) + :cljs cljs.core/-reduce) xs rf init)) +#?(:cljs ([rf rf?, init t/any?, xs (t/isa|direct? cljs.core/IIterable)] (reduce-iter rf init xs))) +#?(:cljs ([rf rf?, init t/any?, xs (t/isa|direct? cljs.core/ISeqable)] + (reduce-seq rf init (>seq xs))))) (var/def rfi? "Reducing function, indexed" (t/ftype "seed arity" [] From 60d9443df83570b665431c31de5832400a567076 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 26 Sep 2018 13:41:46 -0600 Subject: [PATCH 302/810] Finished `>seq` --- resources-dev/defnt.cljc | 1 + src/quantum/core/collections_typed.cljc | 31 +++++++++++++++---------- 2 files changed, 20 insertions(+), 12 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 81d6e1d9..b0980576 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -48,6 +48,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative ;; TODO add `^not-native` to `xs` for CLJS (#?(:clj clojure.core.protocols/coll-reduce :cljs cljs.core/-reduce) xs rf init)) + - (if (A) ...) should be (if ^boolean (A) ...) if A returns a `p/boolean?` - t/- : multi-arity - t/isa|direct? - For CLJ, this is `instance?`; for CLJS, this is `instance?` for classes and `implements?` for protocols diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index ba44b5c1..92346f0c 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -124,19 +124,26 @@ ;; ----- Sequences ----- ;; (t/defn ^:inline >seq - {:incorporated '{clojure.lang.RT/seq "9/26/2018"}} + {:incorporated '{clojure.lang.RT/seq "9/26/2018" + clojure.core/seq "9/26/2018" + cljs.core/seq "9/26/2018"}} > (t/? dc/iseq?) - ([x p/nil?] nil) -#?(:clj ([x dc/aseq?] x)) - ([x #?(:clj (t/isa? clojure.lang.Seqable) - :cljs (t/isa|direct? cljs.core/ISeqable))] - (#?(:clj .seq :cljs cljs.core/-seq) x)) -#?(:clj ([x (t/isa? java.lang.Iterable)] (-> x >iterator clojure.lang.RT/chunkIteratorSeq))) -#?(:clj ([x dstr/char-seq?] (clojure.lang.StringSeq/create x))) -#?(:clj ([x dc/java-map?] (-> x .entrySet >seq))) - ;; NOTE `ArraySeq/createFromObject` is the slow path but has to be that way because the - ;; specialized ArraySeq constructors are private -#?(:clj ([x arr/array?] (ArraySeq/createFromObject x)))) + ([x p/nil?] nil) +#?(:clj ([xs dc/aseq?] x)) + ([xs #?(:clj (t/isa? clojure.lang.Seqable) + :cljs (t/isa|direct? cljs.core/ISeqable))] + (#?(:clj .seq :cljs cljs.core/-seq) x)) +#?(:clj ([xs (t/isa? java.lang.Iterable)] (-> x >iterator clojure.lang.RT/chunkIteratorSeq))) +#?(:clj ([xs dstr/char-seq?] (clojure.lang.StringSeq/create x)) + :cljs ([xs dstr/string?] (when-not (zero? (count xs)) ; TODO use `empty?` instead + (IndexedSeq. xs 0 nil)))) +#?(:clj ([xs dc/java-map?] (-> x .entrySet >seq))) + ;; NOTE `ArraySeq/createFromObject` is the slow path but has to be that way because the + ;; specialized ArraySeq constructors are private + ([xs arr/array?] + #?(:clj (ArraySeq/createFromObject xs) + :cljs (when-not (num/zero? (count xs)) ; TODO use `empty?` instead + (cljs.core/IndexedSeq. xs 0 nil))))) (t/defn- ^:inline string-seq>underlying-string [xs (t/isa? clojure.lang.StringSeq) > (t/assume dstr/str?)] (.s xs)) From 9fb34430ec8bd9abfe1c920d845901dc701f1d2c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 26 Sep 2018 13:42:16 -0600 Subject: [PATCH 303/810] Enhanced `>seq` --- src/quantum/core/collections_typed.cljc | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index 92346f0c..659e73cc 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -135,8 +135,8 @@ (#?(:clj .seq :cljs cljs.core/-seq) x)) #?(:clj ([xs (t/isa? java.lang.Iterable)] (-> x >iterator clojure.lang.RT/chunkIteratorSeq))) #?(:clj ([xs dstr/char-seq?] (clojure.lang.StringSeq/create x)) - :cljs ([xs dstr/string?] (when-not (zero? (count xs)) ; TODO use `empty?` instead - (IndexedSeq. xs 0 nil)))) + :cljs ([xs dstr/string?] (when-not (num/zero? (count xs)) ; TODO use `empty?` instead + (cljs.core/IndexedSeq. xs 0 nil)))) #?(:clj ([xs dc/java-map?] (-> x .entrySet >seq))) ;; NOTE `ArraySeq/createFromObject` is the slow path but has to be that way because the ;; specialized ArraySeq constructors are private @@ -382,7 +382,7 @@ :cljs (-count ^not-native x))) #?(:cljs ([x dc/iseqable? > p/int?] ;; TODO TYPED - (loop [s (seq coll) acc 0] + (loop [s (>seq coll) acc 0] (if (counted? s) ; assumes nil is counted, which it currently is (+ acc (-count s)) (recur (next s) (inc acc)))))) From 8594abf51e3124f58c8a0fd2aa46530154a8148e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 26 Sep 2018 13:53:15 -0600 Subject: [PATCH 304/810] Done with `transduce` --- resources-dev/defnt.cljc | 6 ++- src/quantum/core/collections_typed.cljc | 53 +++++++++---------------- 2 files changed, 22 insertions(+), 37 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index b0980576..d1d47c5c 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -51,7 +51,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - (if (A) ...) should be (if ^boolean (A) ...) if A returns a `p/boolean?` - t/- : multi-arity - t/isa|direct? - - For CLJ, this is `instance?`; for CLJS, this is `instance?` for classes and `implements?` for protocols + - For CLJ, this is `instance?` for classes and `instance?` on the underlying interface + associated with a protocol + - For CLJS, this is `instance?` for classes and `implements?` for protocols - t/value-of - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` - t/numerically : e.g. a double representing exactly what a float is able to represent @@ -65,7 +67,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - use logic programming and variable unification e.g. `?1` `?2` ? - t/extend-defnt! - t/input-type - - `(t/input-type >namespace t/?)` meaing the possible input types to the first input to `>namespace` + - `(t/input-type >namespace :?)` meaing the possible input types to the first input to `>namespace` - t/of - (t/of number?) ; implicitly the container is a `traversable?` - (t/of map/+map? symbol? dstr/string?) diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index 659e73cc..53e19d05 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -150,22 +150,6 @@ ;; ===== Reductive functions ===== ;; -;; TODO excise -#?(:cljs -(defn- -reduce-seq - "For some reason |reduce| is not implemented in ClojureScript for certain types. - This is a |loop|-|recur| replacement for it." - {:todo #{"Check if this is really the case..." - "Improve performance with chunking, etc."}} - [xs f init] - (loop [xs (>seq xs) v init] - (if xs - (let [ret (f v (first xs))] - (if (reduced? ret) - @ret - (recur (next xs) ret))) - v)))) - ;; TODO: conditionally optional arities etc. for t/fn (var/def rf? "Reducing function" @@ -332,30 +316,29 @@ "`reduce`, indexed. Uses an unsynchronized mutable counter internally, but this cannot cause race conditions if `reduce` is implemented correctly (this includes single-threadedness)." - [f rfi?, init t/any?, xs dc/reducible?] - (let [f' (let [!i (ref/! -1)] - (t/fn ([ret ? x ...] (f ret x (ref/reset! !i (num/inc* (ref/deref !i))))) - ([ret ? k ... v ...] (f ret k v (ref/reset! !i (num/inc* (ref/deref !i)))))))] - (reduce f' init xs))) + [rf rfi?, init t/any?, xs dc/reducible?] + (let [rf' (let [!i (ref/! -1)] + (fn/aritoid rf' rf' + (t/fn ([ret ?, x ?] + (rf ret x (ref/reset! !i (num/inc* (ref/deref !i)))))) + (t/fn ([ret ?, k ?, v ?] + (rf ret k v (ref/reset! !i (num/inc* (ref/deref !i))))))))] + (reduce rf' init xs))) (var/def xf? "Transforming function" (t/ftype [rf? :> rf?])) (t/defn ^:inline transduce > - ([ f rf?, xs dc/reducible?] (transduce fn/identity f xs)) - ([xf xf?, f rf?, xs dc/reducible?] (transduce xf f (f) xs)) - ([xf xf?, f rf?, init t/any?, xs dc/reducible?] (let [f' (xf f)] (f' (reduce f' init xs))))) - -;; TODO incorporate -(... async-transduce - "async/reduces a channel with a transformation (xform f). - Returns a channel containing the result. ch must close before - transduce produces a result." - [xform f init ch] - (let [f (xform f)] - (go - (let [ret ( Date: Wed, 26 Sep 2018 21:16:12 -0600 Subject: [PATCH 305/810] Clean up `reduce`, `count`, `empty`; `educe`; `bounded-count` --- resources-dev/defnt.cljc | 17 ++ .../quantum/untyped/core/data/numeric.cljc | 2 + src-untyped/quantum/untyped/core/type.cljc | 6 +- src/quantum/core/collections_typed.cljc | 179 +++++++++--------- src/quantum/core/data/collections.cljc | 33 +++- 5 files changed, 142 insertions(+), 95 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index d1d47c5c..e0ff82e3 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -15,6 +15,7 @@ These two should be defined in the (whatever) data namespace: TODO: - `(or (and pred then) (and (not pred) else))` (which is not correct) - needs to equal `(t/and (t/or (t/not a) b) (t/or a c))` (which is correct) +- `(- (or ?!+vector? !vector? #?(:clj !!vector?)) (isa? clojure.lang.Counted))` is not right - conditionally optional arities etc. for t/fn @@ -22,6 +23,7 @@ TODO: Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: + - data.coll/reduced - Analysis - (if (dcoll/reduced? ret) ;; TODO TYPED `(ref/deref ret)` should realize it's dealing with a `reduced?` @@ -65,9 +67,13 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - dependent types: `[x arr/array? > (t/type x)]` - ? : type inference - use logic programming and variable unification e.g. `?1` `?2` ? + - For this situation: `?` is `(t/- dc/counted?)` + ([n dnum/std-integer?, xs dc/counted?] (count xs)) + ([n dnum/std-integer?, xs ?] ...) - t/extend-defnt! - t/input-type - `(t/input-type >namespace :?)` meaing the possible input types to the first input to `>namespace` + - `(t/input-type reduce :_ :_ :?)` - t/of - (t/of number?) ; implicitly the container is a `traversable?` - (t/of map/+map? symbol? dstr/string?) @@ -93,6 +99,17 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative we do the `let*`-binding approach to typing vars? - should be able to be per-arity like so: (^:inline [] ...) + - A good example of inlining: + (t/def empty?|rf + (fn/aritoid + (t/fn [] true) + fn/identity + (t/fn [ret _, x _] (dc/reduced false)) + (t/fn [ret _, k _, v _] (dc/reduced false)))) + (t/defn empty? > p/boolean? + ([x p/nil?] true) + ([xs dc/counted?] (-> xs count num/zero?)) + ([xs (t/input-type educe :_ :_ :?)] (educe empty?|rf x))) - handle varargs - [& args _] shouldn't result in `t/any?` but rather like `t/seqable?` or whatever - do the defnt-equivalences diff --git a/src-untyped/quantum/untyped/core/data/numeric.cljc b/src-untyped/quantum/untyped/core/data/numeric.cljc index bf79fe13..1e4dd982 100644 --- a/src-untyped/quantum/untyped/core/data/numeric.cljc +++ b/src-untyped/quantum/untyped/core/data/numeric.cljc @@ -130,3 +130,5 @@ (t/or number? #?(:clj p/char?))) (def numeric-primitive? (t/- p/primitive? p/boolean?)) + +(def std-integer? (t/or integer? #?(:cljs double?))) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 24f2c251..f73828d8 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -671,7 +671,7 @@ (-def !+vector? (isa? #?(:clj clojure.lang.ITransientVector :cljs cljs.core/ITransientVector))) - (-def ?!+vector? (or +vector? ?!+vector?)) + (-def ?!+vector? (or +vector? !+vector?)) (-def !vector|byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.ByteArrayList) :cljs none?)) (-def !vector|short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.ShortArrayList) :cljs none?)) @@ -695,6 +695,10 @@ ;; just create a synchronized wrapper over an ArrayList ;; via java.util.Collections #?(:clj (-def !!vector? none?)) + ;; We could maybe duck-type as + ;; `(t/and (isa? java.util.RandomAccess) (isa? java.util.List))` + ;; but it's not really sufficient as that doesn't really capture + ;; all the properties we want out of a vector (-def vector? (or ?!+vector? !vector? #?(:clj !!vector?))) ;; ===== Queues ===== ;; Particularly FIFO queues, as LIFO = stack = any vector diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index 53e19d05..95700c11 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -162,17 +162,18 @@ (t/defn reduce-chunked "Made public in case future specializations want to use it." [rf rf?, init t/any?, xs dc/chunked-seq?] - (let [ret (.reduce (chunk-first xs) rf init)] - (if (dc/reduced? ret) - (ref/deref ret) - (recur (chunk-next xs) rf ret))))) + (loop [ret init, xs' xs] + (let [ret' (.reduce (chunk-first xs') rf init)] + (if (dc/reduced? ret') + (ref/deref ret') + (recur ret' (chunk-next xs'))))))) #?(:clj (t/defn reduce-indexed "Made public in case future specializations want to use it." ([rf rf?, init t/any?, xs (t/or dstr/str? vec/!+vector? arr/array?), i0 t/numerically-integer?] (let [ct (count xs)] - (loop [i (p/>int i0) ret init] + (loop [i (p/>int i0), ret init] (if (comp/< i ct) (let [ret' (rf ret (get xs i))] (if (dc/reduced? ret') @@ -228,18 +229,19 @@ cljs.core/array-reduce "9/25/2018" cljs.core/iter-reduce "9/26/2018" cljs.core/seq-reduce "9/26/2018"}} - ([rf rf?, xs ?] (reduce rf (rf) xs)) - ([rf rf?, init t/any?, xs p/nil?] init) + (^:inline [rf rf?, xs ?] (reduce rf (rf) xs)) + (^:inline [rf rf?, init t/any?, xs p/nil?] init) ;; - Adapted from `areduce` ;; - `!+vector?` included because they aren't reducible or seqable by default - ([rf rf?, init t/any?, xs (t/or dstr/str? vec/!+vector? arr/array?)] + (^:inline [rf rf?, init t/any?, xs (t/or dstr/str? vec/!+vector? arr/array?)] (reduce-indexed rf init xs 0)) -#?(:clj ([rf rf?, init t/any?, xs dc/string-seq?] +#?(:clj (^:inline [rf rf?, init t/any?, xs dc/string-seq?] (reduce-indexed rf init (string-seq>underlying-string xs) (.index xs)))) -#?(:clj ([rf rf?, init t/any?, xs dc/array-seq?] +#?(:clj (^:inline [rf rf?, init t/any?, xs dc/array-seq?] (reduce-indexed rf init (.array xs) (.index xs)))) ;; Vector's chunked seq is faster than its iterator -#?(:clj ([rf rf?, init t/any?, xs (t/or (t/isa? clojure.lang.PersistentVector) chunked-seq?)] +#?(:clj (^:inline [rf rf?, init t/any? + xs (t/or (t/isa? clojure.lang.PersistentVector) chunked-seq?)] (reduce-chunked rf init xs))) ([rf rf?, init t/any?, n dnum/numerically-integer?] (loop [i 0, ret init] @@ -252,7 +254,7 @@ (recur (inc i) ret'))) ret))) ;; TODO refine - ([f init ^transformer? x] + (^:inline [f init ^transformer? x] (let [rf ((.-xf x) f)] (rf (reduce* (.-prev x) rf init)))) ([rf rf?, init t/any?, x dasync/read-chan?] @@ -273,12 +275,14 @@ (ref/deref ret') (recur (zip/right xs') ret'))) v))) -#?(:clj ([rf rf?, init t/any? - xs (t/or (t/isa? clojure.lang.APersistentMap$KeySeq) - (t/isa? clojure.lang.APersistentMap$ValSeq))] (reduce-iter rf init xs))) -#?(:clj ([rf rf?, init t/any?, xs (t/isa? clojure.lang.IKVReduce)] (.kvreduce xs rf init))) -#?(:clj ([rf rf?, init t/any?, xs (t/isa? clojure.lang.IReduceInit)] (.reduce xs rf init))) - ;; TODO refine +#?(:clj (^:inline [rf rf?, init t/any? + xs (t/or (t/isa? clojure.lang.APersistentMap$KeySeq) + (t/isa? clojure.lang.APersistentMap$ValSeq))] + (reduce-iter rf init xs))) +#?(:clj (^:inline [rf rf?, init t/any?, xs (t/isa? clojure.lang.IKVReduce)] + (.kvreduce xs rf init))) +#?(:clj (^:inline [rf rf?, init t/any?, xs (t/isa? clojure.lang.IReduceInit)] + (.reduce xs rf init))) #?(:clj ([rf rf?, init t/any?, xs (t/or dc/lseq? dc/aseq?)] (let [c (class xs)] (loop [xs' (>seq xs), ret init] @@ -291,19 +295,22 @@ ;; - `(not (dcomp/== (class xs') (class xs)))` ;; - What the possible types of xs' are as a result (reduce rf init xs')))))) -#?(:clj ([rf rf?, init t/any?, xs (t/isa? java.lang.Iterable)] (reduce-iter rf init xs))) +#?(:clj (^:inline [rf rf?, init t/any?, xs (t/isa? java.lang.Iterable)] (reduce-iter rf init xs))) ;; TODO CLJS might be able to be done more efficiently with more specializations? - ([rf rf?, init t/any?, xs #?(:clj (t/isa? clojure.core.protocols/IKVReduce) - :cljs (t/isa|direct? cljs.core/IKVReduce))] + (^:inline [rf rf?, init t/any? + xs #?(:clj (t/isa? clojure.core.protocols/IKVReduce) + :cljs (t/isa|direct? cljs.core/IKVReduce))] (#?(:clj clojure.core.protocols/kv-reduce :cljs cljs.core/-kv-reduce) xs rf init)) ;; TODO CLJS might be able to be done more efficiently with more specializations? - ([rf rf?, init t/any?, xs #?(:clj (t/isa? clojure.core.protocols/CollReduce) - :cljs (t/isa|direct? cljs.core/IReduce))] + (^:inline [rf rf?, init t/any? + xs #?(:clj (t/isa? clojure.core.protocols/CollReduce) + :cljs (t/isa|direct? cljs.core/IReduce))] (#?(:clj clojure.core.protocols/coll-reduce :cljs cljs.core/-reduce) xs rf init)) -#?(:cljs ([rf rf?, init t/any?, xs (t/isa|direct? cljs.core/IIterable)] (reduce-iter rf init xs))) -#?(:cljs ([rf rf?, init t/any?, xs (t/isa|direct? cljs.core/ISeqable)] +#?(:cljs (^:inline [rf rf?, init t/any?, xs (t/isa|direct? cljs.core/IIterable)] + (reduce-iter rf init xs))) +#?(:cljs (^:inline [rf rf?, init t/any?, xs (t/isa|direct? cljs.core/ISeqable)] (reduce-seq rf init (>seq xs))))) (var/def rfi? "Reducing function, indexed" @@ -325,76 +332,74 @@ (rf ret k v (ref/reset! !i (num/inc* (ref/deref !i))))))))] (reduce rf' init xs))) -(var/def xf? "Transforming function" +(var/def xf? "Transforming function (for transducers)" (t/ftype [rf? :> rf?])) -(t/defn ^:inline transduce > - ([ rf rf?, xs (t/input-type reduce :_ :_ :?)] - (transduce fn/identity rf xs)) - ([xf xf?, rf rf?, xs (t/input-type reduce :_ :_ :?)] - (transduce xf rf (rf) xs)) - ([xf xf?, rf rf?, init t/any?, x dasync/read-chan?] - (let [rf' (xf rf)] - (async/go - (rf' (async/ dnum/integer? +(t/defn ^:inline count > dnum/std-integer? {:todo #{"handle persistent maps"} :incorporated #{'clojure.lang.RT/count 'clojure.lang.RT/countFrom + 'clojure.core/count 'cljs.core/count}} - ;; Concrete classes - ([x p/nil? > #?(:clj p/long? :cljs dnum/nip?)] 0) - ([x ?/transformer? > ????] (reduce-count x)) -#?(:cljs ([x dstr/str? > (t/assume dnum/nip?)] (.-length x))) -#?(:cljs ([x dstr/!str? > (t/assume dnum/nip?)] (.getLength x))) - ([x tup/tuple? > p/int?] (-> x .-vs count)) - ([x arr/std-array? > #?(:clj p/int? :cljs (t/assume dnum/nip?))] - (#?(:clj Array/count :cljs .-length) x)) - ;; TODO `cljs.core/count` is not right here - ([x vec/+vector?] (#?(:clj .count :cljs core/count) x)) - ([x dasync/m2m-chan?] (-> x #?(:clj .buf :cljs .-buf) count)) - ;; Abstract classes - ([x dc/icounted? > #?(:clj p/int? :cljs (t/* dnum/nip?))] - #?(:clj (.count x) - :cljs (-count ^not-native x))) -#?(:cljs ([x dc/iseqable? > p/int?] - ;; TODO TYPED - (loop [s (>seq coll) acc 0] - (if (counted? s) ; assumes nil is counted, which it currently is - (+ acc (-count s)) - (recur (next s) (inc acc)))))) -#?(:clj ([x dc/ipersistentcollection? > p/int?] - ;; TODO TYPED - ISeq s = seq(o); - o = null; - int i = 0; - for(/ s != null / s = s.next()) { - if(s instanceof Counted) - return i + s.count(); - i++; - } - return i; - - )) -#?(:clj ([x dstr/char-seq? > p/int?] (.length x))) -#?(:clj ([x dc/java-coll? > p/int?] (.size x))) -#?(:clj ([x map/java-map? > p/int?] (.size x))) -#?(:clj ([x tup/map-entry? > p/long?] 2)) -#?(:clj ([x arr/array? > p/int?] (java.lang.reflect.Array/getLength x)))) + ;; Counted + ([x p/nil? > #?(:clj p/long? :cljs dnum/nip?)] 0) +#?(:cljs ([xs dstr/str? > (t/assume dnum/nip?)] (.-length xs))) +#?(:cljs ([xs dstr/!str? > (t/assume dnum/nip?)] (.getLength xs))) + ([xs dc/icounted? > #?(:clj p/int? :cljs (t/* dnum/nip?))] + (#?(:clj .count :cljs cljs.core/-count) xs)) +#?(:clj ([xs dstr/char-seq? > p/int?] (.length xs))) + ([xs tup/tuple? > #?(:clj p/int? :cljs (t/assume dnum/nip?))] + (-> xs .-vs count)) + ([xs dasync/m2m-chan? > #?(:clj p/int? :cljs dnum/nip?)] + (-> xs #?(:clj .buf :cljs .-buf) count)) +#?(:clj ([xs tup/map-entry? > p/long?] 2)) + ([xs arr/std-array? > #?(:clj p/int? :cljs (t/assume dnum/nip?))] + (#?(:clj Array/count :cljs .-length) xs)) +#?(:clj ([xs arr/array? > p/int?] (java.lang.reflect.Array/getLength xs))) + ;; Possibly counted + ;; TODO figure out whether there are certain non-counted `java-coll?`s in here that would + ;; have increased performance from an eduction rather than a `.size` +#?(:clj ([xs dc/java-coll? > p/int?] (.size xs))) +#?(:clj ([xs dc/java-map? > p/int?] (.size xs))) + ;; Not counted + ([xs (t/input-type educe :_ :_ :?)] (educe count|rf xs))) + +(t/defn ^:inline gen-bounded-count|rf [n dnum/std-integer?] + (t/fn {:inline true} + ([] 0) + ([ct ?] ct) + ([ct ?, _ ?] (if (dcomp/< ct n) (num/inc ct) (?/reduced ct))))) + +(t/defn ^:inline bounded-count > dnum/std-integer? + ([n dnum/std-integer?, xs dc/counted?] (count xs)) + ([n dnum/std-integer?, xs (t/input-type educe :_ :_ :?)] (educe (gen-bounded-count|rf n) xs))) + +(t/def empty?|rf + (fn/aritoid + (t/fn [] true) + fn/identity + (t/fn [ret _, x _] (dc/reduced false)) + (t/fn [ret _, k _, v _] (dc/reduced false)))) (t/defn empty? > p/boolean? - {:todo #{"import clojure.lang.RT/seq"}} - ;; TODO re-evaluate this arity - #_([x ?] (-> x count num/zero?)) - ([x p/nil?] true) - ([x ?/transformer?] (->> x (reduce (fn' (reduced false)) true))) -#?(:clj ([x dc/java-coll?] (.isEmpty x))) -#?(:clj ([x map/java-map?] (.isEmpty x))) - ;; TODO TYPED - ([^default x] (core/empty? x))) + ([x p/nil?] true) + ([xs dc/counted?] (-> xs count num/zero?)) + ([xs (t/input-type educe :_ :_ :?)] (educe empty?|rf x))) diff --git a/src/quantum/core/data/collections.cljc b/src/quantum/core/data/collections.cljc index a6280cae..61697677 100644 --- a/src/quantum/core/data/collections.cljc +++ b/src/quantum/core/data/collections.cljc @@ -91,28 +91,47 @@ (def editable? (t/isa? #?(:clj clojure.lang.IEditableCollection :cljs cljs.core/IEditableCollection))) +(def iindexed? (t/isa|direct? #?(:clj clojure.lang.Indexed :cljs cljs.core/IIndexed))) + ;; Indicates efficient lookup by (integer) index (via `get`) (def indexed? - (t/or (t/isa? #?(:clj clojure.lang.Indexed :cljs cljs.core/IIndexed)) + (t/or iindexed? ;; Doesn't guarantee `java.util.List` is implemented, except by convention #?(:clj (t/isa? java.util.RandomAccess)) #?(:clj dstr/char-seq? :cljs dstr/string?) arr/array?)) +(def +associative? (t/isa? #?(:clj clojure.lang.Associative + :cljs cljs.core/IAssociative))) + +(def !+associative? (t/isa? #?(:clj clojure.lang.ITransientAssociative + :cljs cljs.core/ITransientAssociative))) + ;; Indicates whether `assoc?!` is supported (def associative? - (t/or (t/isa? #?(:clj clojure.lang.Associative :cljs cljs.core/IAssociative)) - (t/isa? #?(:clj clojure.lang.ITransientAssociative :cljs cljs.core/ITransientAssociative)) - (t/or map/map? indexed?))) + (t/or +associative? !+associative? (t/or map/map? indexed?))) (def sequential? (t/or (t/isa? #?(:clj clojure.lang.Sequential :cljs cljs.core/ISequential)) list? indexed?)) -;; If something is `counted?`, it implements a constant-time `count` +(def icounted? (t/isa|direct? #?(:clj clojure.lang.Counted :cljs cljs.core/ICounted))) + +;; If something is `counted?`, it is supposed to implement a constant-time `count` (def counted? - (t/or (t/isa? #?(:clj clojure.lang.Counted :cljs cljs.core/ICounted)) - #?(:clj dstr/char-seq? :cljs dstr/string?) vec/vector? map/map? set/set? arr/array?)) + (t/or icounted? + ;; It's not guaranteed that `char-seq?`s have constant-time `.length`/`count` but it's very + ;; reasonable to assume. + #?(:clj dstr/char-seq? :cljs dstr/string?) + ;; All enumerated vector types are all known to implement constant-time `count`. + vec/vector? + ;; It's not guaranteed that all `java.util.Map`s have constant-time `.size`/`count` but it's + ;; about as reasonable to assume so as with `char-seq?`s. + map/map? + ;; It's not guaranteed that all `java.util.Set`s have constant-time `.size`/`count` but it's + ;; about as reasonable to assume so as with `java.util.Map`s. + set/set? + arr/array?)) (def iterable? (t/isa? #?(:clj java.lang.Iterable :cljs cljs.core/IIterable))) From e8f4da838e048ed9999705f2d0e0f4c1c6ef277f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 26 Sep 2018 21:24:58 -0600 Subject: [PATCH 306/810] Enhanced some predicates --- src/quantum/core/collections_typed.cljc | 38 ++++++++++++------------- src/quantum/core/data/collections.cljc | 11 +++++-- 2 files changed, 27 insertions(+), 22 deletions(-) diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index 95700c11..09f55218 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -184,7 +184,7 @@ (t/defn reduce-iter "Made public in case future specializations want to use it." - [rf rf?, init t/any?, xs (t/isa|direct? #?(:clj java.lang.Iterable :cljs cljs.core/IIterable))] + [rf rf?, init t/any?, xs dc/iterable?] (let [iter (>iterator xs)] (loop [ret init] (if #?(:clj (.hasNext iter) :cljs ^boolean (.hasNext iter)) @@ -198,7 +198,7 @@ "Reduces a seq, ignoring any opportunities to switch to a more specialized implementation. Made public in case future specializations want to use it." - [rf rf?, init t/any?, xs iseq?] + [rf rf?, init t/any?, xs dc/iseq?] (loop [xs' xs, ret init] (if (nil? xs') ret @@ -324,12 +324,13 @@ Uses an unsynchronized mutable counter internally, but this cannot cause race conditions if `reduce` is implemented correctly (this includes single-threadedness)." [rf rfi?, init t/any?, xs dc/reducible?] - (let [rf' (let [!i (ref/! -1)] - (fn/aritoid rf' rf' - (t/fn ([ret ?, x ?] - (rf ret x (ref/reset! !i (num/inc* (ref/deref !i)))))) - (t/fn ([ret ?, k ?, v ?] - (rf ret k v (ref/reset! !i (num/inc* (ref/deref !i))))))))] + (let [^:inline rf' + (let [!i (ref/! -1)] + (fn/aritoid rf' rf' + (t/fn ([ret ?, x ?] + (rf ret x (ref/reset! !i (num/inc* (ref/deref !i)))))) + (t/fn ([ret ?, k ?, v ?] + (rf ret k v (ref/reset! !i (num/inc* (ref/deref !i))))))))] (reduce rf' init xs))) (var/def xf? "Transforming function (for transducers)" @@ -346,19 +347,18 @@ ;; ===== Count / length / size ===== ;; -(def count|rf - (t/fn {:inline true} - ([] 0) - ([ct ?] ct) - ([ct ?, _ ?] (num/inc ct)))) +(def ^:inline count|rf + (t/fn ([] 0) + ([ct ?] ct) + ([ct ?, _ ?] (num/inc ct)))) ;; TODO make sure !+vector is handled for CLJS (t/defn ^:inline count > dnum/std-integer? {:todo #{"handle persistent maps"} - :incorporated #{'clojure.lang.RT/count - 'clojure.lang.RT/countFrom - 'clojure.core/count - 'cljs.core/count}} + :incorporated {clojure.lang.RT/count "9/2018" + clojure.lang.RT/countFrom "9/2018" + clojure.core/count "9/2018" + cljs.core/count "9/26/2018"}} ;; Counted ([x p/nil? > #?(:clj p/long? :cljs dnum/nip?)] 0) #?(:cljs ([xs dstr/str? > (t/assume dnum/nip?)] (.-length xs))) @@ -392,14 +392,14 @@ ([n dnum/std-integer?, xs dc/counted?] (count xs)) ([n dnum/std-integer?, xs (t/input-type educe :_ :_ :?)] (educe (gen-bounded-count|rf n) xs))) -(t/def empty?|rf +(t/def ^:inline empty?|rf (fn/aritoid (t/fn [] true) fn/identity (t/fn [ret _, x _] (dc/reduced false)) (t/fn [ret _, k _, v _] (dc/reduced false)))) -(t/defn empty? > p/boolean? +(t/defn ^:inline empty? > p/boolean? ([x p/nil?] true) ([xs dc/counted?] (-> xs count num/zero?)) ([xs (t/input-type educe :_ :_ :?)] (educe empty?|rf x))) diff --git a/src/quantum/core/data/collections.cljc b/src/quantum/core/data/collections.cljc index 61697677..bb2e8733 100644 --- a/src/quantum/core/data/collections.cljc +++ b/src/quantum/core/data/collections.cljc @@ -6,7 +6,7 @@ [quantum.core.data.map :as map] [quantum.core.data.set :as set] [quantum.core.data.string :as dstr] - [quantum.core.data.tuple :as tuple] + [quantum.core.data.tuple :as tup] [quantum.core.data.vector :as vec] [quantum.core.type :as t])) @@ -118,11 +118,16 @@ (def icounted? (t/isa|direct? #?(:clj clojure.lang.Counted :cljs cljs.core/ICounted))) ;; If something is `counted?`, it is supposed to implement a constant-time `count` +;; `nil` is counted but this type ignores that (def counted? (t/or icounted? ;; It's not guaranteed that `char-seq?`s have constant-time `.length`/`count` but it's very ;; reasonable to assume. - #?(:clj dstr/char-seq? :cljs dstr/string?) + #?(:clj dstr/char-seq? :cljs (t/or dstr/string? dstr/!string?)) + tup/tuple? + ;; This kind of chan has a buffer which is countable + dasync/m2m-chan? + #?(:clj tup/map-entry?) ;; All enumerated vector types are all known to implement constant-time `count`. vec/vector? ;; It's not guaranteed that all `java.util.Map`s have constant-time `.size`/`count` but it's @@ -133,7 +138,7 @@ set/set? arr/array?)) -(def iterable? (t/isa? #?(:clj java.lang.Iterable :cljs cljs.core/IIterable))) +(def iterable? (t/isa|direct? #?(:clj java.lang.Iterable :cljs cljs.core/IIterable))) #?(:clj (def java-coll? (t/isa? java.util.Collection))) From f9db01551ca881e7263fecdff13fe79f954f1057 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 26 Sep 2018 21:43:49 -0600 Subject: [PATCH 307/810] Begin on `aritoid` --- resources-dev/defnt.cljc | 8 +++++- src/quantum/core/fn.cljc | 58 ++++++++++++++++++++++++++++------------ 2 files changed, 48 insertions(+), 18 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index e0ff82e3..b68f2959 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -262,7 +262,13 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - :todo #{} - :attribution - :doc - - :incorporated #{} + - :incorporated (t/or (t/set-of (t/or )) + (t/map-of (t/or ) + date)) + - :equivalent `{(aritoid vector identity conj) + (fn ([] (vector)) + ([x0] (identity x0)) + ([x0 x1] (conj x0 x1)))}} - Instead of e.g. `ns-` or `var-` we can do `ns-val` and `var-val` - Should we type `when`, `let`? diff --git a/src/quantum/core/fn.cljc b/src/quantum/core/fn.cljc index 7ab437da..96f40123 100644 --- a/src/quantum/core/fn.cljc +++ b/src/quantum/core/fn.cljc @@ -1,11 +1,9 @@ -(ns - ^{:doc "Useful function-related functions (one could say 'metafunctions'). +(ns quantum.core.fn + "Function-related functions ('metafunctions'). - Higher-order functions, currying, monoids, reverse comp, arrow macros, inner partials, juxts, etc." - :attribution "alexandergunnarson"} - quantum.core.fn + Higher-order functions, currying, monoids, reversed comp, arrow macros, inner partials, juxts, etc." (:refer-clojure :exclude - [comp constantly, as->, trampoline]) + [comp constantly, as->, identity, trampoline]) (:require [clojure.core :as core] [clojure.walk] @@ -24,6 +22,8 @@ :refer [aritoid gen-constantly gen-call gen-positional-nthas gen-ntha gen-conja gen-reversea gen-mapa]]))) +(t/defn ^:inline identity [x t/any? > (t/type x)] x) + ;; ===== `fn`: Positional functions ===== ;; #?(:clj (defaliases u fn0 fn1 fnl)) @@ -224,7 +224,40 @@ ([arg1 arg2 arg3] (func (func arg1 arg2) arg3)) ([arg1 arg2 arg3 & args] (apply func (func (func arg1 arg2) arg3) args)))) -#?(:clj (defalias u/aritoid)) +;; TODO finish and generalize based off `u/aritoid` +(t/defn ^:inline aritoid + ;; TODO use `arity-builder` + "Combines fns as arity-callers." + {:equivalent `{(aritoid vector identity conj) + (fn ([] (vector)) + ([x0] (identity x0)) + ([x0 x1] (conj x0 x1)))}} + ([f0 (t/ftype [])] f0) + ([f0 (t/ftype []) + f1 (t/ftype [t/any?])] + (t/fn {:inline true} + ([] (f0)) + ([x0 (t/type-of f1 0)] (f1 x0)))) + ([f0 (t/ftype []) + f1 (t/ftype [t/any?]) + f2 (t/ftype [t/any? t/any?])] + (t/fn {:inline true} + ([] (f0)) + ([x0 (t/type-of f1 0)] (f1 x0)) + ([x0 (t/type-of f1 0) + x1 (t/type-of f1 1)] (f2 x0 x1)))) + ([f0 (t/ftype []) + f1 (t/ftype [t/any?]) + f2 (t/ftype [t/any? t/any?]) + f3 (t/ftype [t/any? t/any? t/any?])] + (t/fn {:inline true} + ([] (f0)) + ([x0 (t/type-of f1 0)] (f1 x0)) + ([x0 (t/type-of f1 0) + x1 (t/type-of f1 1)] (f2 x0 x1)) + ([x0 (t/type-of f2 0) + x1 (t/type-of f2 1) + x2 (t/type-of f2 2)] (f3 x0 x1 x2))))) (defn rf-fix "TODO remove when you figure out transduce vs. reduce" @@ -254,17 +287,8 @@ (defn call->> [& [func & args]] ((apply func (butlast args)) (last args))) ; --------------------------------------- -; ================ JUXTS ================ (possibly deprecate these?) +; ================ JUXTS ================ (deprecate these) ; --------------------------------------- - -; (defn juxtm* -; [map-type args] -; (if (-> args count even?) -; (fn [arg] (->> arg ((apply juxt args)) (apply map-type))) -; (throw (#+clj IllegalArgumentException. -; #+cljs js/Error. -; "juxtm requires an even number of arguments")))) - (defn juxtm* [map-type args] (if (-> args count even?) From 41209b5ae8be1fe29239bbd959a468ecdb1d2592 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 26 Sep 2018 22:30:50 -0600 Subject: [PATCH 308/810] Clear up `reducible?`, `seqable?`, `traversable?` --- resources-dev/defnt.cljc | 12 ++--- src/quantum/core/collections_typed.cljc | 57 ++++++++++++------------ src/quantum/core/data/collections.cljc | 58 ++++++++++--------------- 3 files changed, 60 insertions(+), 67 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index b68f2959..0ebde3eb 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -74,12 +74,12 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - t/input-type - `(t/input-type >namespace :?)` meaing the possible input types to the first input to `>namespace` - `(t/input-type reduce :_ :_ :?)` - - t/of - - (t/of number?) ; implicitly the container is a `traversable?` - - (t/of map/+map? symbol? dstr/string?) - - (t/of t/seq? namespace?) - - t/map-of - - t/seq-of + - dc/of + - (dc/of number?) ; implicitly the container is a `traversable?` + - (dc/of map/+map? symbol? dstr/string?) + - (dc/of t/seq? namespace?) + - dc/map-of + - dc/seq-of - t/defrecord - t/def-concrete-type (i.e. `t/deftype`) - expressions (`quantum.untyped.core.analyze.expr`) diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index 09f55218..a49cd1db 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -123,21 +123,21 @@ ;; ----- Sequences ----- ;; +;; TODO use `core/sequence` implementation to produce whatever is `reducible?` but not currently +;; `seqable?` (t/defn ^:inline >seq {:incorporated '{clojure.lang.RT/seq "9/26/2018" clojure.core/seq "9/26/2018" cljs.core/seq "9/26/2018"}} > (t/? dc/iseq?) - ([x p/nil?] nil) -#?(:clj ([xs dc/aseq?] x)) - ([xs #?(:clj (t/isa? clojure.lang.Seqable) - :cljs (t/isa|direct? cljs.core/ISeqable))] - (#?(:clj .seq :cljs cljs.core/-seq) x)) -#?(:clj ([xs (t/isa? java.lang.Iterable)] (-> x >iterator clojure.lang.RT/chunkIteratorSeq))) + ([x p/nil?] nil) + ([xs dc/iseq?] x) + ([xs dc/iseqable?] (#?(:clj .seq :cljs cljs.core/-seq) x)) +#?(:clj ([xs dc/iterable?] (-> x >iterator clojure.lang.RT/chunkIteratorSeq))) #?(:clj ([xs dstr/char-seq?] (clojure.lang.StringSeq/create x)) - :cljs ([xs dstr/string?] (when-not (num/zero? (count xs)) ; TODO use `empty?` instead - (cljs.core/IndexedSeq. xs 0 nil)))) -#?(:clj ([xs dc/java-map?] (-> x .entrySet >seq))) + :cljs ([xs dstr/string?] (when-not (num/zero? (count xs)) ; TODO use `empty?` instead + (cljs.core/IndexedSeq. xs 0 nil)))) +#?(:clj ([xs dc/java-map?] (-> x .entrySet >seq))) ;; NOTE `ArraySeq/createFromObject` is the slow path but has to be that way because the ;; specialized ArraySeq constructors are private ([xs arr/array?] @@ -145,6 +145,7 @@ :cljs (when-not (num/zero? (count xs)) ; TODO use `empty?` instead (cljs.core/IndexedSeq. xs 0 nil))))) +;; TODO move to better place? (t/defn- ^:inline string-seq>underlying-string [xs (t/isa? clojure.lang.StringSeq) > (t/assume dstr/str?)] (.s xs)) @@ -283,7 +284,21 @@ (.kvreduce xs rf init))) #?(:clj (^:inline [rf rf?, init t/any?, xs (t/isa? clojure.lang.IReduceInit)] (.reduce xs rf init))) -#?(:clj ([rf rf?, init t/any?, xs (t/or dc/lseq? dc/aseq?)] + ;; NOTE We don't accept `xs` that implement `clojure.core.protocols/IKVReduce` only after + ;; the fact because `IKVReduce` could inappropriately specialize on e.g. `Object` + (^:inline [rf rf?, init t/any? + xs (t/isa|direct? #?(:clj clojure.core.protocols/IKVReduce + :cljs cljs.core/IKVReduce))] + (#?(:clj clojure.core.protocols/kv-reduce + :cljs cljs.core/-kv-reduce) xs rf init)) + ;; NOTE We don't accept `xs` that implement `clojure.core.protocols/CollReduce` only after + ;; the fact because `CollReduce` inappropriately specializes on `Object` + (^:inline [rf rf?, init t/any? + xs (t/isa|direct? #?(:clj clojure.core.protocols/CollReduce + :cljs cljs.core/IReduce))] + (#?(:clj clojure.core.protocols/coll-reduce + :cljs cljs.core/-reduce) xs rf init)) +#?(:clj ([rf rf?, init t/any?, xs dc/iseq?] (let [c (class xs)] (loop [xs' (>seq xs), ret init] (if (dcomp/== (class xs') c) @@ -295,23 +310,11 @@ ;; - `(not (dcomp/== (class xs') (class xs)))` ;; - What the possible types of xs' are as a result (reduce rf init xs')))))) -#?(:clj (^:inline [rf rf?, init t/any?, xs (t/isa? java.lang.Iterable)] (reduce-iter rf init xs))) - ;; TODO CLJS might be able to be done more efficiently with more specializations? - (^:inline [rf rf?, init t/any? - xs #?(:clj (t/isa? clojure.core.protocols/IKVReduce) - :cljs (t/isa|direct? cljs.core/IKVReduce))] - (#?(:clj clojure.core.protocols/kv-reduce - :cljs cljs.core/-kv-reduce) xs rf init)) - ;; TODO CLJS might be able to be done more efficiently with more specializations? - (^:inline [rf rf?, init t/any? - xs #?(:clj (t/isa? clojure.core.protocols/CollReduce) - :cljs (t/isa|direct? cljs.core/IReduce))] - (#?(:clj clojure.core.protocols/coll-reduce - :cljs cljs.core/-reduce) xs rf init)) -#?(:cljs (^:inline [rf rf?, init t/any?, xs (t/isa|direct? cljs.core/IIterable)] - (reduce-iter rf init xs))) -#?(:cljs (^:inline [rf rf?, init t/any?, xs (t/isa|direct? cljs.core/ISeqable)] - (reduce-seq rf init (>seq xs))))) + ;; NOTE There's something about CLJS impl such that `cljs.core/reduce` suggests that the + ;; class will never change in the middle of the seq as it might in CLJ +#?(:cljs (^:inline [rf rf?, init t/any?, xs dc/iseq?] (reduce-seq rf init xs))) + (^:inline [rf rf?, init t/any?, xs dc/iseqable?] (reduce rf init (>seq xs))) + (^:inline [rf rf?, init t/any?, xs dc/iterable?] (reduce-iter rf init xs))) (var/def rfi? "Reducing function, indexed" (t/ftype "seed arity" [] diff --git a/src/quantum/core/data/collections.cljc b/src/quantum/core/data/collections.cljc index bb2e8733..68389cad 100644 --- a/src/quantum/core/data/collections.cljc +++ b/src/quantum/core/data/collections.cljc @@ -10,9 +10,12 @@ [quantum.core.data.vector :as vec] [quantum.core.type :as t])) +;; TODO move to `quantum.core.data.sequence` ;; ===== Sequences and sequence-wrappers ===== ;; ;; Sequential (generally not efficient Lookup / RandomAccess) +(def iseqable? (t/isa|direct? #?(:clj clojure.lang.Seqable :cljs cljs.core/ISeqable))) + (def iseq? (t/isa? #?(:clj clojure.lang.ISeq :cljs cljs.core/ISeq))) #?(:clj (def aseq? (t/isa? clojure.lang.ASeq))) @@ -150,37 +153,24 @@ :cljs (t/isa? cljs.core/ICollection)) sequential? associative?)) -;; Whatever is `seqable?` is reducible via a call to `seq`. -;; Reduction is nearly always preferable to seq-iteration if for no other reason than that -;; it can take advantage of transducers and reducers. This predicate just answers whether -;; it is more efficient to reduce than to seq-iterate (note that it should be at least as -;; efficient as seq-iteration). -;; TODO re-enable when dispatch enabled -#_(def prefer-reduce? - (t/or (t/isa? #?(:clj clojure.lang.IReduceInit :cljs cljs.core/IReduce)) - (t/isa? #?(:clj clojure.lang.IKVReduce :cljs cljs.core/IKVReduce)) - #?(:clj (t/isa? clojure.core.protocols/IKVReduce)) - #?(:clj dstr/char-seq? :cljs dstr/string?) - arr/array? - record? - (t/isa? #?(:clj fast_zip.core.ZipperLocation :cljs fast-zip.core/ZipperLocation)) - chan?)) - -;; Whatever is `reducible?` is seqable via a call to `sequence`. -(def seqable? - (t/or #?@(:clj [(t/isa? clojure.lang.Seqable) iterable? dstr/char-seq? map/map? arr/array?] - :cljs [(t/isa? cljs.core/ISeqable) arr/array? dstr/string?]))) - -;; Able to be traversed over in some fashion, whether by `first`/`next` seq-iteration, -;; reduction, etc. -;; TODO re-enable when dispatch enabled -#_(def traversable? - (t/or (t/isa? #?(:clj clojure.lang.IReduceInit :cljs cljs.core/IReduce)) - (t/isa? #?(:clj clojure.lang.IKVReduce :cljs cljs.core/IKVReduce)) - #?(:clj (t/isa? clojure.core.protocols/IKVReduce)) - (t/isa? #?(:clj clojure.lang.Seqable :cljs cljs.core/ISeqable)) - iterable? - #?(:clj dstr/char-seq? :cljs dstr/string?) - arr/array? - (t/isa? #?(:clj fast_zip.core.ZipperLocation :cljs fast-zip.core/ZipperLocation)) - chan?)) +(def reducible? + (t/or p/nil? dstr/str? vec/!+vector? arr/array? dnum/numerically-integer? + ;; TODO what about `transformer?` + dasync/read-chan? + (t/isa? fast_zip.core.ZipperLocation) + #?(:clj (t/isa? clojure.lang.IKVReduce)) + #?(:clj (t/isa? clojure.lang.IReduceInit)) + ;; We're ignoring indirect implementation for reasons noted in the `reduce` impl + (t/isa|direct? #?(:clj clojure.core.protocols/IKVReduce + :cljs cljs.core/IKVReduce)) + ;; We're ignoring indirect implementation for reasons noted in the `reduce` impl + (t/isa|direct? #?(:clj clojure.core.protocols/CollReduce + :cljs cljs.core/IReduce)) + iseq? + iseqable? + iterable?)) + +;; Whatever is `seqable?` is reducible, and whatever is `reducible?` is `seqable?`. +;; Since reduction is preferred to "manual" `first`/`next` seq traversal, we prefer `reducible?` to +;; `seqable?` as the base type. +(def seqable? reducible?) From 8f1de4591d1eb9eae67cc99ab1d5a26859e2e2b9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 26 Sep 2018 22:32:26 -0600 Subject: [PATCH 309/810] Update note --- resources-dev/defnt.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 0ebde3eb..57899137 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -75,7 +75,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - `(t/input-type >namespace :?)` meaing the possible input types to the first input to `>namespace` - `(t/input-type reduce :_ :_ :?)` - dc/of - - (dc/of number?) ; implicitly the container is a `traversable?` + - (dc/of number?) ; implicitly the container is a `reducible?` - (dc/of map/+map? symbol? dstr/string?) - (dc/of t/seq? namespace?) - dc/map-of From 2433717aca90fa5acf302749abaee78cebe0fe60 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 26 Sep 2018 23:15:31 -0600 Subject: [PATCH 310/810] Clean some docs and code up --- resources-dev/defnt.cljc | 21 +- .../smaller-scratch.md | 194 ++++++++++++------ src-dev/quantum/core/defnt_equivalences.cljc | 116 ----------- src-untyped/quantum/untyped/core/type.cljc | 24 +-- src/quantum/core/collections/core.cljc | 59 ------ src/quantum/core/compare.cljc | 60 ++++++ src/quantum/core/error.cljc | 7 +- src/quantum/ui/style/css/untitled | 123 ----------- .../test/untyped/core/type/compare.cljc | 8 +- 9 files changed, 218 insertions(+), 394 deletions(-) rename src/quantum/ui/style/css/FJPool is a work-stealing pool => resources-dev/smaller-scratch.md (62%) delete mode 100644 src/quantum/ui/style/css/untitled diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 57899137..b033c7fb 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -17,13 +17,15 @@ TODO: - needs to equal `(t/and (t/or (t/not a) b) (t/or a c))` (which is correct) - `(- (or ?!+vector? !vector? #?(:clj !!vector?)) (isa? clojure.lang.Counted))` is not right -- conditionally optional arities etc. for t/fn +TODO: +- split up `quantum.core.untyped.type` predicates #_" Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - data.coll/reduced + - data.coll/reduced? - Analysis - (if (dcoll/reduced? ret) ;; TODO TYPED `(ref/deref ret)` should realize it's dealing with a `reduced?` @@ -86,6 +88,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - comparison of `t/fn`s is probably possible? - t/def - t/fnt (t/fn; current t/fn might transition to t/fn-spec or whatever?) + - t/ftype + - conditionally optional arities etc. - t/declare - declare-fnt (a way to do protocols/interfaces) - extend-fnt! @@ -144,21 +148,26 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - Conversion functions belong in the namespace that their destination types belong in - TODO transition the quantum.core.* namespaces: ->>>>>> TODO need to add *all* quantum namespaces in here + - Legend: + [.] : in progress + [-] : done as far as possible but not truly complete + [x] : actually done - List of semi-approximately topologically ordered namespaces to make typed: - [ ] quantum.core.core -> TODO just need to delete this from all references - [ ] quantum.core.type.core + - [x] quantum.core.data.async - [ ] quantum.core.type.defs - [ ] quantum.core.refs -> quantum.core.data.refs - [ ] quantum.core.logic - (def nneg? (l/fn-not neg?)) - (def pos-int? (l/fn-and dnum/integer? pos?)) - - [ ] quantum.core.fn + - [.] quantum.core.fn - [ ] quantum.core.cache - [ ] quantum.core.type-old - - [ ] quantum.core.data.string - - [x] quantum.core.data.map - - [x] quantum.core.data.meta - - [x] quantum.core.ns ; TODO split up into data.ns? + - [.] quantum.core.data.string + - [.] quantum.core.data.map + - [.] quantum.core.data.meta + - [.] quantum.core.ns ; TODO split up into data.ns? - [ ] quantum.core.print - [ ] quantum.core.log - [ ] quantum.core.data.vector diff --git a/src/quantum/ui/style/css/FJPool is a work-stealing pool b/resources-dev/smaller-scratch.md similarity index 62% rename from src/quantum/ui/style/css/FJPool is a work-stealing pool rename to resources-dev/smaller-scratch.md index 8a5d6cd1..b48e7cac 100644 --- a/src/quantum/ui/style/css/FJPool is a work-stealing pool +++ b/resources-dev/smaller-scratch.md @@ -1,3 +1,129 @@ +https://github.com/clojure/clojure/blob/f572a60262852af68cdb561784a517143a5847cf/src/clj/clojure/core/specs.clj + + + + +(let [ignore? (fn-or fn? t/protocol? t/multimethod? t/unbound? var/namespace? dasync/thread?)] + (->> (all-ns) + (map+ ns-interns) + (join {}) + (map+ val) + (remove+ #{#'clojure.core/*1 + #'clojure.core/*2 + #'clojure.core/*3 + #'clojure.core/*data-readers* + #'clojure.core/default-data-readers + #'clojure.tools.reader/default-data-readers + #'clojure.core.async.impl.timers/timeouts-queue + #'clojure.tools.analyzer.jvm/default-passes + #'aleph.http/default-connection-pool + #'aleph.http/default-response-executor + #'clojure.core.async.impl.ioc-macros/passes + #'byte-streams/inverse-conversions + #'byte-streams/conversions}) + (remove+ (rcomp deref (fn-or ignore? (fn-and var? (fn-> deref ignore?))))) + (map+ (juxt identity (fn-> deref quantum.core.meta.bench/shallow-byte-size))) + (join {}) + (map+ val) + (reduce +) + (#(quantum.measure.convert/convert % :bytes :MB)) + double)) + +(def-map 1) + +; -> 18.21 MB... there must be lots of data not referenced by vars + +; TODO log these stats when every namespace is compiled +(->> (java.lang.management.ManagementFactory/getMemoryPoolMXBeans) + (mapv (juxt #(.getName %) #(.getType %) #(.getUsage %)))) + + {:code-cache 25.52099609375, + :metaspace 203.1375122070312, (some of this is definitely garbage collected) + :compressed-class-space 69.5936279296875} + + +TODO make sure to set a global onerror handler for PhantomJS (via a flag of course) + +TODO decrease memory footprint? (it's huge!) +TODO allow return types for `defnt` like `sequential?` +TODO also allow return types like :whatever/validator + +TODO longs vs. long-array + +; TODO fn (params-match? ->double 1) -> true; (params-match? ->double "asd") -> false +; TODO do fast-as-possible ops given math expr +; (* a (- b c) v) -> (scale (* a (- b c)) v) + +; TODO: + +(fnt [^indexed? x a] + (conj' x a)) ; and have it know what function needs to be looked up + +(:abcde my-validated-map) ; and know what its type will be + + + + +(defn dropr-digit + ([n] (quot n 10)) + ([digits n] + (if (<= digits 0) + n + (recur (dec digits) (dropr-digit n))))) + +(defn count-digits-integral + "Counts the digits of a number `n` not having a decimal portion." + ([n] (count-digits-integral (dropr-digit n) 1)) + ([n d] (if (zero? n) + d + (recur (dropr-digit n) (inc d))))) + +(defn ->integral [n] (- n (->decimal n))) + +(defn ->decimal [n] (rem n 1)) + +(defn pow-10 [n] (long (Math/pow 10 (int n)))) + +(defn decimal->integer-like-decimal + "E.g. 0.003812317M -> 1003812317N + `n` must be 0 ≤ n < 1 + Returns a `bigint`." + [n] + (if (zero? n) + 0 + (bigint (str "1" (subs (str (.stripTrailingZeros (bigdec n))) 2))))) + +(defn integer-like-decimal->decimal + "E.g. 1003812317N -> 0.003812317M + `n` must be an integer. + Returns a `bigdec`." + [n] + (bigdec (str "0." (subs (str n) 1)))) + +(->decimal 1/4) + + +(defn num-decimal-places [n] + (-> n ->decimal bigdec (.stripTrailingZeros) (.scale) (max 0))) + +(defn truncate-digits + "Truncates an integer `n` the specified number of `digits`, replacing + the truncated portion with 0s." + [digits n] + (if (<= digits 0) + n + (* (dropr-digit digits n) + (pow-10 digits)))) + +(defn exact [n] + (if (or (double? n) + (float? n) + (decimal? n)) + (rationalize n) + n)) + + + Take a look at Claypoole. Example code: (require '[com.climate.claypoole :as cp]) @@ -35,66 +161,6 @@ http://eng.climate.com/2014/02/25/claypoole-threadpool-tools-for-clojure/ (throw (ex-info "`view-rest` not supported on type" {:type (type xs)})))) -(defprotocol InternalReduce - "Protocol for concrete seq types that can reduce themselves - faster than first/next recursion. Called by clojure.core/reduce." - (internal-reduce [seq f start])) - -(defn- naive-seq-reduce - "Reduces a seq, ignoring any opportunities to switch to a more - specialized implementation." - [s f val] - (loop [s (seq s) - val val] - (if s - (let [ret (f val (first s))] - (if (reduced? ret) - @ret - (recur (next s) ret))) - val))) - -(defn- interface-or-naive-reduce - "Reduces via IReduceInit if possible, else naively." - [coll f val] - (if (instance? clojure.lang.IReduceInit coll) - (.reduce ^clojure.lang.IReduceInit coll f val) - (naive-seq-reduce coll f val))) - -(extend-protocol InternalReduce - ;; handles vectors and ranges - clojure.lang.IChunkedSeq - (internal-reduce - [s f val] - (if-let [s (seq s)] - (if (chunked-seq? s) - (let [ret (.reduce (chunk-first s) f val)] - (if (reduced? ret) - @ret - (recur (chunk-next s) - f - ret))) - (interface-or-naive-reduce s f val)) - val)) - - - java.lang.Object - (internal-reduce - [s f val] - (loop [cls (class s) - s s - f f - val val] - (if-let [s (seq s)] - (if (identical? (class s) cls) - (let [ret (f val (first s))] - (if (reduced? ret) - @ret - (recur cls (next s) f ret))) - (interface-or-naive-reduce s f val)) - val)))) - - - (defn num-integral-digits [^double n] (-> n Math/abs Math/log10 inc int)) @@ -216,14 +282,6 @@ The core premise is that entities can be found to belong to one or more classes. TODO look at AtomicLong.accumulateAndGet(long x, LongBinaryOperator accumulatorFunction) TODO revisit whether transformers are necessary compared with transducers -The power offered by spec is probably better compared against dependent type systems like Idris. True static type systems run analysis at compile-time, but spec allows you to perform very complex checks because you have the power of full blown language. - -For example, with spec you can write a function spec that says "Union is a function that takes two hashsets. The return value of this function is a hashset that contains all the values found in the hashset arguments". That's impossible to statically check in most languages. Some languages like Idris approach this level of expressibility, but when they fall short, you're sunk. In spec you can always pop the escape hatch and write a custom predicate in Clojure code. - -So for me that's the tradeoff. I lose compile-time checking, but gain a *ton* of power. And since types exist at run-time we can do cool things like introspect them and generate data, documentation, better error messages, or even run logic over them to write a static type checker. - - - http://www.kdgregory.com/?page=java.byteBuffer — useful reading about off-heap memory https://www.akkadia.org/drepper/cpumemory.pdf — what every programmer should know about memory https://mechanical-sympathy.blogspot.com/2012/10/compact-off-heap-structurestuples-in.html — compact off-heap structures and tuples diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 4495570d..22201f8b 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -1648,122 +1648,6 @@ "completing arity" [t/any?] "reducing arity" [t/any? t/any?])) -(self/defn reduce - "Much of this content taken from clojure.core.protocols for inlining and - type-checking purposes." - {:attribution "alexandergunnarson"} - ([f rf? xs t/nil?] (f)) - ([f rf?, init _ xs t/nil?] init) - ([f rf?, init _, z (t/isa? fast_zip.core.ZipperLocation)] - (loop [xs (zip/down z) v init] - (if (some? z) - (let [ret (f v z)] - (if (reduced? ret) - @ret - (recur (zip/right xs) ret))) - v))) - ;; TODO look at CLJS `array-reduce` - ([f rf?, init _, xs (t/or t/array? t/str? t/!+vector?)] ; because transient vectors aren't reducible - (let [ct (count xs)] - (loop [i 0 v init] - (if (< i ct) - (let [ret (f v (get xs i))] - (if (reduced? ret) - @ret - (recur (inc* i) ret))) - v)))) -#?(:clj ([f rf?, init _, xs (t/isa? clojure.lang.StringSeq)] - (let [s (.s xs)] - (loop [i (.i xs) v init] - (if (< i (count s)) - (let [ret (f v (get s i))] - (if (reduced? ret) - @ret - (recur (inc* i) ret))) - v))))) -#?(:clj ([f rf? - xs (t/or (t/isa? clojure.lang.PersistentVector) ; vector's chunked seq is faster than its iter - (t/isa? clojure.lang.LazySeq) ; for range - (t/isa? clojure.lang.ASeq))] ; aseqs are iterable, masking internal-reducers - (if-let [s (seq xs)] - (clojure.core.protocols/internal-reduce (next s) f (first s)) - (f)))) -#?(:clj ([f rf?, init _ - xs (t/or (isa? clojure.lang.PersistentVector) ; vector's chunked seq is faster than its iter - (isa? clojure.lang.LazySeq) ; for range - (isa? clojure.lang.ASeq))] ; aseqs are iterable, masking internal-reducers - (let [s (seq xs)] - (clojure.core.protocols/internal-reduce s f init)))) - ([x transformer?, f rf?] - (let [rf ((.-xf x) f)] - (rf (reduce rf (rf) (.-prev x))))) - ([x transformer?, f rf?, init _] - (let [rf ((.-xf x) f)] - (rf (reduce rf init (.-prev x))))) - ([f rf?, init _, x t/chan?] (async/reduce f init x)) ; TODO spec `async/reduce` -#?(:cljs ([f rf?, init _, xs map/+map?] (#_(:clj clojure.core.protocols/kv-reduce - :cljs -kv-reduce) ; in order to use transducers... - -reduce-seq xs f init))) -#?(:cljs ([f rf?, init _, xs set/+set?] (-reduce-seq xs f init))) - ([f rf?, init _, n (t/numerically t/int?)] - (loop [i 0 v init] - (if (< i n) - (let [ret (f v i)] - (if (reduced? ret) - @ret - (recur (inc* i) ret))) ; TODO should only be unchecked if `n` is within unchecked range - v))) - ;; `iter-reduce` -#?(:clj ([f rf? - xs (t/or (t/isa? clojure.lang.APersistentMap$KeySeq) - (t/isa? clojure.lang.APersistentMap$ValSeq) - t/iterable?)] - (let [iter (.iterator xs)] - (if (.hasNext iter) - (loop [ret (.next iter)] - (if (.hasNext iter) - (let [ret (f ret (.next iter))] - (if (reduced? ret) - @ret - (recur ret))) - ret)) - (f))))) - ;; `iter-reduce` -#?(:clj ([f rf?, init _ - xs (t/or (t/isa? clojure.lang.APersistentMap$KeySeq) - (t/isa? clojure.lang.APersistentMap$ValSeq) - t/iterable?)] - (let [iter (.iterator xs)] - (loop [ret init] - (if (.hasNext iter) - (let [ret (f ret (.next iter))] - (if (reduced? ret) - @ret - (recur ret))) - ret))))) -#?(:clj ([f rf?, xs (t/isa? clojure.lang.IReduce) ] (.reduce xs f))) -#?(:clj ([f rf?, init _, xs (t/isa? clojure.lang.IKVReduce) ] (.kvreduce xs f init))) -#?(:clj ([f rf?, init _, xs (t/isa? clojure.lang.IReduceInit)] (.reduce xs f init))) - ([f rf?, xs (t/isa? clojure.core.protocols/CollReduce)] - (#?(:clj clojure.core.protocols/coll-reduce - :cljs -reduce) xs f)) - ([f rf?, init _, xs (t/isa? clojure.core.protocols/CollReduce)] - (#?(:clj clojure.core.protocols/coll-reduce - :cljs -reduce) xs f init))) - -;; ----- expanded code ----- ;; - -;; =====|=====|=====|=====|===== ;; - -(do (t/def xf? "Transforming function" - (t/fn [rf? :> rf?])) - - (self/defn transduce - ([ f rf?, xs t/reducible?] (transduce identity f xs)) - ([xf xf?, f rf?, xs t/reducible?] (transduce xf f (f) xs)) - ([xf xf?, f rf?, init _, xs t/reducible?] - (let [f' (xf f)] (f' (reduce f' init xs)))))) - ;; ----- expanded code ----- ;; diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index f73828d8..b79647d4 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -903,14 +903,13 @@ #?(:clj (-def thread? (isa? java.lang.Thread))) - ;; Able to be used with `throw` - (-def throwable? #?(:clj (isa? java.lang.Throwable) :cljs any?)) + ;; Used by `quantum.untyped.core.analyze` + (def throwable? "Able to be used with `throw`" + #?(:clj (isa? java.lang.Throwable) :cljs any?)) + ;; Used by `quantum.untyped.core.analyze` (-def regex? (isa? #?(:clj java.util.regex.Pattern :cljs js/RegExp))) - (-def chan? (isa? #?(:clj clojure.core.async.impl.protocols/Channel - :cljs cljs.core.async.impl.protocols/Channel))) - ;; Used by `quantum.untyped.core.analyze` (-def keyword? (isa? #?(:clj clojure.lang.Keyword :cljs cljs.core/Keyword))) @@ -920,8 +919,6 @@ ;; Used by `quantum.untyped.core.analyze` via `t/literal?` (-def symbol? (isa? #?(:clj clojure.lang.Symbol :cljs cljs.core/Symbol))) -#?(:clj (-def namespace? (isa? clojure.lang.Namespace))) - ;; `js/File` isn't always available! Use an abstraction #?(:clj (-def file? (isa? java.io.File))) @@ -931,17 +928,12 @@ (-def transformer? (isa? quantum.untyped.core.reducers.Transformer)) + ;; TODO move (-def delay? (isa? #?(:clj clojure.lang.Delay :cljs cljs.core/Delay))) -#?(:clj (-def tagged-literal? (isa? clojure.lang.TaggedLiteral))) +#?(:clj (-def tagged-literal? (isa? clojure.lang.TaggedLiteral))) ;; Used in `quantum.untyped.core.analyze` - (-def literal? (or nil? boolean? symbol? keyword? str? #?(:clj long?) double? #?(:clj tagged-literal?))) + (-def literal? + (or nil? boolean? symbol? keyword? str? #?(:clj long?) double? #?(:clj tagged-literal?))) #_(-def form? (or literal? +list? +vector? ...)) - -;; ===== Generic ===== ;; - - ;; TODO make into a type - #_(def nneg-int? #(c/and (integer? %) (c/>= % 0))) - ;; TODO make into a type - #_(def index? nneg-int?) diff --git a/src/quantum/core/collections/core.cljc b/src/quantum/core/collections/core.cljc index 361f7b6b..29b05cd8 100644 --- a/src/quantum/core/collections/core.cljc +++ b/src/quantum/core/collections/core.cljc @@ -147,65 +147,6 @@ q) (java.util.ArrayDeque. (int n))) f1 init))))) -;___________________________________________________________________________________________________________________________________ -;=================================================={ EQUIVALENCE }===================================================== -;=================================================={ =, identical? }===================================================== -; (defnt ^boolean identical? -; [^Object k1, ^Object k2] -; (clojure.lang.RT/identical k1 k2)) - -; static public boolean pcequiv(Object k1, Object k2){ -; if(k1 instanceof IPersistentCollection) -; return ((IPersistentCollection)k1).equiv(k2); -; return ((IPersistentCollection)k2).equiv(k1); -; } - -; static public boolean equals(Object k1, Object k2){ -; if(k1 == k2) -; return true; -; return k1 != null && k1.equals(k2); -; } - -; static public boolean equiv(Object k1, Object k2){ -; if(k1 == k2) -; return true; -; if(k1 != null) -; { -; if(k1 instanceof Number && k2 instanceof Number) -; return Numbers.equal((Number)k1, (Number)k2); -; else if(k1 instanceof IPersistentCollection || k2 instanceof IPersistentCollection) -; return pcequiv(k1,k2); -; return k1.equals(k2); -; } -; return false; -; } - -; equivNull : boolean equiv(Object k1, Object k2) return k2 == null -; equivEquals : boolean equiv(Object k1, Object k2) return k1.equals(k2) -; equivNumber : boolean equiv(Object k1, Object k2) -; if(k2 instanceof Number) -; return Numbers.equal((Number) k1, (Number) k2); -; return false - -; equivColl : boolean equiv(Object k1, Object k2) -; if(k1 instanceof IPersistentCollection || k2 instanceof IPersistentCollection) -; return pcequiv(k1, k2); -; return k1.equals(k2); - -; ; equivPred: -; ; nil : equivNull -; ; Number : equivNumber -; ; String, Symbol : equivEquals -; ; Collection, Map : equivColl -; ; :else : equivEquals - -; (defnt equiv ^boolean -; ([^Object a #{long double boolean} b] (clojure.lang.RT/equiv a b)) -; ([#{long double boolean} a ^Object b] (clojure.lang.RT/equiv a b)) -; ([#{long double boolean} a #{long double boolean} b] (clojure.lang.RT/equiv a b)) -; ([^char a ^char b] (clojure.lang.RT/equiv a b)) - -; ) ;___________________________________________________________________________________________________________________________________ ;=================================================={ RETRIEVAL }===================================================== diff --git a/src/quantum/core/compare.cljc b/src/quantum/core/compare.cljc index 2171629c..3efc631b 100644 --- a/src/quantum/core/compare.cljc +++ b/src/quantum/core/compare.cljc @@ -33,6 +33,66 @@ (:import clojure.lang.BigInt quantum.core.Numeric))) +;; TODO TYPED incorporate this commented code + +; (defnt ^boolean identical? +; [^Object k1, ^Object k2] +; (clojure.lang.RT/identical k1 k2)) + +; static public boolean pcequiv(Object k1, Object k2){ +; if(k1 instanceof IPersistentCollection) +; return ((IPersistentCollection)k1).equiv(k2); +; return ((IPersistentCollection)k2).equiv(k1); +; } + +; static public boolean equals(Object k1, Object k2){ +; if(k1 == k2) +; return true; +; return k1 != null && k1.equals(k2); +; } + +; static public boolean equiv(Object k1, Object k2){ +; if(k1 == k2) +; return true; +; if(k1 != null) +; { +; if(k1 instanceof Number && k2 instanceof Number) +; return Numbers.equal((Number)k1, (Number)k2); +; else if(k1 instanceof IPersistentCollection || k2 instanceof IPersistentCollection) +; return pcequiv(k1,k2); +; return k1.equals(k2); +; } +; return false; +; } + +; equivNull : boolean equiv(Object k1, Object k2) return k2 == null +; equivEquals : boolean equiv(Object k1, Object k2) return k1.equals(k2) +; equivNumber : boolean equiv(Object k1, Object k2) +; if(k2 instanceof Number) +; return Numbers.equal((Number) k1, (Number) k2); +; return false + +; equivColl : boolean equiv(Object k1, Object k2) +; if(k1 instanceof IPersistentCollection || k2 instanceof IPersistentCollection) +; return pcequiv(k1, k2); +; return k1.equals(k2); + +; ; equivPred: +; ; nil : equivNull +; ; Number : equivNumber +; ; String, Symbol : equivEquals +; ; Collection, Map : equivColl +; ; :else : equivEquals + +; (defnt equiv ^boolean +; ([^Object a #{long double boolean} b] (clojure.lang.RT/equiv a b)) +; ([#{long double boolean} a ^Object b] (clojure.lang.RT/equiv a b)) +; ([#{long double boolean} a #{long double boolean} b] (clojure.lang.RT/equiv a b)) +; ([^char a ^char b] (clojure.lang.RT/equiv a b)) + +; ) + + (defaliases ccomp compare min-key first-min-key second-min-key diff --git a/src/quantum/core/error.cljc b/src/quantum/core/error.cljc index 786bf416..dbbb8a94 100644 --- a/src/quantum/core/error.cljc +++ b/src/quantum/core/error.cljc @@ -9,11 +9,12 @@ [quantum.core.data.map :as map] [quantum.core.fn :refer [fnl fn1 rcomp fn']] + [quantum.core.type :as t] + [quantum.core.vars :as var + :refer [defalias defaliases]] [quantum.untyped.core.core :as ucore] [quantum.untyped.core.form.evaluate :refer [case-env case-env*]] - [quantum.untyped.core.vars - :refer [defalias defaliases]] [quantum.untyped.core.error :as u])) (ucore/log-this-ns) @@ -21,6 +22,8 @@ (def ^{:todo {0 "Finish up `conditions` fork" 1 "look at cljs.stacktrace / clojure.stacktrace"}} annotations) +(defalias t/throwable?) + ;; ===== Config ===== ;; (defalias u/*pr-data-to-str?) diff --git a/src/quantum/ui/style/css/untitled b/src/quantum/ui/style/css/untitled deleted file mode 100644 index 85fafe9a..00000000 --- a/src/quantum/ui/style/css/untitled +++ /dev/null @@ -1,123 +0,0 @@ -https://github.com/clojure/clojure/blob/f572a60262852af68cdb561784a517143a5847cf/src/clj/clojure/core/specs.clj - - - - -(let [ignore? (fn-or fn? t/protocol? t/multimethod? t/unbound? t/namespace? t/thread?)] - (->> (all-ns) - (map+ ns-interns) - (join {}) - (map+ val) - (remove+ #{#'clojure.core/*1 - #'clojure.core/*2 - #'clojure.core/*3 - #'clojure.core/*data-readers* - #'clojure.core/default-data-readers - #'clojure.tools.reader/default-data-readers - #'clojure.core.async.impl.timers/timeouts-queue - #'clojure.tools.analyzer.jvm/default-passes - #'aleph.http/default-connection-pool - #'aleph.http/default-response-executor - #'clojure.core.async.impl.ioc-macros/passes - #'byte-streams/inverse-conversions - #'byte-streams/conversions}) - (remove+ (rcomp deref (fn-or ignore? (fn-and var? (fn-> deref ignore?))))) - (map+ (juxt identity (fn-> deref quantum.core.meta.bench/shallow-byte-size))) - (join {}) - (map+ val) - (reduce +) - (#(quantum.measure.convert/convert % :bytes :MB)) - double)) - -(def-map 1) - -; -> 18.21 MB... there must be lots of data not referenced by vars - -; TODO log these stats when every namespace is compiled -(->> (java.lang.management.ManagementFactory/getMemoryPoolMXBeans) - (mapv (juxt #(.getName %) #(.getType %) #(.getUsage %)))) - - {:code-cache 25.52099609375, - :metaspace 203.1375122070312, (some of this is definitely garbage collected) - :compressed-class-space 69.5936279296875} - - -TODO make sure to set a global onerror handler for PhantomJS (via a flag of course) - -TODO decrease memory footprint? (it's huge!) -TODO allow return types for `defnt` like `sequential?` -TODO also allow return types like :whatever/validator - -TODO longs vs. long-array - -; TODO fn (params-match? ->double 1) -> true; (params-match? ->double "asd") -> false -; TODO do fast-as-possible ops given math expr -; (* a (- b c) v) -> (scale (* a (- b c)) v) - -; TODO: - -(fnt [^indexed? x a] - (conj' x a)) ; and have it know what function needs to be looked up - -(:abcde my-validated-map) ; and know what its type will be - - - - -(defn dropr-digit - ([n] (quot n 10)) - ([digits n] - (if (<= digits 0) - n - (recur (dec digits) (dropr-digit n))))) - -(defn count-digits-integral - "Counts the digits of a number `n` not having a decimal portion." - ([n] (count-digits-integral (dropr-digit n) 1)) - ([n d] (if (zero? n) - d - (recur (dropr-digit n) (inc d))))) - -(defn ->integral [n] (- n (->decimal n))) - -(defn ->decimal [n] (rem n 1)) - -(defn pow-10 [n] (long (Math/pow 10 (int n)))) - -(defn decimal->integer-like-decimal - "E.g. 0.003812317M -> 1003812317N - `n` must be 0 ≤ n < 1 - Returns a `bigint`." - [n] - (if (zero? n) - 0 - (bigint (str "1" (subs (str (.stripTrailingZeros (bigdec n))) 2))))) - -(defn integer-like-decimal->decimal - "E.g. 1003812317N -> 0.003812317M - `n` must be an integer. - Returns a `bigdec`." - [n] - (bigdec (str "0." (subs (str n) 1)))) - -(->decimal 1/4) - - -(defn num-decimal-places [n] - (-> n ->decimal bigdec (.stripTrailingZeros) (.scale) (max 0))) - -(defn truncate-digits - "Truncates an integer `n` the specified number of `digits`, replacing - the truncated portion with 0s." - [digits n] - (if (<= digits 0) - n - (* (dropr-digit digits n) - (pow-10 digits)))) - -(defn exact [n] - (if (or (double? n) - (float? n) - (decimal? n)) - (rationalize n) - n)) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index f3c83af5..35ecd808 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -720,7 +720,7 @@ (testing "< , >" (test-comparison " - (test-comparison <>ident t/long? t/thread?))) + (test-comparison <>ident t/long? (t/isa? Thread)))) (testing "Boxed Primitive + Abstract" (test-comparison <>ident t/long? (t/isa? java.util.AbstractCollection))) (testing "Boxed Primitive + Interface" @@ -743,14 +743,14 @@ (testing "< , >" (test-comparison " - (test-comparison <>ident a t/thread?))) + (test-comparison <>ident a (t/isa? Thread)))) (testing "Extensible Concrete + Abstract" (testing "< , >" (test-comparison " - (test-comparison <>ident t/thread? (t/isa? java.util.AbstractCollection)) - (test-comparison <>ident (t/isa? java.util.AbstractCollection) t/thread?))) + (test-comparison <>ident (t/isa? Thread) (t/isa? java.util.AbstractCollection)) + (test-comparison <>ident (t/isa? java.util.AbstractCollection) (t/isa? Thread)))) (testing "Extensible Concrete + Interface" (test-comparison > Date: Wed, 26 Sep 2018 23:40:11 -0600 Subject: [PATCH 311/810] Move reference-type predicates --- resources-dev/defnt.cljc | 39 ++++++++------- resources-dev/smaller-scratch.md | 2 - src-dev/quantum/core/defnt_equivalences.cljc | 6 +-- src-untyped/quantum/untyped/core/type.cljc | 29 ------------ src/quantum/core/async/pool.cljc | 15 +++--- src/quantum/core/collections_typed.cljc | 3 ++ src/quantum/core/io/filesystem.cljc | 2 +- src/quantum/core/reducers/reduce.cljc | 4 +- src/quantum/core/refs.cljc | 41 +++++++++++++--- src/quantum/core/resources.cljc | 16 +++---- src/quantum/core/type_old.cljc | 6 +-- src/quantum/db/datomic.cljc | 7 +-- src/quantum/db/datomic/core.cljc | 4 +- src/quantum/ui/components.cljc | 50 ++++++++++---------- src/quantum/ui/style/css/core.cljc | 2 +- test/quantum/test/core/core.cljc | 36 -------------- 16 files changed, 112 insertions(+), 150 deletions(-) delete mode 100644 test/quantum/test/core/core.cljc diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index b033c7fb..7a749366 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -129,15 +129,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative to types: - [xs (t/fn [x (t/isa? clojure.lang.Range)] ...)] - No return value means that it should infer - - typed core fns - - `apply` - - especially with `t/defn` as the caller - - `merge` - - `str` - - `compare` - - `get` - - `concat` - - `repeat` - NOTE on namespace organization: - [quantum.untyped.core.ns :refer [namespace?]] instead of @@ -153,38 +144,52 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative [-] : done as far as possible but not truly complete [x] : actually done - List of semi-approximately topologically ordered namespaces to make typed: + - [.] (TEMPORARY) collections-typed + - [ ] `get` + - [ ] `merge` + - [ ] `concat` + - [ ] `repeat` - [ ] quantum.core.core -> TODO just need to delete this from all references - [ ] quantum.core.type.core - [x] quantum.core.data.async - [ ] quantum.core.type.defs - - [ ] quantum.core.refs -> quantum.core.data.refs + - [.] quantum.core.refs -> quantum.core.data.refs ? - [ ] quantum.core.logic - (def nneg? (l/fn-not neg?)) - (def pos-int? (l/fn-and dnum/integer? pos?)) - [.] quantum.core.fn + - [ ] `apply` + - especially with `t/defn` as the caller - [ ] quantum.core.cache - [ ] quantum.core.type-old + - [.] quantum.core.data.primitive - [.] quantum.core.data.string + - [ ] `>str` - [.] quantum.core.data.map - [.] quantum.core.data.meta - - [.] quantum.core.ns ; TODO split up into data.ns? + - [.] quantum.core.compare + - [ ] `compare` + - [x] quantum.core.ns ; TODO split up into data.ns? + - [.] quantum.core.vars - [ ] quantum.core.print - [ ] quantum.core.log - [ ] quantum.core.data.vector - [ ] quantum.core.spec - [ ] quantum.core.error - - [ ] quantum.core.data.string — this is where `>str` belongs + - [.] quantum.core.data.string - [ ] quantum.core.data.array - - [ ] quantum.core.data.collections + - [.] quantum.core.data.collections - [ ] quantum.core.data.tuple - [ ] quantum.core.numeric.predicates - [ ] quantum.core.numeric.convert + - [.] quantum.core.numeric.exponents - [ ] quantum.core.numeric.misc - [ ] quantum.core.numeric.operators - [ ] quantum.core.numeric.trig - [ ] quantum.core.numeric.truncate + - [.] quantum.core.numeric.types - [ ] quantum.core.data.numeric - - [ ] quantum.core.numeric + - [.] quantum.core.numeric - [ ] quantum.core.string.regex - [ ] quantum.core.data.set - [ ] quantum.core.macros.type-hint @@ -197,14 +202,11 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] quantum.core.macros.reify - [ ] quantum.core.macros.defnt - [ ] quantum.core.macros - - [ ] quantum.core.reducers.reduce + - [.] quantum.core.reducers.reduce - [ ] quantum.core.collections.logic - [ ] quantum.core.collections.core - Worked through all we can for now: - - - - TODO delete this namespace? - - quantum.core.data.primitive (TODO make it compile) - quantum.core.data.bits - quantum.core.convert.primitive - List of corresponding untyped namespaces to incorporate: @@ -214,6 +216,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] quantum.untyped.core.data.map - [ ] quantum.untyped.core.type.defs - [ ] quantum.untyped.core.data + - [ ] quantum.untyped.core.refs - [ ] quantum.untyped.core.data.bits - [x] quantum.untyped.core.identifiers - List of Array fns to implement: diff --git a/resources-dev/smaller-scratch.md b/resources-dev/smaller-scratch.md index b48e7cac..a6489315 100644 --- a/resources-dev/smaller-scratch.md +++ b/resources-dev/smaller-scratch.md @@ -29,8 +29,6 @@ https://github.com/clojure/clojure/blob/f572a60262852af68cdb561784a517143a5847cf (#(quantum.measure.convert/convert % :bytes :MB)) double)) -(def-map 1) - ; -> 18.21 MB... there must be lots of data not referenced by vars ; TODO log these stats when every namespace is compiled diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 22201f8b..5368d896 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -1644,9 +1644,9 @@ ;; TODO: conditionally optional arities etc. for t/fn (t/def rf? "Reducing function" - (t/fn "seed arity" [] - "completing arity" [t/any?] - "reducing arity" [t/any? t/any?])) + (t/ftype "seed arity" [] + "completing arity" [t/any?] + "reducing arity" [t/any? t/any?])) ;; ----- expanded code ----- ;; diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index b79647d4..f3d283ce 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -869,33 +869,6 @@ ;; functional interfaces to be `callable?`? (-def callable? (or ifn? fnt?)) -;; ===== References ===== ;; - - (-def atom? (isa? #?(:clj clojure.lang.IAtom :cljs cljs.core/IAtom))) - - (-def volatile? (isa? #?(:clj clojure.lang.Volatile :cljs cljs.core/Volatile))) - -#?(:clj (-def atomic? (or atom? volatile? - java.util.concurrent.atomic.AtomicReference - ;; From the java.util.concurrent package: - ;; "Additionally, classes are provided only for those - ;; types that are commonly useful in intended applications. - ;; For example, there is no atomic class for representing - ;; byte. In those infrequent cases where you would like - ;; to do so, you can use an AtomicInteger to hold byte - ;; values, and cast appropriately. You can also hold floats - ;; using Float.floatToIntBits and Float.intBitstoFloat - ;; conversions, and doubles using Double.doubleToLongBits - ;; and Double.longBitsToDouble conversions." - java.util.concurrent.atomic.AtomicBoolean - #_java.util.concurrent.atomic.AtomicByte - #_java.util.concurrent.atomic.AtomicShort - java.util.concurrent.atomic.AtomicInteger - java.util.concurrent.atomic.AtomicLong - #_java.util.concurrent.atomic.AtomicFloat - #_java.util.concurrent.atomic.AtomicDouble - com.google.common.util.concurrent.AtomicDouble))) - ;; ===== Miscellaneous ===== ;; ;; Used by `quantum.untyped.core.analyze.ast` @@ -926,8 +899,6 @@ ;; TODO other things are comparable; really it depends on the two objects in question :cljs (or nil? (isa? cljs.core/IComparable)))) - (-def transformer? (isa? quantum.untyped.core.reducers.Transformer)) - ;; TODO move (-def delay? (isa? #?(:clj clojure.lang.Delay :cljs cljs.core/Delay))) diff --git a/src/quantum/core/async/pool.cljc b/src/quantum/core/async/pool.cljc index a1fcf42c..f7e5454f 100644 --- a/src/quantum/core/async/pool.cljc +++ b/src/quantum/core/async/pool.cljc @@ -26,15 +26,14 @@ [quantum.core.macros :as macros :refer [defnt]] [quantum.core.reflect :as refl] - [quantum.core.refs :as refs + [quantum.core.refs :as ref :refer [fref]] [quantum.core.spec :as s :refer [validate]] [quantum.core.resources :as res] [quantum.core.time.core :as time] [quantum.measure.convert :as uconv] - [quantum.core.type-old :as t - :refer [atom?]] + [quantum.core.type-old :as t] [quantum.core.vars :as var]) #?(:cljs (:require-macros @@ -153,8 +152,8 @@ ([^BusyWaitScheduler scheduler at f] (validate at (s/and number? (fn1 >= 0)) f fn?) - (let [shut-down? (-> scheduler :shut-down? (validate atom?) deref) - queue (-> scheduler :queue (validate atom?))] + (let [shut-down? (-> scheduler :shut-down? (validate ref/atom?) deref) + queue (-> scheduler :queue (validate ref/atom?))] (if shut-down? false (do (swap! queue update (long at) (fn-> (c/ensurec []) (conj f))) @@ -450,9 +449,9 @@ ;; TODO make `chan` the primary point of contact for components ;; It's used to ensure that resources are stopped being used before cleanup starts chan #_chan? stop-ch #_promise? - *tasks #_(t/of atom? (t/of map? ident? - (t/and ::task - (t/keys :req-un [(spec :stop-ch promise?)]))))] + *tasks #_(t/of ref/atom? (t/of map? ident? + (t/and ::task + (t/keys :req-un [(spec :stop-ch promise?)]))))] ([this] (let [chan' (async/chan 100) ; `100` is arbitrary *tasks' (atom {}) diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index a49cd1db..23746cd5 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -42,6 +42,9 @@ - TODO `(rreduce [f init o]) - like reduce but in reverse order = Equivalent to Scheme's `foldr` " +;; TODO move or excise +(def transformer? (t/isa? quantum.untyped.core.reducers.Transformer)) + ;; ===== Access functions ===== ;; ;; TODO for CLJS we should do !+vector diff --git a/src/quantum/core/io/filesystem.cljc b/src/quantum/core/io/filesystem.cljc index 261f0bb3..cad62e93 100644 --- a/src/quantum/core/io/filesystem.cljc +++ b/src/quantum/core/io/filesystem.cljc @@ -40,7 +40,7 @@ [{:as opts :keys [file] {:keys [modified]} :handlers} {:as thread-opts :keys [close-reqs]}] - (with-throw (type/atom? file) "File must be an atom.") + (with-throw (ref/atom? file) "File must be an atom.") (let [^File file-0 (-> @file convert/->file) _ (with-throw (type/file? file-0) "File must be a java.io.File.") timestamp-0 (.lastModified file-0) diff --git a/src/quantum/core/reducers/reduce.cljc b/src/quantum/core/reducers/reduce.cljc index b4ad32cc..13fe0fec 100644 --- a/src/quantum/core/reducers/reduce.cljc +++ b/src/quantum/core/reducers/reduce.cljc @@ -55,9 +55,7 @@ ; Fixing it so the seqs are headless. ; Christophe Grand - https://groups.google.com/forum/#!searchin/clojure-dev/reducer/clojure-dev/t6NhGnYNH1A/2lXghJS5HywJ -;___________________________________________________________________________________________________________________________________ -;=================================================={ REDUCING FUNCTIONS }===================================================== -;=================================================={ (Generalized) }===================================================== +;; TODO TYPED (defaliases ur transformer transformer? transducer->transformer) (defn conj-red diff --git a/src/quantum/core/refs.cljc b/src/quantum/core/refs.cljc index b49f9ac4..8ba44064 100644 --- a/src/quantum/core/refs.cljc +++ b/src/quantum/core/refs.cljc @@ -1,4 +1,4 @@ -(ns quantum.core.refs ; TODO TYPED move to `quantum.core.data.refs` and incorporate `nil?` and `val?` here +(ns quantum.core.refs ; TODO TYPED move to `quantum.core.data.refs`? (:refer-clojure :exclude [deref volatile! @@ -13,14 +13,12 @@ [clojure.string :as str] [quantum.core.error :as err :refer [TODO]] + [quantum.core.identifiers :as id] [quantum.core.macros :refer [case-env defnt #?(:clj defnt') env-lang]] [quantum.core.type-old :as t :refer [val?]] [quantum.core.type.defs :as tdefs] - [quantum.untyped.core.identifiers :as uident] - [quantum.untyped.core.refs - :refer [atom?]] [quantum.core.vars :as var :refer [defalias]]) #?(:clj @@ -29,6 +27,30 @@ [java.util.concurrent.atomic AtomicReference AtomicBoolean AtomicInteger AtomicLong] [com.google.common.util.concurrent AtomicDouble]))) +(def atom? (t/isa?|direct #?(:clj clojure.lang.IAtom :cljs cljs.core/IAtom))) + +(def volatile? (t/isa? #?(:clj clojure.lang.Volatile :cljs cljs.core/Volatile))) + +#?(:clj +(var/def atomic? + "From the `java.util.concurrent` package: + 'Additionally, classes are provided only for those types that are commonly useful in intended + applications. For example, there is no atomic class for representing byte. In those infrequent + cases where you would like to do so, you can use an `AtomicInteger` to hold byte values, and + cast appropriately. You can also hold floats using `Float.floatToIntBits` and + `Float.intBitstoFloat` conversions, and doubles using `Double.doubleToLongBits` and + `Double.longBitsToDouble` conversions.'" + (t/or atom? + java.util.concurrent.atomic.AtomicReference + java.util.concurrent.atomic.AtomicBoolean + #_java.util.concurrent.atomic.AtomicByte + #_java.util.concurrent.atomic.AtomicShort + java.util.concurrent.atomic.AtomicInteger + java.util.concurrent.atomic.AtomicLong + #_java.util.concurrent.atomic.AtomicFloat + #_java.util.concurrent.atomic.AtomicDouble + com.google.common.util.concurrent.AtomicDouble))) + ; ===== UNSYNCHRONIZED MUTABILITY ===== ; (#?(:clj definterface :cljs defprotocol) IMutableReference @@ -77,7 +99,7 @@ [~(with-meta 'x {:tag kind})] (new ~deftype-sym ~'x)) (defmacro ~(symbol (str "!" kind)) ([ ] `(new ~'~deftype-sym (~'~kind 0))) - ([~macro-param] `(~'~(uident/qualify *ns* defnt-sym) ~~macro-param)))))) + ([~macro-param] `(~'~(id/qualify *ns* defnt-sym) ~~macro-param)))))) #?(:clj (defmacro gen-primitive-mutables [] @@ -117,6 +139,11 @@ #?(:clj (defmacro setm! "Set mutable" [x v] (case-env :cljs `(set! (.-val ~x) ~v) `(setm!* ~x ~v)))) #?(:clj (defmacro setm!& "Set mutable" [x v] (case-env :cljs `(set! (.-val ~x) ~v) `(setm!*& ~x ~v)))) +;; ===== Dereferencing ===== ;; + +(def derefable? (t/isa?|direct #?(:clj clojure.lang.IDeref :cljs cljs.core/IDeref))) + +;; TODO TYPED #?(:clj (defnt deref ([#{clojure.lang.IDeref} x] (.deref x)) ([#{AtomicBoolean @@ -149,11 +176,13 @@ (defn ?deref [a] (when (val? a) (deref a))) ; TODO type this (defn ->derefable [x] - (if (t/derefable? x) + (if (derefable? x) x (reify #?(:clj clojure.lang.IDeref :cljs cljs.core/IDeref) ; TODO `reify-compatible` (#?(:clj deref :cljs -deref) [_] x)))) +;; ===== End dereferencing ===== ;; + #?(:clj (defmacro swapm! [*x0 *x1] `(let [*x0# ~*x0 *x1# ~*x1 diff --git a/src/quantum/core/resources.cljc b/src/quantum/core/resources.cljc index 7b7fff7d..771cde0d 100644 --- a/src/quantum/core/resources.cljc +++ b/src/quantum/core/resources.cljc @@ -6,15 +6,16 @@ #?(:clj [clojure.tools.namespace.repl :as repl :refer [refresh refresh-all - set-refresh-dirs] ]) + set-refresh-dirs]]) [clojure.core.async :as casync] [quantum.core.cache :as cache :refer [callable-times]] [quantum.core.core :as qcore] + [quantum.core.data.primitive :as p] [quantum.core.data.set :as set] [quantum.core.error :as err :refer [>ex-info catch-all]] - [quantum.core.log :as log ] + [quantum.core.log :as log] [quantum.core.fn :refer [fn1 fnl with-do fn->]] [quantum.core.logic :as logic @@ -22,8 +23,7 @@ [quantum.core.macros :as macros :refer [defnt]] [quantum.core.async :as async] - [quantum.core.type-old :as type - :refer [atom? val?]] + [quantum.core.refs :as ref] [quantum.core.spec :as s :refer [validate]]) #?(:cljs @@ -60,7 +60,7 @@ ([^quantum.core.data.queue.LinkedBlockingQueue obj] (async/close! obj))]) ([^clojure.core.async.impl.channels.ManyToManyChannel obj] (casync/close! obj)) ([ obj] - (when (val? obj) (throw (>ex-info :not-implemented)))))) + (when (p/val? obj) (throw (>ex-info :not-implemented)))))) #?(:cljs (declare close!)) @@ -467,15 +467,15 @@ (with-do (swap! systems assoc k (->system k config make-system)) (log/pr ::debug "Registered system.")))) -(defn stop-registered-system! [system-kw] (swap! systems update system-kw (whenf1 val? stop!))) +(defn stop-registered-system! [system-kw] (swap! systems update system-kw (whenf1 p/val? stop!))) -(defn deregister-system! [system-kw] (swap! systems (fn-> (update system-kw (whenf1 val? stop!)) (dissoc system-kw)))) +(defn deregister-system! [system-kw] (swap! systems (fn-> (update system-kw (whenf1 p/val? stop!)) (dissoc system-kw)))) (defn default-main [system-kw re-register? config] (when-not (async/web-worker?) (let [system (get @systems system-kw) - system (whenf system val? stop!) + system (whenf system p/val? stop!) system (if (or re-register? (nil? system)) (get (register-system! system-kw config) system-kw) system) diff --git a/src/quantum/core/type_old.cljc b/src/quantum/core/type_old.cljc index 2ac99a44..6cd7658c 100644 --- a/src/quantum/core/type_old.cljc +++ b/src/quantum/core/type_old.cljc @@ -153,14 +153,10 @@ (def map-entry? #?(:clj core/map-entry? :cljs (fn-and vector? (fn-> count (= 2))))) - (defalias atom? uref/atom?) + #?(:clj (defalias var? core/var?)) ; TODO `ref?`, `future?` - (defn derefable? [obj] - #?(:clj (instance? clojure.lang.IDeref obj) - :cljs (satisfies? cljs.core/IDeref obj))) - #?(:clj (def throwable? (partial instance+? java.lang.Throwable ))) (defnt error? ([#{#?(:clj Throwable :cljs js/Error)} obj] true) ([obj] false)) diff --git a/src/quantum/db/datomic.cljc b/src/quantum/db/datomic.cljc index 1b9c6b74..43bba7ac 100644 --- a/src/quantum/db/datomic.cljc +++ b/src/quantum/db/datomic.cljc @@ -28,6 +28,7 @@ :refer [fn-and fn-or whenf condf default]] [quantum.core.process :as proc] [quantum.core.resources :as res] + [quantum.core.refs :as ref] [quantum.core.string :as str] [quantum.core.async :as async :refer [go]] @@ -164,7 +165,7 @@ {:this this :err {:e e :stack #?(:clj (.getStackTrace e) :cljs (.-stack e))}}) this)))) (stop [this] - (when (t/atom? conn) + (when (ref/atom? conn) (reset! conn nil)) ; TODO is this wise? ; TODO unregister all listeners? this)) @@ -280,7 +281,7 @@ set-main-conn? (validate (default set-main-conn? false) (fn1 p/boolean?)) set-main-part? (validate (default set-main-part? false) (fn1 p/boolean?)) default-partition (validate (or default-partition :db.part/test) (s/and keyword? (fn-> namespace (= "db.part")))) - conn (validate (or conn (atom nil)) t/atom?) + conn (validate (or conn (atom nil)) ref/atom?) connection-retries (validate (or (if (= type :dynamo) 1 5)) integer?) ; DynamoDB auto-retries uri (case type :free @@ -344,7 +345,7 @@ (c/assoc this :txr-process txr-process-f) (kw-map type uri name host port create-if-not-present? default-partition conn))))) (stop [this] - (when (and (t/atom? conn) (val? @conn)) + (when (and (ref/atom? conn) (val? @conn)) #?(:clj (bdb/release @conn)) (swap! conn* #(if (identical? % @conn) nil %)) (reset! conn nil)) diff --git a/src/quantum/db/datomic/core.cljc b/src/quantum/db/datomic/core.cljc index 8c0b252d..fe1d3ace 100644 --- a/src/quantum/db/datomic/core.cljc +++ b/src/quantum/db/datomic/core.cljc @@ -77,7 +77,7 @@ mdb? (partial instance? datascript.db.DB)) #?(:clj (def conn? (partial instance? datomic.Connection))) -(defn mconn? [x] (and (t/atom? x) (mdb? @x))) +(defn mconn? [x] (and (ref/atom? x) (mdb? @x))) (defn ->uri-string [{:keys [type host port db-name] @@ -774,7 +774,7 @@ ([^Database db] (let [history (-> db :ephemeral :history) conn (-> db :ephemeral :conn )] - (validate history t/atom?) + (validate history ref/atom?) (when (contains? @history) (let [prev (peek @history) before (:db-before prev) diff --git a/src/quantum/ui/components.cljc b/src/quantum/ui/components.cljc index 26f2e28b..3a62f74c 100644 --- a/src/quantum/ui/components.cljc +++ b/src/quantum/ui/components.cljc @@ -6,25 +6,25 @@ (:refer-clojure :exclude [for reduce]) (:require #?@(:cljs - [[reagent.core :as rx] + [[reagent.core :as rx] [re-frame.core :refer [subscribe dispatch dispatch-sync reg-event reg-sub]]]) - [quantum.ui.revision :as rev] - [quantum.core.fn :as fn + [quantum.ui.revision :as rev] + [quantum.core.data.primitive :as p] + [quantum.core.fn :as fn :refer [fn-> fn->> fn']] [quantum.core.logic :refer [whenf]] - [quantum.db.datomic :as db] - [quantum.core.collections :as coll + [quantum.core.refs :as ref] + [quantum.db.datomic :as db] + [quantum.core.collections :as coll :refer [for fori join kw-map reduce map-vals+ ensurec merge-deep]] - [quantum.core.error :as err] - [quantum.core.log :as log] - [quantum.core.system :as sys + [quantum.core.error :as err] + [quantum.core.log :as log] + [quantum.core.system :as sys :refer [#?@(:cljs [react-native])]] - [quantum.core.type-old :as t - :refer [val?]] - [quantum.core.async :as async + [quantum.core.async :as async :refer [go]] [quantum.ui.style.core :refer [layout-x layout-y layout layout-perp @@ -73,7 +73,7 @@ #?(:cljs (defn rx-adapt [super sub] (when super - (whenf (aget super sub) val? rx/adapt-react-class)))) + (whenf (aget super sub) p/val? rx/adapt-react-class)))) #?(:cljs (def text (rx-adapt react-native "Text" ))) #?(:cljs (def view (rx-adapt react-native "View" ))) @@ -524,21 +524,21 @@ handle-touch-start (fn [e] (println "TOUCH START") - (when (and (atom? scroller) (:touchable? props)) + (when (and (ref/atom? scroller) (:touchable? props)) (println "SCROLLING IN TOUCH START") (-> scroller deref (.doTouchStart (.-touches e) (.-timeStamp e))) (.preventDefault e))) handle-touch-move (fn [e] (println "TOUCH MOVE") - (when (and (atom? scroller) (:touchable? props)) + (when (and (ref/atom? scroller) (:touchable? props)) (println "SCROLLING IN TOUCH MOVE") (-> scroller deref (.doTouchMove (.-touches e) (.-timeStamp e) (.-scale e))) (.preventDefault e))) handle-touch-end (fn [e] (println "TOUCH END") - (when (and (atom? scroller) (:touchable? props)) + (when (and (ref/atom? scroller) (:touchable? props)) (println "SCROLLING IN TOUCH END") #_(-> scroller deref (.doTouchEnd (.-timeStamp e))) ; Without this the scroller was reset to top:0 left: 0 on touchEnd. @@ -561,8 +561,8 @@ (defn touch-wrapper [[child-tag {:keys [table-width table-height] :as child-props} & child-elems] ] - (assert (atom? table-width )) - (assert (atom? table-height)) + (assert (ref/atom? table-width )) + (assert (ref/atom? table-height)) (let [scroller (rx/atom nil) left (rx/atom 0) top (rx/atom 0) @@ -622,8 +622,8 @@ (defn fb-table-example [{:keys [data headers headers-widths style width height cell-props-fn fixed-header-key]}] - (assert (val? width )) - (assert (val? height)) + (assert (p/val? width )) + (assert (p/val? height)) (let [std-col-width (/ @width (count @headers)) col-indices (reaction (->> @headers ; TODO code pattern (map-indexed (fn [i x] [x i])) @@ -707,9 +707,9 @@ :or {row-height-getter (fn [] row-height) scrolling-deceleration 0.97 scrolling-acceleration 0.13}}] - (assert (atom? data )) - (assert (val? width )) - (assert (val? height)) + (assert (ref/atom? data )) + (assert (p/val? width )) + (assert (p/val? height)) (assert (fn? row-render-fn)) (let [] (fn [] @@ -771,9 +771,9 @@ (defn ellipsis [{:keys [clamp-lines font-size line-height width] :as style} content] - (assert (val? clamp-lines)) - (assert (val? font-size )) - (assert (val? width )) + (assert (p/val? clamp-lines)) + (assert (p/val? font-size )) + (assert (p/val? width )) (fn [] [:div.ellipsis {:style (merge (style/ellipsis clamp-lines font-size line-height) (dissoc style diff --git a/src/quantum/ui/style/css/core.cljc b/src/quantum/ui/style/css/core.cljc index ba4716d4..e07c557e 100644 --- a/src/quantum/ui/style/css/core.cljc +++ b/src/quantum/ui/style/css/core.cljc @@ -104,7 +104,7 @@ {:in "{:width 2 :font-size [[\"16px\" \"1px\"] [\"17px\"]]}" :out "width:2;font-size:16px 1px,17px" } [css-block] - (if (or (derefable? css-block) + (if (or (ref/derefable? css-block) (and (string? css-block) (str/starts-with? css-block "calc"))) css-block diff --git a/test/quantum/test/core/core.cljc b/test/quantum/test/core/core.cljc deleted file mode 100644 index 1b9a7893..00000000 --- a/test/quantum/test/core/core.cljc +++ /dev/null @@ -1,36 +0,0 @@ -(ns quantum.test.core.core - (:require [quantum.core.core :as ns])) - -; ===== TYPE PREDICATES ===== - -(defn test:atom? [x]) - -(defn test:boolean? [x]) - -(defn test:seqable? [x]) - -(defn test:editable? [coll]) - -; ===== REFS AND ATOMS ===== - -(defn test:?deref [a]) - -(defn test:lens [x getter]) - -(defn test:cursor - [x getter & [setter]]) - -(defn test:seq= [a b]) - -; ===== TYPE ===== - -(defn test:unchecked-inc-long [x]) - -(defn test:with - [expr & body]) - -(defn test:name+ [x]) - -(defn test:ensure-println [& args]) - -(defn test:js-println [& args]) From 391500df1a87ac8dbd52d4778b9ee64d3e4bce6e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 26 Sep 2018 23:47:00 -0600 Subject: [PATCH 312/810] Clean up some pending to-move items --- resources-dev/defnt.cljc | 38 ++++++++++++++++++++ resources-dev/to-move.cljc | 54 ---------------------------- src/quantum/core/data/validated.cljc | 5 +-- src/quantum/core/refs.cljc | 14 +++++--- 4 files changed, 51 insertions(+), 60 deletions(-) delete mode 100644 resources-dev/to-move.cljc diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 7a749366..f7fa6852 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -1,3 +1,33 @@ +;; TO MOVE + +;; ===== quantum.core.system + +#?(:clj +(defnt pid [> (? t/string?)] + (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) + (.getName)))) + +;; TODO TYPED +(defalias u/*registered-components) + +;; ===== UNKNOWN ===== ;; + +(defnt >sentinel [> t/object?] #?(:clj (Object.) :cljs #js {})) +(defalias >object >sentinel) + +;; TODO TYPED +#?(:clj +(defmacro with + "Evaluates @expr, then @body, then returns @expr. + For (side) effects." + [expr #_t/form?, & body #_(? (t/seq-of t/form?))] + `(let [expr# ~expr] ~@body expr#))) + + + + + + ;; Truncation is different from safe coercion `>integer` is for e.g.: - truncation e.g. js/Math.trunc @@ -205,6 +235,14 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [.] quantum.core.reducers.reduce - [ ] quantum.core.collections.logic - [ ] quantum.core.collections.core + - [ ] quantum.core.form + - [ ] `(t/def langs #{:clj :cljs :clr})` + - [ ] `(t/def lang "The language this code is compiled under" #?(:clj :clj :cljs :cljs))` + - [ ] quantum.core.form.generate + - [ ] ``` + ;; TODO TYPED + (defalias u/externs?) + ``` - Worked through all we can for now: - quantum.core.data.bits diff --git a/resources-dev/to-move.cljc b/resources-dev/to-move.cljc deleted file mode 100644 index df02baa2..00000000 --- a/resources-dev/to-move.cljc +++ /dev/null @@ -1,54 +0,0 @@ -;; TO MOVE - -;; ===== quantum.core.form - -(t/def langs #{:clj :cljs :clr}) - -(t/def lang "The language this code is compiled under" #?(:clj :clj :cljs :cljs)) - -;; ===== quantum.core.form.generate - -;; TODO TYPED -(defalias u/externs?) - -;; ===== quantum.core.system - -#?(:clj -(defnt pid [> (? t/string?)] - (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) - (.getName)))) - -;; TODO TYPED -(defalias u/*registered-components) - - -;; ===== UNKNOWN ===== ;; - -;; ----- Mutability/Effects - -;; TODO TYPED -(defprotocol IValue - (get [this]) - (set [this newv])) -#_(do (declare-fnt get [this _]) - (declare-fnt set [this _, newv _])) - -;; ----- Really unknown - -(defnt >sentinel [> t/object?] #?(:clj (Object.) :cljs #js {})) -(defalias >object >sentinel) - -;; TODO TYPED -#?(:clj -(defmacro with - "Evaluates @expr, then @body, then returns @expr. - For (side) effects." - [expr & body] - `(let [expr# ~expr] ~@body expr#))) - -#_(:clj -(defmacrot with - "Evaluates @expr, then @body, then returns @expr. - For (side) effects." - [expr t/form? & body (? (t/seq-of t/form?))] - `(let [expr# ~expr] ~@body expr#))) diff --git a/src/quantum/core/data/validated.cljc b/src/quantum/core/data/validated.cljc index c7c56f26..f95b5d90 100644 --- a/src/quantum/core/data/validated.cljc +++ b/src/quantum/core/data/validated.cljc @@ -16,6 +16,7 @@ :refer [defrecord+]] [quantum.core.macros.optimization :refer [identity*]] + [quantum.core.refs :as ref] [quantum.core.spec :as s :refer [validate]] [quantum.untyped.core.collections :as ucoll @@ -264,7 +265,7 @@ {~'hash ([_#] (int (bit-xor ~type-hash (~(case-env :clj '.hashEq :cljs '-hash) ~'v))))} ~'?Deref {~'deref ([_#] ~'v)} - quantum.core.core/IValue + refs/IValue {~'get ([_#] ~'v) ~'set ([_# v#] (new ~sym (-> v# ~(if-not conformer `identity* conformer-sym) (s/validate ~spec-name))))}}) @@ -479,7 +480,7 @@ {~'pr ([_# w# opts#] (~'-pr-writer ~'v w# opts#))} ~'?Hash {~'hash ([_#] (int (bit-xor ~type-hash (~(case-env :clj '.hashEq :cljs '-hash) ~'v))))} - quantum.core.core/IValue + refs/IValue {~'get ([_#] ~'v) ~'set ([_# v#] (if (instance? ~sym v#) v# (new ~sym (~create v#))))}}) (defn ~constructor-sym [m#] (new ~qualified-sym (~create m#))) diff --git a/src/quantum/core/refs.cljc b/src/quantum/core/refs.cljc index 8ba44064..c0ffbf64 100644 --- a/src/quantum/core/refs.cljc +++ b/src/quantum/core/refs.cljc @@ -51,12 +51,18 @@ #_java.util.concurrent.atomic.AtomicDouble com.google.common.util.concurrent.AtomicDouble))) +;; TODO TYPED +(defprotocol IValue + (get [this]) + (set [this newv])) + ; ===== UNSYNCHRONIZED MUTABILITY ===== ; -(#?(:clj definterface :cljs defprotocol) IMutableReference - (get [#?(:cljs this)]) - (set [#?(:cljs this) v]) - (getAndSet [#?(:cljs this) v])) +;; TODO TYPED (was interface in CLJ, not protocol) +(defprotocol IMutableReference + (get [this]) + (set [this v]) + (getAndSet [this v])) ;; TODO create for every primitive datatype as well (deftype MutableReference [#?(:clj ^:unsynchronized-mutable val :cljs ^:mutable val)] From 3958ba15c18bf4cb88a8b52ebf60c498ea518bd4 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 26 Sep 2018 23:53:23 -0600 Subject: [PATCH 313/810] Add `>reduced` --- resources-dev/defnt.cljc | 2 -- src-dev/quantum/core/defnt_equivalences.cljc | 2 +- src/quantum/core/data/collections.cljc | 9 ++++++++- src/quantum/core/data/map.cljc | 1 + 4 files changed, 10 insertions(+), 4 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index f7fa6852..342a8cea 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -54,8 +54,6 @@ TODO: Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - - data.coll/reduced - - data.coll/reduced? - Analysis - (if (dcoll/reduced? ret) ;; TODO TYPED `(ref/deref ret)` should realize it's dealing with a `reduced?` diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 5368d896..8a70eb90 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -1573,7 +1573,7 @@ (defn seq "Taken from `clojure.lang.RT/seq`" {:quantum.core.type/type - (t/fn > (t/? (t/isa? ISeq)) + (t/ftype :> (t/? (t/isa? ISeq)) [t/nil?] [(t/isa? ASeq)] [(t/or (t/isa? LazySeq) (t/isa? Seqable))] diff --git a/src/quantum/core/data/collections.cljc b/src/quantum/core/data/collections.cljc index 68389cad..6d8e6c46 100644 --- a/src/quantum/core/data/collections.cljc +++ b/src/quantum/core/data/collections.cljc @@ -1,6 +1,6 @@ (ns quantum.core.data.collections (:refer-clojure :exclude - [associative? indexed? list? sequential?]) + [associative? indexed? list? reduced? sequential?]) (:require [quantum.core.data.array :as arr] [quantum.core.data.map :as map] @@ -153,6 +153,13 @@ :cljs (t/isa? cljs.core/ICollection)) sequential? associative?)) +(def reduced? (t/isa? #?(:clj clojure.lang.Reduced :cljs cljs.core/Reduced))) + +;; TODO non-boxing `>reduced` +(t/defn >reduced + "Wraps ->`x` in a way such that a `reduce` will terminate with the value ->`x`." + [x t/ref?] (#?(:clj clojure.lang.Reduced. :cljs cljs.core/Reduced.) x)) + (def reducible? (t/or p/nil? dstr/str? vec/!+vector? arr/array? dnum/numerically-integer? ;; TODO what about `transformer?` diff --git a/src/quantum/core/data/map.cljc b/src/quantum/core/data/map.cljc index 318e7adb..10505595 100644 --- a/src/quantum/core/data/map.cljc +++ b/src/quantum/core/data/map.cljc @@ -1350,6 +1350,7 @@ ;; TODO generate this function via macro ;; TODO TYPED replaced `t/fn?` with a more specific `(t/fn [...])` named as e.g. `fn/comparator?` +;; TODO somehow the `TreeMap` constructor is not right, probably because expecting a `Comparator` (t/defn >!sorted-map-by "Creates a single-threaded, mutable sorted map with the specified comparator. On the JVM, this is a `java.util.TreeMap`. From f1c5ccd97d591a7887eb14279b8465afc05d0e48 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 26 Sep 2018 23:53:38 -0600 Subject: [PATCH 314/810] Add return type --- src/quantum/core/data/collections.cljc | 1 + 1 file changed, 1 insertion(+) diff --git a/src/quantum/core/data/collections.cljc b/src/quantum/core/data/collections.cljc index 6d8e6c46..8d63d626 100644 --- a/src/quantum/core/data/collections.cljc +++ b/src/quantum/core/data/collections.cljc @@ -158,6 +158,7 @@ ;; TODO non-boxing `>reduced` (t/defn >reduced "Wraps ->`x` in a way such that a `reduce` will terminate with the value ->`x`." + > reduced? [x t/ref?] (#?(:clj clojure.lang.Reduced. :cljs cljs.core/Reduced.) x)) (def reducible? From 12a4626a4a0e77f080745a344c9bc1a816ace739 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 00:06:42 -0600 Subject: [PATCH 315/810] Move preds into data.vector --- resources-dev/defnt.cljc | 5 +- src-untyped/quantum/untyped/core/type.cljc | 148 +++++++-------------- src/quantum/core/data/primitive.cljc | 13 +- src/quantum/core/data/vector.cljc | 75 +++++++++-- 4 files changed, 125 insertions(+), 116 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 342a8cea..26ca45bf 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -115,6 +115,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - expressions (`quantum.untyped.core.analyze.expr`) - comparison of `t/fn`s is probably possible? - t/def + - TODO what would this even look like? - t/fnt (t/fn; current t/fn might transition to t/fn-spec or whatever?) - t/ftype - conditionally optional arities etc. @@ -201,9 +202,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [.] quantum.core.vars - [ ] quantum.core.print - [ ] quantum.core.log - - [ ] quantum.core.data.vector + - [.] quantum.core.data.vector - [ ] quantum.core.spec - - [ ] quantum.core.error + - [.] quantum.core.error - [.] quantum.core.data.string - [ ] quantum.core.data.array - [.] quantum.core.data.collections diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index f3d283ce..ef26fdcc 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -62,7 +62,7 @@ :refer [def- defmacro- update-meta]]) #?(:cljs (:require-macros [quantum.untyped.core.type :as self - :refer [-def def-preds|map|any def-preds|map|same-types]])) + :refer [def-preds|map|any def-preds|map|same-types]])) #?(:clj (:import [quantum.untyped.core.analyze.expr Expression] [quantum.untyped.core.type.reifications @@ -274,23 +274,17 @@ ;; TODO clean up (defn undef! [sym] (swap! *type-registry undef sym)) -#_(:clj -(defmacro defalias [sym t] - `(~'def ~sym (>type ~t)))) - -#?(:clj (uvar/defalias -def define)) - -(-def type? (isa? PType)) -(-def not-type? (isa? NotType)) -(-def or-type? (isa? OrType)) -(-def and-type? (isa? AndType)) -(-def protocol-type? (isa? ProtocolType)) -(-def class-type? (isa? ClassType)) -(-def value-type? (isa? ValueType)) +(def type? (isa? PType)) +(def not-type? (isa? NotType)) +(def or-type? (isa? OrType)) +(def and-type? (isa? AndType)) +(def protocol-type? (isa? ProtocolType)) +(def class-type? (isa? ClassType)) +(def value-type? (isa? ValueType)) ;; For use in logical operators -(-def nil? (value nil)) -(-def object? (isa? #?(:clj java.lang.Object :cljs js/Object))) +(def nil? (value nil)) +(def object? (isa? #?(:clj java.lang.Object :cljs js/Object))) ;; ===== Type metadata ===== ;; @@ -587,120 +581,70 @@ ;; ===== General ===== ;; - (-def none? empty-set) - (-def any? universal-set) + (def none? empty-set) + (def any? universal-set) - ;; TODO this is incomplete for CLJS base classes, I think - (-def val|by-class? (or object? #?@(:cljs [(isa? js/String) (isa? js/Symbol)]))) - (-def val? (not nil?)) + ;; TODO this is incomplete for CLJS base classes, I think + (def val|by-class? (or object? #?@(:cljs [(isa? js/String) (isa? js/Symbol)]))) + (def val? (not nil?)) - (-def ref? (ref any?)) + (def ref? (ref any?)) ;; ===== Meta ===== ;; -#?(:clj (-def class? (isa? java.lang.Class))) -#?(:clj (-def primitive-class? (or (value Boolean/TYPE) - (value Byte/TYPE) - (value Character/TYPE) - (value Short/TYPE) - (value Integer/TYPE) - (value Long/TYPE) - (value Float/TYPE) - (value Double/TYPE)))) +#?(:clj (def class? (isa? java.lang.Class))) +#?(:clj (def primitive-class? (or (value Boolean/TYPE) + (value Byte/TYPE) + (value Character/TYPE) + (value Short/TYPE) + (value Integer/TYPE) + (value Long/TYPE) + (value Float/TYPE) + (value Double/TYPE)))) ;; TODO for CLJS -#?(:clj (-def protocol? (>expr (ufn/fn-> :on-interface class?)))) +#?(:clj (def protocol? (>expr (ufn/fn-> :on-interface class?)))) ;; ===== Primitives ===== ;; ;; NOTE these are kept here because they're used in both type analysis and various test namespaces - (-def boolean? (isa? #?(:clj Boolean :cljs js/Boolean))) -#?(:clj (-def byte? (isa? Byte))) -#?(:clj (-def char? (isa? Character))) -#?(:clj (-def short? (isa? Short))) -#?(:clj (-def int? (isa? Integer))) -#?(:clj (-def long? (isa? Long))) -#?(:clj (-def float? (isa? Float))) - (-def double? (isa? #?(:clj Double :cljs js/Number))) + (def boolean? (isa? #?(:clj Boolean :cljs js/Boolean))) +#?(:clj (def byte? (isa? Byte))) +#?(:clj (def char? (isa? Character))) +#?(:clj (def short? (isa? Short))) +#?(:clj (def int? (isa? Integer))) +#?(:clj (def long? (isa? Long))) +#?(:clj (def float? (isa? Float))) + (def double? (isa? #?(:clj Double :cljs js/Number))) ;; These are special for CLJS protocols -#?(:cljs (-def native? (or (isa? js/Boolean) - (isa? js/Number) - (isa? js/Object) - (isa? js/Array) - (isa? js/String) - (isa? js/Function) - nil?))) +#?(:cljs (def native? (or (isa? js/Boolean) + (isa? js/Number) + (isa? js/Object) + (isa? js/Array) + (isa? js/String) + (isa? js/Function) + nil?))) ;; ===== Booleans ===== ;; - (-def true? (value true)) - (-def false? (value false)) + ;; Used in `quantum.untyped.core.analyze` + (def true? (value true)) + (def false? (value false)) ;; ===== Numbers ===== ;; ;; ----- General ----- ;; - (-def primitive-number? (or #?@(:clj [short? int? long? float?]) double?)) + (def primitive-number? (or #?@(:clj [short? int? long? float?]) double?)) ;; ========== Collections ========== ;; -;; Necessary for `quantum.untyped.core.analyze` +;; Used in `quantum.untyped.core.analyze` (def +map|built-in? (or (isa? #?(:clj clojure.lang.PersistentHashMap :cljs cljs.core/PersistentHashMap)) (isa? #?(:clj clojure.lang.PersistentArrayMap :cljs cljs.core/PersistentArrayMap)) (isa? #?(:clj clojure.lang.PersistentTreeMap :cljs cljs.core/PersistentTreeMap)))) -;; ===== Vectors ===== ;; Sequential, Associative (specifically, whose keys are sequential, - ;; dense integer values), extensible - - (-def !array-list? #?(:clj (or (isa? java.util.ArrayList) - ;; indexed and associative, but not extensible - (isa? java.util.Arrays$ArrayList)) - :cljs (or ;; not used - #_(isa? cljs.core/ArrayList) - ;; because supports .push etc. - (isa? js/Array)))) - ;; svec = "spliceable vector" - (-def svector? (isa? clojure.core.rrb_vector.rrbt.Vector)) - - (-def +vector? (isa? #?(:clj clojure.lang.IPersistentVector - :cljs cljs.core/IVector))) - - (-def +vector|built-in? (isa? #?(:clj clojure.lang.PersistentVector - :cljs cljs.core/PersistentVector))) - - (-def !+vector? (isa? #?(:clj clojure.lang.ITransientVector - :cljs cljs.core/ITransientVector))) - (-def ?!+vector? (or +vector? !+vector?)) - - (-def !vector|byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.ByteArrayList) :cljs none?)) - (-def !vector|short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.ShortArrayList) :cljs none?)) - (-def !vector|char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.CharArrayList) :cljs none?)) - (-def !vector|int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.IntArrayList) :cljs none?)) - (-def !vector|long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.LongArrayList) :cljs none?)) - (-def !vector|float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.FloatArrayList) :cljs none?)) - (-def !vector|double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.DoubleArrayList) :cljs none?)) - - (-def !vector|ref? #?(:clj (or (isa? java.util.ArrayList) - (isa? it.unimi.dsi.fastutil.objects.ReferenceArrayList)) - ;; because supports .push etc. - :cljs (isa? js/Array))) - - (-def !vector? (or !vector|ref? - !vector|byte? !vector|short? !vector|char? - !vector|int? !vector|long? - !vector|float? !vector|double?)) - - ;; java.util.Vector is deprecated, because you can - ;; just create a synchronized wrapper over an ArrayList - ;; via java.util.Collections -#?(:clj (-def !!vector? none?)) - ;; We could maybe duck-type as - ;; `(t/and (isa? java.util.RandomAccess) (isa? java.util.List))` - ;; but it's not really sufficient as that doesn't really capture - ;; all the properties we want out of a vector - (-def vector? (or ?!+vector? !vector? #?(:clj !!vector?))) - ;; ===== Queues ===== ;; Particularly FIFO queues, as LIFO = stack = any vector (-def +queue? (isa? #?(:clj clojure.lang.PersistentQueue diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 26db5dc5..f01c16a9 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -1,9 +1,13 @@ (ns quantum.core.data.primitive (:refer-clojure :exclude - [boolean? char? comparable? decimal? double? float? int? integer?]) + [boolean? char? comparable? decimal? double? false? float? int? integer? true?]) (:require #?(:cljs [com.gfredericks.goog.math.Integer :as int]) - [quantum.core.type :as t]) + [quantum.core.type :as t] + [quantum.untyped.core.type :as ut] + ;; TODO TYPED excise reference + [quantum.untyped.core.vars + :refer [defaliases]]) #?(:clj (:import [java.nio ByteBuffer] [quantum.core Numeric Primitive]))) @@ -33,6 +37,8 @@ ;; Specifically comparable primitives (def comparable? (t/- primitive? boolean?)) + (defaliases ut true? false?) + ;; ===== Boxing/unboxing ===== ;; #?(:clj @@ -138,7 +144,8 @@ ;; ===== Conversion ===== ;; -(def radix? (fnt [x integer?] + ;; TODO TYPED add t/fn +(def radix? (t/fn [x integer?] (<= #?(:clj Character/MIN_RADIX :cljs 2) x #?(:clj Character/MAX_RADIX :cljs 36)))) ;; ----- Boolean ----- ;; diff --git a/src/quantum/core/data/vector.cljc b/src/quantum/core/data/vector.cljc index 62884da6..b883b603 100644 --- a/src/quantum/core/data/vector.cljc +++ b/src/quantum/core/data/vector.cljc @@ -1,11 +1,10 @@ -(ns - ^{:doc "Vector operations. Includes relaxed radix-balanced vectors (RRB vectors) - my Michal Marczyk. Also includes |conjl| (for now)." - :attribution "alexandergunnarson"} - quantum.core.data.vector +(ns quantum.core.data.vector + "A vector is Sequential, Associative (specifically, whose keys are sequential, dense + integer values), and extensible." (:refer-clojure :exclude - [vector]) + [vector vector?]) (:require + ;; TODO TYPED excise [clojure.core :as core] [clojure.core.rrb-vector :as svec] #?@(:clj @@ -14,10 +13,12 @@ PSpliceableVector splicev]] [clojure.core.rrb-vector.rrbt :refer [AsRRBT as-rrbt]]]) - [quantum.core.fn - :refer [rcomp]] + [quantum.core.type :as t] [quantum.core.vars :as var - :refer [defalias]]) + :refer [defalias]] + ;; TODO TYPED excise + [quantum.core.untyped.fn + :refer [rcomp]]) #?(:clj (:import java.util.ArrayList @@ -35,6 +36,62 @@ ; - michalmarczyk/devec: double-ended vector ; ======================================= +(def !array-list? + #?(:clj (t/or (t/isa? java.util.ArrayList) + ;; indexed and associative, but not extensible + (t/isa? java.util.Arrays$ArrayList)) + :cljs (t/or ;; not used + #_(t/isa? cljs.core/ArrayList) + ;; because supports .push etc. + (t/isa? js/Array)))) + +;; svec = "spliceable vector" +(def svector? (t/isa? clojure.core.rrb_vector.rrbt.Vector)) + +(def +vector? (t/isa? #?(:clj clojure.lang.IPersistentVector + :cljs cljs.core/IVector))) + +(def +vector|built-in? (t/isa? #?(:clj clojure.lang.PersistentVector + :cljs cljs.core/PersistentVector))) + +(def !+vector? (t/isa? #?(:clj clojure.lang.ITransientVector + :cljs cljs.core/ITransientVector))) + +(def ?!+vector? (t/or +vector? !+vector?)) + +(def !vector|byte? #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.ByteArrayList) :cljs t/none?)) +(def !vector|short? #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.ShortArrayList) :cljs t/none?)) +(def !vector|char? #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.CharArrayList) :cljs t/none?)) +(def !vector|int? #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.IntArrayList) :cljs t/none?)) +(def !vector|long? #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.LongArrayList) :cljs t/none?)) +(def !vector|float? #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.FloatArrayList) :cljs t/none?)) +(def !vector|double? #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.DoubleArrayList) :cljs t/none?)) + +(def !vector|ref? + #?(:clj (t/or (t/isa? java.util.ArrayList) + (t/isa? it.unimi.dsi.fastutil.objects.ReferenceArrayList)) + ;; because supports .push etc. + :cljs (t/isa? js/Array))) + +(def !vector? + (t/or !vector|ref? + !vector|byte? !vector|short? !vector|char? !vector|int? !vector|long? + !vector|float? !vector|double?)) + + ;; java.util.Vector is deprecated, because you can + ;; just create a synchronized wrapper over an ArrayList + ;; via java.util.Collections +#?(:clj (def !!vector? t/none?)) + +;; We could maybe duck-type as `(t/and (isa? java.util.RandomAccess) (isa? java.util.List))` but +;; it's not really sufficient as that doesn't really capture all the properties we want out of a +;; vector +(def vector? (t/or ?!+vector? !vector? #?(:clj !!vector?))) + + +;; TODO TYPED below + + (defalias vector core/vector) (defalias +vector vector) (def !+vector (rcomp vector transient)) From fb10bdfca614fcb8a58b60533ccb941e445b9b5f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 00:08:24 -0600 Subject: [PATCH 316/810] `primitive-number?` --- src-untyped/quantum/untyped/core/data/numeric.cljc | 2 ++ src-untyped/quantum/untyped/core/type.cljc | 12 +++--------- 2 files changed, 5 insertions(+), 9 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/numeric.cljc b/src-untyped/quantum/untyped/core/data/numeric.cljc index 1e4dd982..ffec549c 100644 --- a/src-untyped/quantum/untyped/core/data/numeric.cljc +++ b/src-untyped/quantum/untyped/core/data/numeric.cljc @@ -125,6 +125,8 @@ (def number? (t/or #?@(:clj [(t/isa? java.lang.Number)] :cljs [integer? decimal? ratio?]))) +(def primitive-number? (t/or #?@(:clj [p/short? t/int? t/long? t/float?]) t/double?)) + (var/def numeric? "Something 'numeric' is something that may be treated as a number but may not actually *be* one." (t/or number? #?(:clj p/char?))) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index ef26fdcc..5435c151 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -627,15 +627,9 @@ ;; ===== Booleans ===== ;; - ;; Used in `quantum.untyped.core.analyze` - (def true? (value true)) - (def false? (value false)) - -;; ===== Numbers ===== ;; - -;; ----- General ----- ;; - - (def primitive-number? (or #?@(:clj [short? int? long? float?]) double?)) +;; Used in `quantum.untyped.core.analyze` +(def true? (value true)) +(def false? (value false)) ;; ========== Collections ========== ;; From 41de94c12658ba77ba9a76090c9466e739f7bbb5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 12:01:49 -0600 Subject: [PATCH 317/810] Add `>string` --- resources-dev/defnt.cljc | 2 +- src/quantum/core/data/primitive.cljc | 7 +- src/quantum/core/data/string.cljc | 117 +++++++++++++++++---------- 3 files changed, 78 insertions(+), 48 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 26ca45bf..9d69959c 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -144,7 +144,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative ([xs dc/counted?] (-> xs count num/zero?)) ([xs (t/input-type educe :_ :_ :?)] (educe empty?|rf x))) - handle varargs - - [& args _] shouldn't result in `t/any?` but rather like `t/seqable?` or whatever + - [& args _] shouldn't result in `t/any?` but rather like `t/reducible?` or whatever - do the defnt-equivalences - a linting warning that you can narrow the type to whatever the deduced type is from whatever wider declared type there is diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index f01c16a9..36ab553b 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -144,9 +144,10 @@ ;; ===== Conversion ===== ;; - ;; TODO TYPED add t/fn -(def radix? (t/fn [x integer?] - (<= #?(:clj Character/MIN_RADIX :cljs 2) x #?(:clj Character/MAX_RADIX :cljs 36)))) +;; TODO TYPED add t/fn +(def radix? integer? + #_(t/fn [x integer?] + (<= #?(:clj Character/MIN_RADIX :cljs 2) x #?(:clj Character/MAX_RADIX :cljs 36)))) ;; ----- Boolean ----- ;; diff --git a/src/quantum/core/data/string.cljc b/src/quantum/core/data/string.cljc index 50f1725d..69e9601b 100644 --- a/src/quantum/core/data/string.cljc +++ b/src/quantum/core/data/string.cljc @@ -1,9 +1,13 @@ (ns quantum.core.data.string "A String is a special wrapper for a char array where different encodings, etc. are possible." + (:refer-clojure :exclude + [string?]) (:require - [quantum.core.data.meta :as meta] - [quantum.core.type :as t] - [quantum.untyped.core.core :as ucore]) + [quantum.core.data.meta :as meta] + [quantum.core.data.primitive :as p] + [quantum.core.type :as t] + ;; TODO TYPED excise + [quantum.untyped.core.core :as ucore]) (:import #?(:clj [com.carrotsearch.hppc CharArrayDeque]) #?(:cljs [goog.string StringBuffer]))) @@ -19,60 +23,25 @@ #?(:clj (def char-seq? (t/isa? java.lang.CharSequence))) -;; ===== Immutable strings ===== ;; - -(def str? (t/isa? #?(:clj java.lang.String :cljs js/String))) - -#_(t/defn >str ...) ; TODO TYPED - -;; ----- Metable immutable strings ----- ;; - -;; TODO TYPED `t/deftype` -#?(:clj -(deftype MetableString [^String s ^clojure.lang.IPersistentMap _meta] - clojure.lang.IObj - (meta [this] _meta) - (withMeta [this meta'] (MetableString. s meta')) - CharSequence - (charAt [this i] (.charAt s i)) - (length [this] (.length s)) - (subSequence [this a b] (.subSequence s a b)) - Object - (toString [this] s) - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] s))) - -#?(:clj -(defmethod print-method MetableString [^MetableString x ^java.io.Writer w] - (print-method (.toString x) w))) - -(def metable-str? #?(:clj (t/isa? MetableString) :cljs str?)) - -(t/defn >metable-str - > metable-str? - ([s str?] #?(:clj (MetableString. s nil) :cljs s)) - ([s str?, meta' meta/meta?] #?(:clj (MetableString. s meta') :cljs (meta/with-meta s new-meta)))) - ;; ===== Mutable strings ===== ;; -(def !str? (t/isa? #?(:clj java.lang.StringBuilder :cljs StringBuffer))) +(def !string? (t/isa? #?(:clj java.lang.StringBuilder :cljs StringBuffer))) -(t/defn ^:inline >!str +(t/defn ^:inline >!string "Creates a mutable string." - > !str? + > !string? ([] #?(:clj (StringBuilder.) :cljs (StringBuffer.))) ;; TODO #_([x0] #?(:clj (StringBuilder. x0) :cljs (StringBuffer. x0)))) ;; ----- Synchronously mutable strings ----- ;; -#?(:clj (def !sync-str? (t/isa? java.lang.StringBuffer))) +#?(:clj (def !sync-string? (t/isa? java.lang.StringBuffer))) #?(:clj -(t/defn ^:inline >!sync-str +(t/defn ^:inline >!sync-string "Creates a synchronized mutable string." - > !sync-str? + > !sync-string? [] (StringBuffer.))) ;; ----- Mutable char deques ----- ;; @@ -140,3 +109,63 @@ (conjl! sb arg) (when (< n (-> args count dec)) (conjl! sb " ")))))) + +;; ===== Immutable strings ===== ;; + +(def string? (t/isa? #?(:clj java.lang.String :cljs js/String))) + +(t/defn >string + "Creates an immutable string." + {:incorporated '{clojure.core/str "9/27/2018" + cljs.core/str "9/27/2018"}} + > string? + ([] "") + ([x p/nil?] "") + ([x string?] x) +#?(:cljs ([x !string?] (.toString x))) +#?(:clj ([x p/boolean? > (t/assume string?)] (Boolean/toString x))) +#?(:clj ([x p/byte? > (t/assume string?)] (Byte/toString x))) +#?(:clj ([x p/short? > (t/assume string?)] (Short/toString x))) +#?(:clj ([x p/char? > (t/assume string?)] (Character/toString x))) +#?(:clj ([x p/int? > (t/assume string?)] (Integer/toString x))) +#?(:clj ([x p/long? > (t/assume string?)] (Long/toString x))) +#?(:clj ([x p/float? > (t/assume string?)] (Float/toString x))) +#?(:clj ([x p/double? > (t/assume string?)] (Double/toString x))) +#?(:clj ([x t/ref?] (-> x .toString >string)) + :cljs ([x t/any? > (t/assume string?)] (.join #js [x] ""))) + ;; TODO refine this + #_([x ? & xs ...] + (loop [sb (-> x >string >!string) more ys] + (if more + (recur (.append sb (str (first more))) (next more)) + (>string sb))))) + +;; ----- Metable immutable strings ----- ;; + +;; TODO TYPED `t/deftype` +#?(:clj +(deftype MetableString [^String s ^clojure.lang.IPersistentMap _meta] + clojure.lang.IObj + (meta [this] _meta) + (withMeta [this meta'] (MetableString. s meta')) + CharSequence + (charAt [this i] (.charAt s i)) + (length [this] (.length s)) + (subSequence [this a b] (.subSequence s a b)) + Object + (toString [this] s) + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] s))) + +#?(:clj +(defmethod print-method MetableString [^MetableString x ^java.io.Writer w] + (print-method (.toString x) w))) + +(def metable-string? #?(:clj (t/isa? MetableString) :cljs string?)) + +(t/defn >metable-string + > metable-stingr? + ([s string?] #?(:clj (MetableString. s nil) :cljs s)) + ([s string?, meta' meta/meta?] + #?(:clj (MetableString. s meta') :cljs (meta/with-meta s new-meta)))) From 9890c07086e84ee8197eab89ccf526b7554c247a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 13:50:39 -0600 Subject: [PATCH 318/810] Set up some comparison operators --- doc/cljc/quantum/core/defnt.md | 1 - resources-dev/defnt.cljc | 37 ++- .../quantum/untyped/core/data/numeric.cljc | 51 ++-- src-untyped/quantum/untyped/core/type.cljc | 4 - src/quantum/core/compare.cljc | 44 +++- src/quantum/core/compare/core.cljc | 228 ++++++++++-------- src/quantum/core/data/primitive.cljc | 28 ++- src/quantum/core/data/time.cljc | 7 + src/quantum/core/numeric/truncate.cljc | 3 +- 9 files changed, 265 insertions(+), 138 deletions(-) create mode 100644 src/quantum/core/data/time.cljc diff --git a/doc/cljc/quantum/core/defnt.md b/doc/cljc/quantum/core/defnt.md index 41a838c5..9804dcea 100644 --- a/doc/cljc/quantum/core/defnt.md +++ b/doc/cljc/quantum/core/defnt.md @@ -262,7 +262,6 @@ I think the best approach is not inference, but rather being able to at least do - Conditional specs Thus the code turns into: -*(TODO: conditionally optional arities etc.)* ```clojure (def rf? "Reducing function" diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 9d69959c..45b8c8a6 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -132,6 +132,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative we do the `let*`-binding approach to typing vars? - should be able to be per-arity like so: (^:inline [] ...) + - ^:inline set on a function should propagate to all overloads, including ones added after the fact - A good example of inlining: (t/def empty?|rf (fn/aritoid @@ -173,6 +174,31 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative [-] : done as far as possible but not truly complete [x] : actually done - List of semi-approximately topologically ordered namespaces to make typed: + - [.] clojure.core / cljs.core + - [x x] = + - [ ] == + - [. .] boolean + - [x x] boolean? + - [x x] byte + - [x x] byte? + - [x x] char + - [x x] char? + - [x x] compare + - [x x] double + - [x x] double? + - [x x] identical? + - [x x] float + - [x x] float? + - [x x] int + - [x x] int? + - [x x] long + - [x x] long? + - [x x] number? + - [x x] short + - [x x] short? + - [.] clojure.lang.Numbers + - [.] clojure.lang.RT + - [.] clojure.lang.Util - [.] (TEMPORARY) collections-typed - [ ] `get` - [ ] `merge` @@ -206,9 +232,10 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] quantum.core.spec - [.] quantum.core.error - [.] quantum.core.data.string - - [ ] quantum.core.data.array + - [.] quantum.core.data.array - [.] quantum.core.data.collections - - [ ] quantum.core.data.tuple + - [.] quantum.core.data.tuple + - [x] quantum.core.data.time - [ ] quantum.core.numeric.predicates - [ ] quantum.core.numeric.convert - [.] quantum.core.numeric.exponents @@ -233,7 +260,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] quantum.core.macros - [.] quantum.core.reducers.reduce - [ ] quantum.core.collections.logic - - [ ] quantum.core.collections.core + - [.] quantum.core.collections.core - [ ] quantum.core.form - [ ] `(t/def langs #{:clj :cljs :clr})` - [ ] `(t/def lang "The language this code is compiled under" #?(:clj :clj :cljs :cljs))` @@ -277,8 +304,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] lte - [ ] gt - [ ] gte - - [ ] eq - - [ ] neq + - [x] eq + - [x] neq - [ ] inc - [ ] dec - [ ] isZero diff --git a/src-untyped/quantum/untyped/core/data/numeric.cljc b/src-untyped/quantum/untyped/core/data/numeric.cljc index ffec549c..d0c9407b 100644 --- a/src-untyped/quantum/untyped/core/data/numeric.cljc +++ b/src-untyped/quantum/untyped/core/data/numeric.cljc @@ -88,24 +88,38 @@ ;; ===== Likenesses ===== ;; -#_(-def integer-value? (or integer? (and decimal? (>expr unum/integer-value?)))) +#_(def numerically-integer? (or integer? (and decimal? (>expr unum/integer-value?)))) -#_(-def numeric-primitive? (and primitive? (not boolean?))) +#_(def numeric-primitive? (and primitive? (not boolean?))) -#_(-def numerically-byte? (and integer-value? (>expr (c/fn [x] (c/<= -128 x 127))))) -#_(-def numerically-short? (and integer-value? (>expr (c/fn [x] (c/<= -32768 x 32767))))) -#_(-def numerically-char? (and integer-value? (>expr (c/fn [x] (c/<= 0 x 65535))))) -#_(-def numerically-unsigned-short? numerically-char?) -#_(-def numerically-int? (and integer-value? (>expr (c/fn [x] (c/<= -2147483648 x 2147483647))))) -#_(-def numerically-long? (and integer-value? (>expr (c/fn [x] (c/<= -9223372036854775808 x 9223372036854775807))))) -#_(-def numerically-float? (and number? - (>expr (c/fn [x] (c/<= -3.4028235E38 x 3.4028235E38))) - (>expr (c/fn [x] (-> x #?(:clj clojure.lang.RT/floatCast :cljs c/float) (c/== x)))))) -#_(-def numerically-double? (and number? - (>expr (c/fn [x] (c/<= -1.7976931348623157E308 x 1.7976931348623157E308))) - (>expr (c/fn [x] (-> x clojure.lang.RT/doubleCast (c/== x)))))) +#_(def numerically-byte? + (and numerically-integer? (>expr (c/fn [x] (c/<= -128 x 127))))) -#_(-def int-like? (and integer-value? numerically-int?)) +#_(def numerically-short? + (and numerically-integer? (>expr (c/fn [x] (c/<= -32768 x 32767))))) + +#_(def numerically-char? + (and numerically-integer? (>expr (c/fn [x] (c/<= 0 x 65535))))) + +#_(def numerically-unsigned-short? numerically-char?) + +#_(def numerically-int? + (and numerically-integer? (>expr (c/fn [x] (c/<= -2147483648 x 2147483647))))) + +#_(def numerically-long? + (and numerically-integer? (>expr (c/fn [x] (c/<= -9223372036854775808 x 9223372036854775807))))) + +#_(def numerically-float? + (and number? + (>expr (c/fn [x] (c/<= -3.4028235E38 x 3.4028235E38))) + (>expr (c/fn [x] (-> x #?(:clj clojure.lang.RT/floatCast :cljs c/float) (c/== x)))))) + +#_(def numerically-double? + (and number? + (>expr (c/fn [x] (c/<= -1.7976931348623157E308 x 1.7976931348623157E308))) + (>expr (c/fn [x] (-> x clojure.lang.RT/doubleCast (c/== x)))))) + +#_(-def int-like? (and numerically-integer? numerically-int?)) #_(defn numerically [t] @@ -133,4 +147,9 @@ (def numeric-primitive? (t/- p/primitive? p/boolean?)) -(def std-integer? (t/or integer? #?(:cljs double?))) +(def numerically-integer-double? (t/and p/double? numerically-integer?)) +(def ni-double? numerically-integer-double?) + +(def numerically-integer-primitive? (t/and p/primitive? numerically-integer?)) + +(def std-integer? (t/or integer? #?(:cljs numerically-integer-double?))) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 5435c151..fa196090 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -833,10 +833,6 @@ ;; `js/File` isn't always available! Use an abstraction #?(:clj (-def file? (isa? java.io.File))) - (-def comparable? #?(:clj (isa? java.lang.Comparable) - ;; TODO other things are comparable; really it depends on the two objects in question - :cljs (or nil? (isa? cljs.core/IComparable)))) - ;; TODO move (-def delay? (isa? #?(:clj clojure.lang.Delay :cljs cljs.core/Delay))) diff --git a/src/quantum/core/compare.cljc b/src/quantum/core/compare.cljc index 3efc631b..ea88fa67 100644 --- a/src/quantum/core/compare.cljc +++ b/src/quantum/core/compare.cljc @@ -1,9 +1,13 @@ (ns quantum.core.compare (:refer-clojure :exclude + ;; TODO enable + #_[= == compare] + ;; TODO clean up [= not= < > <= >= max min max-key min-key neg? pos? zero? - -' + inc compare reduce, transduce, first]) (:require [clojure.core :as core] + [goog.array :as garray] [quantum.core.log :as log :refer [prl!]] [quantum.core.collections.core :as ccoll @@ -22,6 +26,7 @@ [quantum.core.numeric.predicates :as pred :refer [neg? pos? zero?]] [quantum.core.data.numeric :as dnum] + [quantum.core.data.time :as dtime] [quantum.core.reducers :as red :refer [reduce, transduce]] [quantum.core.vars @@ -92,13 +97,44 @@ ; ) +;; TODO TYPED; also incorporate `core/fn->comparator` +(defn fn->comparator [f] + #?(:clj (cast java.util.Comparator f) + :cljs (core/fn->comparator f))) + +#?(:clj +(defnt' ^int compare-1d-arrays-lexicographically ; TODO reflection + "Arrays are not `Comparable`, so we need a custom + comparator which we can pass to `sort`." + {:from "clojure.tools.nrepl.bencode" + :adapted-by "Alex Gunnarson"} + ([^array-1d? a ^array-1d? b] + (let [alen (alength a) + blen (alength b) + len (core/min alen blen)] + (loop [i 0] + (if (== i len) ; TODO = ? + (- alen blen) + (let [x (p/>long (- (->num (aget a i)) (->num (aget b i))))] ; TODO remove protocol + (if (zero? x) + (recur (core/inc i)) + x)))))))) + +(def compare ccomp/compare) + +;; TODO TYPED define variadic arity +(t/extend-defn! compare +#?(:cljs ([a js/Date , b js/Date] (compare (dtime/date>value a) (dtime/date>value b)))) + ([a arr/array-1d?, b arr/array-1d?] (compare-1d-arrays-lexicographically a b))) + +;; TODO TYPED define variadic arity +(t/extend-defn! = +#?(:cljs ([a js/Date, b js/Date] (== (dtime/date>value o) (dtime/date>value other))))) (defaliases ccomp - compare min-key first-min-key second-min-key max-key first-max-key second-max-key - #?@(:clj [compare-1d-arrays-lexicographically - = =& not= not=& + #?@(:clj [= =& not= not=& < <& comp< comp<& <= <=& comp<= comp<=& > >& comp> comp>& @@ -203,7 +239,7 @@ ([kf xs] (unsorted-by kf core/compare xs)) ([kf comparef xs] (let [xs' (transient []) - comparef (ccomp/fn->comparator comparef)] + comparef (fn->comparator comparef)] (red/reducei-sentinel (fn [a b i] (when-not (neg? (#?@(:clj [.compare ^java.util.Comparator comparef] diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index b096fb1d..5c6919f3 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -1,104 +1,143 @@ (ns quantum.core.compare.core - (:refer-clojure :exclude - [= not= < > <= >= max min max-key min-key neg? pos? zero? - -' + inc compare]) - (:require - [clojure.core :as core] - [quantum.core.error :as err - :refer [TODO]] - [quantum.core.fn - :refer [fn&2]] - [quantum.core.macros - :refer [defnt #?@(:clj [defnt' variadic-proxy variadic-predicate-proxy])]] - [quantum.core.vars - :refer [defalias]] - [quantum.core.numeric.operators :as op - :refer [- -' + abs inc div:natural]] - [quantum.core.numeric.predicates :as pred - :refer [neg? pos? zero?]] - [quantum.core.numeric.convert - :refer [->num ->num&]] - [quantum.core.data.numeric :as dnum] - [quantum.core.data.primitive :as p]) -#?(:cljs - (:require-macros - [quantum.core.compare.core :as self - :refer [< > <= >=]])) -#?(:clj - (:import - clojure.lang.BigInt quantum.core.Numeric))) + "Defines fundamental comparison operators but does not necessarily provide definitions for all + type overloads. + + A complete (w.r.t. the `quantum.core.data.*` namespaces) set of definitions for type overloads is + found in `quantum.core.compare`." + (:refer-clojure :exclude + ;; TODO TYPED enable + #_[= == compare] + ;; TODO TYPED remove + [= not= < > <= >= max min max-key min-key neg? pos? zero? - -' + inc compare]) + (:require + ;; TODO TYPED excise + [clojure.core :as core] + ;; TODO TYPED excise + [quantum.core.error :as err + :refer [TODO]] + ;; TODO TYPED excise + [quantum.core.fn + :refer [fn&2]] + [quantum.core.vars + :refer [defalias]] + ;; TODO TYPED excise + [quantum.core.numeric.operators :as op + :refer [- -' + abs inc div:natural]] + ;; TODO TYPED excise + [quantum.core.numeric.predicates :as pred + :refer [neg? pos? zero?]] + ;; TODO TYPED excise + [quantum.core.numeric.convert + :refer [->num ->num&]] + ;; TODO TYPED excise + [quantum.core.data.numeric :as dnum] + [quantum.core.data.primitive :as p] + [quantum.core.type :as t]) +#?(:clj (:import + [quantum.core Numeric]))) ;; TODO `==` from Numeric/equals -; Some of the ideas here adapted from gfredericks/compare -; TODO include diffing -; TODO use -compare in CLJS -; TODO do `defnt` `compare` for different types -; TODO = vs. == vs. RT/equiv vs. etc. -; TODO bring in from clojure.lang.RT -; TODO comp< vs. <; comp< should include arrays -; `=` <- `==`, `=`: permissive -; `='` <- `=`: strict like `core/=` with numbers -; `==` <- `identical?` -; `hash=` +;; Some of the ideas here adapted from gfredericks/compare +;; TODO include diffing +;; TODO use -compare in CLJS +;; TODO do `defnt` `compare` for different types +;; TODO = vs. == vs. RT/equiv vs. etc. +;; TODO bring in from clojure.lang.RT +;; TODO comp< vs. <; comp< should include arrays +;; `=` <- `==`, `=`: permissive +;; `='` <- `=`: strict like `core/=` with numbers +;; `==` <- `identical?` +;; TODO `hash=` + +; ===== `==`, `=`, `not=` ===== ; + +;; TODO TYPED +(t/defn ^:inline == + "Tests identity-equality." + > p/boolean? + ([x t/any?] true) + ([a ..., b ...] (Util/identical a b))) + +(defn ^boolean = + ([x y] + (if (nil? x) + (nil? y) + (or (identical? x y) + ^boolean (-equiv x y))))) + +;; TODO .equals vs. .equiv vs. all the others? + +(t/defn ^:inline = + "Tests value-equality." + > p/boolean? + ([x t/any?] true) +#?(:clj ([a p/boolean? , b p/boolean?] (Numeric/eq a b))) +#?(:clj ([a (t/- p/primitive? t/boolean?), b (t/- p/primitive? t/boolean?)] (Numeric/eq a b))) + ([a p/boolean? , b (t/- p/primitive? t/boolean?)] false) + ([a (t/- p/primitive? t/boolean?), b p/boolean?] false)) + +(t/defn ^:inline not= + "Tests value-inequality." + > p/boolean? + ([x t/any?] false) +#?(:clj ([a p/boolean? , b p/boolean?] (Numeric/neq a b))) +#?(:clj ([a (t/- p/primitive? t/boolean?), b (t/- p/primitive? t/boolean?)] (Numeric/neq a b))) + ([a p/boolean? , b (t/- p/primitive? t/boolean?)] true) + ([a (t/- p/primitive? t/boolean?), b p/boolean?] true)) ; ===== `compare` ===== ; -(defn fn->comparator [f] - #?(:clj (cast java.util.Comparator f) - :cljs (core/fn->comparator f))) - -#?(:clj -(defnt' ^int compare-1d-arrays-lexicographically ; TODO reflection - "Arrays are not `Comparable`, so we need a custom - comparator which we can pass to `sort`." - {:from "clojure.tools.nrepl.bencode" - :adapted-by "Alex Gunnarson"} - ([^array-1d? a ^array-1d? b] - (let [alen (alength a) - blen (alength b) - len (core/min alen blen)] - (loop [i 0] - (if (== i len) ; TODO = ? - (- alen blen) - (let [x (p/>long (- (->num (aget a i)) (->num (aget b i))))] ; TODO remove protocol - (if (zero? x) - (recur (core/inc i)) - x)))))))) - -#?(:clj (defnt' ^int compare - {:todo #{"Handle nil values"}} - ([^Comparable a ^Comparable b] (int (.compareTo a b))) - ([^Comparable a ^prim? b] (int (.compareTo a b))) - ([^prim? a ^Comparable b] (int (.compareTo (p/box a) b))) - ([^array-1d? a ^array-1d? b] (compare-1d-arrays-lexicographically a b))) - :cljs (defalias compare core/compare)) - -; ===== `=`, `not=` ===== ; - -#?(:clj (defnt' ^boolean =-bin - ([#{byte char short int long float double} x - #{byte char short int long float double} y] (Numeric/eq x y)) - ([^boolean x ^boolean y] (Numeric/eq x y)) - ([^boolean x #{byte char short int long float double} y] false) - ([#{byte char short int long float double} x ^boolean y] false) - ([ x y] (.equals ^Object x y)) - ([ x ^prim? y] (.equals ^Object x y)) - ([^prim? x y] (.equals ^Object y x))) - :cljs (defn =-bin - ([x] true) - ([x y] (TODO "fix") (core/zero? (dnum/-compare x y))))) - -#?(:clj (variadic-predicate-proxy = =-bin )) -#?(:clj (variadic-predicate-proxy =& =-bin&)) - -#?(:clj (defnt' ^boolean not=-bin - ([#{#_Object prim?} x #{#_Object prim?} y] (Numeric/not (=-bin& x y)))) ; TODO make this one operation; TODO can only work with inline - :cljs (defn not=-bin - ([x] false) - ([x y] (TODO "fix") (not (core/zero? (dnum/-compare x y)))))) - -#?(:clj (variadic-predicate-proxy not= not=-bin )) -#?(:clj (variadic-predicate-proxy not=& not=-bin&)) +(def icomparable? + #?(:clj (t/isa? java.lang.Comparable) + ;; TODO other things are comparable; really it depends on the two objects in question + :cljs (t/or p/nil? (t/isa? cljs.core/IComparable)))) + +(def comparison? #?(:clj p/int? :cljs p/double?)) + +(t/defn ^:inline compare + "When ->`a` is logically 'less than' ->`b`, outputs a negative number. + When ->`a` is logically 'equal to' ->`b`, outputs zero. + When ->`a` is logically 'greater than' ->`b`, outputs a positive number." + {:incorporated '{clojure.lang.Util/compare "9/27/2018" + clojure.core/compare "9/27/2018" + cljs.core/compare "9/27/2018"}} + > comparison? + ;; TODO TYPED should we use `>int` here? + ([a p/nil? , b p/val?] (int -1)) + ;; TODO TYPED should we use `>int` here? + ([a p/val? , b p/nil?] (int 1)) + ([a primitive?, b primitive?] ) + ([^Comparable a ^Comparable b] (.compareTo a b)) + ([^Comparable a ^prim? b] (.compareTo a b)) + ([^prim? a ^Comparable b] (int (.compareTo (p/box a) b)))) + +static public int compare(Object k1, Object k2){ + if(k1 == k2) + return 0; + + if(k1 instanceof Number) + return Numbers.compare((Number) k1, (Number) k2); + return ((Comparable) k1).compareTo(k2); +} + +(defn ^number compare + [x y] + (cond + (identical? x y) 0 + + (number? x) (if (number? y) + (garray/defaultCompare x y) + (throw (js/Error. (str "Cannot compare " x " to " y)))) + + (satisfies? IComparable x) + (-compare x y) + + :else + (if (and (or (string? x) (array? x) (boolean? x)) + (identical? (type x) (type y))) + (garray/defaultCompare x y) + (throw (js/Error. (str "Cannot compare " x " to " y)))))) ; ===== `<` ===== ; @@ -113,6 +152,7 @@ #?(:clj (variadic-predicate-proxy < <-bin)) #?(:clj (variadic-predicate-proxy <& <-bin&)) + ; ----- `comp<` ----- ; #?(:clj (defnt' ^boolean comp<-bin diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 36ab553b..7bb7436e 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -162,23 +162,25 @@ ;; Forward-declared so `radix?` coercion to `int` works #?(:clj -(t/defn ^:inline >int* > int? +(t/defn ^:inline >int* "May involve non-out-of-range truncation" + > int? ([x int?] x) ;; For purposes of intrinsics ([x (t/- primitive? int? boolean?)] (clojure.lang.RT/uncheckedIntCast x)))) -(t/defn ^:inline >int > #?(:clj int? :cljs numerically-int?) +(t/defn ^:inline >int "May involve non-out-of-range truncation" - ([x #?(:clj int? :cljs numerically-int?)] x) -#?(:clj ([x (t/and (t/- primitive? int? boolean?) (range-of int?))] (>int* x)) - :cljs ([x (t/and double? (range-of int?))] (js/Math.round x))) + > #?(:clj int? :cljs numerically-int?) + ([x #?(:clj int? :cljs numerically-int?)] x) +#?(:clj ([x (t/and (t/- primitive? int? boolean?) numerically-int?)] (>int* x)) + :cljs ([x (t/and double? numerically-int?) > (t/assume numerically-int?)] (js/Math.round x))) ([x boolean?] (if x #?(:clj (int 1) :cljs 1) #?(:clj (int 0) :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) (range-of int?))] (>int* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) (range-of int?))] (.intValue x))) -#?(:clj ([x (t/and dnum/ratio? (range-of int?))] (-> x .bigIntegerValue .intValue))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-int?)] (>int* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-int?)] (.intValue x))) +#?(:clj ([x (t/and dnum/ratio? numerically-int?)] (-> x .bigIntegerValue .intValue))) ([x string?] #?(:clj (Integer/parseInteger x) - ;; NOTE could use `js/parseInt` but it's very 'unsafe' + ;; NOTE could use `js/parseInt` but it's very 'unsafe' :cljs (throw (ex-info "Parsing not implemented" {:string x})))) ([x string?, radix radix?] #?(:clj (Integer/parseInteger x (>int radix)) @@ -198,12 +200,12 @@ (defnt ^:inline >byte > #?(:clj byte? :cljs numerically-byte?) "May involve non-out-of-range truncation" ([x #?(:clj byte? :cljs numerically-byte?)] x) -#?(:clj ([x (t/and (t/- primitive? byte? boolean?) (range-of byte?))] (>byte* x)) +#?(:clj ([x (t/and (t/- primitive? byte? boolean?) numerically-byte?)] (>byte* x)) :cljs ([x (t/and double? (range-of byte?))] (js/Math.round x))) ([x boolean?] (if x #?(:clj (byte 1) :cljs 1) #?(:clj (byte 0) :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) (range-of byte?))] (>byte* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) (range-of byte?))] (.byteValue x))) -#?(:clj ([x (t/and dnum/ratio? (range-of byte?))] (-> x .bigIntegerValue .byteValue))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-byte?)] (>byte* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-byte?)] (.byteValue x))) +#?(:clj ([x (t/and dnum/ratio? numerically-byte?)] (-> x .bigIntegerValue .byteValue))) ([x string?] #?(:clj (Byte/parseByte x) ;; NOTE could use `js/parseInt` but it's very 'unsafe' diff --git a/src/quantum/core/data/time.cljc b/src/quantum/core/data/time.cljc new file mode 100644 index 00000000..1a19fdff --- /dev/null +++ b/src/quantum/core/data/time.cljc @@ -0,0 +1,7 @@ +(ns quantum.core.data.time + (:require + [quantum.core.data.numeric :as dnum] + [quantum.core.type :as t])) + +;; TODO is this the right place to put this? +#?(:cljs (t/defn date>millis [x js/Date > (t/assume dnum/ni-double?)] (.valueOf x))) diff --git a/src/quantum/core/numeric/truncate.cljc b/src/quantum/core/numeric/truncate.cljc index dca443f1..2411d409 100644 --- a/src/quantum/core/numeric/truncate.cljc +++ b/src/quantum/core/numeric/truncate.cljc @@ -18,7 +18,8 @@ #?(:clj (:import java.math.BigDecimal clojure.lang.Ratio))) #?(:clj -(defnt' rint "The double value that is closest in value to @x and is equal to a mathematical integer." +(defnt' rint + "The double value that is closest in value to ->`x` and is equal to a mathematical integer." (^double [^double x] (Math/rint x)))) #?(:clj (defalias round-double rint)) From 5eddb84df598349e6bba7d1bcce3eb3ff72471d7 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 14:15:55 -0600 Subject: [PATCH 319/810] Add goog.math.Integer and goog.math.Long; `fixed-integer?` --- resources-dev/defnt.cljc | 26 +++++++++++++++++++ .../quantum/untyped/core/data/numeric.cljc | 20 +++++++++++++- src/quantum/core/compare/core.cljc | 26 +++++++++++++++++++ src/quantum/core/data/primitive.cljc | 25 +++++++++++++++--- 4 files changed, 92 insertions(+), 5 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 45b8c8a6..0c0d7b1a 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -173,32 +173,58 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative [.] : in progress [-] : done as far as possible but not truly complete [x] : actually done + [|] : not possible / N/A / refused - List of semi-approximately topologically ordered namespaces to make typed: - [.] clojure.core / cljs.core - [x x] = - [ ] == + - [ ] any? - [. .] boolean - [x x] boolean? - [x x] byte - [x x] byte? - [x x] char - [x x] char? + - [ |] class - [x x] compare - [x x] double - [x x] double? + - [ ] even? - [x x] identical? + - [x x] integer? - [x x] float - [x x] float? - [x x] int - [x x] int? - [x x] long - [x x] long? + - [ ] nat-int? + - [ ] neg? + - [x x] not= - [x x] number? + - [ ] odd? + - [ ] pos? - [x x] short - [x x] short? + - [ ] some? - [.] clojure.lang.Numbers - [.] clojure.lang.RT - [.] clojure.lang.Util + - [ ] classOf + - [ ] clearCache + - [x] compare + - [x] equiv + - [ ] hash + - [ ] hashCombine + - [ ] hasheq + - [x] identical + - [x] isInteger + - [ ] isPrimitive + - [ ] loadWithClass + - [ ] pcequiv + - [|] ret1 + - [|] runtimeException + - [|] sneakyThrow - [.] (TEMPORARY) collections-typed - [ ] `get` - [ ] `merge` diff --git a/src-untyped/quantum/untyped/core/data/numeric.cljc b/src-untyped/quantum/untyped/core/data/numeric.cljc index d0c9407b..d11665d2 100644 --- a/src-untyped/quantum/untyped/core/data/numeric.cljc +++ b/src-untyped/quantum/untyped/core/data/numeric.cljc @@ -28,7 +28,15 @@ (def bigint? #?(:clj (t/or clj-bigint? big-integer?) :cljs (t/isa? com.gfredericks.goog.math.Integer))) -(def integer? (t/or #?@(:clj [p/byte? p/short? p/int? p/long?]) bigint?)) +;; Incorporated `clojure.lang.Util/isInteger` +;; Incorporated `clojure.core/integer?` +;; Incorporated `cljs.core/integer?` +(def integer? (t/or #?@(:clj [p/byte? p/short?]) p/int? p/long? bigint?)) + +;; Incorporated `clojure.core/int?` +;; Incorporated `cljs.core/int?` +(var/def fixed-integer? "The set of all fixed-precision integers." + (t/or ?@(:clj [p/byte? p/short?]) p/int? p/long?)) #?(:clj (defnt >big-integer > big-integer? @@ -88,6 +96,16 @@ ;; ===== Likenesses ===== ;; + +;; TODO incorporate +(defn ^boolean numerically-integer? + "Returns true if n is a JavaScript number with no decimal part." + [n] + (and (number? n) + (not ^boolean (js/isNaN n)) + (not (identical? n js/Infinity)) + (== (js/parseFloat n) (js/parseInt n 10)))) + #_(def numerically-integer? (or integer? (and decimal? (>expr unum/integer-value?)))) #_(def numeric-primitive? (and primitive? (not boolean?))) diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index 5c6919f3..6159c337 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -52,10 +52,21 @@ ; ===== `==`, `=`, `not=` ===== ; +(defn identical? + "Tests if 2 arguments are the same object" + {:inline (fn [x y] `(. clojure.lang.Util identical ~x ~y)) + :inline-arities #{2} + :added "1.0"} + ([x y] (clojure.lang.Util/identical x y))) + + ;; TODO TYPED (t/defn ^:inline == "Tests identity-equality." > p/boolean? + {:incorporated '{clojure.lang.Util/identical "9/27/2018" + clojure.core/identical? "9/27/2018" + cljs.core/identical? "9/27/2018"}} ([x t/any?] true) ([a ..., b ...] (Util/identical a b))) @@ -68,8 +79,21 @@ ;; TODO .equals vs. .equiv vs. all the others? +(defn = + ([x y] (clojure.lang.Util/equiv x y)) + ([x y & more] + (if (clojure.lang.Util/equiv x y) + (if (next more) + (recur y (first more) (next more)) + (clojure.lang.Util/equiv y (first more))) + false))) + + (t/defn ^:inline = "Tests value-equality." + {:incorporated '{clojure.lang.Util/equiv "9/27/2018" + clojure.core/= "9/27/2018" + cljs.core/= "9/27/2018"}} > p/boolean? ([x t/any?] true) #?(:clj ([a p/boolean? , b p/boolean?] (Numeric/eq a b))) @@ -80,6 +104,8 @@ (t/defn ^:inline not= "Tests value-inequality." > p/boolean? + {:incorporated '{clojure.core/not= "9/27/2018" + cljs.core/not= "9/27/2018"}} ([x t/any?] false) #?(:clj ([a p/boolean? , b p/boolean?] (Numeric/neq a b))) #?(:clj ([a (t/- p/primitive? t/boolean?), b (t/- p/primitive? t/boolean?)] (Numeric/neq a b))) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 7bb7436e..56369e63 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -3,10 +3,12 @@ [boolean? char? comparable? decimal? double? false? float? int? integer? true?]) (:require #?(:cljs [com.gfredericks.goog.math.Integer :as int]) + #?(:cljs goog.math.Integer) + #?(:cljs goog.math.Long) [quantum.core.type :as t] [quantum.untyped.core.type :as ut] ;; TODO TYPED excise reference - [quantum.untyped.core.vars + [quantum.untyped.core.vars :as var :refer [defaliases]]) #?(:clj (:import [java.nio ByteBuffer] @@ -15,15 +17,30 @@ ;; ===== Predicates ===== ;; #?(:clj (def boolean? (t/isa? #?(:clj Boolean :cljs js/Boolean)))) + #?(:clj (def byte? (t/isa? Byte))) + #?(:clj (def short? (t/isa? Short))) + #?(:clj (def char? (t/isa? Character))) -#?(:clj (def int? (t/isa? Integer))) -#?(:clj (def long? (t/isa? Long))) + + (var/def int? + "For CLJS, `int?` is not primitive even though it mimics the boxed version of the Java + `int` primitive. It is included in this namespace merely for cohesion." + (t/isa? #?(:clj Integer :cljs goog.math.Integer))) + + (var/def long? + "For CLJS, `long?` is not primitive even though it mimics the boxed version of the Java + `long` primitive. It is included in this namespace merely for cohesion." + (t/isa? #?(:clj Long :cljs goog.math.Long))) + #?(:clj (def float? (t/isa? Float))) + (def double? (t/isa? #?(:clj Double :cljs js/Number))) - (def primitive? (t/or boolean? #?@(:clj [byte? short? char? int? long? float?]) double?)) + (var/def primitive? + "For CLJS, `int?` and `long?` are not primitive even though they mimic Java primitives." + (t/or boolean? #?@(:clj [byte? short? char? int? long? float?]) double?)) ;; Specifically primitive integers (def integer? (t/or #?@(:clj [byte? short? int? long?]))) From ab726537de513dc462d671958f793188031e502c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 14:22:03 -0600 Subject: [PATCH 320/810] `arr/array?` --- resources-dev/defnt.cljc | 5 ++++- src/quantum/core/data/array.cljc | 6 ++++-- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 0c0d7b1a..3bb45e7b 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -200,13 +200,16 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x x] long? - [ ] nat-int? - [ ] neg? + - [ ] neg-int? + - [x x] nil? - [x x] not= - [x x] number? - [ ] odd? - [ ] pos? + - [ ] pos-int? - [x x] short - [x x] short? - - [ ] some? + - [x x] some? - [.] clojure.lang.Numbers - [.] clojure.lang.RT - [.] clojure.lang.Util diff --git a/src/quantum/core/data/array.cljc b/src/quantum/core/data/array.cljc index ff686c0a..80fe591a 100644 --- a/src/quantum/core/data/array.cljc +++ b/src/quantum/core/data/array.cljc @@ -121,11 +121,13 @@ (>array-nd-type 'object 9) (>array-nd-type 'object 10)]))) - ;; TODO differentiate between "all supported n-D arrays" and "all n-D arrays" - (def array? (t/or array-1d? + (def std-array? (t/or array-1d? #?@(:clj [array-2d? array-3d? array-4d? array-5d? array-6d? array-7d? array-8d? array-9d? array-10d?]))) + ;; TODO differentiate between "all supported n-D arrays" and "all n-D arrays" + (def array? (t/or std-array? #?(:clj (t/fn [x p/val?] (-> x ?/>class .isArray))))) + ; TODO look at http://fastutil.di.unimi.it to complete this namespace ; TODO `fill!` <~> `Arrays/fill`, `lodash/fill` ; TODO move this to type From 67dfe0d4b0ec11629ec72c54baaf0a9b9d5059de Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 15:06:30 -0600 Subject: [PATCH 321/810] Add comparison ops, and all todos in clojure.lang.Numbers --- resources-dev/defnt.cljc | 93 ++++++++++++- .../quantum/untyped/core/data/numeric.cljc | 2 +- src/quantum/core/collections/core.cljc | 2 +- src/quantum/core/collections_typed.cljc | 2 +- src/quantum/core/compare/core.cljc | 123 +++++++++--------- src/quantum/core/data/primitive.cljc | 21 +-- 6 files changed, 168 insertions(+), 75 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 3bb45e7b..513e7e0c 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -104,6 +104,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - t/input-type - `(t/input-type >namespace :?)` meaing the possible input types to the first input to `>namespace` - `(t/input-type reduce :_ :_ :?)` + - Then if those fns ever get extended then it should trigger a chain-reaction of recompilations - dc/of - (dc/of number?) ; implicitly the container is a `reducible?` - (dc/of map/+map? symbol? dstr/string?) @@ -211,8 +212,95 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x x] short? - [x x] some? - [.] clojure.lang.Numbers + https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/Numbers.java + - [ ] add + - [ ] addP + - [ ] and + - [ ] andNot + - [ ] boolean_array + - [ ] booleans + - [ ] byte_array + - [ ] bytes + - [ ] char_array + - [ ] chars + - [ ] clearBit + - [ ] compare + - [ ] dec + - [ ] decP + - [ ] denominator + - [ ] divide + - [ ] double_array + - [ ] doubles + - [ ] equal + - [ ] equiv + - [ ] flipBit + - [ ] float_array + - [ ] floats + - [ ] gt + - [ ] gte + - [ ] hasheq + - [ ] hasheqFrom + - [ ] inc + - [ ] incP + - [ ] int_array + - [ ] ints + - [ ] isNaN + - [ ] isNeg + - [ ] isPos + - [ ] isZero + - [ ] long_array + - [ ] longs + - [ ] lt + - [ ] lte + - [ ] max + - [ ] min + - [ ] minus + - [ ] minusP + - [ ] multiply + - [ ] multiplyP + - [ ] not + - [ ] num + - [ ] numerator + - [ ] or + - [ ] quotient + - [ ] rationalize + - [ ] reduceBigInt + - [ ] remainder + - [ ] shiftLeft + - [ ] shiftLeftInt + - [ ] shiftRight + - [ ] shiftRightInt + - [ ] short_array + - [ ] shorts + - [ ] setBit + - [ ] testBit + - [ ] toBigDecimal + - [ ] toBigInt + - [ ] toBigInteger + - [ ] toRatio + - [ ] unchecked_add + - [ ] unchecked_dec + - [ ] unchecked_divide + - [ ] unchecked_inc + - [ ] unchecked_minus + - [ ] unchecked_multiply + - [ ] unchecked_negate + - [ ] unchecked_remainder + - [ ] unchecked_int_add + - [ ] unchecked_int_dec + - [ ] unchecked_int_divide + - [ ] unchecked_int_inc + - [ ] unchecked_int_multiply + - [ ] unchecked_int_negate + - [ ] unchecked_int_remainder + - [ ] unchecked_int_subtract + - [ ] unsignedShiftRight + - [ ] unsignedShiftRightInt + - [ ] xor - [.] clojure.lang.RT + https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/RT.java - [.] clojure.lang.Util + https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/Util.java - [ ] classOf - [ ] clearCache - [x] compare @@ -265,6 +353,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [.] quantum.core.data.collections - [.] quantum.core.data.tuple - [x] quantum.core.data.time + - [.] quantum.core.compare.core - [ ] quantum.core.numeric.predicates - [ ] quantum.core.numeric.convert - [.] quantum.core.numeric.exponents @@ -329,8 +418,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] (logical) and (?) - [ ] (logical) or (?) - [ ] (logical) not - - [ ] lt - - [ ] lte + - [x] lt + - [x] lte - [ ] gt - [ ] gte - [x] eq diff --git a/src-untyped/quantum/untyped/core/data/numeric.cljc b/src-untyped/quantum/untyped/core/data/numeric.cljc index d11665d2..819e3510 100644 --- a/src-untyped/quantum/untyped/core/data/numeric.cljc +++ b/src-untyped/quantum/untyped/core/data/numeric.cljc @@ -163,7 +163,7 @@ "Something 'numeric' is something that may be treated as a number but may not actually *be* one." (t/or number? #?(:clj p/char?))) -(def numeric-primitive? (t/- p/primitive? p/boolean?)) +(def numeric-primitive? p/numeric?) (def numerically-integer-double? (t/and p/double? numerically-integer?)) (def ni-double? numerically-integer-double?) diff --git a/src/quantum/core/collections/core.cljc b/src/quantum/core/collections/core.cljc index 29b05cd8..152d6eb4 100644 --- a/src/quantum/core/collections/core.cljc +++ b/src/quantum/core/collections/core.cljc @@ -247,7 +247,7 @@ #?(:clj (^<0> [#{!map? !!map?} x k v] (.put x k v) x)) (^<0> [^transient? x k v] (core/assoc! x k v)) #?(:clj (^<0> [^default x ^int k v] - (if (t/array? x) + (if (arr/array? x) (java.lang.reflect.Array/set x k v) (throw (>ex-info :not-supported "`assoc!` not supported on this object" {:type (type x)})))))) diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index 23746cd5..d14b6f84 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -144,7 +144,7 @@ ;; NOTE `ArraySeq/createFromObject` is the slow path but has to be that way because the ;; specialized ArraySeq constructors are private ([xs arr/array?] - #?(:clj (ArraySeq/createFromObject xs) + #?(:clj (clojure.lang.ArraySeq/createFromObject xs) :cljs (when-not (num/zero? (count xs)) ; TODO use `empty?` instead (cljs.core/IndexedSeq. xs 0 nil))))) diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index 6159c337..be772d38 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -5,34 +5,28 @@ A complete (w.r.t. the `quantum.core.data.*` namespaces) set of definitions for type overloads is found in `quantum.core.compare`." (:refer-clojure :exclude - ;; TODO TYPED enable - #_[= == compare] + [< <= = not= == not== > >= compare] ;; TODO TYPED remove - [= not= < > <= >= max min max-key min-key neg? pos? zero? - -' + inc compare]) + #_[= not= < > <= >= max min max-key min-key neg? pos? zero? - -' + inc compare]) (:require ;; TODO TYPED excise [clojure.core :as core] ;; TODO TYPED excise - [quantum.core.error :as err - :refer [TODO]] - ;; TODO TYPED excise - [quantum.core.fn - :refer [fn&2]] - [quantum.core.vars - :refer [defalias]] - ;; TODO TYPED excise - [quantum.core.numeric.operators :as op + #_[quantum.core.numeric.operators :as op :refer [- -' + abs inc div:natural]] ;; TODO TYPED excise - [quantum.core.numeric.predicates :as pred + #_[quantum.core.numeric.predicates :as pred :refer [neg? pos? zero?]] ;; TODO TYPED excise - [quantum.core.numeric.convert + #_[quantum.core.numeric.convert :refer [->num ->num&]] ;; TODO TYPED excise - [quantum.core.data.numeric :as dnum] + #_[quantum.core.data.numeric :as dnum] [quantum.core.data.primitive :as p] - [quantum.core.type :as t]) + [quantum.core.type :as t] + ;; TODO TYPED excise + [quantum.untyped.core.logic + :refer [ifs]]) #?(:clj (:import [quantum.core Numeric]))) @@ -52,14 +46,6 @@ ; ===== `==`, `=`, `not=` ===== ; -(defn identical? - "Tests if 2 arguments are the same object" - {:inline (fn [x y] `(. clojure.lang.Util identical ~x ~y)) - :inline-arities #{2} - :added "1.0"} - ([x y] (clojure.lang.Util/identical x y))) - - ;; TODO TYPED (t/defn ^:inline == "Tests identity-equality." @@ -68,7 +54,11 @@ clojure.core/identical? "9/27/2018" cljs.core/identical? "9/27/2018"}} ([x t/any?] true) - ([a ..., b ...] (Util/identical a b))) + ([a ..., b ...] (clojure.lang.Util/identical a b))) + +(t/defn ^:inline not== + "Tests identity-inequality." + ...) (defn ^boolean = ([x y] @@ -112,9 +102,50 @@ ([a p/boolean? , b (t/- p/primitive? t/boolean?)] true) ([a (t/- p/primitive? t/boolean?), b p/boolean?] true)) +; ===== `<` ===== ; + +(t/defn ^:inline < + "Numeric less-than comparison." + > p/boolean? + ([x p/numeric?] true) + ([a p/numeric?, b p/numeric?] (Numeric/lt a b)) + ; TODO numbers, but not nil + ) + +; ===== `<=` ===== ; + +(t/defn ^:inline <= + "Numeric less-than-or-value-equal comparison." + > p/boolean? + ([x p/numeric?] true) + ([a p/numeric?, b p/numeric?] (Numeric/lte a b)) + ; TODO numbers, but not nil + ) + +; ===== `>` ===== ; + +(t/defn ^:inline > + "Numeric greater-than comparison." + > p/boolean? + ([x p/numeric?] true) + ([a p/numeric?, b p/numeric?] (Numeric/gt a b)) + ; TODO numbers, but not nil + ) + +; ===== `>=` ===== ; + +(t/defn ^:inline >= + "Numeric greater-than-or-value-equal comparison." + > p/boolean? + ([x p/numeric?] true) + ([a p/numeric?, b p/numeric?] (Numeric/gte a b)) + ; TODO numbers, but not nil + ) + ; ===== `compare` ===== ; -(def icomparable? +(var/def icomparable? + "That which is comparable to its own 'concrete type' (i.e. class)." #?(:clj (t/isa? java.lang.Comparable) ;; TODO other things are comparable; really it depends on the two objects in question :cljs (t/or p/nil? (t/isa? cljs.core/IComparable)))) @@ -122,7 +153,9 @@ (def comparison? #?(:clj p/int? :cljs p/double?)) (t/defn ^:inline compare - "When ->`a` is logically 'less than' ->`b`, outputs a negative number. + "Logical (not numeric) comparison. + + When ->`a` is logically 'less than' ->`b`, outputs a negative number. When ->`a` is logically 'equal to' ->`b`, outputs zero. When ->`a` is logically 'greater than' ->`b`, outputs a positive number." {:incorporated '{clojure.lang.Util/compare "9/27/2018" @@ -130,10 +163,10 @@ cljs.core/compare "9/27/2018"}} > comparison? ;; TODO TYPED should we use `>int` here? - ([a p/nil? , b p/val?] (int -1)) + ([a p/nil? , b p/val?] (int -1)) ;; TODO TYPED should we use `>int` here? - ([a p/val? , b p/nil?] (int 1)) - ([a primitive?, b primitive?] ) + ([a p/val? , b p/nil?] (int 1)) + ([a p/primitive?, b p/primitive?] (ifs (> a b) 1, (< a b) -1, 0)) ([^Comparable a ^Comparable b] (.compareTo a b)) ([^Comparable a ^prim? b] (.compareTo a b)) ([^prim? a ^Comparable b] (int (.compareTo (p/box a) b)))) @@ -152,10 +185,6 @@ static public int compare(Object k1, Object k2){ (cond (identical? x y) 0 - (number? x) (if (number? y) - (garray/defaultCompare x y) - (throw (js/Error. (str "Cannot compare " x " to " y)))) - (satisfies? IComparable x) (-compare x y) @@ -165,19 +194,6 @@ static public int compare(Object k1, Object k2){ (garray/defaultCompare x y) (throw (js/Error. (str "Cannot compare " x " to " y)))))) -; ===== `<` ===== ; - -#?(:clj (defnt' ^boolean <-bin - ([#{byte char short int long float double} x] true) - ([#{byte char short int long float double} x - #{byte char short int long float double} y] (Numeric/lt x y)) - ; TODO numbers, but not nil - ) - :cljs (defn <-bin ([x] true) ([x y] (core/< x y)))) - -#?(:clj (variadic-predicate-proxy < <-bin)) -#?(:clj (variadic-predicate-proxy <& <-bin&)) - ; ----- `comp<` ----- ; @@ -199,19 +215,6 @@ static public int compare(Object k1, Object k2){ comp< comp<-bin)) #?(:clj (variadic-predicate-proxy comp<& comp<-bin&)) -; ===== `<=` ===== ; - -#?(:clj (defnt' ^boolean <=-bin - ([#{byte char short int long float double} x] true) - ([#{byte char short int long float double} x - #{byte char short int long float double} y] (Numeric/lte x y)) - ; TODO numbers, but not nil - ) - :cljs (defn <=-bin ([x] true) ([x y] (core/<= x y)))) - -#?(:clj (variadic-predicate-proxy <= <=-bin)) -#?(:clj (variadic-predicate-proxy <=& <=-bin&)) - ; ----- `comp<=` ----- ; #?(:clj (defnt' ^boolean comp<=-bin diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 56369e63..0d4c4c25 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -39,20 +39,21 @@ (def double? (t/isa? #?(:clj Double :cljs js/Number))) (var/def primitive? - "For CLJS, `int?` and `long?` are not primitive even though they mimic Java primitives." + "For CLJS, `int?` and `long?` are not primitive even though they mimic Java primitives. + For CLJS, does not include built-in platform types like js/String that are considered + 'primitive' in some contexts." (t/or boolean? #?@(:clj [byte? short? char? int? long? float?]) double?)) - ;; Specifically primitive integers - (def integer? (t/or #?@(:clj [byte? short? int? long?]))) + (var/def integer? "Specifically primitive integers." + (t/or #?@(:clj [byte? short? int? long?]))) - ;; Specifically primitive decimals - (def decimal? (t/or #?(:clj float?) double?)) + (var/def decimal? "Specifically primitive decimals." + (t/or #?(:clj float?) double?)) - ;; Specifically primitive integrals - (def integral? (t/or integer? char?)) - - ;; Specifically comparable primitives - (def comparable? (t/- primitive? boolean?)) + (var/def numeric? + "Specifically primitive numeric things. + Something 'numeric' is something that may be treated as a number but may not actually *be* one." + (t/- primitive? boolean?)) (defaliases ut true? false?) From ae5275da7931e5009e7d9f5b61a8b7b762666332 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 15:38:33 -0600 Subject: [PATCH 322/810] Figure out bigint, bigdec, and ratio for CLJS --- resources-dev/clojure-lang-numbers-temp.java | 4190 +++++++++++++++++ resources-dev/defnt.cljc | 6 +- .../quantum/untyped/core/data/numeric.cljc | 81 +- src/quantum/core/compare/core.cljc | 15 +- src/quantum/core/numeric/types.cljc | 171 - test/quantum/test.cljc | 1 - 6 files changed, 4279 insertions(+), 185 deletions(-) create mode 100644 resources-dev/clojure-lang-numbers-temp.java delete mode 100644 src/quantum/core/numeric/types.cljc diff --git a/resources-dev/clojure-lang-numbers-temp.java b/resources-dev/clojure-lang-numbers-temp.java new file mode 100644 index 00000000..858868dc --- /dev/null +++ b/resources-dev/clojure-lang-numbers-temp.java @@ -0,0 +1,4190 @@ + +public class Numbers{ + +static interface Ops{ + + +static abstract class OpsP implements Ops{ + public Number addP(Number x, Number y){ + return add(x, y); + } + + public Number unchecked_add(Number x, Number y){ + return add(x, y); + } + + public Number multiplyP(Number x, Number y){ + return multiply(x, y); + } + + public Number unchecked_multiply(Number x, Number y){ + return multiply(x, y); + } + + public Number negateP(Number x){ + return negate(x); + } + + public Number unchecked_negate(Number x){ + return negate(x); + } + + public Number incP(Number x){ + return inc(x); + } + + public Number unchecked_inc(Number x){ + return inc(x); + } + + public Number decP(Number x){ + return dec(x); + } + + public Number unchecked_dec(Number x){ + return dec(x); + } + +} + +static public boolean isZero(Object x){ + return ops(x).isZero((Number)x); +} + +static public boolean isPos(Object x){ + return ops(x).isPos((Number)x); +} + +static public boolean isNeg(Object x){ + return ops(x).isNeg((Number)x); +} + +static public Number minus(Object x){ + return ops(x).negate((Number)x); +} + +static public Number minusP(Object x){ + return ops(x).negateP((Number)x); +} + +static public Number inc(Object x){ + return ops(x).inc((Number)x); +} + +static public Number incP(Object x){ + return ops(x).incP((Number)x); +} + +static public Number dec(Object x){ + return ops(x).dec((Number)x); +} + +static public Number decP(Object x){ + return ops(x).decP((Number)x); +} + +static public Number add(Object x, Object y){ + return ops(x).combine(ops(y)).add((Number)x, (Number)y); +} + +static public Number addP(Object x, Object y){ + return ops(x).combine(ops(y)).addP((Number)x, (Number)y); +} + +static public Number minus(Object x, Object y){ + Ops yops = ops(y); + return ops(x).combine(yops).add((Number)x, yops.negate((Number)y)); +} + +static public Number minusP(Object x, Object y){ + Ops yops = ops(y); + Number negativeY = yops.negateP((Number) y); + Ops negativeYOps = ops(negativeY); + return ops(x).combine(negativeYOps).addP((Number)x, negativeY); +} + +static public Number multiply(Object x, Object y){ + return ops(x).combine(ops(y)).multiply((Number)x, (Number)y); +} + +static public Number multiplyP(Object x, Object y){ + return ops(x).combine(ops(y)).multiplyP((Number)x, (Number)y); +} + +static public Number divide(Object x, Object y){ + if (isNaN(x)){ + return (Number)x; + } else if(isNaN(y)){ + return (Number)y; + } + Ops yops = ops(y); + if(yops.isZero((Number)y)) + throw new ArithmeticException("Divide by zero"); + return ops(x).combine(yops).divide((Number)x, (Number)y); +} + +static public Number quotient(Object x, Object y){ + Ops yops = ops(y); + if(yops.isZero((Number) y)) + throw new ArithmeticException("Divide by zero"); + return ops(x).combine(yops).quotient((Number)x, (Number)y); +} + +static public Number remainder(Object x, Object y){ + Ops yops = ops(y); + if(yops.isZero((Number) y)) + throw new ArithmeticException("Divide by zero"); + return ops(x).combine(yops).remainder((Number)x, (Number)y); +} + +static public double quotient(double n, double d){ + if(d == 0) + throw new ArithmeticException("Divide by zero"); + + double q = n / d; + if(q <= Long.MAX_VALUE && q >= Long.MIN_VALUE) + { + return (double)(long) q; + } + else + { //bigint quotient + return new BigDecimal(q).toBigInteger().doubleValue(); + } +} + +static public double remainder(double n, double d){ + if(d == 0) + throw new ArithmeticException("Divide by zero"); + + double q = n / d; + if(q <= Long.MAX_VALUE && q >= Long.MIN_VALUE) + { + return (n - ((long) q) * d); + } + else + { //bigint quotient + Number bq = new BigDecimal(q).toBigInteger(); + return (n - bq.doubleValue() * d); + } +} + +static public boolean equiv(Object x, Object y){ + return equiv((Number) x, (Number) y); +} + +static public boolean equiv(Number x, Number y){ + return ops(x).combine(ops(y)).equiv(x, y); +} + +static public boolean equal(Number x, Number y){ + return category(x) == category(y) + && ops(x).combine(ops(y)).equiv(x, y); +} + +static public boolean lt(Object x, Object y){ + return ops(x).combine(ops(y)).lt((Number)x, (Number)y); +} + +static public boolean lte(Object x, Object y){ + return ops(x).combine(ops(y)).lte((Number)x, (Number)y); +} + +static public boolean gt(Object x, Object y){ + return ops(x).combine(ops(y)).lt((Number)y, (Number)x); +} + +static public boolean gte(Object x, Object y){ + return ops(x).combine(ops(y)).gte((Number)x, (Number)y); +} + +static public int compare(Number x, Number y){ + Ops ops = ops(x).combine(ops(y)); + if(ops.lt(x, y)) + return -1; + else if(ops.lt(y, x)) + return 1; + return 0; +} + +@WarnBoxedMath(false) +static BigInt toBigInt(Object x){ + if(x instanceof BigInt) + return (BigInt) x; + if(x instanceof BigInteger) + return BigInt.fromBigInteger((BigInteger) x); + else + return BigInt.fromLong(((Number) x).longValue()); +} + +@WarnBoxedMath(false) +static BigInteger toBigInteger(Object x){ + if(x instanceof BigInteger) + return (BigInteger) x; + else if(x instanceof BigInt) + return ((BigInt) x).toBigInteger(); + else + return BigInteger.valueOf(((Number) x).longValue()); +} + +@WarnBoxedMath(false) +static BigDecimal toBigDecimal(Object x){ + if(x instanceof BigDecimal) + return (BigDecimal) x; + else if(x instanceof BigInt) + { + BigInt bi = (BigInt) x; + if(bi.bipart == null) + return BigDecimal.valueOf(bi.lpart); + else + return new BigDecimal(bi.bipart); + } + else if(x instanceof BigInteger) + return new BigDecimal((BigInteger) x); + else if(x instanceof Double) + return new BigDecimal(((Number) x).doubleValue()); + else if(x instanceof Float) + return new BigDecimal(((Number) x).doubleValue()); + else if(x instanceof Ratio) + { + Ratio r = (Ratio)x; + return (BigDecimal)divide(new BigDecimal(r.numerator), r.denominator); + } + else + return BigDecimal.valueOf(((Number) x).longValue()); +} + +@WarnBoxedMath(false) +static public Ratio toRatio(Object x){ + if(x instanceof Ratio) + return (Ratio) x; + else if(x instanceof BigDecimal) + { + BigDecimal bx = (BigDecimal) x; + BigInteger bv = bx.unscaledValue(); + int scale = bx.scale(); + if(scale < 0) + return new Ratio(bv.multiply(BigInteger.TEN.pow(-scale)), BigInteger.ONE); + else + return new Ratio(bv, BigInteger.TEN.pow(scale)); + } + return new Ratio(toBigInteger(x), BigInteger.ONE); +} + +@WarnBoxedMath(false) +static public Number rationalize(Number x){ + if(x instanceof Float || x instanceof Double) + return rationalize(BigDecimal.valueOf(x.doubleValue())); + else if(x instanceof BigDecimal) + { + BigDecimal bx = (BigDecimal) x; + BigInteger bv = bx.unscaledValue(); + int scale = bx.scale(); + if(scale < 0) + return BigInt.fromBigInteger(bv.multiply(BigInteger.TEN.pow(-scale))); + else + return divide(bv, BigInteger.TEN.pow(scale)); + } + return x; +} + +static public BigInteger numerator(Ratio x){ + return x.numerator; +} + +static public BigInteger numerator(long x){ + return BigInteger.valueOf(x); +} + +static public BigInteger numerator(BigInt x){ + return x.toBigInteger(); +} + +static public BigInteger numerator(BigInteger x){ + return x; +} + +static public BigInteger denominator(Ratio x){ + return x.denominator; +} + +static public BigInteger denominator(long x){ + return BigInteger.ONE; +} + +static public BigInteger denominator(BigInt x){ + return BigInteger.ONE; +} + +static public BigInteger denominator(BigInteger x){ + return BigInteger.ONE; +} + +//static Number box(int val){ +// return Integer.valueOf(val); +//} + +//static Number box(long val){ +// return Long.valueOf(val); +//} +// +//static Double box(double val){ +// return Double.valueOf(val); +//} +// +//static Double box(float val){ +// return Double.valueOf((double) val); +//} + +@WarnBoxedMath(false) +static public Number reduceBigInt(BigInt val){ + if(val.bipart == null) + return num(val.lpart); + else + return val.bipart; +} + +static public Number divide(BigInteger n, BigInteger d){ + if(d.equals(BigInteger.ZERO)) + throw new ArithmeticException("Divide by zero"); + BigInteger gcd = n.gcd(d); + if(gcd.equals(BigInteger.ZERO)) + return BigInt.ZERO; + n = n.divide(gcd); + d = d.divide(gcd); + if(d.equals(BigInteger.ONE)) + return BigInt.fromBigInteger(n); + else if(d.equals(BigInteger.ONE.negate())) + return BigInt.fromBigInteger(n.negate()); + return new Ratio((d.signum() < 0 ? n.negate() : n), + (d.signum() < 0 ? d.negate() : d)); +} + +static public int shiftLeftInt(int x, int n){ + return x << n; +} + +static public long shiftLeft(Object x, Object y){ + return shiftLeft(bitOpsCast(x),bitOpsCast(y)); +} +static public long shiftLeft(Object x, long y){ + return shiftLeft(bitOpsCast(x),y); +} +static public long shiftLeft(long x, Object y){ + return shiftLeft(x,bitOpsCast(y)); +} +static public long shiftLeft(long x, long n){ + return x << n; +} + +static public int shiftRightInt(int x, int n){ + return x >> n; +} + +static public long shiftRight(Object x, Object y){ + return shiftRight(bitOpsCast(x),bitOpsCast(y)); +} +static public long shiftRight(Object x, long y){ + return shiftRight(bitOpsCast(x),y); +} +static public long shiftRight(long x, Object y){ + return shiftRight(x,bitOpsCast(y)); +} +static public long shiftRight(long x, long n){ + return x >> n; +} + +static public int unsignedShiftRightInt(int x, int n){ + return x >>> n; +} + +static public long unsignedShiftRight(Object x, Object y){ + return unsignedShiftRight(bitOpsCast(x),bitOpsCast(y)); +} +static public long unsignedShiftRight(Object x, long y){ + return unsignedShiftRight(bitOpsCast(x),y); +} +static public long unsignedShiftRight(long x, Object y){ + return unsignedShiftRight(x,bitOpsCast(y)); +} +static public long unsignedShiftRight(long x, long n){ + return x >>> n; +} + +final static class LongOps implements Ops{ + public Ops combine(Ops y){ + return y.opsWith(this); + } + + final public Ops opsWith(LongOps x){ + return this; + } + + final public Ops opsWith(DoubleOps x){ + return DOUBLE_OPS; + } + + final public Ops opsWith(RatioOps x){ + return RATIO_OPS; + } + + final public Ops opsWith(BigIntOps x){ + return BIGINT_OPS; + } + + final public Ops opsWith(BigDecimalOps x){ + return BIGDECIMAL_OPS; + } + + public boolean isZero(Number x){ + return x.longValue() == 0; + } + + public boolean isPos(Number x){ + return x.longValue() > 0; + } + + public boolean isNeg(Number x){ + return x.longValue() < 0; + } + + final public Number add(Number x, Number y){ + return num(Numbers.add(x.longValue(),y.longValue())); + } + + final public Number addP(Number x, Number y){ + long lx = x.longValue(), ly = y.longValue(); + long ret = lx + ly; + if ((ret ^ lx) < 0 && (ret ^ ly) < 0) + return BIGINT_OPS.add(x, y); + return num(ret); + } + + final public Number unchecked_add(Number x, Number y){ + return num(Numbers.unchecked_add(x.longValue(), y.longValue())); + } + + final public Number multiply(Number x, Number y){ + return num(Numbers.multiply(x.longValue(), y.longValue())); + } + + final public Number multiplyP(Number x, Number y){ + long lx = x.longValue(), ly = y.longValue(); + if (lx == Long.MIN_VALUE && ly < 0) + return BIGINT_OPS.multiply(x, y); + long ret = lx * ly; + if (ly != 0 && ret/ly != lx) + return BIGINT_OPS.multiply(x, y); + return num(ret); + } + + final public Number unchecked_multiply(Number x, Number y){ + return num(Numbers.unchecked_multiply(x.longValue(), y.longValue())); + } + + static long gcd(long u, long v){ + while(v != 0) + { + long r = u % v; + u = v; + v = r; + } + return u; + } + + public Number divide(Number x, Number y){ + long n = x.longValue(); + long val = y.longValue(); + long gcd = gcd(n, val); + if(gcd == 0) + return num(0); + + n = n / gcd; + long d = val / gcd; + if(d == 1) + return num(n); + if(d < 0) + { + n = -n; + d = -d; + } + return new Ratio(BigInteger.valueOf(n), BigInteger.valueOf(d)); + } + + public Number quotient(Number x, Number y){ + return num(x.longValue() / y.longValue()); + } + + public Number remainder(Number x, Number y){ + return num(x.longValue() % y.longValue()); + } + + public boolean equiv(Number x, Number y){ + return x.longValue() == y.longValue(); + } + + public boolean lt(Number x, Number y){ + return x.longValue() < y.longValue(); + } + + public boolean lte(Number x, Number y){ + return x.longValue() <= y.longValue(); + } + + public boolean gte(Number x, Number y){ + return x.longValue() >= y.longValue(); + } + + //public Number subtract(Number x, Number y); + final public Number negate(Number x){ + long val = x.longValue(); + return num(Numbers.minus(val)); + } + + final public Number negateP(Number x){ + long val = x.longValue(); + if(val > Long.MIN_VALUE) + return num(-val); + return BigInt.fromBigInteger(BigInteger.valueOf(val).negate()); + } + + final public Number unchecked_negate(Number x){ + long val = x.longValue(); + return num(Numbers.unchecked_minus(val)); + } + + public Number inc(Number x){ + long val = x.longValue(); + return num(Numbers.inc(val)); + } + + public Number incP(Number x){ + long val = x.longValue(); + if(val < Long.MAX_VALUE) + return num(val + 1); + return BIGINT_OPS.inc(x); + } + + public Number unchecked_inc(Number x){ + long val = x.longValue(); + return num(Numbers.unchecked_inc(val)); + } + + public Number dec(Number x){ + long val = x.longValue(); + return num(Numbers.dec(val)); + } + + public Number decP(Number x){ + long val = x.longValue(); + if(val > Long.MIN_VALUE) + return num(val - 1); + return BIGINT_OPS.dec(x); + } + + public Number unchecked_dec(Number x){ + long val = x.longValue(); + return num(Numbers.unchecked_dec(val)); + } +} + +final static class DoubleOps extends OpsP{ + public Ops combine(Ops y){ + return y.opsWith(this); + } + + final public Ops opsWith(LongOps x){ + return this; + } + + final public Ops opsWith(DoubleOps x){ + return this; + } + + final public Ops opsWith(RatioOps x){ + return this; + } + + final public Ops opsWith(BigIntOps x){ + return this; + } + + final public Ops opsWith(BigDecimalOps x){ + return this; + } + + public boolean isZero(Number x){ + return x.doubleValue() == 0; + } + + public boolean isPos(Number x){ + return x.doubleValue() > 0; + } + + public boolean isNeg(Number x){ + return x.doubleValue() < 0; + } + + final public Number add(Number x, Number y){ + return Double.valueOf(x.doubleValue() + y.doubleValue()); + } + + final public Number multiply(Number x, Number y){ + return Double.valueOf(x.doubleValue() * y.doubleValue()); + } + + public Number divide(Number x, Number y){ + return Double.valueOf(x.doubleValue() / y.doubleValue()); + } + + public Number quotient(Number x, Number y){ + return Numbers.quotient(x.doubleValue(), y.doubleValue()); + } + + public Number remainder(Number x, Number y){ + return Numbers.remainder(x.doubleValue(), y.doubleValue()); + } + + public boolean equiv(Number x, Number y){ + return x.doubleValue() == y.doubleValue(); + } + + public boolean lt(Number x, Number y){ + return x.doubleValue() < y.doubleValue(); + } + + public boolean lte(Number x, Number y){ + return x.doubleValue() <= y.doubleValue(); + } + + public boolean gte(Number x, Number y){ + return x.doubleValue() >= y.doubleValue(); + } + + //public Number subtract(Number x, Number y); + final public Number negate(Number x){ + return Double.valueOf(-x.doubleValue()); + } + + public Number inc(Number x){ + return Double.valueOf(x.doubleValue() + 1); + } + + public Number dec(Number x){ + return Double.valueOf(x.doubleValue() - 1); + } +} + +final static class RatioOps extends OpsP{ + public Ops combine(Ops y){ + return y.opsWith(this); + } + + final public Ops opsWith(LongOps x){ + return this; + } + + final public Ops opsWith(DoubleOps x){ + return DOUBLE_OPS; + } + + final public Ops opsWith(RatioOps x){ + return this; + } + + final public Ops opsWith(BigIntOps x){ + return this; + } + + final public Ops opsWith(BigDecimalOps x){ + return BIGDECIMAL_OPS; + } + + public boolean isZero(Number x){ + Ratio r = (Ratio) x; + return r.numerator.signum() == 0; + } + + public boolean isPos(Number x){ + Ratio r = (Ratio) x; + return r.numerator.signum() > 0; + } + + public boolean isNeg(Number x){ + Ratio r = (Ratio) x; + return r.numerator.signum() < 0; + } + + static Number normalizeRet(Number ret, Number x, Number y){ +// if(ret instanceof BigInteger && !(x instanceof BigInteger || y instanceof BigInteger)) +// { +// return reduceBigInt((BigInteger) ret); +// } + return ret; + } + + final public Number add(Number x, Number y){ + Ratio rx = toRatio(x); + Ratio ry = toRatio(y); + Number ret = divide(ry.numerator.multiply(rx.denominator) + .add(rx.numerator.multiply(ry.denominator)) + , ry.denominator.multiply(rx.denominator)); + return normalizeRet(ret, x, y); + } + + final public Number multiply(Number x, Number y){ + Ratio rx = toRatio(x); + Ratio ry = toRatio(y); + Number ret = Numbers.divide(ry.numerator.multiply(rx.numerator) + , ry.denominator.multiply(rx.denominator)); + return normalizeRet(ret, x, y); + } + + public Number divide(Number x, Number y){ + Ratio rx = toRatio(x); + Ratio ry = toRatio(y); + Number ret = Numbers.divide(ry.denominator.multiply(rx.numerator) + , ry.numerator.multiply(rx.denominator)); + return normalizeRet(ret, x, y); + } + + public Number quotient(Number x, Number y){ + Ratio rx = toRatio(x); + Ratio ry = toRatio(y); + BigInteger q = rx.numerator.multiply(ry.denominator).divide( + rx.denominator.multiply(ry.numerator)); + return normalizeRet(BigInt.fromBigInteger(q), x, y); + } + + public Number remainder(Number x, Number y){ + Ratio rx = toRatio(x); + Ratio ry = toRatio(y); + BigInteger q = rx.numerator.multiply(ry.denominator).divide( + rx.denominator.multiply(ry.numerator)); + Number ret = Numbers.minus(x, Numbers.multiply(q, y)); + return normalizeRet(ret, x, y); + } + + public boolean equiv(Number x, Number y){ + Ratio rx = toRatio(x); + Ratio ry = toRatio(y); + return rx.numerator.equals(ry.numerator) + && rx.denominator.equals(ry.denominator); + } + + public boolean lt(Number x, Number y){ + Ratio rx = toRatio(x); + Ratio ry = toRatio(y); + return Numbers.lt(rx.numerator.multiply(ry.denominator), ry.numerator.multiply(rx.denominator)); + } + + public boolean lte(Number x, Number y){ + Ratio rx = toRatio(x); + Ratio ry = toRatio(y); + return Numbers.lte(rx.numerator.multiply(ry.denominator), ry.numerator.multiply(rx.denominator)); + } + + public boolean gte(Number x, Number y){ + Ratio rx = toRatio(x); + Ratio ry = toRatio(y); + return Numbers.gte(rx.numerator.multiply(ry.denominator), ry.numerator.multiply(rx.denominator)); + } + + //public Number subtract(Number x, Number y); + final public Number negate(Number x){ + Ratio r = (Ratio) x; + return new Ratio(r.numerator.negate(), r.denominator); + } + + public Number inc(Number x){ + return Numbers.add(x, 1); + } + + public Number dec(Number x){ + return Numbers.add(x, -1); + } + +} + +final static class BigIntOps extends OpsP{ + public Ops combine(Ops y){ + return y.opsWith(this); + } + + final public Ops opsWith(LongOps x){ + return this; + } + + final public Ops opsWith(DoubleOps x){ + return DOUBLE_OPS; + } + + final public Ops opsWith(RatioOps x){ + return RATIO_OPS; + } + + final public Ops opsWith(BigIntOps x){ + return this; + } + + final public Ops opsWith(BigDecimalOps x){ + return BIGDECIMAL_OPS; + } + + public boolean isZero(Number x){ + BigInt bx = toBigInt(x); + if(bx.bipart == null) + return bx.lpart == 0; + return bx.bipart.signum() == 0; + } + + public boolean isPos(Number x){ + BigInt bx = toBigInt(x); + if(bx.bipart == null) + return bx.lpart > 0; + return bx.bipart.signum() > 0; + } + + public boolean isNeg(Number x){ + BigInt bx = toBigInt(x); + if(bx.bipart == null) + return bx.lpart < 0; + return bx.bipart.signum() < 0; + } + + final public Number add(Number x, Number y){ + return toBigInt(x).add(toBigInt(y)); + } + + final public Number multiply(Number x, Number y){ + return toBigInt(x).multiply(toBigInt(y)); + } + + public Number divide(Number x, Number y){ + return Numbers.divide(toBigInteger(x), toBigInteger(y)); + } + + public Number quotient(Number x, Number y){ + return toBigInt(x).quotient(toBigInt(y)); + } + + public Number remainder(Number x, Number y){ + return toBigInt(x).remainder(toBigInt(y)); + } + + public boolean equiv(Number x, Number y){ + return toBigInt(x).equals(toBigInt(y)); + } + + public boolean lt(Number x, Number y){ + return toBigInt(x).lt(toBigInt(y)); + } + + public boolean lte(Number x, Number y){ + return toBigInteger(x).compareTo(toBigInteger(y)) <= 0; + } + + public boolean gte(Number x, Number y){ + return toBigInteger(x).compareTo(toBigInteger(y)) >= 0; + } + + //public Number subtract(Number x, Number y); + final public Number negate(Number x){ + return BigInt.fromBigInteger(toBigInteger(x).negate()); + } + + public Number inc(Number x){ + BigInteger bx = toBigInteger(x); + return BigInt.fromBigInteger(bx.add(BigInteger.ONE)); + } + + public Number dec(Number x){ + BigInteger bx = toBigInteger(x); + return BigInt.fromBigInteger(bx.subtract(BigInteger.ONE)); + } +} + + +final static class BigDecimalOps extends OpsP{ + final static Var MATH_CONTEXT = RT.MATH_CONTEXT; + + public Ops combine(Ops y){ + return y.opsWith(this); + } + + final public Ops opsWith(LongOps x){ + return this; + } + + final public Ops opsWith(DoubleOps x){ + return DOUBLE_OPS; + } + + final public Ops opsWith(RatioOps x){ + return this; + } + + final public Ops opsWith(BigIntOps x){ + return this; + } + + final public Ops opsWith(BigDecimalOps x){ + return this; + } + + public boolean isZero(Number x){ + BigDecimal bx = (BigDecimal) x; + return bx.signum() == 0; + } + + public boolean isPos(Number x){ + BigDecimal bx = (BigDecimal) x; + return bx.signum() > 0; + } + + public boolean isNeg(Number x){ + BigDecimal bx = (BigDecimal) x; + return bx.signum() < 0; + } + + final public Number add(Number x, Number y){ + MathContext mc = (MathContext) MATH_CONTEXT.deref(); + return mc == null + ? toBigDecimal(x).add(toBigDecimal(y)) + : toBigDecimal(x).add(toBigDecimal(y), mc); + } + + final public Number multiply(Number x, Number y){ + MathContext mc = (MathContext) MATH_CONTEXT.deref(); + return mc == null + ? toBigDecimal(x).multiply(toBigDecimal(y)) + : toBigDecimal(x).multiply(toBigDecimal(y), mc); + } + + public Number divide(Number x, Number y){ + MathContext mc = (MathContext) MATH_CONTEXT.deref(); + return mc == null + ? toBigDecimal(x).divide(toBigDecimal(y)) + : toBigDecimal(x).divide(toBigDecimal(y), mc); + } + + public Number quotient(Number x, Number y){ + MathContext mc = (MathContext) MATH_CONTEXT.deref(); + return mc == null + ? toBigDecimal(x).divideToIntegralValue(toBigDecimal(y)) + : toBigDecimal(x).divideToIntegralValue(toBigDecimal(y), mc); + } + + public Number remainder(Number x, Number y){ + MathContext mc = (MathContext) MATH_CONTEXT.deref(); + return mc == null + ? toBigDecimal(x).remainder(toBigDecimal(y)) + : toBigDecimal(x).remainder(toBigDecimal(y), mc); + } + + public boolean equiv(Number x, Number y){ + return toBigDecimal(x).compareTo(toBigDecimal(y)) == 0; + } + + public boolean lt(Number x, Number y){ + return toBigDecimal(x).compareTo(toBigDecimal(y)) < 0; + } + + public boolean lte(Number x, Number y){ + return toBigDecimal(x).compareTo(toBigDecimal(y)) <= 0; + } + + public boolean gte(Number x, Number y){ + return toBigDecimal(x).compareTo(toBigDecimal(y)) >= 0; + } + + //public Number subtract(Number x, Number y); + final public Number negate(Number x){ + MathContext mc = (MathContext) MATH_CONTEXT.deref(); + return mc == null + ? ((BigDecimal) x).negate() + : ((BigDecimal) x).negate(mc); + } + + public Number inc(Number x){ + MathContext mc = (MathContext) MATH_CONTEXT.deref(); + BigDecimal bx = (BigDecimal) x; + return mc == null + ? bx.add(BigDecimal.ONE) + : bx.add(BigDecimal.ONE, mc); + } + + public Number dec(Number x){ + MathContext mc = (MathContext) MATH_CONTEXT.deref(); + BigDecimal bx = (BigDecimal) x; + return mc == null + ? bx.subtract(BigDecimal.ONE) + : bx.subtract(BigDecimal.ONE, mc); + } +} + +static final LongOps LONG_OPS = new LongOps(); +static final DoubleOps DOUBLE_OPS = new DoubleOps(); +static final RatioOps RATIO_OPS = new RatioOps(); +static final BigIntOps BIGINT_OPS = new BigIntOps(); +static final BigDecimalOps BIGDECIMAL_OPS = new BigDecimalOps(); + +static public enum Category {INTEGER, FLOATING, DECIMAL, RATIO}; + +static Ops ops(Object x){ + Class xc = x.getClass(); + + if(xc == Long.class) + return LONG_OPS; + else if(xc == Double.class) + return DOUBLE_OPS; + else if(xc == Integer.class) + return LONG_OPS; + else if(xc == Float.class) + return DOUBLE_OPS; + else if(xc == BigInt.class) + return BIGINT_OPS; + else if(xc == BigInteger.class) + return BIGINT_OPS; + else if(xc == Ratio.class) + return RATIO_OPS; + else if(xc == BigDecimal.class) + return BIGDECIMAL_OPS; + else + return LONG_OPS; +} + +@WarnBoxedMath(false) +static int hasheqFrom(Number x, Class xc){ + if(xc == Integer.class + || xc == Short.class + || xc == Byte.class + || (xc == BigInteger.class && lte(x, Long.MAX_VALUE) && gte(x,Long.MIN_VALUE))) + { + long lpart = x.longValue(); + return Murmur3.hashLong(lpart); + //return (int) (lpart ^ (lpart >>> 32)); + } + if(xc == BigDecimal.class) + { + // stripTrailingZeros() to make all numerically equal + // BigDecimal values come out the same before calling + // hashCode. Special check for 0 because + // stripTrailingZeros() does not do anything to values + // equal to 0 with different scales. + if (isZero(x)) + return BigDecimal.ZERO.hashCode(); + else + { + BigDecimal tmp = ((BigDecimal) x).stripTrailingZeros(); + return tmp.hashCode(); + } + } + if(xc == Float.class && x.equals(-0.0f)) + { + return 0; // match 0.0f + } + return x.hashCode(); +} + +@WarnBoxedMath(false) +static int hasheq(Number x){ + Class xc = x.getClass(); + + if(xc == Long.class) + { + long lpart = x.longValue(); + return Murmur3.hashLong(lpart); + //return (int) (lpart ^ (lpart >>> 32)); + } + if(xc == Double.class) + { + if(x.equals(-0.0)) + return 0; // match 0.0 + return x.hashCode(); + } + return hasheqFrom(x, xc); +} + +static Category category(Object x){ + Class xc = x.getClass(); + + if(xc == Integer.class) + return Category.INTEGER; + else if(xc == Double.class) + return Category.FLOATING; + else if(xc == Long.class) + return Category.INTEGER; + else if(xc == Float.class) + return Category.FLOATING; + else if(xc == BigInt.class) + return Category.INTEGER; + else if(xc == Ratio.class) + return Category.RATIO; + else if(xc == BigDecimal.class) + return Category.DECIMAL; + else + return Category.INTEGER; +} + +static long bitOpsCast(Object x){ + Class xc = x.getClass(); + + if(xc == Long.class + || xc == Integer.class + || xc == Short.class + || xc == Byte.class) + return RT.longCast(x); + // no bignums, no decimals + throw new IllegalArgumentException("bit operation not supported for: " + xc); +} + + @WarnBoxedMath(false) + static public float[] float_array(int size, Object init){ + float[] ret = new float[size]; + if(init instanceof Number) + { + float f = ((Number) init).floatValue(); + for(int i = 0; i < ret.length; i++) + ret[i] = f; + } + else + { + ISeq s = RT.seq(init); + for(int i = 0; i < size && s != null; i++, s = s.next()) + ret[i] = ((Number) s.first()).floatValue(); + } + return ret; + } + + @WarnBoxedMath(false) + static public float[] float_array(Object sizeOrSeq){ + if(sizeOrSeq instanceof Number) + return new float[((Number) sizeOrSeq).intValue()]; + else + { + ISeq s = RT.seq(sizeOrSeq); + int size = RT.count(s); + float[] ret = new float[size]; + for(int i = 0; i < size && s != null; i++, s = s.next()) + ret[i] = ((Number) s.first()).floatValue(); + return ret; + } + } + +@WarnBoxedMath(false) +static public double[] double_array(int size, Object init){ + double[] ret = new double[size]; + if(init instanceof Number) + { + double f = ((Number) init).doubleValue(); + for(int i = 0; i < ret.length; i++) + ret[i] = f; + } + else + { + ISeq s = RT.seq(init); + for(int i = 0; i < size && s != null; i++, s = s.next()) + ret[i] = ((Number) s.first()).doubleValue(); + } + return ret; +} + +@WarnBoxedMath(false) +static public double[] double_array(Object sizeOrSeq){ + if(sizeOrSeq instanceof Number) + return new double[((Number) sizeOrSeq).intValue()]; + else + { + ISeq s = RT.seq(sizeOrSeq); + int size = RT.count(s); + double[] ret = new double[size]; + for(int i = 0; i < size && s != null; i++, s = s.next()) + ret[i] = ((Number) s.first()).doubleValue(); + return ret; + } +} + +@WarnBoxedMath(false) +static public int[] int_array(int size, Object init){ + int[] ret = new int[size]; + if(init instanceof Number) + { + int f = ((Number) init).intValue(); + for(int i = 0; i < ret.length; i++) + ret[i] = f; + } + else + { + ISeq s = RT.seq(init); + for(int i = 0; i < size && s != null; i++, s = s.next()) + ret[i] = ((Number) s.first()).intValue(); + } + return ret; +} + +@WarnBoxedMath(false) +static public int[] int_array(Object sizeOrSeq){ + if(sizeOrSeq instanceof Number) + return new int[((Number) sizeOrSeq).intValue()]; + else + { + ISeq s = RT.seq(sizeOrSeq); + int size = RT.count(s); + int[] ret = new int[size]; + for(int i = 0; i < size && s != null; i++, s = s.next()) + ret[i] = ((Number) s.first()).intValue(); + return ret; + } +} + +@WarnBoxedMath(false) +static public long[] long_array(int size, Object init){ + long[] ret = new long[size]; + if(init instanceof Number) + { + long f = ((Number) init).longValue(); + for(int i = 0; i < ret.length; i++) + ret[i] = f; + } + else + { + ISeq s = RT.seq(init); + for(int i = 0; i < size && s != null; i++, s = s.next()) + ret[i] = ((Number) s.first()).longValue(); + } + return ret; +} + +@WarnBoxedMath(false) +static public long[] long_array(Object sizeOrSeq){ + if(sizeOrSeq instanceof Number) + return new long[((Number) sizeOrSeq).intValue()]; + else + { + ISeq s = RT.seq(sizeOrSeq); + int size = RT.count(s); + long[] ret = new long[size]; + for(int i = 0; i < size && s != null; i++, s = s.next()) + ret[i] = ((Number) s.first()).longValue(); + return ret; + } +} + +@WarnBoxedMath(false) +static public short[] short_array(int size, Object init){ + short[] ret = new short[size]; + if(init instanceof Short) + { + short s = (Short) init; + for(int i = 0; i < ret.length; i++) + ret[i] = s; + } + else + { + ISeq s = RT.seq(init); + for(int i = 0; i < size && s != null; i++, s = s.next()) + ret[i] = ((Number) s.first()).shortValue(); + } + return ret; +} + +@WarnBoxedMath(false) +static public short[] short_array(Object sizeOrSeq){ + if(sizeOrSeq instanceof Number) + return new short[((Number) sizeOrSeq).intValue()]; + else + { + ISeq s = RT.seq(sizeOrSeq); + int size = RT.count(s); + short[] ret = new short[size]; + for(int i = 0; i < size && s != null; i++, s = s.next()) + ret[i] = ((Number) s.first()).shortValue(); + return ret; + } +} + +@WarnBoxedMath(false) +static public char[] char_array(int size, Object init){ + char[] ret = new char[size]; + if(init instanceof Character) + { + char c = (Character) init; + for(int i = 0; i < ret.length; i++) + ret[i] = c; + } + else + { + ISeq s = RT.seq(init); + for(int i = 0; i < size && s != null; i++, s = s.next()) + ret[i] = (Character) s.first(); + } + return ret; +} + +@WarnBoxedMath(false) +static public char[] char_array(Object sizeOrSeq){ + if(sizeOrSeq instanceof Number) + return new char[((Number) sizeOrSeq).intValue()]; + else + { + ISeq s = RT.seq(sizeOrSeq); + int size = RT.count(s); + char[] ret = new char[size]; + for(int i = 0; i < size && s != null; i++, s = s.next()) + ret[i] = (Character) s.first(); + return ret; + } +} + +@WarnBoxedMath(false) +static public byte[] byte_array(int size, Object init){ + byte[] ret = new byte[size]; + if(init instanceof Byte) + { + byte b = (Byte) init; + for(int i = 0; i < ret.length; i++) + ret[i] = b; + } + else + { + ISeq s = RT.seq(init); + for(int i = 0; i < size && s != null; i++, s = s.next()) + ret[i] = ((Number) s.first()).byteValue(); + } + return ret; +} + +@WarnBoxedMath(false) +static public byte[] byte_array(Object sizeOrSeq){ + if(sizeOrSeq instanceof Number) + return new byte[((Number) sizeOrSeq).intValue()]; + else + { + ISeq s = RT.seq(sizeOrSeq); + int size = RT.count(s); + byte[] ret = new byte[size]; + for(int i = 0; i < size && s != null; i++, s = s.next()) + ret[i] = ((Number) s.first()).byteValue(); + return ret; + } +} + +@WarnBoxedMath(false) +static public boolean[] boolean_array(int size, Object init){ + boolean[] ret = new boolean[size]; + if(init instanceof Boolean) + { + boolean b = (Boolean) init; + for(int i = 0; i < ret.length; i++) + ret[i] = b; + } + else + { + ISeq s = RT.seq(init); + for(int i = 0; i < size && s != null; i++, s = s.next()) + ret[i] = (Boolean)s.first(); + } + return ret; +} + +@WarnBoxedMath(false) +static public boolean[] boolean_array(Object sizeOrSeq){ + if(sizeOrSeq instanceof Number) + return new boolean[((Number) sizeOrSeq).intValue()]; + else + { + ISeq s = RT.seq(sizeOrSeq); + int size = RT.count(s); + boolean[] ret = new boolean[size]; + for(int i = 0; i < size && s != null; i++, s = s.next()) + ret[i] = (Boolean)s.first(); + return ret; + } +} + +@WarnBoxedMath(false) +static public boolean[] booleans(Object array){ + return (boolean[]) array; +} + +@WarnBoxedMath(false) +static public byte[] bytes(Object array){ + return (byte[]) array; +} + +@WarnBoxedMath(false) +static public char[] chars(Object array){ + return (char[]) array; +} + +@WarnBoxedMath(false) +static public short[] shorts(Object array){ + return (short[]) array; +} + +@WarnBoxedMath(false) +static public float[] floats(Object array){ + return (float[]) array; +} + +@WarnBoxedMath(false) +static public double[] doubles(Object array){ + return (double[]) array; +} + +@WarnBoxedMath(false) +static public int[] ints(Object array){ + return (int[]) array; +} + +@WarnBoxedMath(false) +static public long[] longs(Object array){ + return (long[]) array; +} + +static public Number num(Object x){ + return (Number) x; +} + +static public Number num(float x){ + return Float.valueOf(x); +} + +static public Number num(double x){ + return Double.valueOf(x); +} + +static public double add(double x, double y){ + return x + y; +} + +static public double addP(double x, double y){ + return x + y; +} + +static public double minus(double x, double y){ + return x - y; +} + +static public double minusP(double x, double y){ + return x - y; +} + +static public double minus(double x){ + return -x; +} + +static public double minusP(double x){ + return -x; +} + +static public double inc(double x){ + return x + 1; +} + +static public double incP(double x){ + return x + 1; +} + +static public double dec(double x){ + return x - 1; +} + +static public double decP(double x){ + return x - 1; +} + +static public double multiply(double x, double y){ + return x * y; +} + +static public double multiplyP(double x, double y){ + return x * y; +} + +static public double divide(double x, double y){ + return x / y; +} + +static public boolean equiv(double x, double y){ + return x == y; +} + +static public boolean lt(double x, double y){ + return x < y; +} + +static public boolean lte(double x, double y){ + return x <= y; +} + +static public boolean gt(double x, double y){ + return x > y; +} + +static public boolean gte(double x, double y){ + return x >= y; +} + +static public boolean isPos(double x){ + return x > 0; +} + +static public boolean isNeg(double x){ + return x < 0; +} + +static public boolean isZero(double x){ + return x == 0; +} + +static int throwIntOverflow(){ + throw new ArithmeticException("integer overflow"); +} + +//static public Number num(int x){ +// return Integer.valueOf(x); +//} + +static public int unchecked_int_add(int x, int y){ + return x + y; +} + +static public int unchecked_int_subtract(int x, int y){ + return x - y; +} + +static public int unchecked_int_negate(int x){ + return -x; +} + +static public int unchecked_int_inc(int x){ + return x + 1; +} + +static public int unchecked_int_dec(int x){ + return x - 1; +} + +static public int unchecked_int_multiply(int x, int y){ + return x * y; +} + +//static public int add(int x, int y){ +// int ret = x + y; +// if ((ret ^ x) < 0 && (ret ^ y) < 0) +// return throwIntOverflow(); +// return ret; +//} + +//static public int not(int x){ +// return ~x; +//} + +static public long not(Object x){ + return not(bitOpsCast(x)); +} +static public long not(long x){ + return ~x; +} +//static public int and(int x, int y){ +// return x & y; +//} + +static public long and(Object x, Object y){ + return and(bitOpsCast(x),bitOpsCast(y)); +} +static public long and(Object x, long y){ + return and(bitOpsCast(x),y); +} +static public long and(long x, Object y){ + return and(x,bitOpsCast(y)); +} +static public long and(long x, long y){ + return x & y; +} + +//static public int or(int x, int y){ +// return x | y; +//} + +static public long or(Object x, Object y){ + return or(bitOpsCast(x),bitOpsCast(y)); +} +static public long or(Object x, long y){ + return or(bitOpsCast(x),y); +} +static public long or(long x, Object y){ + return or(x,bitOpsCast(y)); +} +static public long or(long x, long y){ + return x | y; +} + +//static public int xor(int x, int y){ +// return x ^ y; +//} + +static public long xor(Object x, Object y){ + return xor(bitOpsCast(x),bitOpsCast(y)); +} +static public long xor(Object x, long y){ + return xor(bitOpsCast(x),y); +} +static public long xor(long x, Object y){ + return xor(x,bitOpsCast(y)); +} +static public long xor(long x, long y){ + return x ^ y; +} + +static public long andNot(Object x, Object y){ + return andNot(bitOpsCast(x),bitOpsCast(y)); +} +static public long andNot(Object x, long y){ + return andNot(bitOpsCast(x),y); +} +static public long andNot(long x, Object y){ + return andNot(x,bitOpsCast(y)); +} +static public long andNot(long x, long y){ + return x & ~y; +} + +static public long clearBit(Object x, Object y){ + return clearBit(bitOpsCast(x),bitOpsCast(y)); +} +static public long clearBit(Object x, long y){ + return clearBit(bitOpsCast(x),y); +} +static public long clearBit(long x, Object y){ + return clearBit(x,bitOpsCast(y)); +} +static public long clearBit(long x, long n){ + return x & ~(1L << n); +} + +static public long setBit(Object x, Object y){ + return setBit(bitOpsCast(x),bitOpsCast(y)); +} +static public long setBit(Object x, long y){ + return setBit(bitOpsCast(x),y); +} +static public long setBit(long x, Object y){ + return setBit(x,bitOpsCast(y)); +} +static public long setBit(long x, long n){ + return x | (1L << n); +} + +static public long flipBit(Object x, Object y){ + return flipBit(bitOpsCast(x),bitOpsCast(y)); +} +static public long flipBit(Object x, long y){ + return flipBit(bitOpsCast(x),y); +} +static public long flipBit(long x, Object y){ + return flipBit(x,bitOpsCast(y)); +} +static public long flipBit(long x, long n){ + return x ^ (1L << n); +} + +static public boolean testBit(Object x, Object y){ + return testBit(bitOpsCast(x),bitOpsCast(y)); +} +static public boolean testBit(Object x, long y){ + return testBit(bitOpsCast(x),y); +} +static public boolean testBit(long x, Object y){ + return testBit(x,bitOpsCast(y)); +} +static public boolean testBit(long x, long n){ + return (x & (1L << n)) != 0; +} + +//static public int minus(int x, int y){ +// int ret = x - y; +// if (((ret ^ x) < 0 && (ret ^ ~y) < 0)) +// return throwIntOverflow(); +// return ret; +//} + +//static public int minus(int x){ +// if(x == Integer.MIN_VALUE) +// return throwIntOverflow(); +// return -x; +//} + +//static public int inc(int x){ +// if(x == Integer.MAX_VALUE) +// return throwIntOverflow(); +// return x + 1; +//} + +//static public int dec(int x){ +// if(x == Integer.MIN_VALUE) +// return throwIntOverflow(); +// return x - 1; +//} + +//static public int multiply(int x, int y){ +// int ret = x * y; +// if (y != 0 && ret/y != x) +// return throwIntOverflow(); +// return ret; +//} + +static public int unchecked_int_divide(int x, int y){ + return x / y; +} + +static public int unchecked_int_remainder(int x, int y){ + return x % y; +} + +//static public boolean equiv(int x, int y){ +// return x == y; +//} + +//static public boolean lt(int x, int y){ +// return x < y; +//} + +//static public boolean lte(int x, int y){ +// return x <= y; +//} + +//static public boolean gt(int x, int y){ +// return x > y; +//} + +//static public boolean gte(int x, int y){ +// return x >= y; +//} + +//static public boolean isPos(int x){ +// return x > 0; +//} + +//static public boolean isNeg(int x){ +// return x < 0; +//} + +//static public boolean isZero(int x){ +// return x == 0; +//} + +static public Number num(long x){ + return Long.valueOf(x); +} + +static public long unchecked_add(long x, long y){return x + y;} +static public long unchecked_minus(long x, long y){return x - y;} +static public long unchecked_multiply(long x, long y){return x * y;} +static public long unchecked_minus(long x){return -x;} +static public long unchecked_inc(long x){return x + 1;} +static public long unchecked_dec(long x){return x - 1;} + +static public Number unchecked_add(Object x, Object y){ + return ops(x).combine(ops(y)).unchecked_add((Number)x, (Number)y); +} + +static public Number unchecked_minus(Object x, Object y){ + Ops yops = ops(y); + return ops(x).combine(yops).unchecked_add((Number)x, yops.unchecked_negate((Number)y)); +} + +static public Number unchecked_multiply(Object x, Object y){ + return ops(x).combine(ops(y)).unchecked_multiply((Number)x, (Number)y); +} + +static public Number unchecked_minus(Object x){ + return ops(x).unchecked_negate((Number)x); +} + +static public Number unchecked_inc(Object x){ + return ops(x).unchecked_inc((Number)x); +} + +static public Number unchecked_dec(Object x){ + return ops(x).unchecked_dec((Number)x); +} + +static public double unchecked_add(double x, double y){return add(x,y);} +static public double unchecked_minus(double x, double y){return minus(x,y);} +static public double unchecked_multiply(double x, double y){return multiply(x,y);} +static public double unchecked_minus(double x){return minus(x);} +static public double unchecked_inc(double x){return inc(x);} +static public double unchecked_dec(double x){return dec(x);} + +static public double unchecked_add(double x, Object y){return add(x,y);} +static public double unchecked_minus(double x, Object y){return minus(x,y);} +static public double unchecked_multiply(double x, Object y){return multiply(x,y);} +static public double unchecked_add(Object x, double y){return add(x,y);} +static public double unchecked_minus(Object x, double y){return minus(x,y);} +static public double unchecked_multiply(Object x, double y){return multiply(x,y);} + +static public double unchecked_add(double x, long y){return add(x,y);} +static public double unchecked_minus(double x, long y){return minus(x,y);} +static public double unchecked_multiply(double x, long y){return multiply(x,y);} +static public double unchecked_add(long x, double y){return add(x,y);} +static public double unchecked_minus(long x, double y){return minus(x,y);} +static public double unchecked_multiply(long x, double y){return multiply(x,y);} + +static public Number unchecked_add(long x, Object y){return unchecked_add((Object)x,y);} +static public Number unchecked_minus(long x, Object y){return unchecked_minus((Object)x,y);} +static public Number unchecked_multiply(long x, Object y){return unchecked_multiply((Object)x,y);} +static public Number unchecked_add(Object x, long y){return unchecked_add(x,(Object)y);} +static public Number unchecked_minus(Object x, long y){return unchecked_minus(x,(Object)y);} +static public Number unchecked_multiply(Object x, long y){return unchecked_multiply(x,(Object)y);} + +static public Number quotient(double x, Object y){return quotient((Object)x,y);} +static public Number quotient(Object x, double y){return quotient(x,(Object)y);} +static public Number quotient(long x, Object y){return quotient((Object)x,y);} +static public Number quotient(Object x, long y){return quotient(x,(Object)y);} +static public double quotient(double x, long y){return quotient(x,(double)y);} +static public double quotient(long x, double y){return quotient((double)x,y);} + +static public Number remainder(double x, Object y){return remainder((Object)x,y);} +static public Number remainder(Object x, double y){return remainder(x,(Object)y);} +static public Number remainder(long x, Object y){return remainder((Object)x,y);} +static public Number remainder(Object x, long y){return remainder(x,(Object)y);} +static public double remainder(double x, long y){return remainder(x,(double)y);} +static public double remainder(long x, double y){return remainder((double)x,y);} + +static public long add(long x, long y){ + long ret = x + y; + if ((ret ^ x) < 0 && (ret ^ y) < 0) + return throwIntOverflow(); + return ret; +} + +static public Number addP(long x, long y){ + long ret = x + y; + if ((ret ^ x) < 0 && (ret ^ y) < 0) + return addP((Number)x,(Number)y); + return num(ret); +} + +static public long minus(long x, long y){ + long ret = x - y; + if (((ret ^ x) < 0 && (ret ^ ~y) < 0)) + return throwIntOverflow(); + return ret; +} + +static public Number minusP(long x, long y){ + long ret = x - y; + if (((ret ^ x) < 0 && (ret ^ ~y) < 0)) + return minusP((Number)x,(Number)y); + return num(ret); +} + +static public long minus(long x){ + if(x == Long.MIN_VALUE) + return throwIntOverflow(); + return -x; +} + +static public Number minusP(long x){ + if(x == Long.MIN_VALUE) + return BigInt.fromBigInteger(BigInteger.valueOf(x).negate()); + return num(-x); +} + +static public long inc(long x){ + if(x == Long.MAX_VALUE) + return throwIntOverflow(); + return x + 1; +} + +static public Number incP(long x){ + if(x == Long.MAX_VALUE) + return BIGINT_OPS.inc(x); + return num(x + 1); +} + +static public long dec(long x){ + if(x == Long.MIN_VALUE) + return throwIntOverflow(); + return x - 1; +} + +static public Number decP(long x){ + if(x == Long.MIN_VALUE) + return BIGINT_OPS.dec(x); + return num(x - 1); +} + + +static public long multiply(long x, long y){ + if (x == Long.MIN_VALUE && y < 0) + return throwIntOverflow(); + long ret = x * y; + if (y != 0 && ret/y != x) + return throwIntOverflow(); + return ret; +} + +static public Number multiplyP(long x, long y){ + if (x == Long.MIN_VALUE && y < 0) + return multiplyP((Number)x,(Number)y); + long ret = x * y; + if (y != 0 && ret/y != x) + return multiplyP((Number)x,(Number)y); + return num(ret); +} + +static public long quotient(long x, long y){ + return x / y; +} + +static public long remainder(long x, long y){ + return x % y; +} + +static public boolean equiv(long x, long y){ + return x == y; +} + +static public boolean lt(long x, long y){ + return x < y; +} + +static public boolean lte(long x, long y){ + return x <= y; +} + +static public boolean gt(long x, long y){ + return x > y; +} + +static public boolean gte(long x, long y){ + return x >= y; +} + +static public boolean isPos(long x){ + return x > 0; +} + +static public boolean isNeg(long x){ + return x < 0; +} + +static public boolean isZero(long x){ + return x == 0; +} + +/* +static public class F{ + static public float add(float x, float y){ + return x + y; + } + + static public float subtract(float x, float y){ + return x - y; + } + + static public float negate(float x){ + return -x; + } + + static public float inc(float x){ + return x + 1; + } + + static public float dec(float x){ + return x - 1; + } + + static public float multiply(float x, float y){ + return x * y; + } + + static public float divide(float x, float y){ + return x / y; + } + + static public boolean equiv(float x, float y){ + return x == y; + } + + static public boolean lt(float x, float y){ + return x < y; + } + + static public boolean lte(float x, float y){ + return x <= y; + } + + static public boolean gt(float x, float y){ + return x > y; + } + + static public boolean gte(float x, float y){ + return x >= y; + } + + static public boolean pos(float x){ + return x > 0; + } + + static public boolean neg(float x){ + return x < 0; + } + + static public boolean zero(float x){ + return x == 0; + } + + static public float aget(float[] xs, int i){ + return xs[i]; + } + + static public float aset(float[] xs, int i, float v){ + xs[i] = v; + return v; + } + + static public int alength(float[] xs){ + return xs.length; + } + + static public float[] aclone(float[] xs){ + return xs.clone(); + } + + static public float[] vec(int size, Object init){ + float[] ret = new float[size]; + if(init instanceof Number) + { + float f = ((Number) init).floatValue(); + for(int i = 0; i < ret.length; i++) + ret[i] = f; + } + else + { + ISeq s = RT.seq(init); + for(int i = 0; i < size && s != null; i++, s = s.rest()) + ret[i] = ((Number) s.first()).floatValue(); + } + return ret; + } + + static public float[] vec(Object sizeOrSeq){ + if(sizeOrSeq instanceof Number) + return new float[((Number) sizeOrSeq).intValue()]; + else + { + ISeq s = RT.seq(sizeOrSeq); + int size = s.count(); + float[] ret = new float[size]; + for(int i = 0; i < size && s != null; i++, s = s.rest()) + ret[i] = ((Number) s.first()).intValue(); + return ret; + } + } + + + static public float[] vsadd(float[] x, float y){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] += y; + return xs; + } + + static public float[] vssub(float[] x, float y){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] -= y; + return xs; + } + + static public float[] vsdiv(float[] x, float y){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] /= y; + return xs; + } + + static public float[] vsmul(float[] x, float y){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] *= y; + return xs; + } + + static public float[] svdiv(float y, float[] x){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = y / xs[i]; + return xs; + } + + static public float[] vsmuladd(float[] x, float y, float[] zs){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[i] * y + zs[i]; + return xs; + } + + static public float[] vsmulsub(float[] x, float y, float[] zs){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[i] * y - zs[i]; + return xs; + } + + static public float[] vsmulsadd(float[] x, float y, float z){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[i] * y + z; + return xs; + } + + static public float[] vsmulssub(float[] x, float y, float z){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[i] * y - z; + return xs; + } + + static public float[] vabs(float[] x){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = Math.abs(xs[i]); + return xs; + } + + static public float[] vnegabs(float[] x){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = -Math.abs(xs[i]); + return xs; + } + + static public float[] vneg(float[] x){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = -xs[i]; + return xs; + } + + static public float[] vsqr(float[] x){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] *= xs[i]; + return xs; + } + + static public float[] vsignedsqr(float[] x){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] *= Math.abs(xs[i]); + return xs; + } + + static public float[] vclip(float[] x, float low, float high){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + { + if(xs[i] < low) + xs[i] = low; + else if(xs[i] > high) + xs[i] = high; + } + return xs; + } + + static public IPersistentVector vclipcounts(float[] x, float low, float high){ + final float[] xs = x.clone(); + int lowc = 0; + int highc = 0; + + for(int i = 0; i < xs.length; i++) + { + if(xs[i] < low) + { + ++lowc; + xs[i] = low; + } + else if(xs[i] > high) + { + ++highc; + xs[i] = high; + } + } + return RT.vector(xs, lowc, highc); + } + + static public float[] vthresh(float[] x, float thresh, float otherwise){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + { + if(xs[i] < thresh) + xs[i] = otherwise; + } + return xs; + } + + static public float[] vreverse(float[] x){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[xs.length - i - 1]; + return xs; + } + + static public float[] vrunningsum(float[] x){ + final float[] xs = x.clone(); + for(int i = 1; i < xs.length; i++) + xs[i] = xs[i - 1] + xs[i]; + return xs; + } + + static public float[] vsort(float[] x){ + final float[] xs = x.clone(); + Arrays.sort(xs); + return xs; + } + + static public float vdot(float[] xs, float[] ys){ + float ret = 0; + for(int i = 0; i < xs.length; i++) + ret += xs[i] * ys[i]; + return ret; + } + + static public float vmax(float[] xs){ + if(xs.length == 0) + return 0; + float ret = xs[0]; + for(int i = 0; i < xs.length; i++) + ret = Math.max(ret, xs[i]); + return ret; + } + + static public float vmin(float[] xs){ + if(xs.length == 0) + return 0; + float ret = xs[0]; + for(int i = 0; i < xs.length; i++) + ret = Math.min(ret, xs[i]); + return ret; + } + + static public float vmean(float[] xs){ + if(xs.length == 0) + return 0; + return vsum(xs) / xs.length; + } + + static public double vrms(float[] xs){ + if(xs.length == 0) + return 0; + float ret = 0; + for(int i = 0; i < xs.length; i++) + ret += xs[i] * xs[i]; + return Math.sqrt(ret / xs.length); + } + + static public float vsum(float[] xs){ + float ret = 0; + for(int i = 0; i < xs.length; i++) + ret += xs[i]; + return ret; + } + + static public boolean vequiv(float[] xs, float[] ys){ + return Arrays.equals(xs, ys); + } + + static public float[] vadd(float[] x, float[] ys){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] += ys[i]; + return xs; + } + + static public float[] vsub(float[] x, float[] ys){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] -= ys[i]; + return xs; + } + + static public float[] vaddmul(float[] x, float[] ys, float[] zs){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] + ys[i]) * zs[i]; + return xs; + } + + static public float[] vsubmul(float[] x, float[] ys, float[] zs){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] - ys[i]) * zs[i]; + return xs; + } + + static public float[] vaddsmul(float[] x, float[] ys, float z){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] + ys[i]) * z; + return xs; + } + + static public float[] vsubsmul(float[] x, float[] ys, float z){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] - ys[i]) * z; + return xs; + } + + static public float[] vmulsadd(float[] x, float[] ys, float z){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] * ys[i]) + z; + return xs; + } + + static public float[] vdiv(float[] x, float[] ys){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] /= ys[i]; + return xs; + } + + static public float[] vmul(float[] x, float[] ys){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] *= ys[i]; + return xs; + } + + static public float[] vmuladd(float[] x, float[] ys, float[] zs){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] * ys[i]) + zs[i]; + return xs; + } + + static public float[] vmulsub(float[] x, float[] ys, float[] zs){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] * ys[i]) - zs[i]; + return xs; + } + + static public float[] vmax(float[] x, float[] ys){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = Math.max(xs[i], ys[i]); + return xs; + } + + static public float[] vmin(float[] x, float[] ys){ + final float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = Math.min(xs[i], ys[i]); + return xs; + } + + static public float[] vmap(IFn fn, float[] x) { + float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = ((Number) fn.invoke(xs[i])).floatValue(); + return xs; + } + + static public float[] vmap(IFn fn, float[] x, float[] ys) { + float[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = ((Number) fn.invoke(xs[i], ys[i])).floatValue(); + return xs; + } + +} + +static public class D{ + static public double add(double x, double y){ + return x + y; + } + + static public double subtract(double x, double y){ + return x - y; + } + + static public double negate(double x){ + return -x; + } + + static public double inc(double x){ + return x + 1; + } + + static public double dec(double x){ + return x - 1; + } + + static public double multiply(double x, double y){ + return x * y; + } + + static public double divide(double x, double y){ + return x / y; + } + + static public boolean equiv(double x, double y){ + return x == y; + } + + static public boolean lt(double x, double y){ + return x < y; + } + + static public boolean lte(double x, double y){ + return x <= y; + } + + static public boolean gt(double x, double y){ + return x > y; + } + + static public boolean gte(double x, double y){ + return x >= y; + } + + static public boolean pos(double x){ + return x > 0; + } + + static public boolean neg(double x){ + return x < 0; + } + + static public boolean zero(double x){ + return x == 0; + } + + static public double aget(double[] xs, int i){ + return xs[i]; + } + + static public double aset(double[] xs, int i, double v){ + xs[i] = v; + return v; + } + + static public int alength(double[] xs){ + return xs.length; + } + + static public double[] aclone(double[] xs){ + return xs.clone(); + } + + static public double[] vec(int size, Object init){ + double[] ret = new double[size]; + if(init instanceof Number) + { + double f = ((Number) init).doubleValue(); + for(int i = 0; i < ret.length; i++) + ret[i] = f; + } + else + { + ISeq s = RT.seq(init); + for(int i = 0; i < size && s != null; i++, s = s.rest()) + ret[i] = ((Number) s.first()).doubleValue(); + } + return ret; + } + + static public double[] vec(Object sizeOrSeq){ + if(sizeOrSeq instanceof Number) + return new double[((Number) sizeOrSeq).intValue()]; + else + { + ISeq s = RT.seq(sizeOrSeq); + int size = s.count(); + double[] ret = new double[size]; + for(int i = 0; i < size && s != null; i++, s = s.rest()) + ret[i] = ((Number) s.first()).intValue(); + return ret; + } + } + + static public double[] vsadd(double[] x, double y){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] += y; + return xs; + } + + static public double[] vssub(double[] x, double y){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] -= y; + return xs; + } + + static public double[] vsdiv(double[] x, double y){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] /= y; + return xs; + } + + static public double[] vsmul(double[] x, double y){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] *= y; + return xs; + } + + static public double[] svdiv(double y, double[] x){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = y / xs[i]; + return xs; + } + + static public double[] vsmuladd(double[] x, double y, double[] zs){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[i] * y + zs[i]; + return xs; + } + + static public double[] vsmulsub(double[] x, double y, double[] zs){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[i] * y - zs[i]; + return xs; + } + + static public double[] vsmulsadd(double[] x, double y, double z){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[i] * y + z; + return xs; + } + + static public double[] vsmulssub(double[] x, double y, double z){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[i] * y - z; + return xs; + } + + static public double[] vabs(double[] x){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = Math.abs(xs[i]); + return xs; + } + + static public double[] vnegabs(double[] x){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = -Math.abs(xs[i]); + return xs; + } + + static public double[] vneg(double[] x){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = -xs[i]; + return xs; + } + + static public double[] vsqr(double[] x){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] *= xs[i]; + return xs; + } + + static public double[] vsignedsqr(double[] x){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] *= Math.abs(xs[i]); + return xs; + } + + static public double[] vclip(double[] x, double low, double high){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + { + if(xs[i] < low) + xs[i] = low; + else if(xs[i] > high) + xs[i] = high; + } + return xs; + } + + static public IPersistentVector vclipcounts(double[] x, double low, double high){ + final double[] xs = x.clone(); + int lowc = 0; + int highc = 0; + + for(int i = 0; i < xs.length; i++) + { + if(xs[i] < low) + { + ++lowc; + xs[i] = low; + } + else if(xs[i] > high) + { + ++highc; + xs[i] = high; + } + } + return RT.vector(xs, lowc, highc); + } + + static public double[] vthresh(double[] x, double thresh, double otherwise){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + { + if(xs[i] < thresh) + xs[i] = otherwise; + } + return xs; + } + + static public double[] vreverse(double[] x){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[xs.length - i - 1]; + return xs; + } + + static public double[] vrunningsum(double[] x){ + final double[] xs = x.clone(); + for(int i = 1; i < xs.length; i++) + xs[i] = xs[i - 1] + xs[i]; + return xs; + } + + static public double[] vsort(double[] x){ + final double[] xs = x.clone(); + Arrays.sort(xs); + return xs; + } + + static public double vdot(double[] xs, double[] ys){ + double ret = 0; + for(int i = 0; i < xs.length; i++) + ret += xs[i] * ys[i]; + return ret; + } + + static public double vmax(double[] xs){ + if(xs.length == 0) + return 0; + double ret = xs[0]; + for(int i = 0; i < xs.length; i++) + ret = Math.max(ret, xs[i]); + return ret; + } + + static public double vmin(double[] xs){ + if(xs.length == 0) + return 0; + double ret = xs[0]; + for(int i = 0; i < xs.length; i++) + ret = Math.min(ret, xs[i]); + return ret; + } + + static public double vmean(double[] xs){ + if(xs.length == 0) + return 0; + return vsum(xs) / xs.length; + } + + static public double vrms(double[] xs){ + if(xs.length == 0) + return 0; + double ret = 0; + for(int i = 0; i < xs.length; i++) + ret += xs[i] * xs[i]; + return Math.sqrt(ret / xs.length); + } + + static public double vsum(double[] xs){ + double ret = 0; + for(int i = 0; i < xs.length; i++) + ret += xs[i]; + return ret; + } + + static public boolean vequiv(double[] xs, double[] ys){ + return Arrays.equals(xs, ys); + } + + static public double[] vadd(double[] x, double[] ys){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] += ys[i]; + return xs; + } + + static public double[] vsub(double[] x, double[] ys){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] -= ys[i]; + return xs; + } + + static public double[] vaddmul(double[] x, double[] ys, double[] zs){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] + ys[i]) * zs[i]; + return xs; + } + + static public double[] vsubmul(double[] x, double[] ys, double[] zs){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] - ys[i]) * zs[i]; + return xs; + } + + static public double[] vaddsmul(double[] x, double[] ys, double z){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] + ys[i]) * z; + return xs; + } + + static public double[] vsubsmul(double[] x, double[] ys, double z){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] - ys[i]) * z; + return xs; + } + + static public double[] vmulsadd(double[] x, double[] ys, double z){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] * ys[i]) + z; + return xs; + } + + static public double[] vdiv(double[] x, double[] ys){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] /= ys[i]; + return xs; + } + + static public double[] vmul(double[] x, double[] ys){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] *= ys[i]; + return xs; + } + + static public double[] vmuladd(double[] x, double[] ys, double[] zs){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] * ys[i]) + zs[i]; + return xs; + } + + static public double[] vmulsub(double[] x, double[] ys, double[] zs){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] * ys[i]) - zs[i]; + return xs; + } + + static public double[] vmax(double[] x, double[] ys){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = Math.max(xs[i], ys[i]); + return xs; + } + + static public double[] vmin(double[] x, double[] ys){ + final double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = Math.min(xs[i], ys[i]); + return xs; + } + + static public double[] vmap(IFn fn, double[] x) { + double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = ((Number) fn.invoke(xs[i])).doubleValue(); + return xs; + } + + static public double[] vmap(IFn fn, double[] x, double[] ys) { + double[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = ((Number) fn.invoke(xs[i], ys[i])).doubleValue(); + return xs; + } +} + +static public class I{ + static public int add(int x, int y){ + return x + y; + } + + static public int subtract(int x, int y){ + return x - y; + } + + static public int negate(int x){ + return -x; + } + + static public int inc(int x){ + return x + 1; + } + + static public int dec(int x){ + return x - 1; + } + + static public int multiply(int x, int y){ + return x * y; + } + + static public int divide(int x, int y){ + return x / y; + } + + static public boolean equiv(int x, int y){ + return x == y; + } + + static public boolean lt(int x, int y){ + return x < y; + } + + static public boolean lte(int x, int y){ + return x <= y; + } + + static public boolean gt(int x, int y){ + return x > y; + } + + static public boolean gte(int x, int y){ + return x >= y; + } + + static public boolean pos(int x){ + return x > 0; + } + + static public boolean neg(int x){ + return x < 0; + } + + static public boolean zero(int x){ + return x == 0; + } + + static public int aget(int[] xs, int i){ + return xs[i]; + } + + static public int aset(int[] xs, int i, int v){ + xs[i] = v; + return v; + } + + static public int alength(int[] xs){ + return xs.length; + } + + static public int[] aclone(int[] xs){ + return xs.clone(); + } + + static public int[] vec(int size, Object init){ + int[] ret = new int[size]; + if(init instanceof Number) + { + int f = ((Number) init).intValue(); + for(int i = 0; i < ret.length; i++) + ret[i] = f; + } + else + { + ISeq s = RT.seq(init); + for(int i = 0; i < size && s != null; i++, s = s.rest()) + ret[i] = ((Number) s.first()).intValue(); + } + return ret; + } + + static public int[] vec(Object sizeOrSeq){ + if(sizeOrSeq instanceof Number) + return new int[((Number) sizeOrSeq).intValue()]; + else + { + ISeq s = RT.seq(sizeOrSeq); + int size = s.count(); + int[] ret = new int[size]; + for(int i = 0; i < size && s != null; i++, s = s.rest()) + ret[i] = ((Number) s.first()).intValue(); + return ret; + } + } + + static public int[] vsadd(int[] x, int y){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] += y; + return xs; + } + + static public int[] vssub(int[] x, int y){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] -= y; + return xs; + } + + static public int[] vsdiv(int[] x, int y){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] /= y; + return xs; + } + + static public int[] vsmul(int[] x, int y){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] *= y; + return xs; + } + + static public int[] svdiv(int y, int[] x){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = y / xs[i]; + return xs; + } + + static public int[] vsmuladd(int[] x, int y, int[] zs){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[i] * y + zs[i]; + return xs; + } + + static public int[] vsmulsub(int[] x, int y, int[] zs){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[i] * y - zs[i]; + return xs; + } + + static public int[] vsmulsadd(int[] x, int y, int z){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[i] * y + z; + return xs; + } + + static public int[] vsmulssub(int[] x, int y, int z){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[i] * y - z; + return xs; + } + + static public int[] vabs(int[] x){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = Math.abs(xs[i]); + return xs; + } + + static public int[] vnegabs(int[] x){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = -Math.abs(xs[i]); + return xs; + } + + static public int[] vneg(int[] x){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = -xs[i]; + return xs; + } + + static public int[] vsqr(int[] x){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] *= xs[i]; + return xs; + } + + static public int[] vsignedsqr(int[] x){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] *= Math.abs(xs[i]); + return xs; + } + + static public int[] vclip(int[] x, int low, int high){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + { + if(xs[i] < low) + xs[i] = low; + else if(xs[i] > high) + xs[i] = high; + } + return xs; + } + + static public IPersistentVector vclipcounts(int[] x, int low, int high){ + final int[] xs = x.clone(); + int lowc = 0; + int highc = 0; + + for(int i = 0; i < xs.length; i++) + { + if(xs[i] < low) + { + ++lowc; + xs[i] = low; + } + else if(xs[i] > high) + { + ++highc; + xs[i] = high; + } + } + return RT.vector(xs, lowc, highc); + } + + static public int[] vthresh(int[] x, int thresh, int otherwise){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + { + if(xs[i] < thresh) + xs[i] = otherwise; + } + return xs; + } + + static public int[] vreverse(int[] x){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[xs.length - i - 1]; + return xs; + } + + static public int[] vrunningsum(int[] x){ + final int[] xs = x.clone(); + for(int i = 1; i < xs.length; i++) + xs[i] = xs[i - 1] + xs[i]; + return xs; + } + + static public int[] vsort(int[] x){ + final int[] xs = x.clone(); + Arrays.sort(xs); + return xs; + } + + static public int vdot(int[] xs, int[] ys){ + int ret = 0; + for(int i = 0; i < xs.length; i++) + ret += xs[i] * ys[i]; + return ret; + } + + static public int vmax(int[] xs){ + if(xs.length == 0) + return 0; + int ret = xs[0]; + for(int i = 0; i < xs.length; i++) + ret = Math.max(ret, xs[i]); + return ret; + } + + static public int vmin(int[] xs){ + if(xs.length == 0) + return 0; + int ret = xs[0]; + for(int i = 0; i < xs.length; i++) + ret = Math.min(ret, xs[i]); + return ret; + } + + static public double vmean(int[] xs){ + if(xs.length == 0) + return 0; + return vsum(xs) / (double) xs.length; + } + + static public double vrms(int[] xs){ + if(xs.length == 0) + return 0; + int ret = 0; + for(int i = 0; i < xs.length; i++) + ret += xs[i] * xs[i]; + return Math.sqrt(ret / (double) xs.length); + } + + static public int vsum(int[] xs){ + int ret = 0; + for(int i = 0; i < xs.length; i++) + ret += xs[i]; + return ret; + } + + static public boolean vequiv(int[] xs, int[] ys){ + return Arrays.equals(xs, ys); + } + + static public int[] vadd(int[] x, int[] ys){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] += ys[i]; + return xs; + } + + static public int[] vsub(int[] x, int[] ys){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] -= ys[i]; + return xs; + } + + static public int[] vaddmul(int[] x, int[] ys, int[] zs){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] + ys[i]) * zs[i]; + return xs; + } + + static public int[] vsubmul(int[] x, int[] ys, int[] zs){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] - ys[i]) * zs[i]; + return xs; + } + + static public int[] vaddsmul(int[] x, int[] ys, int z){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] + ys[i]) * z; + return xs; + } + + static public int[] vsubsmul(int[] x, int[] ys, int z){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] - ys[i]) * z; + return xs; + } + + static public int[] vmulsadd(int[] x, int[] ys, int z){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] * ys[i]) + z; + return xs; + } + + static public int[] vdiv(int[] x, int[] ys){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] /= ys[i]; + return xs; + } + + static public int[] vmul(int[] x, int[] ys){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] *= ys[i]; + return xs; + } + + static public int[] vmuladd(int[] x, int[] ys, int[] zs){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] * ys[i]) + zs[i]; + return xs; + } + + static public int[] vmulsub(int[] x, int[] ys, int[] zs){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] * ys[i]) - zs[i]; + return xs; + } + + static public int[] vmax(int[] x, int[] ys){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = Math.max(xs[i], ys[i]); + return xs; + } + + static public int[] vmin(int[] x, int[] ys){ + final int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = Math.min(xs[i], ys[i]); + return xs; + } + + static public int[] vmap(IFn fn, int[] x) { + int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = ((Number) fn.invoke(xs[i])).intValue(); + return xs; + } + + static public int[] vmap(IFn fn, int[] x, int[] ys) { + int[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = ((Number) fn.invoke(xs[i], ys[i])).intValue(); + return xs; + } + +} + +static public class L{ + static public long add(long x, long y){ + return x + y; + } + + static public long subtract(long x, long y){ + return x - y; + } + + static public long negate(long x){ + return -x; + } + + static public long inc(long x){ + return x + 1; + } + + static public long dec(long x){ + return x - 1; + } + + static public long multiply(long x, long y){ + return x * y; + } + + static public long divide(long x, long y){ + return x / y; + } + + static public boolean equiv(long x, long y){ + return x == y; + } + + static public boolean lt(long x, long y){ + return x < y; + } + + static public boolean lte(long x, long y){ + return x <= y; + } + + static public boolean gt(long x, long y){ + return x > y; + } + + static public boolean gte(long x, long y){ + return x >= y; + } + + static public boolean pos(long x){ + return x > 0; + } + + static public boolean neg(long x){ + return x < 0; + } + + static public boolean zero(long x){ + return x == 0; + } + + static public long aget(long[] xs, int i){ + return xs[i]; + } + + static public long aset(long[] xs, int i, long v){ + xs[i] = v; + return v; + } + + static public int alength(long[] xs){ + return xs.length; + } + + static public long[] aclone(long[] xs){ + return xs.clone(); + } + + static public long[] vec(int size, Object init){ + long[] ret = new long[size]; + if(init instanceof Number) + { + long f = ((Number) init).longValue(); + for(int i = 0; i < ret.length; i++) + ret[i] = f; + } + else + { + ISeq s = RT.seq(init); + for(int i = 0; i < size && s != null; i++, s = s.rest()) + ret[i] = ((Number) s.first()).longValue(); + } + return ret; + } + + static public long[] vec(Object sizeOrSeq){ + if(sizeOrSeq instanceof Number) + return new long[((Number) sizeOrSeq).intValue()]; + else + { + ISeq s = RT.seq(sizeOrSeq); + int size = s.count(); + long[] ret = new long[size]; + for(int i = 0; i < size && s != null; i++, s = s.rest()) + ret[i] = ((Number) s.first()).intValue(); + return ret; + } + } + + + static public long[] vsadd(long[] x, long y){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] += y; + return xs; + } + + static public long[] vssub(long[] x, long y){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] -= y; + return xs; + } + + static public long[] vsdiv(long[] x, long y){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] /= y; + return xs; + } + + static public long[] vsmul(long[] x, long y){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] *= y; + return xs; + } + + static public long[] svdiv(long y, long[] x){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = y / xs[i]; + return xs; + } + + static public long[] vsmuladd(long[] x, long y, long[] zs){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[i] * y + zs[i]; + return xs; + } + + static public long[] vsmulsub(long[] x, long y, long[] zs){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[i] * y - zs[i]; + return xs; + } + + static public long[] vsmulsadd(long[] x, long y, long z){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[i] * y + z; + return xs; + } + + static public long[] vsmulssub(long[] x, long y, long z){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[i] * y - z; + return xs; + } + + static public long[] vabs(long[] x){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = Math.abs(xs[i]); + return xs; + } + + static public long[] vnegabs(long[] x){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = -Math.abs(xs[i]); + return xs; + } + + static public long[] vneg(long[] x){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = -xs[i]; + return xs; + } + + static public long[] vsqr(long[] x){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] *= xs[i]; + return xs; + } + + static public long[] vsignedsqr(long[] x){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] *= Math.abs(xs[i]); + return xs; + } + + static public long[] vclip(long[] x, long low, long high){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + { + if(xs[i] < low) + xs[i] = low; + else if(xs[i] > high) + xs[i] = high; + } + return xs; + } + + static public IPersistentVector vclipcounts(long[] x, long low, long high){ + final long[] xs = x.clone(); + int lowc = 0; + int highc = 0; + + for(int i = 0; i < xs.length; i++) + { + if(xs[i] < low) + { + ++lowc; + xs[i] = low; + } + else if(xs[i] > high) + { + ++highc; + xs[i] = high; + } + } + return RT.vector(xs, lowc, highc); + } + + static public long[] vthresh(long[] x, long thresh, long otherwise){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + { + if(xs[i] < thresh) + xs[i] = otherwise; + } + return xs; + } + + static public long[] vreverse(long[] x){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = xs[xs.length - i - 1]; + return xs; + } + + static public long[] vrunningsum(long[] x){ + final long[] xs = x.clone(); + for(int i = 1; i < xs.length; i++) + xs[i] = xs[i - 1] + xs[i]; + return xs; + } + + static public long[] vsort(long[] x){ + final long[] xs = x.clone(); + Arrays.sort(xs); + return xs; + } + + static public long vdot(long[] xs, long[] ys){ + long ret = 0; + for(int i = 0; i < xs.length; i++) + ret += xs[i] * ys[i]; + return ret; + } + + static public long vmax(long[] xs){ + if(xs.length == 0) + return 0; + long ret = xs[0]; + for(int i = 0; i < xs.length; i++) + ret = Math.max(ret, xs[i]); + return ret; + } + + static public long vmin(long[] xs){ + if(xs.length == 0) + return 0; + long ret = xs[0]; + for(int i = 0; i < xs.length; i++) + ret = Math.min(ret, xs[i]); + return ret; + } + + static public double vmean(long[] xs){ + if(xs.length == 0) + return 0; + return vsum(xs) / (double) xs.length; + } + + static public double vrms(long[] xs){ + if(xs.length == 0) + return 0; + long ret = 0; + for(int i = 0; i < xs.length; i++) + ret += xs[i] * xs[i]; + return Math.sqrt(ret / (double) xs.length); + } + + static public long vsum(long[] xs){ + long ret = 0; + for(int i = 0; i < xs.length; i++) + ret += xs[i]; + return ret; + } + + static public boolean vequiv(long[] xs, long[] ys){ + return Arrays.equals(xs, ys); + } + + static public long[] vadd(long[] x, long[] ys){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] += ys[i]; + return xs; + } + + static public long[] vsub(long[] x, long[] ys){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] -= ys[i]; + return xs; + } + + static public long[] vaddmul(long[] x, long[] ys, long[] zs){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] + ys[i]) * zs[i]; + return xs; + } + + static public long[] vsubmul(long[] x, long[] ys, long[] zs){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] - ys[i]) * zs[i]; + return xs; + } + + static public long[] vaddsmul(long[] x, long[] ys, long z){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] + ys[i]) * z; + return xs; + } + + static public long[] vsubsmul(long[] x, long[] ys, long z){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] - ys[i]) * z; + return xs; + } + + static public long[] vmulsadd(long[] x, long[] ys, long z){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] * ys[i]) + z; + return xs; + } + + static public long[] vdiv(long[] x, long[] ys){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] /= ys[i]; + return xs; + } + + static public long[] vmul(long[] x, long[] ys){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] *= ys[i]; + return xs; + } + + static public long[] vmuladd(long[] x, long[] ys, long[] zs){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] * ys[i]) + zs[i]; + return xs; + } + + static public long[] vmulsub(long[] x, long[] ys, long[] zs){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = (xs[i] * ys[i]) - zs[i]; + return xs; + } + + static public long[] vmax(long[] x, long[] ys){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = Math.max(xs[i], ys[i]); + return xs; + } + + static public long[] vmin(long[] x, long[] ys){ + final long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = Math.min(xs[i], ys[i]); + return xs; + } + + static public long[] vmap(IFn fn, long[] x) { + long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = ((Number) fn.invoke(xs[i])).longValue(); + return xs; + } + + static public long[] vmap(IFn fn, long[] x, long[] ys) { + long[] xs = x.clone(); + for(int i = 0; i < xs.length; i++) + xs[i] = ((Number) fn.invoke(xs[i], ys[i])).longValue(); + return xs; + } + +} +*/ + + +//overload resolution +//* + +static public Number add(long x, Object y){ + return add((Object)x,y); +} + +static public Number add(Object x, long y){ + return add(x,(Object)y); +} + +static public Number addP(long x, Object y){ + return addP((Object)x,y); +} + +static public Number addP(Object x, long y){ + return addP(x,(Object)y); +} + +static public double add(double x, Object y){ + return add(x,((Number)y).doubleValue()); +} + +static public double add(Object x, double y){ + return add(((Number)x).doubleValue(),y); +} + +static public double add(double x, long y){ + return x + y; +} + +static public double add(long x, double y){ + return x + y; +} + +static public double addP(double x, Object y){ + return addP(x,((Number)y).doubleValue()); +} + +static public double addP(Object x, double y){ + return addP(((Number)x).doubleValue(),y); +} + +static public double addP(double x, long y){ + return x + y; +} + +static public double addP(long x, double y){ + return x + y; +} + +static public Number minus(long x, Object y){ + return minus((Object)x,y); +} + +static public Number minus(Object x, long y){ + return minus(x,(Object)y); +} + +static public Number minusP(long x, Object y){ + return minusP((Object)x,y); +} + +static public Number minusP(Object x, long y){ + return minusP(x,(Object)y); +} + +static public double minus(double x, Object y){ + return minus(x,((Number)y).doubleValue()); +} + +static public double minus(Object x, double y){ + return minus(((Number)x).doubleValue(),y); +} + +static public double minus(double x, long y){ + return x - y; +} + +static public double minus(long x, double y){ + return x - y; +} + +static public double minusP(double x, Object y){ + return minus(x,((Number)y).doubleValue()); +} + +static public double minusP(Object x, double y){ + return minus(((Number)x).doubleValue(),y); +} + +static public double minusP(double x, long y){ + return x - y; +} + +static public double minusP(long x, double y){ + return x - y; +} + +static public Number multiply(long x, Object y){ + return multiply((Object)x,y); +} + +static public Number multiply(Object x, long y){ + return multiply(x,(Object)y); +} + +static public Number multiplyP(long x, Object y){ + return multiplyP((Object)x,y); +} + +static public Number multiplyP(Object x, long y){ + return multiplyP(x,(Object)y); +} + +static public double multiply(double x, Object y){ + return multiply(x,((Number)y).doubleValue()); +} + +static public double multiply(Object x, double y){ + return multiply(((Number)x).doubleValue(),y); +} + +static public double multiply(double x, long y){ + return x * y; +} + +static public double multiply(long x, double y){ + return x * y; +} + +static public double multiplyP(double x, Object y){ + return multiplyP(x,((Number)y).doubleValue()); +} + +static public double multiplyP(Object x, double y){ + return multiplyP(((Number)x).doubleValue(),y); +} + +static public double multiplyP(double x, long y){ + return x * y; +} + +static public double multiplyP(long x, double y){ + return x * y; +} + +static public Number divide(long x, Object y){ + return divide((Object)x,y); +} + +static public Number divide(Object x, long y){ + return divide(x,(Object)y); +} + +static public double divide(double x, Object y){ + return x / ((Number)y).doubleValue(); +} + +static public double divide(Object x, double y){ + return ((Number)x).doubleValue() / y; +} + +static public double divide(double x, long y){ + return x / y; +} + +static public double divide(long x, double y){ + return x / y; +} + +static public Number divide(long x, long y){ + return divide((Number)x, (Number)y); +} + +static public boolean lt(long x, Object y){ + return lt((Object)x,y); +} + +static public boolean lt(Object x, long y){ + return lt(x,(Object)y); +} + +static public boolean lt(double x, Object y){ + return x < ((Number)y).doubleValue(); +} + +static public boolean lt(Object x, double y){ + return ((Number)x).doubleValue() < y; +} + +static public boolean lt(double x, long y){ + return x < y; +} + +static public boolean lt(long x, double y){ + return x < y; +} + +static public boolean lte(long x, Object y){ + return lte((Object)x,y); +} + +static public boolean lte(Object x, long y){ + return lte(x,(Object)y); +} + +static public boolean lte(double x, Object y){ + return x <= ((Number)y).doubleValue(); +} + +static public boolean lte(Object x, double y){ + return ((Number)x).doubleValue() <= y; +} + +static public boolean lte(double x, long y){ + return x <= y; +} + +static public boolean lte(long x, double y){ + return x <= y; +} + +static public boolean gt(long x, Object y){ + return gt((Object)x,y); +} + +static public boolean gt(Object x, long y){ + return gt(x,(Object)y); +} + +static public boolean gt(double x, Object y){ + return x > ((Number)y).doubleValue(); +} + +static public boolean gt(Object x, double y){ + return ((Number)x).doubleValue() > y; +} + +static public boolean gt(double x, long y){ + return x > y; +} + +static public boolean gt(long x, double y){ + return x > y; +} + +static public boolean gte(long x, Object y){ + return gte((Object)x,y); +} + +static public boolean gte(Object x, long y){ + return gte(x,(Object)y); +} + +static public boolean gte(double x, Object y){ + return x >= ((Number)y).doubleValue(); +} + +static public boolean gte(Object x, double y){ + return ((Number)x).doubleValue() >= y; +} + +static public boolean gte(double x, long y){ + return x >= y; +} + +static public boolean gte(long x, double y){ + return x >= y; +} + +static public boolean equiv(long x, Object y){ + return equiv((Object)x,y); +} + +static public boolean equiv(Object x, long y){ + return equiv(x,(Object)y); +} + +static public boolean equiv(double x, Object y){ + return x == ((Number)y).doubleValue(); +} + +static public boolean equiv(Object x, double y){ + return ((Number)x).doubleValue() == y; +} + +static public boolean equiv(double x, long y){ + return x == y; +} + +static public boolean equiv(long x, double y){ + return x == y; +} + + +static boolean isNaN(Object x){ + return (x instanceof Double) && ((Double)x).isNaN() + || (x instanceof Float) && ((Float)x).isNaN(); +} + +static public double max(double x, double y){ + return Math.max(x, y); +} + +static public Object max(double x, long y){ + if(Double.isNaN(x)){ + return x; + } + if(x > y){ + return x; + } else { + return y; + } +} + +static public Object max(double x, Object y){ + if(Double.isNaN(x)){ + return x; + } else if(isNaN(y)){ + return y; + } + if(x > ((Number)y).doubleValue()){ + return x; + } else { + return y; + } +} + +static public Object max(long x, double y){ + if(Double.isNaN(y)){ + return y; + } + if(x > y){ + return x; + } else { + return y; + } +} + + +static public long max(long x, long y){ + if(x > y) { + return x; + } else { + return y; + } +} + + +static public Object max(long x, Object y){ + if(isNaN(y)){ + return y; + } + if(gt(x,y)){ + return x; + } else { + return y; + } +} + +static public Object max(Object x, long y){ + if(isNaN(x)){ + return x; + } + if(gt(x,y)){ + return x; + } else { + return y; + } +} + +static public Object max(Object x, double y){ + if (isNaN(x)){ + return x; + } else if(Double.isNaN(y)){ + return y; + } + if(((Number)x).doubleValue() > y){ + return x; + } else { + return y; + } +} + +static public Object max(Object x, Object y){ + if(isNaN(x)){ + return x; + } else if(isNaN(y)){ + return y; + } + if(gt(x, y)) { + return x; + } else { + return y; + } +} + + +static public double min(double x, double y){ + return Math.min(x, y); +} + +static public Object min(double x, long y){ + if (Double.isNaN(x)){ + return x; + } + if(x < y){ + return x; + } else { + return y; + } +} + +static public Object min(double x, Object y){ + if(Double.isNaN(x)){ + return x; + } else if(isNaN(y)){ + return y; + } + if(x < ((Number)y).doubleValue()){ + return x; + } else { + return y; + } +} + +static public Object min(long x, double y){ + if(Double.isNaN(y)){ + return y; + } + if(x < y){ + return x; + } else { + return y; + } +} + + +static public long min(long x, long y){ + if(x < y) { + return x; + } else { + return y; + } +} + +static public Object min(long x, Object y){ + if(isNaN(y)){ + return y; + } + if(lt(x,y)){ + return x; + } else { + return y; + } +} + +static public Object min(Object x, long y){ + if(isNaN(x)){ + return x; + } + if(lt(x,y)){ + return x; + } else { + return y; + } +} + +static public Object min(Object x, double y){ + if(isNaN(x)){ + return x; + } else if(Double.isNaN(y)){ + return y; + } + if(((Number)x).doubleValue() < y){ + return x; + } else { + return y; + } +} + +static public Object min(Object x, Object y){ + if (isNaN(x)){ + return x; + } else if(isNaN(y)){ + return y; + } + if(lt(x,y)) { + return x; + } else { + return y; + } +} + +} diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 513e7e0c..0a562be5 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -100,7 +100,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - For this situation: `?` is `(t/- dc/counted?)` ([n dnum/std-integer?, xs dc/counted?] (count xs)) ([n dnum/std-integer?, xs ?] ...) - - t/extend-defnt! + - t/extend-defn! - t/input-type - `(t/input-type >namespace :?)` meaing the possible input types to the first input to `>namespace` - `(t/input-type reduce :_ :_ :?)` @@ -124,6 +124,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - declare-fnt (a way to do protocols/interfaces) - extend-fnt! - defnt (t/defn) + - Arity elision: if any type in an arity is `t/none?` then elide it and emit a warning + - `([x bigint?] x)` - t/defn- - (t/and (t/or a b) c) should -> (t/or (t/and a c) (t/and b c)) for purposes of separating dispatches - t/extend-defn! @@ -361,7 +363,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] quantum.core.numeric.operators - [ ] quantum.core.numeric.trig - [ ] quantum.core.numeric.truncate - - [.] quantum.core.numeric.types + - [x] quantum.core.numeric.types - [ ] quantum.core.data.numeric - [.] quantum.core.numeric - [ ] quantum.core.string.regex diff --git a/src-untyped/quantum/untyped/core/data/numeric.cljc b/src-untyped/quantum/untyped/core/data/numeric.cljc index 819e3510..b160e7f6 100644 --- a/src-untyped/quantum/untyped/core/data/numeric.cljc +++ b/src-untyped/quantum/untyped/core/data/numeric.cljc @@ -1,10 +1,25 @@ (ns quantum.core.data.numeric + "Better `bigint?` for CLJ: + - There are almost certainly faster ones but whether they will be as correct is unknown + + Better `bigdec?` for CLJ: + - There are almost certainly faster ones + + `bigint?` for CLJS: + - `BigInt` is a built-in JS object in Chrome as of 5/2018. It's faster than bn.js. https://developers.google.com/web/updates/2018/05/bigint + - As of 5/2018, the best current substitute for `BigInt` is bn.js, but there apparently is a + polyfill available for BigInt so maybe that's better. + + `bigdec?` for CLJS: + - decimal.js is the best contender as of 9/27/2018. https://github.com/MikeMcl/decimal.js + + `ratio?` for CLJS: + - Fraction.js is the best contender as of 9/27/2018. https://github.com/infusion/Fraction.js" (:refer-clojure :exclude [#?@(:cljs [-compare]) decimal? denominator integer? number? numerator ratio?]) (:require [clojure.core :as core] [clojure.string :as str] - #?(:cljs [com.gfredericks.goog.math.Integer :as int]) [quantum.core.data.primitive :as p] [quantum.core.data.string :as dstr] [quantum.core.logic @@ -19,6 +34,19 @@ #?(:cljs (:require-macros [quantum.core.data.numeric :as self]))) + +#?(:clj (defalias numerator core/numerator) + :cljs (t/defn numerator)) + +#?(:clj (defalias denominator core/denominator) + :cljs (t/defn denominator)) + +#?(:clj (defalias ratio? core/ratio?) + :cljs (defn ratio? [x] (instance? Ratio x))) + + + + ;; ===== Integers ===== ;; #?(:clj (def big-integer? (t/isa? BigInteger))) @@ -26,7 +54,8 @@ #?(:clj (def clj-bigint? (t/isa? clojure.lang.BigInt))) (def bigint? #?(:clj (t/or clj-bigint? big-integer?) - :cljs (t/isa? com.gfredericks.goog.math.Integer))) + ;; TODO bring in implementation per the ns docstring + :cljs t/none?)) ;; Incorporated `clojure.lang.Util/isInteger` ;; Incorporated `clojure.core/integer?` @@ -39,22 +68,24 @@ (t/or ?@(:clj [p/byte? p/short?]) p/int? p/long?)) #?(:clj -(defnt >big-integer > big-integer? +(t/defn >big-integer > big-integer? ([x big-integer?] x) ([x clj-bigint? > (t/* big-integer?)] (.toBigInteger x)) - ([; TODO TYPED `(- number? BigInteger BigInt)` + ([;; TODO TYPED `(- number? BigInteger BigInt)` x (t/or p/short? p/int? p/long?) > (t/* big-integer?)] ; TODO BigDecimal (-> x p/>long (BigInteger/valueOf))))) #?(:cljs -(defnt >bigint > bigint? +(t/defn >bigint > bigint? ([x bigint?] x) - ([x dstr/string?] (int/fromString x)) ([x p/double?] (-> x (.toString) >bigint)))) ;; ===== Decimals ===== ;; -(def bigdec? #?(:clj (t/isa? BigDecimal) :cljs t/none?)) +(def bigdec? #?(:clj ;; TODO bring in a better implementation per the ns docstring? + (t/isa? BigDecimal) + ;; TODO bring in implementation per the ns docstring + :cljs t/none?)) ;; ===== Ratios ===== ;; @@ -171,3 +202,39 @@ (def numerically-integer-primitive? (t/and p/primitive? numerically-integer?)) (def std-integer? (t/or integer? #?(:cljs numerically-integer-double?))) + +;; TODO TYPED +(t/defn read-rational + "Create cross-platform literal rational numbers from decimal, without intermediate inexact + (e.g. float/double) representation. + + Example: + #r 2.712 -> (rationalize 2.712M)" + {:todo #{"Support exponent notation e.g. 2.313E7 | 2.313e7"}} + [r string?] + (let [r-str (cond (string? r) + r + (symbol? r) + (do (assert (-> r namespace nil?)) + (assert (-> r name first (= \r))) + (->> r name rest (apply str)))) + minus-ct (->> r-str (filter #(= % \-)) count) + _ (assert (#{0 1} minus-ct)) + r-str (case minus-ct + 0 r-str + 1 (do (assert (-> r-str first (= \-))) + (->> r-str rest (apply str)))) + [integral-str decimal-str :as split] (str/split r-str #"\.") + _ (when (-> split count (> 2)) + (throw (ex-info "Number cannot have more than one decimal point" {:num r-str}))) + _ (doseq [s split] + (when-not (every? #{\0 \1 \2 \3 \4 \5 \6 \7 \8 \9} s) + (throw (ex-info "Number must have only numeric characters" {:num s})))) + integral (read-string integral-str) + decimal (read-string decimal-str) + scale (if decimal + (#?(:clj Math/pow :cljs js/Math.pow) 10 (count decimal-str)) + 1)] + (* (if (= minus-ct 1) -1 1) + (->ratio (+ (* scale integral) (or decimal 0)) + scale)))) diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index be772d38..e26f8f74 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -109,7 +109,8 @@ > p/boolean? ([x p/numeric?] true) ([a p/numeric?, b p/numeric?] (Numeric/lt a b)) - ; TODO numbers, but not nil + ;; TODO numbers, but not nil + ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) ) ; ===== `<=` ===== ; @@ -119,7 +120,8 @@ > p/boolean? ([x p/numeric?] true) ([a p/numeric?, b p/numeric?] (Numeric/lte a b)) - ; TODO numbers, but not nil + ;; TODO numbers, but not nil + ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) ) ; ===== `>` ===== ; @@ -129,7 +131,8 @@ > p/boolean? ([x p/numeric?] true) ([a p/numeric?, b p/numeric?] (Numeric/gt a b)) - ; TODO numbers, but not nil + ;; TODO numbers, but not nil + ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) ) ; ===== `>=` ===== ; @@ -140,6 +143,7 @@ ([x p/numeric?] true) ([a p/numeric?, b p/numeric?] (Numeric/gte a b)) ; TODO numbers, but not nil + ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) ) ; ===== `compare` ===== ; @@ -166,7 +170,10 @@ ([a p/nil? , b p/val?] (int -1)) ;; TODO TYPED should we use `>int` here? ([a p/val? , b p/nil?] (int 1)) - ([a p/primitive?, b p/primitive?] (ifs (> a b) 1, (< a b) -1, 0)) + ([a p/primitive?, b p/primitive?] + (ifs (> a b) (int 1) + (< a b) (int -1) + (int 0))) ([^Comparable a ^Comparable b] (.compareTo a b)) ([^Comparable a ^prim? b] (.compareTo a b)) ([^prim? a ^Comparable b] (int (.compareTo (p/box a) b)))) diff --git a/src/quantum/core/numeric/types.cljc b/src/quantum/core/numeric/types.cljc deleted file mode 100644 index da1e8f8a..00000000 --- a/src/quantum/core/numeric/types.cljc +++ /dev/null @@ -1,171 +0,0 @@ -(ns quantum.core.numeric.types - (:refer-clojure :exclude - [denominator numerator ratio? #?@(:cljs [-compare]) read-string]) - (:require - [clojure.core :as core] - [clojure.string :as str] - [clojure.tools.reader - :refer [read-string]] - #?(:cljs [com.gfredericks.goog.math.Integer :as int]) - [quantum.core.logic - :refer [whenf fn-not fn=]] - [quantum.core.type - :refer [defnt]] - [quantum.core.vars - :refer [defalias]]) -#?(:cljs (:require-macros - [quantum.core.numeric.types :as self]))) - -(declare gcd) -(declare normalize) -#?(:cljs (declare ->bigint)) -#?(:cljs (declare ->ratio)) - -#?(:cljs (defprotocol Add (-add [x y]))) -#?(:cljs (defprotocol AddWithInteger (-add-with-integer [x y]))) -#?(:cljs (defprotocol AddWithRatio (-add-with-ratio [x y]))) -#?(:cljs (defprotocol Multiply (-multiply [x y]))) -#?(:cljs (defprotocol MultiplyWithInteger (-multiply-with-integer [x y]))) -#?(:cljs (defprotocol MultiplyWithRatio (-multiply-with-ratio [x y]))) -#?(:cljs (defprotocol Invert (-invert [x] ))) -#?(:cljs (defprotocol Negate (-negate [x] ))) -#?(:cljs (defprotocol Ordered (-compare [x y]))) -#?(:cljs (defprotocol CompareToInteger (-compare-to-integer [x y]))) -#?(:cljs (defprotocol CompareToRatio (-compare-to-ratio [x y]))) - -#?(:cljs -(extend-type number - Add (-add [x y] (-add (->bigint x) y)) - ;; I have a hard time reasoning about whether or not this is necessary - AddWithInteger (-add-with-integer [x y] (-add-with-integer (->bigint x) y)) - AddWithRatio (-add-with-ratio [x y] (-add-with-ratio (->bigint x) y)) - Multiply (-multiply [x y] (-multiply (->bigint x) y)) - MultiplyWithInteger (-multiply-with-integer [x y] (-multiply-with-integer (->bigint x) y)) - MultiplyWithRatio (-multiply-with-ratio [x y] (-multiply-with-ratio (->bigint x) y)) - Negate (-negate [x] (-negate (->bigint x) )) - Ordered (-compare [x y] (-compare (->bigint x) y)) - CompareToInteger (-compare-to-integer [x y] (-compare-to-integer (->bigint x) y)) - CompareToRatio (-compare-to-ratio [x y] (-compare-to-ratio (->bigint x) y)))) - -#?(:cljs -(extend-type com.gfredericks.goog.math.Integer - Add (-add [x y] (-add-with-integer y x)) - AddWithInteger (-add-with-integer [x y] (.add x y)) - AddWithRatio (-add-with-ratio [x y] (-add-with-ratio (->ratio x) y)) - Multiply (-multiply [x y] (-multiply-with-integer y x)) - MultiplyWithInteger (-multiply-with-integer [x y] (.multiply x y)) - MultiplyWithRatio (-multiply-with-ratio [x y] (-multiply-with-ratio (->ratio x) y)) - Negate (-negate [x] (.negate x)) - Invert (-invert [x] (->ratio int/ONE x)) - Ordered (-compare [x y] (core/- (-compare-to-integer y x))) - CompareToInteger (-compare-to-integer [x y] (.compare x y)) - CompareToRatio (-compare-to-ratio [x y] (-compare-to-ratio (->ratio x) y)) - IEquiv (-equiv [x y] (and (instance? com.gfredericks.goog.math.Integer y) (.equals x y))) - ;; dunno? - IHash (-hash [this] (reduce bit-xor 899242490 (.-bits_ this))) - IComparable (-compare [x y] (-compare x y)))) - - -#?(:cljs -(deftype Ratio [n d] - ;; "Ratios should not be constructed directly by user code; we assume n and d are - ;; canonical; i.e., they are coprime and at most n is negative." - Object - (toString [_] (str "#ratio [" n " " d "]")) - Add (-add [x y] (-add-with-ratio y x)) - AddWithInteger (-add-with-integer [x y] (-add-with-ratio x (->ratio y))) - AddWithRatio - (-add-with-ratio [x y] - (let [+ -add-with-integer - * -multiply-with-integer - n' (+ (* (.-n x) (.-d y)) - (* (.-d x) (.-n y))) - d' (* (.-d x) (.-d y)) - the-gcd (gcd n' d')] - (normalize (.divide n' the-gcd) (.divide d' the-gcd)))) - Multiply (-multiply [x y] (-multiply-with-ratio y x )) - MultiplyWithInteger (-multiply-with-integer [x y] (-multiply x (->ratio y))) - MultiplyWithRatio - (-multiply-with-ratio [x y] - (let [* -multiply-with-integer - n' (* (.-n x) (.-n y)) - d' (* (.-d x) (.-d y)) - the-gcd (gcd n' d')] - (normalize (.divide n' the-gcd) (.divide d' the-gcd)))) - Negate (-negate [x] (->ratio (-negate n) d)) - Invert (-invert [x] (normalize d n)) - Ordered (-compare [x y] (core/- (-compare-to-ratio y x))) - CompareToInteger (-compare-to-integer [x y] (-compare-to-ratio x (->ratio y))) - CompareToRatio - (-compare-to-ratio [x y] - (let [* -multiply-with-integer] - (-compare-to-integer (* (.-n x) (.-d y)) - (* (.-n y) (.-d x))))) - IEquiv - (-equiv [_ other] - (and (instance? Ratio other) - (core/= n (.-n other)) - (core/= d (.-d other)))) - IHash - (-hash [_] (bit-xor 124790411 (-hash n) (-hash d))) - IComparable - (-compare [x y] (-compare x y)))) - -#?(:cljs -(defn- normalize - [n d] - (if (.isNegative d) - (let [n' (.negate n) - d' (.negate d)] - (if (.equals d' int/ONE) - n' - (->ratio n' d'))) - (if (.equals d int/ONE) - n - (->ratio n d))))) - - - -#?(:clj (defalias numerator core/numerator) - :cljs (defnt numerator - ([^ratio? x] (.-n x)))) - -#?(:clj (defalias denominator core/denominator) - :cljs (defnt denominator - ([^ratio? x] (.-d x)))) - -#?(:clj (defalias ratio? core/ratio?) - :cljs (defn ratio? [x] (instance? Ratio x))) - -(defn read-rational - "Create cross-platform literal rational numbers from decimal, without intermediate inexact - (e.g. float/double) representation. - #r 2.712 -> (rationalize 2.712M)" - {:todo #{"Support exponent notation e.g. 2.313E7 | 2.313e7"}} - [^String r] - (let [r-str (cond (string? r) - r - (symbol? r) - (do (assert (-> r namespace nil?)) - (assert (-> r name first (= \r))) - (->> r name rest (apply str)))) - minus-ct (->> r-str (filter #(= % \-)) count) - _ (assert (#{0 1} minus-ct)) - r-str (case minus-ct - 0 r-str - 1 (do (assert (-> r-str first (= \-))) - (->> r-str rest (apply str)))) - [integral-str decimal-str :as split] (str/split r-str #"\.") - _ (when (-> split count (> 2)) - (throw (ex-info "Number cannot have more than one decimal point" {:num r-str}))) - _ (doseq [s split] - (when-not (every? #{\0 \1 \2 \3 \4 \5 \6 \7 \8 \9} s) - (throw (ex-info "Number must have only numeric characters" {:num s})))) - integral (read-string integral-str) - decimal (read-string decimal-str) - scale (if decimal - (#?(:clj Math/pow :cljs js/Math.pow) 10 (count decimal-str)) - 1)] - (* (if (= minus-ct 1) -1 1) - (->ratio (+ (* scale integral) (or decimal 0)) - scale)))) diff --git a/test/quantum/test.cljc b/test/quantum/test.cljc index 77c68961..9556db96 100644 --- a/test/quantum/test.cljc +++ b/test/quantum/test.cljc @@ -91,7 +91,6 @@ [quantum.test.core.numeric.predicates] [quantum.test.core.numeric.trig] [quantum.test.core.numeric.truncate] - [quantum.test.core.numeric.types] [quantum.test.core.paths] [quantum.test.core.print] [quantum.test.core.process] From 87b361a7d6ba5a163917b8dd2e19230d103d44e5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 16:29:40 -0600 Subject: [PATCH 323/810] Remove denominator, numerator, new vector math ops --- resources-dev/clojure-lang-numbers-temp.java | 1763 ------------------ 1 file changed, 1763 deletions(-) diff --git a/resources-dev/clojure-lang-numbers-temp.java b/resources-dev/clojure-lang-numbers-temp.java index 858868dc..485d4250 100644 --- a/resources-dev/clojure-lang-numbers-temp.java +++ b/resources-dev/clojure-lang-numbers-temp.java @@ -287,53 +287,6 @@ else if(x instanceof BigDecimal) return x; } -static public BigInteger numerator(Ratio x){ - return x.numerator; -} - -static public BigInteger numerator(long x){ - return BigInteger.valueOf(x); -} - -static public BigInteger numerator(BigInt x){ - return x.toBigInteger(); -} - -static public BigInteger numerator(BigInteger x){ - return x; -} - -static public BigInteger denominator(Ratio x){ - return x.denominator; -} - -static public BigInteger denominator(long x){ - return BigInteger.ONE; -} - -static public BigInteger denominator(BigInt x){ - return BigInteger.ONE; -} - -static public BigInteger denominator(BigInteger x){ - return BigInteger.ONE; -} - -//static Number box(int val){ -// return Integer.valueOf(val); -//} - -//static Number box(long val){ -// return Long.valueOf(val); -//} -// -//static Double box(double val){ -// return Double.valueOf(val); -//} -// -//static Double box(float val){ -// return Double.valueOf((double) val); -//} @WarnBoxedMath(false) static public Number reduceBigInt(BigInt val){ @@ -1976,1722 +1929,6 @@ static public boolean isZero(long x){ return x == 0; } -/* -static public class F{ - static public float add(float x, float y){ - return x + y; - } - - static public float subtract(float x, float y){ - return x - y; - } - - static public float negate(float x){ - return -x; - } - - static public float inc(float x){ - return x + 1; - } - - static public float dec(float x){ - return x - 1; - } - - static public float multiply(float x, float y){ - return x * y; - } - - static public float divide(float x, float y){ - return x / y; - } - - static public boolean equiv(float x, float y){ - return x == y; - } - - static public boolean lt(float x, float y){ - return x < y; - } - - static public boolean lte(float x, float y){ - return x <= y; - } - - static public boolean gt(float x, float y){ - return x > y; - } - - static public boolean gte(float x, float y){ - return x >= y; - } - - static public boolean pos(float x){ - return x > 0; - } - - static public boolean neg(float x){ - return x < 0; - } - - static public boolean zero(float x){ - return x == 0; - } - - static public float aget(float[] xs, int i){ - return xs[i]; - } - - static public float aset(float[] xs, int i, float v){ - xs[i] = v; - return v; - } - - static public int alength(float[] xs){ - return xs.length; - } - - static public float[] aclone(float[] xs){ - return xs.clone(); - } - - static public float[] vec(int size, Object init){ - float[] ret = new float[size]; - if(init instanceof Number) - { - float f = ((Number) init).floatValue(); - for(int i = 0; i < ret.length; i++) - ret[i] = f; - } - else - { - ISeq s = RT.seq(init); - for(int i = 0; i < size && s != null; i++, s = s.rest()) - ret[i] = ((Number) s.first()).floatValue(); - } - return ret; - } - - static public float[] vec(Object sizeOrSeq){ - if(sizeOrSeq instanceof Number) - return new float[((Number) sizeOrSeq).intValue()]; - else - { - ISeq s = RT.seq(sizeOrSeq); - int size = s.count(); - float[] ret = new float[size]; - for(int i = 0; i < size && s != null; i++, s = s.rest()) - ret[i] = ((Number) s.first()).intValue(); - return ret; - } - } - - - static public float[] vsadd(float[] x, float y){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] += y; - return xs; - } - - static public float[] vssub(float[] x, float y){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] -= y; - return xs; - } - - static public float[] vsdiv(float[] x, float y){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] /= y; - return xs; - } - - static public float[] vsmul(float[] x, float y){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] *= y; - return xs; - } - - static public float[] svdiv(float y, float[] x){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = y / xs[i]; - return xs; - } - - static public float[] vsmuladd(float[] x, float y, float[] zs){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[i] * y + zs[i]; - return xs; - } - - static public float[] vsmulsub(float[] x, float y, float[] zs){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[i] * y - zs[i]; - return xs; - } - - static public float[] vsmulsadd(float[] x, float y, float z){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[i] * y + z; - return xs; - } - - static public float[] vsmulssub(float[] x, float y, float z){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[i] * y - z; - return xs; - } - - static public float[] vabs(float[] x){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = Math.abs(xs[i]); - return xs; - } - - static public float[] vnegabs(float[] x){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = -Math.abs(xs[i]); - return xs; - } - - static public float[] vneg(float[] x){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = -xs[i]; - return xs; - } - - static public float[] vsqr(float[] x){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] *= xs[i]; - return xs; - } - - static public float[] vsignedsqr(float[] x){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] *= Math.abs(xs[i]); - return xs; - } - - static public float[] vclip(float[] x, float low, float high){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - { - if(xs[i] < low) - xs[i] = low; - else if(xs[i] > high) - xs[i] = high; - } - return xs; - } - - static public IPersistentVector vclipcounts(float[] x, float low, float high){ - final float[] xs = x.clone(); - int lowc = 0; - int highc = 0; - - for(int i = 0; i < xs.length; i++) - { - if(xs[i] < low) - { - ++lowc; - xs[i] = low; - } - else if(xs[i] > high) - { - ++highc; - xs[i] = high; - } - } - return RT.vector(xs, lowc, highc); - } - - static public float[] vthresh(float[] x, float thresh, float otherwise){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - { - if(xs[i] < thresh) - xs[i] = otherwise; - } - return xs; - } - - static public float[] vreverse(float[] x){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[xs.length - i - 1]; - return xs; - } - - static public float[] vrunningsum(float[] x){ - final float[] xs = x.clone(); - for(int i = 1; i < xs.length; i++) - xs[i] = xs[i - 1] + xs[i]; - return xs; - } - - static public float[] vsort(float[] x){ - final float[] xs = x.clone(); - Arrays.sort(xs); - return xs; - } - - static public float vdot(float[] xs, float[] ys){ - float ret = 0; - for(int i = 0; i < xs.length; i++) - ret += xs[i] * ys[i]; - return ret; - } - - static public float vmax(float[] xs){ - if(xs.length == 0) - return 0; - float ret = xs[0]; - for(int i = 0; i < xs.length; i++) - ret = Math.max(ret, xs[i]); - return ret; - } - - static public float vmin(float[] xs){ - if(xs.length == 0) - return 0; - float ret = xs[0]; - for(int i = 0; i < xs.length; i++) - ret = Math.min(ret, xs[i]); - return ret; - } - - static public float vmean(float[] xs){ - if(xs.length == 0) - return 0; - return vsum(xs) / xs.length; - } - - static public double vrms(float[] xs){ - if(xs.length == 0) - return 0; - float ret = 0; - for(int i = 0; i < xs.length; i++) - ret += xs[i] * xs[i]; - return Math.sqrt(ret / xs.length); - } - - static public float vsum(float[] xs){ - float ret = 0; - for(int i = 0; i < xs.length; i++) - ret += xs[i]; - return ret; - } - - static public boolean vequiv(float[] xs, float[] ys){ - return Arrays.equals(xs, ys); - } - - static public float[] vadd(float[] x, float[] ys){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] += ys[i]; - return xs; - } - - static public float[] vsub(float[] x, float[] ys){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] -= ys[i]; - return xs; - } - - static public float[] vaddmul(float[] x, float[] ys, float[] zs){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] + ys[i]) * zs[i]; - return xs; - } - - static public float[] vsubmul(float[] x, float[] ys, float[] zs){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] - ys[i]) * zs[i]; - return xs; - } - - static public float[] vaddsmul(float[] x, float[] ys, float z){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] + ys[i]) * z; - return xs; - } - - static public float[] vsubsmul(float[] x, float[] ys, float z){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] - ys[i]) * z; - return xs; - } - - static public float[] vmulsadd(float[] x, float[] ys, float z){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] * ys[i]) + z; - return xs; - } - - static public float[] vdiv(float[] x, float[] ys){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] /= ys[i]; - return xs; - } - - static public float[] vmul(float[] x, float[] ys){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] *= ys[i]; - return xs; - } - - static public float[] vmuladd(float[] x, float[] ys, float[] zs){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] * ys[i]) + zs[i]; - return xs; - } - - static public float[] vmulsub(float[] x, float[] ys, float[] zs){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] * ys[i]) - zs[i]; - return xs; - } - - static public float[] vmax(float[] x, float[] ys){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = Math.max(xs[i], ys[i]); - return xs; - } - - static public float[] vmin(float[] x, float[] ys){ - final float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = Math.min(xs[i], ys[i]); - return xs; - } - - static public float[] vmap(IFn fn, float[] x) { - float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = ((Number) fn.invoke(xs[i])).floatValue(); - return xs; - } - - static public float[] vmap(IFn fn, float[] x, float[] ys) { - float[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = ((Number) fn.invoke(xs[i], ys[i])).floatValue(); - return xs; - } - -} - -static public class D{ - static public double add(double x, double y){ - return x + y; - } - - static public double subtract(double x, double y){ - return x - y; - } - - static public double negate(double x){ - return -x; - } - - static public double inc(double x){ - return x + 1; - } - - static public double dec(double x){ - return x - 1; - } - - static public double multiply(double x, double y){ - return x * y; - } - - static public double divide(double x, double y){ - return x / y; - } - - static public boolean equiv(double x, double y){ - return x == y; - } - - static public boolean lt(double x, double y){ - return x < y; - } - - static public boolean lte(double x, double y){ - return x <= y; - } - - static public boolean gt(double x, double y){ - return x > y; - } - - static public boolean gte(double x, double y){ - return x >= y; - } - - static public boolean pos(double x){ - return x > 0; - } - - static public boolean neg(double x){ - return x < 0; - } - - static public boolean zero(double x){ - return x == 0; - } - - static public double aget(double[] xs, int i){ - return xs[i]; - } - - static public double aset(double[] xs, int i, double v){ - xs[i] = v; - return v; - } - - static public int alength(double[] xs){ - return xs.length; - } - - static public double[] aclone(double[] xs){ - return xs.clone(); - } - - static public double[] vec(int size, Object init){ - double[] ret = new double[size]; - if(init instanceof Number) - { - double f = ((Number) init).doubleValue(); - for(int i = 0; i < ret.length; i++) - ret[i] = f; - } - else - { - ISeq s = RT.seq(init); - for(int i = 0; i < size && s != null; i++, s = s.rest()) - ret[i] = ((Number) s.first()).doubleValue(); - } - return ret; - } - - static public double[] vec(Object sizeOrSeq){ - if(sizeOrSeq instanceof Number) - return new double[((Number) sizeOrSeq).intValue()]; - else - { - ISeq s = RT.seq(sizeOrSeq); - int size = s.count(); - double[] ret = new double[size]; - for(int i = 0; i < size && s != null; i++, s = s.rest()) - ret[i] = ((Number) s.first()).intValue(); - return ret; - } - } - - static public double[] vsadd(double[] x, double y){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] += y; - return xs; - } - - static public double[] vssub(double[] x, double y){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] -= y; - return xs; - } - - static public double[] vsdiv(double[] x, double y){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] /= y; - return xs; - } - - static public double[] vsmul(double[] x, double y){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] *= y; - return xs; - } - - static public double[] svdiv(double y, double[] x){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = y / xs[i]; - return xs; - } - - static public double[] vsmuladd(double[] x, double y, double[] zs){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[i] * y + zs[i]; - return xs; - } - - static public double[] vsmulsub(double[] x, double y, double[] zs){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[i] * y - zs[i]; - return xs; - } - - static public double[] vsmulsadd(double[] x, double y, double z){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[i] * y + z; - return xs; - } - - static public double[] vsmulssub(double[] x, double y, double z){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[i] * y - z; - return xs; - } - - static public double[] vabs(double[] x){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = Math.abs(xs[i]); - return xs; - } - - static public double[] vnegabs(double[] x){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = -Math.abs(xs[i]); - return xs; - } - - static public double[] vneg(double[] x){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = -xs[i]; - return xs; - } - - static public double[] vsqr(double[] x){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] *= xs[i]; - return xs; - } - - static public double[] vsignedsqr(double[] x){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] *= Math.abs(xs[i]); - return xs; - } - - static public double[] vclip(double[] x, double low, double high){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - { - if(xs[i] < low) - xs[i] = low; - else if(xs[i] > high) - xs[i] = high; - } - return xs; - } - - static public IPersistentVector vclipcounts(double[] x, double low, double high){ - final double[] xs = x.clone(); - int lowc = 0; - int highc = 0; - - for(int i = 0; i < xs.length; i++) - { - if(xs[i] < low) - { - ++lowc; - xs[i] = low; - } - else if(xs[i] > high) - { - ++highc; - xs[i] = high; - } - } - return RT.vector(xs, lowc, highc); - } - - static public double[] vthresh(double[] x, double thresh, double otherwise){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - { - if(xs[i] < thresh) - xs[i] = otherwise; - } - return xs; - } - - static public double[] vreverse(double[] x){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[xs.length - i - 1]; - return xs; - } - - static public double[] vrunningsum(double[] x){ - final double[] xs = x.clone(); - for(int i = 1; i < xs.length; i++) - xs[i] = xs[i - 1] + xs[i]; - return xs; - } - - static public double[] vsort(double[] x){ - final double[] xs = x.clone(); - Arrays.sort(xs); - return xs; - } - - static public double vdot(double[] xs, double[] ys){ - double ret = 0; - for(int i = 0; i < xs.length; i++) - ret += xs[i] * ys[i]; - return ret; - } - - static public double vmax(double[] xs){ - if(xs.length == 0) - return 0; - double ret = xs[0]; - for(int i = 0; i < xs.length; i++) - ret = Math.max(ret, xs[i]); - return ret; - } - - static public double vmin(double[] xs){ - if(xs.length == 0) - return 0; - double ret = xs[0]; - for(int i = 0; i < xs.length; i++) - ret = Math.min(ret, xs[i]); - return ret; - } - - static public double vmean(double[] xs){ - if(xs.length == 0) - return 0; - return vsum(xs) / xs.length; - } - - static public double vrms(double[] xs){ - if(xs.length == 0) - return 0; - double ret = 0; - for(int i = 0; i < xs.length; i++) - ret += xs[i] * xs[i]; - return Math.sqrt(ret / xs.length); - } - - static public double vsum(double[] xs){ - double ret = 0; - for(int i = 0; i < xs.length; i++) - ret += xs[i]; - return ret; - } - - static public boolean vequiv(double[] xs, double[] ys){ - return Arrays.equals(xs, ys); - } - - static public double[] vadd(double[] x, double[] ys){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] += ys[i]; - return xs; - } - - static public double[] vsub(double[] x, double[] ys){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] -= ys[i]; - return xs; - } - - static public double[] vaddmul(double[] x, double[] ys, double[] zs){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] + ys[i]) * zs[i]; - return xs; - } - - static public double[] vsubmul(double[] x, double[] ys, double[] zs){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] - ys[i]) * zs[i]; - return xs; - } - - static public double[] vaddsmul(double[] x, double[] ys, double z){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] + ys[i]) * z; - return xs; - } - - static public double[] vsubsmul(double[] x, double[] ys, double z){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] - ys[i]) * z; - return xs; - } - - static public double[] vmulsadd(double[] x, double[] ys, double z){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] * ys[i]) + z; - return xs; - } - - static public double[] vdiv(double[] x, double[] ys){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] /= ys[i]; - return xs; - } - - static public double[] vmul(double[] x, double[] ys){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] *= ys[i]; - return xs; - } - - static public double[] vmuladd(double[] x, double[] ys, double[] zs){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] * ys[i]) + zs[i]; - return xs; - } - - static public double[] vmulsub(double[] x, double[] ys, double[] zs){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] * ys[i]) - zs[i]; - return xs; - } - - static public double[] vmax(double[] x, double[] ys){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = Math.max(xs[i], ys[i]); - return xs; - } - - static public double[] vmin(double[] x, double[] ys){ - final double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = Math.min(xs[i], ys[i]); - return xs; - } - - static public double[] vmap(IFn fn, double[] x) { - double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = ((Number) fn.invoke(xs[i])).doubleValue(); - return xs; - } - - static public double[] vmap(IFn fn, double[] x, double[] ys) { - double[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = ((Number) fn.invoke(xs[i], ys[i])).doubleValue(); - return xs; - } -} - -static public class I{ - static public int add(int x, int y){ - return x + y; - } - - static public int subtract(int x, int y){ - return x - y; - } - - static public int negate(int x){ - return -x; - } - - static public int inc(int x){ - return x + 1; - } - - static public int dec(int x){ - return x - 1; - } - - static public int multiply(int x, int y){ - return x * y; - } - - static public int divide(int x, int y){ - return x / y; - } - - static public boolean equiv(int x, int y){ - return x == y; - } - - static public boolean lt(int x, int y){ - return x < y; - } - - static public boolean lte(int x, int y){ - return x <= y; - } - - static public boolean gt(int x, int y){ - return x > y; - } - - static public boolean gte(int x, int y){ - return x >= y; - } - - static public boolean pos(int x){ - return x > 0; - } - - static public boolean neg(int x){ - return x < 0; - } - - static public boolean zero(int x){ - return x == 0; - } - - static public int aget(int[] xs, int i){ - return xs[i]; - } - - static public int aset(int[] xs, int i, int v){ - xs[i] = v; - return v; - } - - static public int alength(int[] xs){ - return xs.length; - } - - static public int[] aclone(int[] xs){ - return xs.clone(); - } - - static public int[] vec(int size, Object init){ - int[] ret = new int[size]; - if(init instanceof Number) - { - int f = ((Number) init).intValue(); - for(int i = 0; i < ret.length; i++) - ret[i] = f; - } - else - { - ISeq s = RT.seq(init); - for(int i = 0; i < size && s != null; i++, s = s.rest()) - ret[i] = ((Number) s.first()).intValue(); - } - return ret; - } - - static public int[] vec(Object sizeOrSeq){ - if(sizeOrSeq instanceof Number) - return new int[((Number) sizeOrSeq).intValue()]; - else - { - ISeq s = RT.seq(sizeOrSeq); - int size = s.count(); - int[] ret = new int[size]; - for(int i = 0; i < size && s != null; i++, s = s.rest()) - ret[i] = ((Number) s.first()).intValue(); - return ret; - } - } - - static public int[] vsadd(int[] x, int y){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] += y; - return xs; - } - - static public int[] vssub(int[] x, int y){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] -= y; - return xs; - } - - static public int[] vsdiv(int[] x, int y){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] /= y; - return xs; - } - - static public int[] vsmul(int[] x, int y){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] *= y; - return xs; - } - - static public int[] svdiv(int y, int[] x){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = y / xs[i]; - return xs; - } - - static public int[] vsmuladd(int[] x, int y, int[] zs){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[i] * y + zs[i]; - return xs; - } - - static public int[] vsmulsub(int[] x, int y, int[] zs){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[i] * y - zs[i]; - return xs; - } - - static public int[] vsmulsadd(int[] x, int y, int z){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[i] * y + z; - return xs; - } - - static public int[] vsmulssub(int[] x, int y, int z){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[i] * y - z; - return xs; - } - - static public int[] vabs(int[] x){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = Math.abs(xs[i]); - return xs; - } - - static public int[] vnegabs(int[] x){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = -Math.abs(xs[i]); - return xs; - } - - static public int[] vneg(int[] x){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = -xs[i]; - return xs; - } - - static public int[] vsqr(int[] x){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] *= xs[i]; - return xs; - } - - static public int[] vsignedsqr(int[] x){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] *= Math.abs(xs[i]); - return xs; - } - - static public int[] vclip(int[] x, int low, int high){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - { - if(xs[i] < low) - xs[i] = low; - else if(xs[i] > high) - xs[i] = high; - } - return xs; - } - - static public IPersistentVector vclipcounts(int[] x, int low, int high){ - final int[] xs = x.clone(); - int lowc = 0; - int highc = 0; - - for(int i = 0; i < xs.length; i++) - { - if(xs[i] < low) - { - ++lowc; - xs[i] = low; - } - else if(xs[i] > high) - { - ++highc; - xs[i] = high; - } - } - return RT.vector(xs, lowc, highc); - } - - static public int[] vthresh(int[] x, int thresh, int otherwise){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - { - if(xs[i] < thresh) - xs[i] = otherwise; - } - return xs; - } - - static public int[] vreverse(int[] x){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[xs.length - i - 1]; - return xs; - } - - static public int[] vrunningsum(int[] x){ - final int[] xs = x.clone(); - for(int i = 1; i < xs.length; i++) - xs[i] = xs[i - 1] + xs[i]; - return xs; - } - - static public int[] vsort(int[] x){ - final int[] xs = x.clone(); - Arrays.sort(xs); - return xs; - } - - static public int vdot(int[] xs, int[] ys){ - int ret = 0; - for(int i = 0; i < xs.length; i++) - ret += xs[i] * ys[i]; - return ret; - } - - static public int vmax(int[] xs){ - if(xs.length == 0) - return 0; - int ret = xs[0]; - for(int i = 0; i < xs.length; i++) - ret = Math.max(ret, xs[i]); - return ret; - } - - static public int vmin(int[] xs){ - if(xs.length == 0) - return 0; - int ret = xs[0]; - for(int i = 0; i < xs.length; i++) - ret = Math.min(ret, xs[i]); - return ret; - } - - static public double vmean(int[] xs){ - if(xs.length == 0) - return 0; - return vsum(xs) / (double) xs.length; - } - - static public double vrms(int[] xs){ - if(xs.length == 0) - return 0; - int ret = 0; - for(int i = 0; i < xs.length; i++) - ret += xs[i] * xs[i]; - return Math.sqrt(ret / (double) xs.length); - } - - static public int vsum(int[] xs){ - int ret = 0; - for(int i = 0; i < xs.length; i++) - ret += xs[i]; - return ret; - } - - static public boolean vequiv(int[] xs, int[] ys){ - return Arrays.equals(xs, ys); - } - - static public int[] vadd(int[] x, int[] ys){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] += ys[i]; - return xs; - } - - static public int[] vsub(int[] x, int[] ys){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] -= ys[i]; - return xs; - } - - static public int[] vaddmul(int[] x, int[] ys, int[] zs){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] + ys[i]) * zs[i]; - return xs; - } - - static public int[] vsubmul(int[] x, int[] ys, int[] zs){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] - ys[i]) * zs[i]; - return xs; - } - - static public int[] vaddsmul(int[] x, int[] ys, int z){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] + ys[i]) * z; - return xs; - } - - static public int[] vsubsmul(int[] x, int[] ys, int z){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] - ys[i]) * z; - return xs; - } - - static public int[] vmulsadd(int[] x, int[] ys, int z){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] * ys[i]) + z; - return xs; - } - - static public int[] vdiv(int[] x, int[] ys){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] /= ys[i]; - return xs; - } - - static public int[] vmul(int[] x, int[] ys){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] *= ys[i]; - return xs; - } - - static public int[] vmuladd(int[] x, int[] ys, int[] zs){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] * ys[i]) + zs[i]; - return xs; - } - - static public int[] vmulsub(int[] x, int[] ys, int[] zs){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] * ys[i]) - zs[i]; - return xs; - } - - static public int[] vmax(int[] x, int[] ys){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = Math.max(xs[i], ys[i]); - return xs; - } - - static public int[] vmin(int[] x, int[] ys){ - final int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = Math.min(xs[i], ys[i]); - return xs; - } - - static public int[] vmap(IFn fn, int[] x) { - int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = ((Number) fn.invoke(xs[i])).intValue(); - return xs; - } - - static public int[] vmap(IFn fn, int[] x, int[] ys) { - int[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = ((Number) fn.invoke(xs[i], ys[i])).intValue(); - return xs; - } - -} - -static public class L{ - static public long add(long x, long y){ - return x + y; - } - - static public long subtract(long x, long y){ - return x - y; - } - - static public long negate(long x){ - return -x; - } - - static public long inc(long x){ - return x + 1; - } - - static public long dec(long x){ - return x - 1; - } - - static public long multiply(long x, long y){ - return x * y; - } - - static public long divide(long x, long y){ - return x / y; - } - - static public boolean equiv(long x, long y){ - return x == y; - } - - static public boolean lt(long x, long y){ - return x < y; - } - - static public boolean lte(long x, long y){ - return x <= y; - } - - static public boolean gt(long x, long y){ - return x > y; - } - - static public boolean gte(long x, long y){ - return x >= y; - } - - static public boolean pos(long x){ - return x > 0; - } - - static public boolean neg(long x){ - return x < 0; - } - - static public boolean zero(long x){ - return x == 0; - } - - static public long aget(long[] xs, int i){ - return xs[i]; - } - - static public long aset(long[] xs, int i, long v){ - xs[i] = v; - return v; - } - - static public int alength(long[] xs){ - return xs.length; - } - - static public long[] aclone(long[] xs){ - return xs.clone(); - } - - static public long[] vec(int size, Object init){ - long[] ret = new long[size]; - if(init instanceof Number) - { - long f = ((Number) init).longValue(); - for(int i = 0; i < ret.length; i++) - ret[i] = f; - } - else - { - ISeq s = RT.seq(init); - for(int i = 0; i < size && s != null; i++, s = s.rest()) - ret[i] = ((Number) s.first()).longValue(); - } - return ret; - } - - static public long[] vec(Object sizeOrSeq){ - if(sizeOrSeq instanceof Number) - return new long[((Number) sizeOrSeq).intValue()]; - else - { - ISeq s = RT.seq(sizeOrSeq); - int size = s.count(); - long[] ret = new long[size]; - for(int i = 0; i < size && s != null; i++, s = s.rest()) - ret[i] = ((Number) s.first()).intValue(); - return ret; - } - } - - - static public long[] vsadd(long[] x, long y){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] += y; - return xs; - } - - static public long[] vssub(long[] x, long y){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] -= y; - return xs; - } - - static public long[] vsdiv(long[] x, long y){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] /= y; - return xs; - } - - static public long[] vsmul(long[] x, long y){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] *= y; - return xs; - } - - static public long[] svdiv(long y, long[] x){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = y / xs[i]; - return xs; - } - - static public long[] vsmuladd(long[] x, long y, long[] zs){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[i] * y + zs[i]; - return xs; - } - - static public long[] vsmulsub(long[] x, long y, long[] zs){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[i] * y - zs[i]; - return xs; - } - - static public long[] vsmulsadd(long[] x, long y, long z){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[i] * y + z; - return xs; - } - - static public long[] vsmulssub(long[] x, long y, long z){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[i] * y - z; - return xs; - } - - static public long[] vabs(long[] x){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = Math.abs(xs[i]); - return xs; - } - - static public long[] vnegabs(long[] x){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = -Math.abs(xs[i]); - return xs; - } - - static public long[] vneg(long[] x){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = -xs[i]; - return xs; - } - - static public long[] vsqr(long[] x){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] *= xs[i]; - return xs; - } - - static public long[] vsignedsqr(long[] x){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] *= Math.abs(xs[i]); - return xs; - } - - static public long[] vclip(long[] x, long low, long high){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - { - if(xs[i] < low) - xs[i] = low; - else if(xs[i] > high) - xs[i] = high; - } - return xs; - } - - static public IPersistentVector vclipcounts(long[] x, long low, long high){ - final long[] xs = x.clone(); - int lowc = 0; - int highc = 0; - - for(int i = 0; i < xs.length; i++) - { - if(xs[i] < low) - { - ++lowc; - xs[i] = low; - } - else if(xs[i] > high) - { - ++highc; - xs[i] = high; - } - } - return RT.vector(xs, lowc, highc); - } - - static public long[] vthresh(long[] x, long thresh, long otherwise){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - { - if(xs[i] < thresh) - xs[i] = otherwise; - } - return xs; - } - - static public long[] vreverse(long[] x){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = xs[xs.length - i - 1]; - return xs; - } - - static public long[] vrunningsum(long[] x){ - final long[] xs = x.clone(); - for(int i = 1; i < xs.length; i++) - xs[i] = xs[i - 1] + xs[i]; - return xs; - } - - static public long[] vsort(long[] x){ - final long[] xs = x.clone(); - Arrays.sort(xs); - return xs; - } - - static public long vdot(long[] xs, long[] ys){ - long ret = 0; - for(int i = 0; i < xs.length; i++) - ret += xs[i] * ys[i]; - return ret; - } - - static public long vmax(long[] xs){ - if(xs.length == 0) - return 0; - long ret = xs[0]; - for(int i = 0; i < xs.length; i++) - ret = Math.max(ret, xs[i]); - return ret; - } - - static public long vmin(long[] xs){ - if(xs.length == 0) - return 0; - long ret = xs[0]; - for(int i = 0; i < xs.length; i++) - ret = Math.min(ret, xs[i]); - return ret; - } - - static public double vmean(long[] xs){ - if(xs.length == 0) - return 0; - return vsum(xs) / (double) xs.length; - } - - static public double vrms(long[] xs){ - if(xs.length == 0) - return 0; - long ret = 0; - for(int i = 0; i < xs.length; i++) - ret += xs[i] * xs[i]; - return Math.sqrt(ret / (double) xs.length); - } - - static public long vsum(long[] xs){ - long ret = 0; - for(int i = 0; i < xs.length; i++) - ret += xs[i]; - return ret; - } - - static public boolean vequiv(long[] xs, long[] ys){ - return Arrays.equals(xs, ys); - } - - static public long[] vadd(long[] x, long[] ys){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] += ys[i]; - return xs; - } - - static public long[] vsub(long[] x, long[] ys){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] -= ys[i]; - return xs; - } - - static public long[] vaddmul(long[] x, long[] ys, long[] zs){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] + ys[i]) * zs[i]; - return xs; - } - - static public long[] vsubmul(long[] x, long[] ys, long[] zs){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] - ys[i]) * zs[i]; - return xs; - } - - static public long[] vaddsmul(long[] x, long[] ys, long z){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] + ys[i]) * z; - return xs; - } - - static public long[] vsubsmul(long[] x, long[] ys, long z){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] - ys[i]) * z; - return xs; - } - - static public long[] vmulsadd(long[] x, long[] ys, long z){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] * ys[i]) + z; - return xs; - } - - static public long[] vdiv(long[] x, long[] ys){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] /= ys[i]; - return xs; - } - - static public long[] vmul(long[] x, long[] ys){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] *= ys[i]; - return xs; - } - - static public long[] vmuladd(long[] x, long[] ys, long[] zs){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] * ys[i]) + zs[i]; - return xs; - } - - static public long[] vmulsub(long[] x, long[] ys, long[] zs){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = (xs[i] * ys[i]) - zs[i]; - return xs; - } - - static public long[] vmax(long[] x, long[] ys){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = Math.max(xs[i], ys[i]); - return xs; - } - - static public long[] vmin(long[] x, long[] ys){ - final long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = Math.min(xs[i], ys[i]); - return xs; - } - - static public long[] vmap(IFn fn, long[] x) { - long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = ((Number) fn.invoke(xs[i])).longValue(); - return xs; - } - - static public long[] vmap(IFn fn, long[] x, long[] ys) { - long[] xs = x.clone(); - for(int i = 0; i < xs.length; i++) - xs[i] = ((Number) fn.invoke(xs[i], ys[i])).longValue(); - return xs; - } - -} -*/ - - //overload resolution //* From 5f7c09195ac5dab8bbad713f13549f4430589fe9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 16:33:43 -0600 Subject: [PATCH 324/810] several numeric data fns done --- resources-dev/defnt.cljc | 12 +- src-java/quantum/core/Numeric.java | 2 + .../quantum/untyped/core/data/numeric.cljc | 133 +++++++++++------- src/quantum/core/numeric/misc.cljc | 3 +- src/quantum/core/numeric/operators.cljc | 4 +- src/quantum/core/numeric/predicates.cljc | 14 +- 6 files changed, 107 insertions(+), 61 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 0a562be5..d380364c 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -190,6 +190,10 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x x] char? - [ |] class - [x x] compare + - [ ] conj + - [ ] contains? + - [x |] decimal? + - [x |] denominator - [x x] double - [x x] double? - [ ] even? @@ -197,19 +201,25 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x x] integer? - [x x] float - [x x] float? + - [ ] infinite? - [x x] int - [x x] int? - [x x] long - [x x] long? + - [ ] mod - [ ] nat-int? - [ ] neg? - [ ] neg-int? - [x x] nil? - [x x] not= - [x x] number? + - [x |] numerator - [ ] odd? - [ ] pos? - [ ] pos-int? + - [x |] ratio? + - [ ] rational? + - [ ] rem - [x x] short - [x x] short? - [x x] some? @@ -262,7 +272,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] multiplyP - [ ] not - [ ] num - - [ ] numerator + - [x] numerator - [ ] or - [ ] quotient - [ ] rationalize diff --git a/src-java/quantum/core/Numeric.java b/src-java/quantum/core/Numeric.java index b07e1a45..37392010 100644 --- a/src-java/quantum/core/Numeric.java +++ b/src-java/quantum/core/Numeric.java @@ -13,10 +13,12 @@ public class Numeric { public static final short short0 = (short)0; public static final char char0 = (char) 0; public static final int int0 = 0; + public static final float float0 = 0.0f; public static final byte byte1 = (byte) 1; public static final short short1 = (short)1; public static final char char1 = (char) 1; public static final int int1 = 1; + public static final float float1 = 1.0f; // ================================= Boolean Operations ===================================== // diff --git a/src-untyped/quantum/untyped/core/data/numeric.cljc b/src-untyped/quantum/untyped/core/data/numeric.cljc index b160e7f6..bed74cf5 100644 --- a/src-untyped/quantum/untyped/core/data/numeric.cljc +++ b/src-untyped/quantum/untyped/core/data/numeric.cljc @@ -16,10 +16,12 @@ `ratio?` for CLJS: - Fraction.js is the best contender as of 9/27/2018. https://github.com/infusion/Fraction.js" (:refer-clojure :exclude - [#?@(:cljs [-compare]) decimal? denominator integer? number? numerator ratio?]) + [decimal? denominator integer? number? numerator ratio?]) (:require [clojure.core :as core] [clojure.string :as str] + #?(:cljs goog.math.Integer) + #?(:cljs goog.math.Long) [quantum.core.data.primitive :as p] [quantum.core.data.string :as dstr] [quantum.core.logic @@ -34,46 +36,34 @@ #?(:cljs (:require-macros [quantum.core.data.numeric :as self]))) - -#?(:clj (defalias numerator core/numerator) - :cljs (t/defn numerator)) - -#?(:clj (defalias denominator core/denominator) - :cljs (t/defn denominator)) - -#?(:clj (defalias ratio? core/ratio?) - :cljs (defn ratio? [x] (instance? Ratio x))) - - - - ;; ===== Integers ===== ;; -#?(:clj (def big-integer? (t/isa? BigInteger))) +;; Incorporated `clojure.core/int?` +;; Incorporated `cljs.core/int?` +(var/def fixint? "The set of all fixed-precision integers." + (t/or #?@(:clj [p/byte? p/short?]) p/int? p/long?)) -#?(:clj (def clj-bigint? (t/isa? clojure.lang.BigInt))) +#?(:clj (def java-bigint? (t/isa? BigInteger))) +#?(:clj (def clj-bigint? (t/isa? clojure.lang.BigInt))) -(def bigint? #?(:clj (t/or clj-bigint? big-integer?) - ;; TODO bring in implementation per the ns docstring - :cljs t/none?)) +(var/def bigint? "The set of all 'big' (arbitrary-precision) integers." + #?(:clj ;; TODO bring in a better implementation per the ns docstring? + (t/or clj-bigint? java-bigint?) + ;; TODO bring in implementation per the ns docstring + :cljs t/none?)) ;; Incorporated `clojure.lang.Util/isInteger` ;; Incorporated `clojure.core/integer?` ;; Incorporated `cljs.core/integer?` -(def integer? (t/or #?@(:clj [p/byte? p/short?]) p/int? p/long? bigint?)) - -;; Incorporated `clojure.core/int?` -;; Incorporated `cljs.core/int?` -(var/def fixed-integer? "The set of all fixed-precision integers." - (t/or ?@(:clj [p/byte? p/short?]) p/int? p/long?)) +(def integer? (t/or fixint? bigint?)) #?(:clj -(t/defn >big-integer > big-integer? - ([x big-integer?] x) - ([x clj-bigint? > (t/* big-integer?)] (.toBigInteger x)) +(t/defn >java-bigint > java-bigint? + ([x java-bigint?] x) + ([x clj-bigint? > (t/assume java-bigint?)] (.toBigInteger x)) ([;; TODO TYPED `(- number? BigInteger BigInt)` - x (t/or p/short? p/int? p/long?) > (t/* big-integer?)] ; TODO BigDecimal - (-> x p/>long (BigInteger/valueOf))))) + x (t/or p/short? p/int? p/long?) > (t/assume java-bigint?)] ; TODO BigDecimal + (-> x p/>long BigInteger/valueOf)))) #?(:cljs (t/defn >bigint > bigint? @@ -82,14 +72,31 @@ ;; ===== Decimals ===== ;; -(def bigdec? #?(:clj ;; TODO bring in a better implementation per the ns docstring? - (t/isa? BigDecimal) - ;; TODO bring in implementation per the ns docstring - :cljs t/none?)) +;; Incorporated `clojure.core/float?` +;; Incorporated `cljs.core/float?` +(var/def fixdec? "The set of all fixed-precision decimals." + (t/or #?(:clj p/float?) p/double?)) + +;; Incorporated `clojure.core/decimal?` +(var/def bigdec? "The set of all 'big' (arbitrary-precision) decimals." + #?(:clj ;; TODO bring in a better implementation per the ns docstring? + (t/isa? BigDecimal) + ;; TODO bring in implementation per the ns docstring + :cljs t/none?)) + +;; ===== Precision ===== ;; + +(var/def fixnum? "The set of all fixed-precision numbers." + (t/or fixint? fixdec?)) + +(var/def bignum? "The set of all 'big' (arbitrary-precision) numbers." + (t/or fixint? fixdec?)) ;; ===== Ratios ===== ;; -(def ratio? (t/isa? #?(:clj clojure.lang.Ratio :cljs quantum.core.data.numeric.Ratio))) +(def ratio? #?(:clj (t/isa? clojure.lang.Ratio) + ;; TODO bring in implementation per the ns docstring + :cljs t/none?)) #?(:clj (defnt rationalize @@ -106,23 +113,51 @@ (Numbers/divide bv (.pow BigInteger.TEN scale))))) ([x (t/isa? java.lang.Number)] x))) -(defnt >ratio > ratio? - ([x ??] (>ratio x #?(:clj 1 :cljs int/ONE))) - ([x ??, y ??] - #?(:clj (whenf (rationalize (/ x y)) - (fn-not core/ratio?) - #(clojure.lang.Ratio. (->big-integer %) java.math.BigInteger/ONE)) - :cljs (let [x (>bigint x) - y (>bigint y) - d (gcd x y) - x' (.divide x d) - y' (.divide y d)] - (if (.isNegative y') - (Ratio. (.negate x') (.negate y')) - (Ratio. x' y')))))) +(t/defn >ratio > ratio? + #?(:clj ([x ??] (>ratio x 1))) + #?(:clj ([x ??, y ??] + (whenf (rationalize (/ x y)) + (fn-not core/ratio?) + #(clojure.lang.Ratio. (->big-integer %) java.math.BigInteger/ONE))))) ;; ===== General ===== ;; +(t/defn ^:inline >zero-of-type #_> #_zero? + ([x p/byte? > (t/type x)] Numeric/byte0) + ([x p/short? > (t/type x)] Numeric/short0) + ([x p/char? > (t/type x)] Numeric/char0) + ([x p/int? > #?(:clj (type x) :cljs (t/assume (t/type x)))] + #?(:clj Numeric/int0 :cljs goog.math.Integer/ZERO)) + ([x p/long? > #?(:clj (type x) :cljs (t/assume (t/type x)))] + #?(:clj 0 :cljs goog.math.Long/ZERO)) + ([x p/float? > (t/type x)] Numeric/float0) + ([x p/double? > (t/type x)] 0.0) +#?(:clj ([x p/java-bigint? > (t/type x)] java.math.BigInteger/ZERO)) +#?(:clj ([x p/clj-bigint? > (t/type x)] clojure.lang.BigInt/ZERO))) + +(t/defn ^:inline >one-of-type #_> #_one? + ([x p/byte? > (t/type x)] Numeric/byte1) + ([x p/short? > (t/type x)] Numeric/short1) + ([x p/char? > (t/type x)] Numeric/char1) + ([x p/int? > #?(:clj (type x) :cljs (t/assume (t/type x)))] + #?(:clj Numeric/int1 :cljs goog.math.Integer/ONE)) + ([x p/long? > #?(:clj (type x) :cljs (t/assume (t/type x)))] + #?(:clj 1 :cljs goog.math.Long/ONE)) + ([x p/float? > (t/type x)] Numeric/float1) + ([x p/double? > (t/type x)] 1.0) +#?(:clj ([x p/java-bigint? > (t/type x)] java.math.BigInteger/ONE)) +#?(:clj ([x p/clj-bigint? > (t/type x)] clojure.lang.BigInt/ONE))) + +(t/defn >one-of-type) + +(t/defn ^:inline numerator > numerically-integer? + ([x numerically-integer? > (t/type x)] x) +#?(:clj ([x ratio? > (t/assume java-bigint?)] (.numerator x)))) + +(t/defn ^:inline denominator > numerically-integer? + ([x numerically-integer? > (t/type x)] (>one-of-type x)) +#?(:clj ([x ratio? > (t/assume java-bigint?)] (.denominator x)))) + (def decimal? (or #?(:clj p/float?) p/double? bigdec?)) ;; ===== Likenesses ===== ;; diff --git a/src/quantum/core/numeric/misc.cljc b/src/quantum/core/numeric/misc.cljc index 5617a80b..2a40b710 100644 --- a/src/quantum/core/numeric/misc.cljc +++ b/src/quantum/core/numeric/misc.cljc @@ -16,8 +16,7 @@ #?(:clj (defmacro rem [n div] `(Numeric/rem ~n ~div)) ; TODO `defnt` :cljs (defnt rem - ([^double? x n] (core/rem x n)) - ([^bigint? x n] (.modulo x n)))) + ([^double? x n] (core/rem x n)))) #?(:clj (defalias mod core/mod) ; TODO fix :cljs (defnt mod diff --git a/src/quantum/core/numeric/operators.cljc b/src/quantum/core/numeric/operators.cljc index 9191f27c..2affc0ac 100644 --- a/src/quantum/core/numeric/operators.cljc +++ b/src/quantum/core/numeric/operators.cljc @@ -80,7 +80,7 @@ ([] 0) ([x numeric-primitive? > (t/type x)] (#?(:clj Numeric/negate :cljs cljs.core/-) x)) #?(:clj ([x clj-bigint? > (t/type x)] ...)) -#?(:clj ([x big-integer? > (t/type x)] (.negate x))) +#?(:clj ([x java-bigint? > (t/type x)] (.negate x))) ([x numeric-primitive?, y numeric-primitive? > ?] (#?(:clj Numeric/subtract :cljs cljs.core/-) x y)))) @@ -322,4 +322,4 @@ ([a# b# c#] (when (and a# b# c#) (~core-op a# b# c#))) ([a# b# c# & args#] (let [argsf# (conj args# c# b# a#)] - (when (every? t/val? argsf#) (reduce ~core-op argsf#)))))))) + (when (every? p/val? argsf#) (reduce ~core-op argsf#)))))))) diff --git a/src/quantum/core/numeric/predicates.cljc b/src/quantum/core/numeric/predicates.cljc index 16fe792e..452dd15b 100644 --- a/src/quantum/core/numeric/predicates.cljc +++ b/src/quantum/core/numeric/predicates.cljc @@ -5,7 +5,7 @@ #?(:cljs [com.gfredericks.goog.math.Integer :as int]) [quantum.core.compare.core :as comp] [quantum.core.data.numeric :as dnum - :refer [big-integer? bigdec? bigint? clj-bigint? numeric-primitive?]] + :refer [bigdec? bigint? clj-bigint? java-bigint? numeric-primitive?]] [quantum.core.data.primitive :as p] [quantum.core.logic :as l] [quantum.core.type :as t] @@ -15,30 +15,30 @@ #?(:clj (:import [quantum.core Numeric]))) - ;; TODO TYPED add CLJS ratio impl + ;; TODO TYPED (t/defn ^:inline neg? > p/boolean? ([x numeric-primitive?] #?(:clj (Numeric/isNeg x) :cljs (comp/< x 0))) -#?(:clj ([x (t/or big-integer? bigdec?)] (-> x .signum neg?))) +#?(:clj ([x (t/or java-bigint? bigdec?)] (-> x .signum neg?))) #?(:clj ([x clj-bigint?] (if (-> x .bipart p/nil?) (-> x .lpart neg?) (-> x .bipart .signum neg?)))) #?(:cljs ([x bigint?] (.isNegative x))) #?(:clj ([x dnum/ratio?] (-> x .numerator .signum neg?)))) - ;; TODO TYPED add CLJS ratio impl + ;; TODO TYPED (t/defn ^:inline pos? > p/boolean? ([x numeric-primitive?] #?(:clj (Numeric/isPos x) :cljs (comp/> x 0))) -#?(:clj ([x (t/or big-integer? bigdec?)] (-> x .signum pos?))) +#?(:clj ([x (t/or java-bigint? bigdec?)] (-> x .signum pos?))) #?(:clj ([x clj-bigint?] (if (-> x .bipart p/nil?) (-> x .lpart pos?) (-> x .bipart .signum pos?)))) #?(:cljs ([x bigint?] (l/not (.isNegative x)))) #?(:clj ([x dnum/ratio?] (-> x .numerator .signum pos?)))) - ;; TODO TYPED add CLJS ratio impl + ;; TODO TYPED (t/defn ^:inline zero? > p/boolean? ([x numeric-primitive?] #?(:clj (Numeric/isZero x) :cljs (comp/== x 0))) -#?(:clj ([x (t/or big-integer? bigdec?)] (-> x .signum zero?))) +#?(:clj ([x (t/or java-bigint? bigdec?)] (-> x .signum zero?))) #?(:clj ([x clj-bigint?] (if (-> x .bipart p/nil?) (-> x .lpart zero?) (-> x .bipart .signum zero?)))) From 3480e1e07135486de5351e68992cbaa847b206a0 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 16:41:44 -0600 Subject: [PATCH 325/810] Fix compilation --- resources-dev/defnt.cljc | 2 +- .../quantum/untyped/core/data/numeric.cljc | 21 +- src-untyped/quantum/untyped/core/type.cljc | 253 ++++++++---------- 3 files changed, 127 insertions(+), 149 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index d380364c..7c32c512 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -102,7 +102,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative ([n dnum/std-integer?, xs ?] ...) - t/extend-defn! - t/input-type - - `(t/input-type >namespace :?)` meaing the possible input types to the first input to `>namespace` + - `(t/input-type >namespace :?)` meaning the possible input types to the first input to `>namespace` - `(t/input-type reduce :_ :_ :?)` - Then if those fns ever get extended then it should trigger a chain-reaction of recompilations - dc/of diff --git a/src-untyped/quantum/untyped/core/data/numeric.cljc b/src-untyped/quantum/untyped/core/data/numeric.cljc index bed74cf5..12af762d 100644 --- a/src-untyped/quantum/untyped/core/data/numeric.cljc +++ b/src-untyped/quantum/untyped/core/data/numeric.cljc @@ -24,17 +24,12 @@ #?(:cljs goog.math.Long) [quantum.core.data.primitive :as p] [quantum.core.data.string :as dstr] - [quantum.core.logic + #_[quantum.core.logic :refer [whenf fn-not fn=]] - [quantum.core.type :as t - :refer [defnt]] - [quantum.core.vars :as var - :refer [defalias]]) - (:import - [clojure.lang BigInt Numbers] - [java.math BigDecimal BigInteger]) -#?(:cljs (:require-macros - [quantum.core.data.numeric :as self]))) + [quantum.core.type :as t] + ;; TODO TYPED excise reference + [quantum.core.untyped.vars :as var + :refer [defalias]])) ;; ===== Integers ===== ;; @@ -43,7 +38,7 @@ (var/def fixint? "The set of all fixed-precision integers." (t/or #?@(:clj [p/byte? p/short?]) p/int? p/long?)) -#?(:clj (def java-bigint? (t/isa? BigInteger))) +#?(:clj (def java-bigint? (t/isa? java.math.BigInteger))) #?(:clj (def clj-bigint? (t/isa? clojure.lang.BigInt))) (var/def bigint? "The set of all 'big' (arbitrary-precision) integers." @@ -84,6 +79,8 @@ ;; TODO bring in implementation per the ns docstring :cljs t/none?)) +(def decimal? (t/or fixdec? bigdec?)) + ;; ===== Precision ===== ;; (var/def fixnum? "The set of all fixed-precision numbers." @@ -158,8 +155,6 @@ ([x numerically-integer? > (t/type x)] (>one-of-type x)) #?(:clj ([x ratio? > (t/assume java-bigint?)] (.denominator x)))) -(def decimal? (or #?(:clj p/float?) p/double? bigdec?)) - ;; ===== Likenesses ===== ;; diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index fa196090..5a1526e6 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -253,27 +253,6 @@ (value x)) :cljs nil))) -;; ===== Definition/Registration ===== ;; - -;; TODO clean up -#?(:clj -(defmacro define [sym t] - `(~'def ~sym (let [t# ~t] - (assert (utr/type? t#) t#) - t#)))) - -;; TODO clean up -(defn undef [reg sym] - (if-let [t (get reg sym)] - (let [reg' (dissoc reg sym)] - (if (instance? ClassType t) - (uc/dissoc-in reg' [:by-class (.-c ^ClassType t)]) - (TODO))) - reg)) - -;; TODO clean up -(defn undef! [sym] (swap! *type-registry undef sym)) - (def type? (isa? PType)) (def not-type? (isa? NotType)) (def or-type? (isa? OrType)) @@ -641,204 +620,208 @@ ;; ===== Queues ===== ;; Particularly FIFO queues, as LIFO = stack = any vector - (-def +queue? (isa? #?(:clj clojure.lang.PersistentQueue + (def +queue? (isa? #?(:clj clojure.lang.PersistentQueue :cljs cljs.core/PersistentQueue))) - (-def !+queue? none?) - (-def ?!+queue? (or +queue? !+queue?)) -#?(:clj (-def !!queue? (or (isa? java.util.concurrent.BlockingQueue) + (def !+queue? none?) + (def ?!+queue? (or +queue? !+queue?)) +#?(:clj (def !!queue? (or (isa? java.util.concurrent.BlockingQueue) (isa? java.util.concurrent.TransferQueue) (isa? java.util.concurrent.ConcurrentLinkedQueue)))) - (-def !queue? #?(:clj ;; Considered single-threaded mutable unless otherwise noted + (def !queue? #?(:clj ;; Considered single-threaded mutable unless otherwise noted (identity #_- (isa? java.util.Queue) #_(or ?!+queue? !!queue?)) ; TODO re-enable once `-` works :cljs (isa? goog.structs.Queue))) - (-def queue? (or ?!+queue? !queue? #?(:clj !!queue?))) + (def queue? (or ?!+queue? !queue? #?(:clj !!queue?))) ;; ===== Sets ===== ;; Associative; A special type of Map whose keys and vals are identical -#?(:clj (-def java-set? (isa? java.util.Set))) +#?(:clj (def java-set? (isa? java.util.Set))) ;; ----- Identity Sets (identity-based equality) ----- ;; - (-def !identity-set? #?(:clj none? #_(isa? java.util.IdentityHashSet) ; TODO implement + (def !identity-set? #?(:clj none? #_(isa? java.util.IdentityHashSet) ; TODO implement :cljs (isa? js/Set))) - (-def identity-set? !identity-set?) + (def identity-set? !identity-set?) ;; ----- Hash Sets (value-based equality) ----- ;; - (-def +hash-set? (isa? #?(:clj clojure.lang.PersistentHashSet + (def +hash-set? (isa? #?(:clj clojure.lang.PersistentHashSet :cljs cljs.core/PersistentHashSet))) - (-def !+hash-set? (isa? #?(:clj clojure.lang.PersistentHashSet$TransientHashSet + (def !+hash-set? (isa? #?(:clj clojure.lang.PersistentHashSet$TransientHashSet :cljs cljs.core/TransientHashSet))) - (-def ?!+hash-set? (or +hash-set? !+hash-set?)) - - (-def !hash-set|byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.ByteOpenHashSet) :cljs none?)) - (-def !hash-set|char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.CharOpenHashSet) :cljs none?)) - (-def !hash-set|short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.ShortOpenHashSet) :cljs none?)) - (-def !hash-set|int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.IntOpenHashSet) :cljs none?)) - (-def !hash-set|long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.LongOpenHashSet) :cljs none?)) - (-def !hash-set|float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.FloatOpenHashSet) :cljs none?)) - (-def !hash-set|double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.DoubleOpenHashSet) :cljs none?)) - (-def !hash-set|ref? #?(:clj (or (isa? java.util.HashSet) - (isa? it.unimi.dsi.fastutil.objects.ReferenceOpenHashSet)) - :cljs none?)) - - (-def !hash-set? (or !hash-set|ref? - !hash-set|byte? !hash-set|short? !hash-set|char? - !hash-set|int? !hash-set|long? - !hash-set|float? !hash-set|double?)) + (def ?!+hash-set? (or +hash-set? !+hash-set?)) + + (def !hash-set|byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.ByteOpenHashSet) :cljs none?)) + (def !hash-set|char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.CharOpenHashSet) :cljs none?)) + (def !hash-set|short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.ShortOpenHashSet) :cljs none?)) + (def !hash-set|int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.IntOpenHashSet) :cljs none?)) + (def !hash-set|long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.LongOpenHashSet) :cljs none?)) + (def !hash-set|float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.FloatOpenHashSet) :cljs none?)) + (def !hash-set|double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.DoubleOpenHashSet) :cljs none?)) + (def !hash-set|ref? #?(:clj (or (isa? java.util.HashSet) + (isa? it.unimi.dsi.fastutil.objects.ReferenceOpenHashSet)) + :cljs none?)) + + (def !hash-set? (or !hash-set|ref? + !hash-set|byte? !hash-set|short? !hash-set|char? + !hash-set|int? !hash-set|long? + !hash-set|float? !hash-set|double?)) ;; CLJ technically can have via ConcurrentHashMap with same KVs but this hasn't been implemented yet -#?(:clj (-def !!hash-set? none?)) - (-def hash-set? (or ?!+hash-set? !hash-set? #?(:clj !!hash-set?))) +#?(:clj (def !!hash-set? none?)) + (def hash-set? (or ?!+hash-set? !hash-set? #?(:clj !!hash-set?))) ;; ----- Unsorted Sets ----- ;; - (-def +unsorted-set? +hash-set?) - (-def !+unsorted-set? !+hash-set?) - (-def ?!+unsorted-set? ?!+hash-set?) + (def +unsorted-set? +hash-set?) + (def !+unsorted-set? !+hash-set?) + (def ?!+unsorted-set? ?!+hash-set?) - (-def !unsorted-set|byte? !hash-set|byte?) - (-def !unsorted-set|short? !hash-set|char?) - (-def !unsorted-set|char? !hash-set|short?) - (-def !unsorted-set|int? !hash-set|int?) - (-def !unsorted-set|long? !hash-set|long?) - (-def !unsorted-set|float? !hash-set|float?) - (-def !unsorted-set|double? !hash-set|double?) - (-def !unsorted-set|ref? !hash-set|ref?) + (def !unsorted-set|byte? !hash-set|byte?) + (def !unsorted-set|short? !hash-set|char?) + (def !unsorted-set|char? !hash-set|short?) + (def !unsorted-set|int? !hash-set|int?) + (def !unsorted-set|long? !hash-set|long?) + (def !unsorted-set|float? !hash-set|float?) + (def !unsorted-set|double? !hash-set|double?) + (def !unsorted-set|ref? !hash-set|ref?) - (-def !unsorted-set? (or !unsorted-set|ref? - !unsorted-set|byte? !unsorted-set|short? !unsorted-set|char? - !unsorted-set|int? !unsorted-set|long? - !unsorted-set|float? !unsorted-set|double?)) + (def !unsorted-set? + (or !unsorted-set|ref? + !unsorted-set|byte? !unsorted-set|short? !unsorted-set|char? + !unsorted-set|int? !unsorted-set|long? + !unsorted-set|float? !unsorted-set|double?)) -#?(:clj (-def !!unsorted-set? !!hash-set?)) - (-def unsorted-set? hash-set?) +#?(:clj (def !!unsorted-set? !!hash-set?)) + (def unsorted-set? hash-set?) ;; ----- Sorted Sets ----- ;; - (-def +sorted-set? (isa? #?(:clj clojure.lang.PersistentTreeSet - :cljs cljs.core/PersistentTreeSet))) - (-def !+sorted-set? none?) - (-def ?!+sorted-set? (or +sorted-set? !+sorted-set?)) - - (-def !sorted-set|byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.ByteSortedSet) - :cljs none?)) - (-def !sorted-set|short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.ShortSortedSet) :cljs none?)) - (-def !sorted-set|char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.CharSortedSet) :cljs none?)) - (-def !sorted-set|int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.IntSortedSet) :cljs none?)) - (-def !sorted-set|long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.LongSortedSet) :cljs none?)) - (-def !sorted-set|float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.FloatSortedSet) :cljs none?)) - (-def !sorted-set|double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.DoubleSortedSet) - :cljs none?)) + (def +sorted-set? (isa? #?(:clj clojure.lang.PersistentTreeSet + :cljs cljs.core/PersistentTreeSet))) + (def !+sorted-set? none?) + (def ?!+sorted-set? (or +sorted-set? !+sorted-set?)) + + (def !sorted-set|byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.ByteSortedSet) + :cljs none?)) + (def !sorted-set|short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.ShortSortedSet) :cljs none?)) + (def !sorted-set|char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.CharSortedSet) :cljs none?)) + (def !sorted-set|int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.IntSortedSet) :cljs none?)) + (def !sorted-set|long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.LongSortedSet) :cljs none?)) + (def !sorted-set|float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.FloatSortedSet) :cljs none?)) + (def !sorted-set|double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.DoubleSortedSet) + :cljs none?)) ;; CLJS technically can have via goog.structs.AVLTree with same KVs but this hasn't been implemented yet - (-def !sorted-set|ref? #?(:clj (isa? java.util.TreeSet) :cljs none?)) + (def !sorted-set|ref? #?(:clj (isa? java.util.TreeSet) :cljs none?)) - (-def !sorted-set? (or !sorted-set|ref? - !sorted-set|byte? !sorted-set|short? !sorted-set|char? - !sorted-set|int? !sorted-set|long? - !sorted-set|float? !sorted-set|double?)) + (def !sorted-set? (or !sorted-set|ref? + !sorted-set|byte? !sorted-set|short? !sorted-set|char? + !sorted-set|int? !sorted-set|long? + !sorted-set|float? !sorted-set|double?)) ;; CLJ technically can have via ConcurrentSkipListMap with same KVs but this hasn't been implemented yet -#?(:clj (-def !!sorted-set? none?)) - (-def sorted-set? (or ?!+sorted-set? !sorted-set? #?@(:clj [!!sorted-set? (isa? java.util.SortedSet)]))) +#?(:clj (def !!sorted-set? none?)) + (def sorted-set? (or ?!+sorted-set? !sorted-set? #?@(:clj [!!sorted-set? (isa? java.util.SortedSet)]))) ;; ----- Other Sets ----- ;; - (-def +insertion-ordered-set? (or (isa? linked.set.LinkedSet) - ;; This is true, but we have replaced OrderedSet with LinkedSet - #_(:clj (isa? flatland.ordered.set.OrderedSet)))) - (-def !+insertion-ordered-set? none? - ;; This is true, but we have replaced OrderedSet with LinkedSet - #_(isa? flatland.ordered.set.TransientOrderedSet)) - (-def ?!+insertion-ordered-set? (or +insertion-ordered-set? !+insertion-ordered-set?)) + (def +insertion-ordered-set? (or (isa? linked.set.LinkedSet) + ;; This is true, but we have replaced OrderedSet with LinkedSet + #_(:clj (isa? flatland.ordered.set.OrderedSet)))) + (def !+insertion-ordered-set? none? + ;; This is true, but we have replaced OrderedSet with LinkedSet + #_(isa? flatland.ordered.set.TransientOrderedSet)) + (def ?!+insertion-ordered-set? (or +insertion-ordered-set? !+insertion-ordered-set?)) - (-def !insertion-ordered-set? #?(:clj (isa? java.util.LinkedHashSet) :cljs none?)) + (def !insertion-ordered-set? #?(:clj (isa? java.util.LinkedHashSet) :cljs none?)) ;; CLJ technically can have via ConcurrentLinkedHashMap with same KVs but this hasn't been implemented yet -#?(:clj (-def !!insertion-ordered-set? none?)) +#?(:clj (def !!insertion-ordered-set? none?)) - (-def insertion-ordered-set? (or ?!+insertion-ordered-set? !insertion-ordered-set? #?(:clj !!insertion-ordered-set?))) + (def insertion-ordered-set? (or ?!+insertion-ordered-set? !insertion-ordered-set? #?(:clj !!insertion-ordered-set?))) ;; ----- General Sets ----- ;; - (-def !+set? (isa? #?(:clj clojure.lang.ITransientSet - :cljs cljs.core/ITransientSet))) + (def !+set? (isa? #?(:clj clojure.lang.ITransientSet + :cljs cljs.core/ITransientSet))) - (-def +set|built-in? (or (isa? #?(:clj clojure.lang.PersistentHashSet :cljs cljs.core/PersistentHashSet)) + (def +set|built-in? (or (isa? #?(:clj clojure.lang.PersistentHashSet :cljs cljs.core/PersistentHashSet)) (isa? #?(:clj clojure.lang.PersistentTreeSet :cljs cljs.core/PersistentTreeSet)))) - (-def +set? (isa? #?(:clj clojure.lang.IPersistentSet - :cljs cljs.core/ISet))) - (-def ?!+set? (or !+set? +set?)) + (def +set? (isa? #?(:clj clojure.lang.IPersistentSet + :cljs cljs.core/ISet))) + (def ?!+set? (or !+set? +set?)) - (-def !set|byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.ByteSet) :cljs none?)) - (-def !set|short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.ShortSet) :cljs none?)) - (-def !set|char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.CharSet) :cljs none?)) - (-def !set|int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.IntSet) :cljs none?)) - (-def !set|long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.LongSet) :cljs none?)) - (-def !set|float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.FloatSet) :cljs none?)) - (-def !set|double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.DoubleSet) :cljs none?)) - (-def !set|ref? (or !unsorted-set|ref? !sorted-set|ref?)) + (def !set|byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.ByteSet) :cljs none?)) + (def !set|short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.ShortSet) :cljs none?)) + (def !set|char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.CharSet) :cljs none?)) + (def !set|int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.IntSet) :cljs none?)) + (def !set|long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.LongSet) :cljs none?)) + (def !set|float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.FloatSet) :cljs none?)) + (def !set|double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.DoubleSet) :cljs none?)) + (def !set|ref? (or !unsorted-set|ref? !sorted-set|ref?)) - (-def !set? (or !set|ref? - !set|byte? !set|short? !set|char? - !set|int? !set|long? - !set|float? !set|double?)) + (def !set? (or !set|ref? + !set|byte? !set|short? !set|char? + !set|int? !set|long? + !set|float? !set|double?)) -#?(:clj (-def !!set? (or !!unsorted-set? !!sorted-set?))) - (-def set? (or ?!+set? !set? #?@(:clj [!!set? (isa? java.util.Set)]))) +#?(:clj (def !!set? (or !!unsorted-set? !!sorted-set?))) + (def set? (or ?!+set? !set? #?@(:clj [!!set? (isa? java.util.Set)]))) ;; ===== Functions ===== ;; - (-def fn? (isa? #?(:clj clojure.lang.Fn :cljs js/Function))) + (def fn? (isa? #?(:clj clojure.lang.Fn :cljs js/Function))) - (-def ifn? (isa? #?(:clj clojure.lang.IFn :cljs cljs.core/IFn))) + (def ifn? (isa? #?(:clj clojure.lang.IFn :cljs cljs.core/IFn))) - (-def fnt? (and fn? (>expr (fn-> c/meta ::type)))) + (def fnt? (and fn? (>expr (fn-> c/meta ::type)))) - (-def multimethod? (isa? #?(:clj clojure.lang.MultiFn :cljs cljs.core/IMultiFn))) + (def multimethod? (isa? #?(:clj clojure.lang.MultiFn :cljs cljs.core/IMultiFn))) ;; I.e., can you call/invoke it by being in functor position (first element of an unquoted ;; list) within a typed context? ;; TODO should we allow java.lang.Runnable, java.util.concurrent.Callable, and other ;; functional interfaces to be `callable?`? - (-def callable? (or ifn? fnt?)) + (def callable? (or ifn? fnt?)) ;; ===== Miscellaneous ===== ;; ;; Used by `quantum.untyped.core.analyze.ast` - (-def with-metable? (isa? #?(:clj clojure.lang.IObj :cljs cljs.core/IWithMeta))) + (def with-metable? (isa? #?(:clj clojure.lang.IObj :cljs cljs.core/IWithMeta))) -#?(:clj (-def thread? (isa? java.lang.Thread))) + ;; TODO move +#?(:clj (def thread? (isa? java.lang.Thread))) ;; Used by `quantum.untyped.core.analyze` (def throwable? "Able to be used with `throw`" #?(:clj (isa? java.lang.Throwable) :cljs any?)) ;; Used by `quantum.untyped.core.analyze` - (-def regex? (isa? #?(:clj java.util.regex.Pattern :cljs js/RegExp))) + (def regex? (isa? #?(:clj java.util.regex.Pattern :cljs js/RegExp))) ;; Used by `quantum.untyped.core.analyze` - (-def keyword? (isa? #?(:clj clojure.lang.Keyword :cljs cljs.core/Keyword))) + (def keyword? (isa? #?(:clj clojure.lang.Keyword :cljs cljs.core/Keyword))) ;; Used by `quantum.untyped.core.analyze` via `t/literal?` - (-def str? (isa? #?(:clj java.lang.String :cljs js/String))) + (def str? (isa? #?(:clj java.lang.String :cljs js/String))) ;; Used by `quantum.untyped.core.analyze` via `t/literal?` - (-def symbol? (isa? #?(:clj clojure.lang.Symbol :cljs cljs.core/Symbol))) + (def symbol? (isa? #?(:clj clojure.lang.Symbol :cljs cljs.core/Symbol))) + ;; TODO move ;; `js/File` isn't always available! Use an abstraction -#?(:clj (-def file? (isa? java.io.File))) +#?(:clj (def file? (isa? java.io.File))) ;; TODO move - (-def delay? (isa? #?(:clj clojure.lang.Delay :cljs cljs.core/Delay))) + (def delay? (isa? #?(:clj clojure.lang.Delay :cljs cljs.core/Delay))) -#?(:clj (-def tagged-literal? (isa? clojure.lang.TaggedLiteral))) +#?(:clj (def tagged-literal? (isa? clojure.lang.TaggedLiteral))) ;; Used in `quantum.untyped.core.analyze` - (-def literal? + (def literal? (or nil? boolean? symbol? keyword? str? #?(:clj long?) double? #?(:clj tagged-literal?))) - #_(-def form? (or literal? +list? +vector? ...)) + + #_(def form? (or literal? +list? +vector? ...)) From d0691dccb06a9e56e8cd4f64b258b525e460aa65 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 17:02:48 -0600 Subject: [PATCH 326/810] Get data.primitive to compile --- resources-dev/defnt.cljc | 4 + src-untyped/quantum/untyped/core/type.cljc | 4 + src/quantum/core/data/primitive.cljc | 170 ++++++++++++--------- src/quantum/core/data/vector.cljc | 14 +- src/quantum/core/type.cljc | 3 +- 5 files changed, 117 insertions(+), 78 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 7c32c512..5fed54f6 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -55,6 +55,10 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - Analysis + - This is accepted by the type system without knowing the type: + (java.math.BigInteger. 1 (-> (ByteBuffer/allocate (int 8)) (.putLong x) .array)) + + So, constructors need the same kind of lookup that dot calls have - (if (dcoll/reduced? ret) ;; TODO TYPED `(ref/deref ret)` should realize it's dealing with a `reduced?` (ref/deref ret) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 5a1526e6..37d9b619 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -618,6 +618,10 @@ (isa? #?(:clj clojure.lang.PersistentArrayMap :cljs cljs.core/PersistentArrayMap)) (isa? #?(:clj clojure.lang.PersistentTreeMap :cljs cljs.core/PersistentTreeMap)))) +;; Used in `quantum.untyped.core.analyze` +(def +vector|built-in? (isa? #?(:clj clojure.lang.PersistentVector + :cljs cljs.core/PersistentVector))) + ;; ===== Queues ===== ;; Particularly FIFO queues, as LIFO = stack = any vector (def +queue? (isa? #?(:clj clojure.lang.PersistentQueue diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 0d4c4c25..cbd55dbe 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -169,7 +169,10 @@ ;; ----- Boolean ----- ;; -(t/defn ^:inline >boolean > boolean? +(t/defn ^:inline >boolean + "Converts input to a boolean. + Differs from asking whether something is truthy/falsey." + > boolean? ([x boolean?] x) ([x (t/value "true")] true) ([x (t/value "false")] false) ;; For purposes of intrinsics @@ -179,14 +182,17 @@ ;; ----- Int ----- ;; ;; Forward-declared so `radix?` coercion to `int` works +;; TODO figure out how to use with goog.math.Integer/Long #?(:clj (t/defn ^:inline >int* - "May involve non-out-of-range truncation" + "May involve non-out-of-range truncation." > int? ([x int?] x) ;; For purposes of intrinsics ([x (t/- primitive? int? boolean?)] (clojure.lang.RT/uncheckedIntCast x)))) -(t/defn ^:inline >int +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +#_(t/defn ^:inline >int "May involve non-out-of-range truncation" > #?(:clj int? :cljs numerically-int?) ([x #?(:clj int? :cljs numerically-int?)] x) @@ -209,17 +215,21 @@ ;; ----- Byte ----- ;; +;; TODO figure out how to use with CLJS #?(:clj -(defnt ^:inline >byte* > byte? - "May involve non-out-of-range truncation" +(t/defn ^:inline >byte* + "May involve non-out-of-range truncation." + > byte? ([x byte?] x) ([x (t/- primitive? byte? boolean?)] (Primitive/uncheckedByteCast x)))) -(defnt ^:inline >byte > #?(:clj byte? :cljs numerically-byte?) - "May involve non-out-of-range truncation" +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +#_(defnt ^:inline >byte > #?(:clj byte? :cljs numerically-byte?) + "May involve non-out-of-range truncation." ([x #?(:clj byte? :cljs numerically-byte?)] x) #?(:clj ([x (t/and (t/- primitive? byte? boolean?) numerically-byte?)] (>byte* x)) - :cljs ([x (t/and double? (range-of byte?))] (js/Math.round x))) + :cljs ([x (t/and double? numerically-byte?)] (js/Math.round x))) ([x boolean?] (if x #?(:clj (byte 1) :cljs 1) #?(:clj (byte 0) :cljs 0))) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-byte?)] (>byte* (.lpart x)))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-byte?)] (.byteValue x))) @@ -235,22 +245,25 @@ ;; ----- Short ----- ;; +;; TODO figure out how to use with CLJS #?(:clj -(defnt ^:inline >short* > short? - "May involve non-out-of-range truncation" +(t/defn ^:inline >short* + "May involve non-out-of-range truncation." + > short? ([x short?] x) ([x (t/- primitive? short? boolean?)] (Primitive/uncheckedShortCast x)))) -#?(:clj -(defnt ^:inline >short > #?(:clj short? :cljs numerically-short?) - "May involve non-out-of-range truncation" +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +#_(t/defn ^:inline >short > #?(:clj short? :cljs numerically-short?) + "May involve non-out-of-range truncation." ([x #?(:clj short? :cljs numerically-short?)] x) -#?(:clj ([x (t/and (t/- primitive? short? boolean?) (range-of short?))] (>short* x)) - :cljs ([x (t/and double? (range-of short?))] (js/Math.round x))) +#?(:clj ([x (t/and (t/- primitive? short? boolean?) numerically-short?)] (>short* x)) + :cljs ([x (t/and double? numerically-short?)] (js/Math.round x))) ([x boolean?] (if x #?(:clj (short 1) :cljs 1) #?(:clj (short 0) :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) (range-of short?))] (>short* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) (range-of short?))] (.shortValue x))) -#?(:clj ([x (t/and dnum/ratio? (range-of short?))] (-> x .bigIntegerValue .shortValue))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-short?)] (>short* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-short?)] (.shortValue x))) +#?(:clj ([x (t/and dnum/ratio? numerically-short?)] (-> x .bigIntegerValue .shortValue))) ([x string?] #?(:clj (Short/parseShort x) ;; NOTE could use `js/parseInt` but it's very 'unsafe' @@ -258,50 +271,59 @@ ([x string?, radix radix?] #?(:clj (Short/parseShort x (>int radix)) ;; NOTE could use `js/parseInt` but it's very 'unsafe' - :cljs (throw (ex-info "Parsing not implemented" {:string x})))))) + :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) ;; ----- Char ----- ;; +;; TODO figure out how to use with CLJS #?(:clj -(defnt ^:inline >char* > char? - "May involve non-out-of-range truncation" +(t/defn ^:inline >char* + "May involve non-out-of-range truncation." + > char? ([x char?] x) ([x (t/- primitive? char? boolean?)] (Primitive/uncheckedCharCast x)))) -(defnt ^:inline >char > #?(:clj char? :cljs numerically-char?) +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +#_(t/defn ^:inline >char > #?(:clj char? :cljs numerically-char?) "May involve non-out-of-range truncation. For CLJS, returns not a String of length 1 but a numerically-char Number." ([x #?(:clj char? :cljs numerically-char?)] x) -#?(:clj ([x (t/and (t/- primitive? char? boolean?) (range-of char?))] (>char* x)) - :cljs ([x (t/and double? (range-of char?))] (js/Math.round x))) +#?(:clj ([x (t/and (t/- primitive? char? boolean?) numerically-char?)] (>char* x)) + :cljs ([x (t/and double? numerically-char?)] (js/Math.round x))) ([x boolean?] (if x #?(:clj (char 1) :cljs 1) #?(:clj (char 0) :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) (range-of char?))] (>char* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) (range-of char?))] (.charValue x))) -#?(:clj ([x (t/and dnum/ratio? (range-of char?))] (-> x .bigIntegerValue .charValue)))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-char?)] (>char* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-char?)] (.charValue x))) +#?(:clj ([x (t/and dnum/ratio? numerically-char?)] (-> x .bigIntegerValue .charValue)))) ;; ----- Long ----- ;; +;; TODO figure out how to use with CLJS, including goog.math.Integer/Long #?(:clj -(defnt ^:inline >long* > long? - "May involve non-out-of-range truncation" - ([x long?] x) ;; For purposes of intrinsics - ([x (t/- primitive? long? boolean?)] (clojure.lang.RT/uncheckedLongCast x)))) - -(defnt ^:inline >long > #?(:clj long? :cljs numerically-long?) - "May involve non-out-of-range truncation" +(t/defn ^:inline >long* + "May involve non-out-of-range truncation." + > long? + ([x long?] x) + ([x char?] (Primitive/uncheckedLongCast x)) ;; For purposes of intrinsics + ([x (t/- primitive? long? boolean? char?)] (clojure.lang.RT/uncheckedLongCast x)))) + +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +#_(t/defn ^:inline >long > #?(:clj long? :cljs numerically-long?) + "May involve non-out-of-range truncation." ([x #?(:clj long? :cljs numerically-long?)] x) -#?(:clj ([x (t/and (t/- primitive? long? boolean?) (range-of long?))] (>long* x)) +#?(:clj ([x (t/and (t/- primitive? long? boolean?) numerically-long?)] (>long* x)) :cljs ([x double?] (js/Math.round x))) ([x boolean?] (if x 1 0)) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) - (range-of long?) - ;; This might be faster than `(range-of long?)` + numerically-long? + ;; This might be faster than `numerically-long?` #_(fnt [x ?] (nil? (.bipart x))))] (.lpart x))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) - (range-of long?) - ;; This might be faster than `(range-of long?)` + numerically-long? + ;; This might be faster than `numerically-long?` #_(fnt [x ?] (< (.bitLength x) 64)))] (.longValue x))) -#?(:clj ([x (t/and dnum/ratio? (range-of long?))] (-> x .bigIntegerValue .longValue))) +#?(:clj ([x (t/and dnum/ratio? numerically-long?)] (-> x .bigIntegerValue .longValue))) ([x string?] #?(:clj (Long/parseLong x) ;; NOTE could use `js/parseInt` but it's very 'unsafe' @@ -313,21 +335,25 @@ ;; ----- Float ----- ;; +;; TODO figure out how to use with CLJS #?(:clj -(defnt ^:inline >float* > float? - "May involve non-out-of-range truncation" +(t/defn ^:inline >float* + "May involve non-out-of-range truncation." + > float? ([x float?] x) ([x (t/- primitive? float? boolean?)] (Primitive/uncheckedFloatCast x)))) -(defnt ^:inline >float > #?(:clj float? :cljs numerically-float?) - "May involve non-out-of-range truncation" +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +#_(t/defn ^:inline >float > #?(:clj float? :cljs numerically-float?) + "May involve non-out-of-range truncation." ([x #?(:clj float? :cljs numerically-float?)] x) -#?(:clj ([x (t/and (t/- primitive? float? boolean?) (range-of float?))] (>float* x)) - :cljs ([x (t/and double? (range-of float?)) > (t/assume numerically-float?)] (js.Math/fround x))) +#?(:clj ([x (t/and (t/- primitive? float? boolean?) numerically-float?)] (>float* x)) + :cljs ([x (t/and double? numerically-float?) > (t/assume numerically-float?)] (js.Math/fround x))) ([x boolean?] (if x #?(:clj (float 1) :cljs 1) #?(:clj (float 0) :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) (range-of float?))] (>float* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) (range-of float?))] (.floatValue x))) -#?(:clj ([x (t/and dnum/ratio? (range-of float?))] (-> x .bigIntegerValue .floatValue))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-float?)] (>float* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-float?)] (.floatValue x))) +#?(:clj ([x (t/and dnum/ratio? numerically-float?)] (-> x .bigIntegerValue .floatValue))) ([x string?] #?(:clj (Float/parseFloat x) ;; NOTE could use `js/parseFloat` but it's very 'unsafe' @@ -335,25 +361,28 @@ ;; ----- Double ----- ;; -#?(:clj -(defnt ^:inline >double* > double? - "May involve non-out-of-range truncation" - ([x double?] x) ;; For purposes of intrinsics - ([x (t/- primitive? double? boolean?)] (clojure.lang.RT/uncheckedDoubleCast x)))) - +;; TODO figure out how to use with goog.math.Integer/Long +(t/defn ^:inline >double* + "May involve non-out-of-range truncation." + > double? + ([x double?] x) + ([x char?] (Primitive/uncheckedDoubleCast x)) ;; For purposes of intrinsics +#?(:clj ([x (t/- primitive? double? boolean? char?)] (clojure.lang.RT/uncheckedDoubleCast x)))) -(defnt ^:inline >double > double? - "May involve non-out-of-range truncation" +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +#_(t/defn ^:inline >double > double? + "May involve non-out-of-range truncation." ([x double?] x) -#?(:clj ([x (t/and (t/- primitive? double? boolean?) (range-of double?))] (>double* x))) - ([x boolean?] (if x #?(:clj (double 1) :cljs 1) #?(:clj (double 0) :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) (range-of double?))] (>double* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) (range-of double?))] (.doubleValue x))) -#?(:clj ([x (t/and dnum/ratio? (range-of double?))] (-> x .bigIntegerValue .doubleValue))) +#?(:clj ([x (t/and (t/- primitive? double? boolean?) numerically-double?)] (>double* x))) + ([x boolean?] (if x #?(:clj 1.0 :cljs 1) #?(:clj 1.0 :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-double?)] (>double* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-double?)] (.doubleValue x))) +#?(:clj ([x (t/and dnum/ratio? numerically-double?)] (-> x .bigIntegerValue .doubleValue))) ([x string?] #?(:clj (Double/parseDouble x) ;; NOTE could use `js/parseFloat` but it's very 'unsafe' - :cljs (throw (ex-info "Parsing not implemented" {:string x})))))) + :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) ;; ===== Unsigned ===== ;; @@ -363,9 +392,12 @@ ([x byte?] (Numeric/bitAnd (short 0xFF) x)) ([x short?] (Numeric/bitAnd (int 0xFFFF) x)) ([x int?] (Numeric/bitAnd (long 0xFFFFFFFF) x)) - ([x long?] (BigInteger. 1 (-> (ByteBuffer/allocate 8) (.putLong x) .array))))) ; TODO reflection - -#?(:clj (t/defn ubyte>byte [x long? > long?] (>long (>byte x)))) -#?(:clj (t/defn ushort>short [x long? > long?] (>long (>short x)))) -#?(:clj (t/defn uint>int [x long? > long?] (>long (>int x)))) -#?(:clj (t/defn ulong>long [x bigint? > long?] (>long (>bigint x)))) + ;; TODO TYPED there is reflection here but there shouldn't be + ([x long?] (java.math.BigInteger. (int 1) + (-> (ByteBuffer/allocate (int 8)) (.putLong x) .array))))) ; TODO reflection + +;; TODO TYPED awaiting `>long` +#_(:clj (t/defn ubyte>byte [x long? > long?] (-> x >byte >long))) +#_(:clj (t/defn ushort>short [x long? > long?] (-> x >short >long))) +#_(:clj (t/defn uint>int [x long? > long?] (-> x >int >long))) +#_(:clj (t/defn ulong>long [x bigint? > long?] (-> x >bigint >long))) diff --git a/src/quantum/core/data/vector.cljc b/src/quantum/core/data/vector.cljc index b883b603..533dc6ec 100644 --- a/src/quantum/core/data/vector.cljc +++ b/src/quantum/core/data/vector.cljc @@ -5,20 +5,21 @@ [vector vector?]) (:require ;; TODO TYPED excise - [clojure.core :as core] - [clojure.core.rrb-vector :as svec] + [clojure.core :as core] + [clojure.core.rrb-vector :as svec] #?@(:clj [[clojure.core.rrb-vector.protocols :refer [PSliceableVector slicev PSpliceableVector splicev]] [clojure.core.rrb-vector.rrbt :refer [AsRRBT as-rrbt]]]) - [quantum.core.type :as t] - [quantum.core.vars :as var + [quantum.core.type :as t] + [quantum.core.vars :as var :refer [defalias]] ;; TODO TYPED excise [quantum.core.untyped.fn - :refer [rcomp]]) + :refer [rcomp]] + [quantum.core.untyped.type :as ut]) #?(:clj (:import java.util.ArrayList @@ -51,8 +52,7 @@ (def +vector? (t/isa? #?(:clj clojure.lang.IPersistentVector :cljs cljs.core/IVector))) -(def +vector|built-in? (t/isa? #?(:clj clojure.lang.PersistentVector - :cljs cljs.core/PersistentVector))) +(defalias ut/+vector|built-in) (def !+vector? (t/isa? #?(:clj clojure.lang.ITransientVector :cljs cljs.core/ITransientVector))) diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index e5c6a8b9..55ae0654 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -26,8 +26,7 @@ nil? none? ref? - fn? - seq?) + fn?) ;; TODO TYPED move From e636b0e45e8a09bb277272dfe1f2a5e420e7b64f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 17:05:44 -0600 Subject: [PATCH 327/810] data.string compiles --- src/quantum/core/data/primitive.cljc | 3 +++ src/quantum/core/data/string.cljc | 11 ++++++----- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index cbd55dbe..8827cc5d 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -14,6 +14,9 @@ [java.nio ByteBuffer] [quantum.core Numeric Primitive]))) +(def nil? ut/nil?) +(def val? ut/val?) + ;; ===== Predicates ===== ;; #?(:clj (def boolean? (t/isa? #?(:clj Boolean :cljs js/Boolean)))) diff --git a/src/quantum/core/data/string.cljc b/src/quantum/core/data/string.cljc index 69e9601b..e29be7f8 100644 --- a/src/quantum/core/data/string.cljc +++ b/src/quantum/core/data/string.cljc @@ -31,7 +31,7 @@ "Creates a mutable string." > !string? ([] #?(:clj (StringBuilder.) :cljs (StringBuffer.))) - ;; TODO + ;; TODO TYPED #_([x0] #?(:clj (StringBuilder. x0) :cljs (StringBuffer. x0)))) ;; ----- Synchronously mutable strings ----- ;; @@ -41,8 +41,9 @@ #?(:clj (t/defn ^:inline >!sync-string "Creates a synchronized mutable string." + {:todo #{"Do the same arity structure as >!string and >string"}} > !sync-string? - [] (StringBuffer.))) + ([] (StringBuffer.)))) ;; ----- Mutable char deques ----- ;; @@ -132,8 +133,8 @@ #?(:clj ([x p/float? > (t/assume string?)] (Float/toString x))) #?(:clj ([x p/double? > (t/assume string?)] (Double/toString x))) #?(:clj ([x t/ref?] (-> x .toString >string)) - :cljs ([x t/any? > (t/assume string?)] (.join #js [x] ""))) - ;; TODO refine this + :cljs ([x t/any? > (t/assume string?)] (.join #js [x] ""))) + ;; TODO TYPED refine this #_([x ? & xs ...] (loop [sb (-> x >string >!string) more ys] (if more @@ -165,7 +166,7 @@ (def metable-string? #?(:clj (t/isa? MetableString) :cljs string?)) (t/defn >metable-string - > metable-stingr? + > metable-string? ([s string?] #?(:clj (MetableString. s nil) :cljs s)) ([s string?, meta' meta/meta?] #?(:clj (MetableString. s meta') :cljs (meta/with-meta s new-meta)))) From 6382da528cb228c5f8b45c0134cfcde0a93b6cd6 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 17:17:13 -0600 Subject: [PATCH 328/810] Move queue types to data.queue --- resources-dev/defnt.cljc | 10 ++-- .../quantum/untyped/core/data/numeric.cljc | 16 +++--- src-untyped/quantum/untyped/core/type.cljc | 16 ------ src/quantum/core/data/queue.cljc | 49 ++++++++++++------- 4 files changed, 45 insertions(+), 46 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 5fed54f6..91c25c9c 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -54,6 +54,8 @@ TODO: Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: + - t/type >>>>>> (PRIORITY 1) <<<<<< + - dependent types: `[x arr/array? > (t/type x)]` - Analysis - This is accepted by the type system without knowing the type: (java.math.BigInteger. 1 (-> (ByteBuffer/allocate (int 8)) (.putLong x) .array)) @@ -85,7 +87,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative (#?(:clj clojure.core.protocols/coll-reduce :cljs cljs.core/-reduce) xs rf init)) - (if (A) ...) should be (if ^boolean (A) ...) if A returns a `p/boolean?` - - t/- : multi-arity + - t/- : fix + - (t/- (t/isa? java.util.Queue) (t/or ?!+queue? !!queue?)) - t/isa|direct? - For CLJ, this is `instance?` for classes and `instance?` on the underlying interface associated with a protocol @@ -95,10 +98,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. - t/numerically-integer? - - t/range-of : e.g. a double being between float max values but possibly representing a 'hole' in - possible float values - - t/type - - dependent types: `[x arr/array? > (t/type x)]` - ? : type inference - use logic programming and variable unification e.g. `?1` `?2` ? - For this situation: `?` is `(t/- dc/counted?)` @@ -340,6 +339,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] quantum.core.core -> TODO just need to delete this from all references - [ ] quantum.core.type.core - [x] quantum.core.data.async + - [.] quantum.core.data.queue - [ ] quantum.core.type.defs - [.] quantum.core.refs -> quantum.core.data.refs ? - [ ] quantum.core.logic diff --git a/src-untyped/quantum/untyped/core/data/numeric.cljc b/src-untyped/quantum/untyped/core/data/numeric.cljc index 12af762d..98b7c0b5 100644 --- a/src-untyped/quantum/untyped/core/data/numeric.cljc +++ b/src-untyped/quantum/untyped/core/data/numeric.cljc @@ -23,12 +23,11 @@ #?(:cljs goog.math.Integer) #?(:cljs goog.math.Long) [quantum.core.data.primitive :as p] - [quantum.core.data.string :as dstr] #_[quantum.core.logic :refer [whenf fn-not fn=]] [quantum.core.type :as t] ;; TODO TYPED excise reference - [quantum.core.untyped.vars :as var + [quantum.untyped.core.vars :as var :refer [defalias]])) ;; ===== Integers ===== ;; @@ -52,7 +51,8 @@ ;; Incorporated `cljs.core/integer?` (def integer? (t/or fixint? bigint?)) -#?(:clj +;; TODO TYPED `>long` +#_(:clj (t/defn >java-bigint > java-bigint? ([x java-bigint?] x) ([x clj-bigint? > (t/assume java-bigint?)] (.toBigInteger x)) @@ -95,10 +95,11 @@ ;; TODO bring in implementation per the ns docstring :cljs t/none?)) -#?(:clj -(defnt rationalize +;; TODO TYPED >double +#_(:clj +(t/defn rationalize "Outputs the rational value of `n`." - {:adapted-from 'clojure.lang.Numbers/rationalize} + {:incorporated {'clojure.lang.Numbers/rationalize "9/2018"}} > (t/isa? java.lang.Number) ([x (t/or p/float? p/double?)] (rationalize (BigDecimal/valueOf (p/>double x)))) @@ -110,7 +111,8 @@ (Numbers/divide bv (.pow BigInteger.TEN scale))))) ([x (t/isa? java.lang.Number)] x))) -(t/defn >ratio > ratio? +;; TODO TYPED finish +#_(t/defn >ratio > ratio? #?(:clj ([x ??] (>ratio x 1))) #?(:clj ([x ??, y ??] (whenf (rationalize (/ x y)) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 37d9b619..a03dc6d8 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -622,22 +622,6 @@ (def +vector|built-in? (isa? #?(:clj clojure.lang.PersistentVector :cljs cljs.core/PersistentVector))) -;; ===== Queues ===== ;; Particularly FIFO queues, as LIFO = stack = any vector - - (def +queue? (isa? #?(:clj clojure.lang.PersistentQueue - :cljs cljs.core/PersistentQueue))) - (def !+queue? none?) - (def ?!+queue? (or +queue? !+queue?)) -#?(:clj (def !!queue? (or (isa? java.util.concurrent.BlockingQueue) - (isa? java.util.concurrent.TransferQueue) - (isa? java.util.concurrent.ConcurrentLinkedQueue)))) - - (def !queue? #?(:clj ;; Considered single-threaded mutable unless otherwise noted - (identity #_- (isa? java.util.Queue) #_(or ?!+queue? !!queue?)) ; TODO re-enable once `-` works - :cljs (isa? goog.structs.Queue))) - - (def queue? (or ?!+queue? !queue? #?(:clj !!queue?))) - ;; ===== Sets ===== ;; Associative; A special type of Map whose keys and vals are identical #?(:clj (def java-set? (isa? java.util.Set))) diff --git a/src/quantum/core/data/queue.cljc b/src/quantum/core/data/queue.cljc index a49f1094..e8abaf4a 100644 --- a/src/quantum/core/data/queue.cljc +++ b/src/quantum/core/data/queue.cljc @@ -1,22 +1,35 @@ -(ns - ^{:doc "Incorporates the semi-obscure clojure.lang.PersistentQueue into the - quantum library." - :attribution "alexandergunnarson"} - quantum.core.data.queue) +(ns quantum.core.data.queue + "Queues, particularly FIFO queues, as LIFO = stack = any vector. -; QUEUES -; https://github.com/michalmarczyk/jumping-queues + To investigate: + - https://github.com/michalmarczyk/jumping-queues" + (:require + [clojure.core :as core] + [quantum.core.type :as t])) -(defn queue - "Creates an empty persistent queue, or one populated with a collection." - {:attribution "weavejester.medley"} - ([] #?(:clj (clojure.lang.PersistentQueue/EMPTY) - :cljs (.-EMPTY cljs.core/PersistentQueue))) - ([coll] (into (queue) coll))) +(def +queue? (t/isa? #?(:clj clojure.lang.PersistentQueue + :cljs cljs.core/PersistentQueue))) +(def !+queue? t/none?) +(def ?!+queue? (t/or +queue? !+queue?)) + +#?(:clj (def !!queue? (t/or (t/isa? java.util.concurrent.BlockingQueue) + (t/isa? java.util.concurrent.TransferQueue) + (t/isa? java.util.concurrent.ConcurrentLinkedQueue)))) + +(def !queue? #?(:clj ;; Considered single-threaded mutable unless otherwise noted + ;; TODO TYPED re-enable one `t/-` works properly + #_(t/- (t/isa? java.util.Queue) (t/or ?!+queue? !!queue?)) + t/none? + :cljs (t/isa? goog.structs.Queue))) + +(def queue? (t/or ?!+queue? !queue? #?(:clj !!queue?))) + +(t/defn >queue > +queue? + ([] #?(:clj clojure.lang.PersistentQueue/EMPTY + :cljs (.-EMPTY cljs.core/PersistentQueue)))) #?(:clj - (defmethod print-method clojure.lang.PersistentQueue - [q w] - (print-method '<- w) - (print-method (seq q) w) - (print-method '-< w))) +(defmethod print-method clojure.lang.PersistentQueue [q w] + (print-method '<- w) + (print-method (core/seq q) w) + (print-method '-< w))) From d971195c596e79c8d6a8a68439264cb1b007bc58 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 18:23:23 -0600 Subject: [PATCH 329/810] Move all predicates from untyped.type ns and record most completed preds --- resources-dev/defnt.cljc | 60 ++++- src-dev/quantum/core/defnt_equivalences.cljc | 82 +++--- src-java/quantum/core/Numeric.java | 4 +- src-untyped/quantum/untyped/core/analyze.cljc | 14 +- src-untyped/quantum/untyped/core/type.cljc | 247 +++++------------- src-untyped/quantum/untyped/ui/dom.cljc | 2 +- src/quantum/core/collections_typed.cljc | 10 +- src/quantum/core/data/collections.cljc | 35 +-- src/quantum/core/data/identifiers.cljc | 72 ++--- src/quantum/core/data/set.cljc | 229 ++++++++++++++-- src/quantum/core/data/tuple.cljc | 8 +- src/quantum/core/fn.cljc | 4 + src/quantum/core/io/core.cljc | 5 + 13 files changed, 432 insertions(+), 340 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 91c25c9c..c90ddac1 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -1,5 +1,15 @@ ;; TO MOVE +#?(:clj (def thread? (isa? java.lang.Thread))) + +(def delay? (isa? #?(:clj clojure.lang.Delay :cljs cljs.core/Delay))) + +#?(:clj (def class? (isa? java.lang.Class))) + +;; TODO for CLJS based on untyped impl +#?(:clj (def protocol? (>expr (ufn/fn-> :on-interface class?)))) + + ;; ===== quantum.core.system #?(:clj @@ -47,9 +57,6 @@ TODO: - needs to equal `(t/and (t/or (t/not a) b) (t/or a c))` (which is correct) - `(- (or ?!+vector? !vector? #?(:clj !!vector?)) (isa? clojure.lang.Counted))` is not right -TODO: -- split up `quantum.core.untyped.type` predicates - #_" Note that `;; TODO TYPED` is the annotation we're using for this initiative @@ -183,8 +190,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - List of semi-approximately topologically ordered namespaces to make typed: - [.] clojure.core / cljs.core - [x x] = - - [ ] == + - [. .] == - [ ] any? + - [x x] associative? - [. .] boolean - [x x] boolean? - [x x] byte @@ -195,37 +203,60 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x x] compare - [ ] conj - [ ] contains? + - [x x] counted? - [x |] decimal? - [x |] denominator - [x x] double - [x x] double? - [ ] even? - [x x] identical? + - [x x] indexed? - [x x] integer? + - [ |] find-keyword - [x x] float - [x x] float? - - [ ] infinite? + - [x x] ident? + - [| ] infinite? - [x x] int - [x x] int? + - [x x] keyword + - [x x] keyword? + - [ |] locking - [x x] long - [x x] long? + - [x x] map? + - [x x] map-entry? - [ ] mod + - [x x] name + - [x x] namespace - [ ] nat-int? - [ ] neg? - [ ] neg-int? - [x x] nil? - [x x] not= + - [x |] ns-name - [x x] number? - [x |] numerator - [ ] odd? - [ ] pos? - [ ] pos-int? + - [x x] qualified-ident? + - [x x] qualified-keyword? + - [x x] qualified-symbol? - [x |] ratio? - [ ] rational? - [ ] rem + - [x x] set? - [x x] short - [x x] short? + - [x x] simple-ident? + - [x x] simple-keyword? + - [x x] simple-symbol? - [x x] some? + - [x x] string? + - [x x] symbol + - [x x] symbol? + - [x x] uuid? - [.] clojure.lang.Numbers https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/Numbers.java - [ ] add @@ -339,7 +370,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] quantum.core.core -> TODO just need to delete this from all references - [ ] quantum.core.type.core - [x] quantum.core.data.async - - [.] quantum.core.data.queue + - [-] quantum.core.data.queue - [ ] quantum.core.type.defs - [.] quantum.core.refs -> quantum.core.data.refs ? - [ ] quantum.core.logic @@ -366,22 +397,23 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [.] quantum.core.error - [.] quantum.core.data.string - [.] quantum.core.data.array + - [.] quantum.core.data.list - [.] quantum.core.data.collections - [.] quantum.core.data.tuple - [x] quantum.core.data.time - [.] quantum.core.compare.core - - [ ] quantum.core.numeric.predicates - - [ ] quantum.core.numeric.convert + - [.] quantum.core.data.numeric + - [.] quantum.core.numeric.predicates + - [.] quantum.core.numeric.convert - [.] quantum.core.numeric.exponents - - [ ] quantum.core.numeric.misc - - [ ] quantum.core.numeric.operators - - [ ] quantum.core.numeric.trig - - [ ] quantum.core.numeric.truncate + - [.] quantum.core.numeric.misc + - [.] quantum.core.numeric.operators + - [.] quantum.core.numeric.trig + - [.] quantum.core.numeric.truncate - [x] quantum.core.numeric.types - - [ ] quantum.core.data.numeric - [.] quantum.core.numeric + - [.] quantum.core.data.set - [ ] quantum.core.string.regex - - [ ] quantum.core.data.set - [ ] quantum.core.macros.type-hint - [ ] quantum.core.analyze.clojure.core - [ ] quantum.core.analyze.clojure.predicates diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/src-dev/quantum/core/defnt_equivalences.cljc index 8a70eb90..f670e09e 100644 --- a/src-dev/quantum/core/defnt_equivalences.cljc +++ b/src-dev/quantum/core/defnt_equivalences.cljc @@ -59,7 +59,7 @@ (deftest test|pid (let [actual (macroexpand ' - (self/defn pid|test [> (? t/str?)] + (self/defn pid|test [> (? t/string?)] (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) (.getName)))) expected @@ -69,13 +69,13 @@ ~(STR '(. (. java.lang.management.ManagementFactory getRuntimeMXBean) getName))))) (defn ~'pid|test - {:quantum.core.type/type (t/fn t/any? ~'[:> (? t/str?)])} + {:quantum.core.type/type (t/fn t/any? ~'[:> (? t/string?)])} ([] (.invoke ~(tag (str `>Object) 'pid|test|__0|0))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) - (eval '(do (is (t/str? (pid|test))) + (eval '(do (is (t/string? (pid|test))) (throws (pid|test 1)))))))) ;; TODO test `:inline` @@ -135,10 +135,10 @@ (deftest test|name (let [actual (macroexpand ' - (self/defn #_:inline name|test > t/str? - ([x t/str?] x) - #?(:clj ([x (t/isa? Named) > (* t/str?)] (.getName x)) - :cljs ([x (t/isa? INamed) > (* t/str?)] (-name x))))) + (self/defn #_:inline name|test > t/string? + ([x t/string?] x) + #?(:clj ([x (t/isa? Named) > (* t/string?)] (.getName x)) + :cljs ([x (t/isa? INamed) > (* t/string?)] (-name x))))) expected (case (env-lang) :clj @@ -146,7 +146,7 @@ ;; Return value can be primitive; in this case it's not ;; The macro in a typed context will find the right dispatch at compile time - ;; [t/str?] + ;; [t/string?] (def ~(tag "[Ljava.lang.Object;" 'name|test|__0|input0|types) (*<> (t/isa? java.lang.String))) @@ -164,13 +164,13 @@ (~(tag "java.lang.Object" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] (let* [~(tag "clojure.lang.Named" 'x) ~'x] (t/validate ~(STR '(. x getName)) - ~'(* t/str?)))))) + ~'(* t/string?)))))) (defn ~'name|test {:quantum.core.type/type - (t/fn ~'t/str? - ~'[t/str?] - ~'[(t/isa? Named) :> (* t/str?)])} + (t/fn ~'t/string? + ~'[t/string?] + ~'[(t/isa? Named) :> (* t/string?)])} ([~'x00__] (ifs ((Array/get ~'name|test|__0|input0|types 0) ~'x00__) (.invoke ~(tag (str `Object>Object) @@ -181,7 +181,7 @@ (unsupported! `name|test [~'x00__] 0)))))) :cljs ($ (do (defn ~'name|test [~'x00__] - (ifs (t/str? x) x + (ifs (t/string? x) x (satisfies? INamed x) (-name x) (unsupported! `name|test [~'x00__] 0))))))] (testing "code equivalence" (is-code= actual expected)) @@ -394,7 +394,7 @@ (is= (>boolean nil) (boolean nil)) (is= (>boolean 123) (boolean 123))))))) -;; Let's say you have (t/| t/str? t/number?) in one `fnt` overload. +;; Let's say you have (t/| t/string? t/number?) in one `fnt` overload. ;; This means that you *can't* have a reify with two Object>Object overloads and expect it to work ;; at all. ;; Therefore, each `fnt` overload necessarily has a one-to-many relationship with `reify`s. @@ -1062,8 +1062,8 @@ ([x ratio?] (-> x >big-integer >long-checked)) ([x (t/value true)] 1) ([x (t/value false)] 0) - ([x t/str?] (Long/parseLong x)) - ([x t/str?, radix int?] (Long/parseLong x radix)))) + ([x t/string?] (Long/parseLong x)) + ([x t/string?, radix int?] (Long/parseLong x radix)))) expected (case (env-lang) :clj ($ (do #_[x (t/- primitive? boolean? float? double?)] @@ -1168,7 +1168,7 @@ ;; - `ratio?` -> t/<> ;; - `(t/value true)` -> t/<> ;; - `(t/value false)` -> t/<> - ;; - `t/str?` -> t/<> + ;; - `t/string?` -> t/<> ;; ;; Since there is no overload that results in t/<, no compile-time match can ;; be found, but a possible runtime match lies in the overload that results in @@ -1196,19 +1196,19 @@ (reify boolean>long (~(tag "long" 'invoke) [_## ~(tag "boolean" 'x)] 0))) - #_[x t/str?] + #_[x t/string?] #_(def ~'>long|__12|input-types - (*<> t/str?)) + (*<> t/string?)) (def ~'>long|__12 (reify Object>long (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] ~'(Long/parseLong x)))) - #_[x t/str?] + #_[x t/string?] #_(def ~'>long|__13|input-types - (*<> t/str? int?)) + (*<> t/string? int?)) (def ~'>long|__13 (reify Object+int>long (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x) ~(tag "int" 'radix)] @@ -1228,8 +1228,8 @@ [ratio?] [(t/value true)] [(t/value false)] - [t/str?] - [t/str? int?])} + [t/string?] + [t/string? int?])} ([x0##] (ifs ((Array/get >long|__0|input-types 0) x0##) (.invoke >long|__0 x0##) ((Array/get >long|__1|input-types 0) x0##) @@ -1259,9 +1259,9 @@ (self/defn !str > #?(:clj (t/isa? StringBuilder) :cljs (t/isa? StringBuffer)) ([] #?(:clj (StringBuilder.) :cljs (StringBuffer.))) - ;; If we had combined this arity, `t/or`ing the `t/str?` means it wouldn't have been + ;; If we had combined this arity, `t/or`ing the `t/string?` means it wouldn't have been ;; handled any differently than `t/char-seq?` - #?(:clj ([x t/str?] (StringBuilder. x))) + #?(:clj ([x t/string?] (StringBuilder. x))) ([x #?(:clj (t/or t/char-seq? int?) :cljs t/val?)] #?(:clj (StringBuilder. x) :cljs (StringBuffer. x))))) @@ -1300,7 +1300,7 @@ {:quantum.core.type/type (t/fn ~'(t/isa? StringBuilder) ~'[] - ~'[t/str?] + ~'[t/string?] ~'[(t/or t/char-seq? int?)])} ([] (.invoke ~(tag "quantum.core.test.defnt_equivalences.>Object" '!str|__0|0))) @@ -1331,7 +1331,7 @@ (t/fn :> #?(:clj (t/isa? StringBuilder) :cljs (t/isa? StringBuffer)) [] - #?(:clj [t/str?]) + #?(:clj [t/string?]) [#?(:clj (t/or t/char-seq? t/int?) :cljs t/val?)])) @@ -1340,8 +1340,8 @@ (reify >Object (^java.lang.Object invoke [_#] (StringBuilder.)))) - ;; `t/str?` - (def ^Object>Object !str|__1 ; `t/str?` + ;; `t/string?` + (def ^Object>Object !str|__1 ; `t/string?` (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'x] (let* [^String x x] (StringBuilder. x))))) @@ -1355,7 +1355,7 @@ (StringBuilder. x)))) (defn !str ([ ] (.invoke !str|__0)) - ([a0] (ifs (t/str? a0) (.invoke !str|__1 a0) + ([a0] (ifs (t/string? a0) (.invoke !str|__1 a0) (t/char-seq? a0) (.invoke !str|__2 a0) (t/int? a0) (.invoke !str|__3 a0))))) :cljs `(do (defn !str ([] (StringBuffer.)) @@ -1365,20 +1365,20 @@ ;; TODO handle inline (macroexpand ' -(self/defn #_:inline str|test > t/str? +(self/defn #_:inline str|test > t/string? ([] "") ([x t/nil?] "") ;; could have inferred but there may be other objects who have overridden .toString - #?(#_:clj #_([x (t/isa? Object) > (* t/str?)] (.toString x)) + #?(#_:clj #_([x (t/isa? Object) > (* t/string?)] (.toString x)) ;; Can't infer that it returns a string (without a pre-constructed list of built-in fns) ;; As such, must explicitly mark - :cljs ([x t/any? > (t/assume t/str?)] (.join #js [x] ""))) + :cljs ([x t/any? > (t/assume t/string?)] (.join #js [x] ""))) ;; TODO only one variadic arity allowed currently; theoretically could dispatch on at ;; least pre-variadic args, if not variadic ;; TODO should have automatic currying? ;; TODO need to handle varargs #_([x (t/fn> str|test t/any?) & xs (? (t/seq-of t/any?)) - #?@(:cljs [> (t/assume t/str?)])] + #?@(:cljs [> (t/assume t/string?)])] (let* [sb (-> x str|test !str)] ; determined to be StringBuilder ;; TODO is `doseq` the right approach, or using reduction? (doseq [x' xs] (.append sb (str x'))) @@ -1397,12 +1397,12 @@ (defn str {:quantum.core.type/type - (t/fn :> t/str? + (t/fn :> t/string? [] [t/nil?] #?(:clj [(t/isa? Object)]) - #?(:cljs [t/any? :> (t/assume t/str?)]) - [(t/fn> str t/any?) :& (? (t/seq-of t/any?)) #?@(:cljs [:> (t/assume t/str?)])])} + #?(:cljs [t/any? :> (t/assume t/string?)]) + [(t/fn> str t/any?) :& (? (t/seq-of t/any?)) #?@(:cljs [:> (t/assume t/string?)])])} ([ ] (.invoke !str|__0)) ([a0] (ifs (nil? x) (.invoke !str|__1) (.invoke !str|__2 a0))) @@ -1425,7 +1425,7 @@ (macroexpand ' (self/defn #_:inline count #_> #_t/nneg-integer? ([xs t/array? #_> #_t/nneg-int?] (.length xs)) - #_([xs t/str? > #?(:clj t/nneg-int? :cljs (t/assume t/nneg-int?))] + #_([xs t/string? > #?(:clj t/nneg-int? :cljs (t/assume t/nneg-int?))] (#?(:clj .length :cljs .-length) xs)) #_([xs !+vector? > t/nneg-int?] (#?(:clj count :cljs (do (TODO) 0)) xs))) ) @@ -1435,7 +1435,7 @@ `(do (swap! fn->spec assoc #'count (t/fn :> t/pos-integer? [t/array? :> t/nneg-int?] - [t/str? :> #?(:clj t/nneg-int? :cljs (t/assume t/nneg-int?))] + [t/string? :> #?(:clj t/nneg-int? :cljs (t/assume t/nneg-int?))] [!+vector? :> t/nneg-int?])) ~(case-env @@ -1450,7 +1450,7 @@ (self/defn #_:inline get ;; TODO `t/numerically ([xs t/array? , k #_(t/numerically t/int?)] (#?(:clj Array/get :cljs aget) xs k)) - ([xs t/str? , k #_(t/numerically t/int?)] (.charAt xs k)) + ([xs t/string?, k #_(t/numerically t/int?)] (.charAt xs k)) ([xs !+vector?, k t/any?] #?(:clj (.valAt xs k) :cljs (TODO)))) ) ;; ----- expanded code ----- ;; @@ -1458,7 +1458,7 @@ `(do (swap! fn->spec assoc #'count (t/fn :> t/pos-integer? [t/array? (t/numerically t/int?)] - [t/str? (t/numerically t/int?)] + [t/string? (t/numerically t/int?)] [!+vector? t/any?])) ...) diff --git a/src-java/quantum/core/Numeric.java b/src-java/quantum/core/Numeric.java index 37392010..a5ceca64 100644 --- a/src-java/quantum/core/Numeric.java +++ b/src-java/quantum/core/Numeric.java @@ -22,8 +22,8 @@ public class Numeric { // ================================= Boolean Operations ===================================== // - public static boolean isTrue (final boolean a ) { return a == true; } - public static boolean isFalse (final boolean a ) { return a == false; } + public static boolean isTrue (final boolean a ) { return a; } + public static boolean isFalse (final boolean a ) { return !a; } public static boolean isNil (final Object a ) { return a == null; } public static boolean not (final boolean a ) { return !a; } public static boolean and (final boolean a, final boolean b) { return a && b; } diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index d81ac747..6f56757e 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -48,7 +48,7 @@ #?(:clj (defns method? [x _] (instance? Method x))) #?(:clj -(defns class->methods [^Class c t/class? > map?] +(defns class->methods [^Class c class? > map?] (->> (.getMethods c) (c/remove+ (fn [^java.lang.reflect.Method x] (java.lang.reflect.Modifier/isPrivate (.getModifiers x)))) @@ -70,7 +70,7 @@ fipp.ednize/IOverride fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "F") (into (array-map) this)))) -(defns class->fields [^Class c t/class? > map?] +(defns class->fields [^Class c class? > map?] (->> (.getFields c) (c/remove+ (fn [^java.lang.reflect.Field x] (java.lang.reflect.Modifier/isPrivate (.getModifiers x)))) @@ -249,7 +249,7 @@ Unchecked fns could be assumed to actually *want* to shift the range over if the range hits a certain point, but we do not make that assumption here." - [c t/class?, method symbol? > (? t/type?)] + [c class?, method symbol? > (? t/type?)] (when (identical? c clojure.lang.RT) (case method (uncheckedBooleanCast booleanCast) t/boolean? @@ -266,7 +266,7 @@ "A note will be made of what methods match the argument types. If only one method is found, that is noted too. If no matching method is found, an exception is thrown." - [env ::env, form _, target uast/node?, target-class t/class?, static? t/boolean? + [env ::env, form _, target uast/node?, target-class class?, static? t/boolean? method-form simple-symbol?, args-forms _ #_(seq-of form?) > uast/method-call?] ;; TODO cache type by method (if-not-let [methods-for-name (-> target-class class->methods|with-cache @@ -324,7 +324,7 @@ (defns classes>class "Ensure that given a set of classes, that set consists of at most a class C and nil. If so, returns C. Otherwise, throws." - [cs (s/set-of (? t/class?)) > t/class?] + [cs (s/set-of (s/? class?)) > class?] (let [cs' (disj cs nil)] (if (-> cs' count (= 1)) (first cs') @@ -396,7 +396,7 @@ (uast/quoted env form (tcore/most-primitive-class-of body))) (defns- analyze-seq|new - [env ::env, [_ _ & [c|form _ #_t/class? & args _ :as body] _ :as form] _ > uast/new-node?] + [env ::env, [_ _ & [c|form _ #_class? & args _ :as body] _ :as form] _ > uast/new-node?] (let [c|analyzed (analyze* env c|form)] (if-not (and (-> c|analyzed :type t/value-type?) (-> c|analyzed :type utr/value-type>value class?)) @@ -620,7 +620,7 @@ (uast/symbol env form resolved (ifs (uast/node? resolved) (:type resolved) - (or (t/literal? resolved) (t/class? resolved)) + (or (t/literal? resolved) (class? resolved)) (t/value resolved) (var? resolved) (or (-> resolved meta :quantum.core.type/type) (t/value @resolved)) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index a03dc6d8..3f520f2c 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -487,6 +487,7 @@ ;; ===== Etc. ===== ;; +;; TODO figure out the best place to put this #?(:clj (def boxed-class->unboxed-symbol {Boolean 'boolean @@ -500,6 +501,7 @@ (uvar/defalias utdef/unboxed-symbol->type-meta) +;; TODO figure out the best place to put this #?(:clj (def primitive-classes (->> unboxed-symbol->type-meta vals (uc/map+ :unboxed) (join #{})))) (defns- -type>classes @@ -556,14 +558,13 @@ ;; ===== Predicates ===== ;; ;; ---------------------- ;; -;; TODO TYPED — split the below predicate definitions into appropriate namespaces - ;; ===== General ===== ;; (def none? empty-set) (def any? universal-set) - ;; TODO this is incomplete for CLJS base classes, I think + ;; TODO this is incomplete for CLJS base classes + ;; TODO is this necessary? (def val|by-class? (or object? #?@(:cljs [(isa? js/String) (isa? js/Symbol)]))) (def val? (not nil?)) @@ -571,7 +572,7 @@ ;; ===== Meta ===== ;; -#?(:clj (def class? (isa? java.lang.Class))) + ;; TODO probably move, but this is used by `quantum.untyped.core.type` etc. #?(:clj (def primitive-class? (or (value Boolean/TYPE) (value Byte/TYPE) (value Character/TYPE) @@ -580,8 +581,6 @@ (value Long/TYPE) (value Float/TYPE) (value Double/TYPE)))) - ;; TODO for CLJS -#?(:clj (def protocol? (>expr (ufn/fn-> :on-interface class?)))) ;; ===== Primitives ===== ;; ;; NOTE these are kept here because they're used in both type analysis and various test namespaces @@ -590,12 +589,13 @@ #?(:clj (def byte? (isa? Byte))) #?(:clj (def char? (isa? Character))) #?(:clj (def short? (isa? Short))) -#?(:clj (def int? (isa? Integer))) -#?(:clj (def long? (isa? Long))) +#?(:clj (def int? (isa? Integer))) ; only primitive int, not goog.math.Integer +#?(:clj (def long? (isa? Long))) ; only primitive long, not goog.math.Long #?(:clj (def float? (isa? Float))) (def double? (isa? #?(:clj Double :cljs js/Number))) ;; These are special for CLJS protocols + ;; Possibly planned to be used by `quantum.untyped.core.analyze` #?(:cljs (def native? (or (isa? js/Boolean) (isa? js/Number) (isa? js/Object) @@ -606,210 +606,83 @@ ;; ===== Booleans ===== ;; -;; Used in `quantum.untyped.core.analyze` +;; Used by `quantum.untyped.core.analyze` (def true? (value true)) (def false? (value false)) ;; ========== Collections ========== ;; -;; Used in `quantum.untyped.core.analyze` +;; Possibly planned to be used by `quantum.untyped.core.analyze` +(def +list|built-in? + (or (isa? #?(:clj clojure.lang.PersistentList$EmptyList :cljs cljs.core/EmptyList)) + (isa? #?(:clj clojure.lang.PersistentList :cljs cljs.core/List)))) + +;; Used by `quantum.untyped.core.analyze` +(def +vector|built-in? (t/isa? #?(:clj clojure.lang.PersistentVector + :cljs cljs.core/PersistentVector))) + +;; Used by `quantum.untyped.core.analyze` (def +map|built-in? (or (isa? #?(:clj clojure.lang.PersistentHashMap :cljs cljs.core/PersistentHashMap)) (isa? #?(:clj clojure.lang.PersistentArrayMap :cljs cljs.core/PersistentArrayMap)) (isa? #?(:clj clojure.lang.PersistentTreeMap :cljs cljs.core/PersistentTreeMap)))) -;; Used in `quantum.untyped.core.analyze` -(def +vector|built-in? (isa? #?(:clj clojure.lang.PersistentVector - :cljs cljs.core/PersistentVector))) - -;; ===== Sets ===== ;; Associative; A special type of Map whose keys and vals are identical - -#?(:clj (def java-set? (isa? java.util.Set))) - -;; ----- Identity Sets (identity-based equality) ----- ;; - - (def !identity-set? #?(:clj none? #_(isa? java.util.IdentityHashSet) ; TODO implement - :cljs (isa? js/Set))) - - (def identity-set? !identity-set?) - -;; ----- Hash Sets (value-based equality) ----- ;; - - (def +hash-set? (isa? #?(:clj clojure.lang.PersistentHashSet - :cljs cljs.core/PersistentHashSet))) - (def !+hash-set? (isa? #?(:clj clojure.lang.PersistentHashSet$TransientHashSet - :cljs cljs.core/TransientHashSet))) - (def ?!+hash-set? (or +hash-set? !+hash-set?)) - - (def !hash-set|byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.ByteOpenHashSet) :cljs none?)) - (def !hash-set|char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.CharOpenHashSet) :cljs none?)) - (def !hash-set|short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.ShortOpenHashSet) :cljs none?)) - (def !hash-set|int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.IntOpenHashSet) :cljs none?)) - (def !hash-set|long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.LongOpenHashSet) :cljs none?)) - (def !hash-set|float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.FloatOpenHashSet) :cljs none?)) - (def !hash-set|double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.DoubleOpenHashSet) :cljs none?)) - (def !hash-set|ref? #?(:clj (or (isa? java.util.HashSet) - (isa? it.unimi.dsi.fastutil.objects.ReferenceOpenHashSet)) - :cljs none?)) - - (def !hash-set? (or !hash-set|ref? - !hash-set|byte? !hash-set|short? !hash-set|char? - !hash-set|int? !hash-set|long? - !hash-set|float? !hash-set|double?)) - - ;; CLJ technically can have via ConcurrentHashMap with same KVs but this hasn't been implemented yet -#?(:clj (def !!hash-set? none?)) - (def hash-set? (or ?!+hash-set? !hash-set? #?(:clj !!hash-set?))) - -;; ----- Unsorted Sets ----- ;; - - (def +unsorted-set? +hash-set?) - (def !+unsorted-set? !+hash-set?) - (def ?!+unsorted-set? ?!+hash-set?) - - (def !unsorted-set|byte? !hash-set|byte?) - (def !unsorted-set|short? !hash-set|char?) - (def !unsorted-set|char? !hash-set|short?) - (def !unsorted-set|int? !hash-set|int?) - (def !unsorted-set|long? !hash-set|long?) - (def !unsorted-set|float? !hash-set|float?) - (def !unsorted-set|double? !hash-set|double?) - (def !unsorted-set|ref? !hash-set|ref?) - - (def !unsorted-set? - (or !unsorted-set|ref? - !unsorted-set|byte? !unsorted-set|short? !unsorted-set|char? - !unsorted-set|int? !unsorted-set|long? - !unsorted-set|float? !unsorted-set|double?)) - -#?(:clj (def !!unsorted-set? !!hash-set?)) - (def unsorted-set? hash-set?) - -;; ----- Sorted Sets ----- ;; - - (def +sorted-set? (isa? #?(:clj clojure.lang.PersistentTreeSet - :cljs cljs.core/PersistentTreeSet))) - (def !+sorted-set? none?) - (def ?!+sorted-set? (or +sorted-set? !+sorted-set?)) - - (def !sorted-set|byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.ByteSortedSet) - :cljs none?)) - (def !sorted-set|short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.ShortSortedSet) :cljs none?)) - (def !sorted-set|char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.CharSortedSet) :cljs none?)) - (def !sorted-set|int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.IntSortedSet) :cljs none?)) - (def !sorted-set|long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.LongSortedSet) :cljs none?)) - (def !sorted-set|float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.FloatSortedSet) :cljs none?)) - (def !sorted-set|double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.DoubleSortedSet) - :cljs none?)) - ;; CLJS technically can have via goog.structs.AVLTree with same KVs but this hasn't been implemented yet - (def !sorted-set|ref? #?(:clj (isa? java.util.TreeSet) :cljs none?)) - - (def !sorted-set? (or !sorted-set|ref? - !sorted-set|byte? !sorted-set|short? !sorted-set|char? - !sorted-set|int? !sorted-set|long? - !sorted-set|float? !sorted-set|double?)) - - ;; CLJ technically can have via ConcurrentSkipListMap with same KVs but this hasn't been implemented yet -#?(:clj (def !!sorted-set? none?)) - (def sorted-set? (or ?!+sorted-set? !sorted-set? #?@(:clj [!!sorted-set? (isa? java.util.SortedSet)]))) - -;; ----- Other Sets ----- ;; - - (def +insertion-ordered-set? (or (isa? linked.set.LinkedSet) - ;; This is true, but we have replaced OrderedSet with LinkedSet - #_(:clj (isa? flatland.ordered.set.OrderedSet)))) - (def !+insertion-ordered-set? none? - ;; This is true, but we have replaced OrderedSet with LinkedSet - #_(isa? flatland.ordered.set.TransientOrderedSet)) - (def ?!+insertion-ordered-set? (or +insertion-ordered-set? !+insertion-ordered-set?)) - - (def !insertion-ordered-set? #?(:clj (isa? java.util.LinkedHashSet) :cljs none?)) - - ;; CLJ technically can have via ConcurrentLinkedHashMap with same KVs but this hasn't been implemented yet -#?(:clj (def !!insertion-ordered-set? none?)) - - (def insertion-ordered-set? (or ?!+insertion-ordered-set? !insertion-ordered-set? #?(:clj !!insertion-ordered-set?))) - -;; ----- General Sets ----- ;; - - (def !+set? (isa? #?(:clj clojure.lang.ITransientSet - :cljs cljs.core/ITransientSet))) - - (def +set|built-in? (or (isa? #?(:clj clojure.lang.PersistentHashSet :cljs cljs.core/PersistentHashSet)) - (isa? #?(:clj clojure.lang.PersistentTreeSet :cljs cljs.core/PersistentTreeSet)))) - - (def +set? (isa? #?(:clj clojure.lang.IPersistentSet - :cljs cljs.core/ISet))) - (def ?!+set? (or !+set? +set?)) - - (def !set|byte? #?(:clj (isa? it.unimi.dsi.fastutil.bytes.ByteSet) :cljs none?)) - (def !set|short? #?(:clj (isa? it.unimi.dsi.fastutil.shorts.ShortSet) :cljs none?)) - (def !set|char? #?(:clj (isa? it.unimi.dsi.fastutil.chars.CharSet) :cljs none?)) - (def !set|int? #?(:clj (isa? it.unimi.dsi.fastutil.ints.IntSet) :cljs none?)) - (def !set|long? #?(:clj (isa? it.unimi.dsi.fastutil.longs.LongSet) :cljs none?)) - (def !set|float? #?(:clj (isa? it.unimi.dsi.fastutil.floats.FloatSet) :cljs none?)) - (def !set|double? #?(:clj (isa? it.unimi.dsi.fastutil.doubles.DoubleSet) :cljs none?)) - (def !set|ref? (or !unsorted-set|ref? !sorted-set|ref?)) - - (def !set? (or !set|ref? - !set|byte? !set|short? !set|char? - !set|int? !set|long? - !set|float? !set|double?)) - -#?(:clj (def !!set? (or !!unsorted-set? !!sorted-set?))) - (def set? (or ?!+set? !set? #?@(:clj [!!set? (isa? java.util.Set)]))) +;; Used by `quantum.untyped.core.analyze` +(def +set|built-in? + (or (isa? #?(:clj clojure.lang.PersistentHashSet :cljs cljs.core/PersistentHashSet)) + (isa? #?(:clj clojure.lang.PersistentTreeSet :cljs cljs.core/PersistentTreeSet)))) ;; ===== Functions ===== ;; - (def fn? (isa? #?(:clj clojure.lang.Fn :cljs js/Function))) - - (def ifn? (isa? #?(:clj clojure.lang.IFn :cljs cljs.core/IFn))) - - (def fnt? (and fn? (>expr (fn-> c/meta ::type)))) +;; Used by `quantum.untyped.core.analyze` +(def fn? (isa? #?(:clj clojure.lang.Fn :cljs js/Function))) - (def multimethod? (isa? #?(:clj clojure.lang.MultiFn :cljs cljs.core/IMultiFn))) +;; Used by `quantum.untyped.core.analyze` via `t/callable?` +(def ifn? (isa? #?(:clj clojure.lang.IFn :cljs cljs.core/IFn))) - ;; I.e., can you call/invoke it by being in functor position (first element of an unquoted - ;; list) within a typed context? - ;; TODO should we allow java.lang.Runnable, java.util.concurrent.Callable, and other - ;; functional interfaces to be `callable?`? - (def callable? (or ifn? fnt?)) +;; Used by `quantum.untyped.core.analyze` via `t/callable?` +(def fnt? (and fn? (>expr (fn-> c/meta ::type)))) -;; ===== Miscellaneous ===== ;; +;; TODO should we allow java.lang.Runnable, java.util.concurrent.Callable, and other +;; functional interfaces to be `callable?`? +;; Used by `quantum.untyped.core.analyze` +(uvar/def callable? + "The set of all objects that are able to called/invoked by being in functor position + (first element of an unquoted list) within a typed context." + (or ifn? fnt?)) - ;; Used by `quantum.untyped.core.analyze.ast` - (def with-metable? (isa? #?(:clj clojure.lang.IObj :cljs cljs.core/IWithMeta))) +;; ===== Metadata ===== ;; - ;; TODO move -#?(:clj (def thread? (isa? java.lang.Thread))) +;; Used by `quantum.untyped.core.analyze.ast` +(def with-metable? (isa? #?(:clj clojure.lang.IObj :cljs cljs.core/IWithMeta))) - ;; Used by `quantum.untyped.core.analyze` - (def throwable? "Able to be used with `throw`" - #?(:clj (isa? java.lang.Throwable) :cljs any?)) +;; ===== Errors ===== ;; - ;; Used by `quantum.untyped.core.analyze` - (def regex? (isa? #?(:clj java.util.regex.Pattern :cljs js/RegExp))) +;; Used by `quantum.untyped.core.analyze` +(def throwable? "Able to be used with `throw`" #?(:clj (isa? java.lang.Throwable) :cljs any?)) - ;; Used by `quantum.untyped.core.analyze` - (def keyword? (isa? #?(:clj clojure.lang.Keyword :cljs cljs.core/Keyword))) +;; ===== Literals ===== ;; - ;; Used by `quantum.untyped.core.analyze` via `t/literal?` - (def str? (isa? #?(:clj java.lang.String :cljs js/String))) +;; Used by `quantum.untyped.core.analyze`, including via `t/literal?` +(def regex? (isa? #?(:clj java.util.regex.Pattern :cljs js/RegExp))) - ;; Used by `quantum.untyped.core.analyze` via `t/literal?` - (def symbol? (isa? #?(:clj clojure.lang.Symbol :cljs cljs.core/Symbol))) +;; Used by `quantum.untyped.core.analyze`, including via `t/literal?` +(def keyword? (isa? #?(:clj clojure.lang.Keyword :cljs cljs.core/Keyword))) - ;; TODO move - ;; `js/File` isn't always available! Use an abstraction -#?(:clj (def file? (isa? java.io.File))) +;; Used by `quantum.untyped.core.analyze` via `t/literal?` +(def string? (isa? #?(:clj java.lang.String :cljs js/String))) - ;; TODO move - (def delay? (isa? #?(:clj clojure.lang.Delay :cljs cljs.core/Delay))) +;; Used by `quantum.untyped.core.analyze` via `t/literal?` +(def symbol? (isa? #?(:clj clojure.lang.Symbol :cljs cljs.core/Symbol))) -#?(:clj (def tagged-literal? (isa? clojure.lang.TaggedLiteral))) + ;; Used by `quantum.untyped.core.analyze` via `t/literal?` +#?(:clj (def tagged-literal? (isa? clojure.lang.TaggedLiteral))) - ;; Used in `quantum.untyped.core.analyze` - (def literal? - (or nil? boolean? symbol? keyword? str? #?(:clj long?) double? #?(:clj tagged-literal?))) +;; Used by `quantum.untyped.core.analyze` +(def literal? + (or nil? boolean? symbol? keyword? str? #?(:clj long?) double? regex? #?(:clj tagged-literal?))) - #_(def form? (or literal? +list? +vector? ...)) +;; TODO this might not be right — quite possibly any seq is a valid form +;; TODO this has to be recursively true for seq, vector, map, and set +;; Possibly planned to be used by `quantum.untyped.core.analyze` +#_(def form? (or literal? +list|built-in? +vector|built-in? +map|built-in? +set|built-in?)) diff --git a/src-untyped/quantum/untyped/ui/dom.cljc b/src-untyped/quantum/untyped/ui/dom.cljc index 5160841e..e243bb32 100644 --- a/src-untyped/quantum/untyped/ui/dom.cljc +++ b/src-untyped/quantum/untyped/ui/dom.cljc @@ -2,7 +2,7 @@ #?(:cljs (:require [quantum.untyped.reactive.core :as re]))) #?(:cljs -(defn append-element! [parent #_dom-element? tag #_dstr/str? id #_dstr/str?] +(defn append-element! [parent #_dom-element? tag #_dstr/string? id #_dstr/string?] (or (.getElementById js/document id) (doto (.createElement js/document tag) (-> .-id (set! id)) diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index d14b6f84..e8072a09 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -150,7 +150,7 @@ ;; TODO move to better place? (t/defn- ^:inline string-seq>underlying-string - [xs (t/isa? clojure.lang.StringSeq) > (t/assume dstr/str?)] (.s xs)) + [xs (t/isa? clojure.lang.StringSeq) > (t/assume dstr/string?)] (.s xs)) ;; ===== Reductive functions ===== ;; @@ -175,7 +175,7 @@ #?(:clj (t/defn reduce-indexed "Made public in case future specializations want to use it." - ([rf rf?, init t/any?, xs (t/or dstr/str? vec/!+vector? arr/array?), i0 t/numerically-integer?] + ([rf rf?, init t/any?, xs (t/or dstr/string? vec/!+vector? arr/array?), i0 t/numerically-integer?] (let [ct (count xs)] (loop [i (p/>int i0), ret init] (if (comp/< i ct) @@ -237,7 +237,7 @@ (^:inline [rf rf?, init t/any?, xs p/nil?] init) ;; - Adapted from `areduce` ;; - `!+vector?` included because they aren't reducible or seqable by default - (^:inline [rf rf?, init t/any?, xs (t/or dstr/str? vec/!+vector? arr/array?)] + (^:inline [rf rf?, init t/any?, xs (t/or dstr/string? vec/!+vector? arr/array?)] (reduce-indexed rf init xs 0)) #?(:clj (^:inline [rf rf?, init t/any?, xs dc/string-seq?] (reduce-indexed rf init (string-seq>underlying-string xs) (.index xs)))) @@ -367,8 +367,8 @@ cljs.core/count "9/26/2018"}} ;; Counted ([x p/nil? > #?(:clj p/long? :cljs dnum/nip?)] 0) -#?(:cljs ([xs dstr/str? > (t/assume dnum/nip?)] (.-length xs))) -#?(:cljs ([xs dstr/!str? > (t/assume dnum/nip?)] (.getLength xs))) +#?(:cljs ([xs dstr/string? > (t/assume dnum/nip?)] (.-length xs))) +#?(:cljs ([xs dstr/!string? > (t/assume dnum/nip?)] (.getLength xs))) ([xs dc/icounted? > #?(:clj p/int? :cljs (t/* dnum/nip?))] (#?(:clj .count :cljs cljs.core/-count) xs)) #?(:clj ([xs dstr/char-seq? > p/int?] (.length xs))) diff --git a/src/quantum/core/data/collections.cljc b/src/quantum/core/data/collections.cljc index 8d63d626..c9b160f7 100644 --- a/src/quantum/core/data/collections.cljc +++ b/src/quantum/core/data/collections.cljc @@ -2,13 +2,16 @@ (:refer-clojure :exclude [associative? indexed? list? reduced? sequential?]) (:require - [quantum.core.data.array :as arr] - [quantum.core.data.map :as map] - [quantum.core.data.set :as set] - [quantum.core.data.string :as dstr] - [quantum.core.data.tuple :as tup] - [quantum.core.data.vector :as vec] - [quantum.core.type :as t])) + [quantum.core.data.array :as arr] + [quantum.core.data.map :as map] + [quantum.core.data.set :as set] + [quantum.core.data.string :as dstr] + [quantum.core.data.tuple :as tup] + [quantum.core.data.vector :as vec] + [quantum.core.type :as t] + [quantum.core.vars :as var] + ;; TODO TYPED excise + [quantum.untyped.core.type :as ut])) ;; TODO move to `quantum.core.data.sequence` ;; ===== Sequences and sequence-wrappers ===== ;; @@ -16,7 +19,7 @@ (def iseqable? (t/isa|direct? #?(:clj clojure.lang.Seqable :cljs cljs.core/ISeqable))) -(def iseq? (t/isa? #?(:clj clojure.lang.ISeq :cljs cljs.core/ISeq))) +(def iseq? (t/isa|direct? #?(:clj clojure.lang.ISeq :cljs cljs.core/ISeq))) #?(:clj (def aseq? (t/isa? clojure.lang.ASeq))) @@ -72,7 +75,10 @@ (t/isa? quantum.core.data.finger_tree.CountedDoubleList)) :cljs (t/isa? quantum.core.data.finger-tree/CountedDoubleList))) +(var/defalias ut/+list|built-in?) + (def +list? (t/isa? #?(:clj clojure.lang.IPersistentList :cljs cljs.core/IList))) + (def !list? #?(:clj (t/isa? java.util.LinkedList) :cljs t/none?)) (def list? #?(:clj (t/isa? java.util.List) :cljs +list?)) @@ -104,15 +110,14 @@ #?(:clj dstr/char-seq? :cljs dstr/string?) arr/array?)) -(def +associative? (t/isa? #?(:clj clojure.lang.Associative - :cljs cljs.core/IAssociative))) +(def +associative? (t/isa|direct? #?(:clj clojure.lang.Associative + :cljs cljs.core/IAssociative))) -(def !+associative? (t/isa? #?(:clj clojure.lang.ITransientAssociative - :cljs cljs.core/ITransientAssociative))) +(def !+associative? (t/isa|direct? #?(:clj clojure.lang.ITransientAssociative + :cljs cljs.core/ITransientAssociative))) ;; Indicates whether `assoc?!` is supported -(def associative? - (t/or +associative? !+associative? (t/or map/map? indexed?))) +(def associative? (t/or +associative? !+associative? (t/or map/map? indexed?))) (def sequential? (t/or (t/isa? #?(:clj clojure.lang.Sequential :cljs cljs.core/ISequential)) @@ -162,7 +167,7 @@ [x t/ref?] (#?(:clj clojure.lang.Reduced. :cljs cljs.core/Reduced.) x)) (def reducible? - (t/or p/nil? dstr/str? vec/!+vector? arr/array? dnum/numerically-integer? + (t/or p/nil? dstr/string? vec/!+vector? arr/array? dnum/numerically-integer? ;; TODO what about `transformer?` dasync/read-chan? (t/isa? fast_zip.core.ZipperLocation) diff --git a/src/quantum/core/data/identifiers.cljc b/src/quantum/core/data/identifiers.cljc index 4fd33b87..a244d814 100644 --- a/src/quantum/core/data/identifiers.cljc +++ b/src/quantum/core/data/identifiers.cljc @@ -7,7 +7,7 @@ [quantum.core.data.meta :refer [>meta]] [quantum.core.data.string :as dstr - :refer [str? >str]] + :refer [>string]] [quantum.core.type :as t] [quantum.untyped.core.core :as ucore])) @@ -23,10 +23,10 @@ ;; ===== Nameability ===== ;; -(def named? (t/isa? #?(:clj clojure.lang.Named :cljs cljs.core/INamed))) +(def named? (t/isa|direct? #?(:clj clojure.lang.Named :cljs cljs.core/INamed))) -(t/defn demunged>namespace [s str?] TODO TYPED #_(subs s 0 (.lastIndexOf s "/"))) -(t/defn demunged>name [s str?] TODO TYPED #_(subs s (inc (.lastIndexOf s "/")))) +(t/defn demunged>namespace [s dstr/string?] TODO TYPED #_(subs s 0 (.lastIndexOf s "/"))) +(t/defn demunged>name [s dstr/string?] TODO TYPED #_(subs s (inc (.lastIndexOf s "/")))) (defn... ?ns>name [?ns] (name #?(:clj (if (namespace? ?ns) @@ -36,9 +36,9 @@ (t/defn >name "Computes the nilable name (the unqualified string identifier) of `x`." - > (t/? str?) - (^:inline [x (t/or t/nil? str?)] x) - (^:inline [x named?] #?(:clj (.getName x) :cljs (-name ^not-native x))) + > (t/? dstr/string?) + (^:inline [x (t/or t/nil? dstr/string?)] x) + (^:inline [x named?] #?(:clj (.getName x) :cljs (cljs.core/-name x))) #?(:clj (^:inline [x ??/class?] (.getName x))) ( [x ??/fn?] #?(:clj (or (some-> (-> >meta :name) >name) @@ -48,9 +48,9 @@ (t/defn >namespace "Computes the nilable identifier-namespace (the string identifier-qualifier) of `x`." - > (t/? str?) - (^:inline [x (t/or t/nil? str? #?(:clj ??/class?) #?(:clj ??/namespace?))] nil) - (^:inline [x named?] #?(:clj (.getNamespace x) :cljs (-namespace ^not-native x))) + > (t/? dstr/string?) + (^:inline [x (t/or t/nil? dstr/string? #?(:clj ??/class?) #?(:clj ??/namespace?))] nil) + (^:inline [x named?] #?(:clj (.getNamespace x) :cljs (cljs.core/-namespace x))) ( [x ??/fn?] #?(:clj (or (some-> (-> x >meta :ns) >name) (-> x ??/>class .getName clojure.lang.Compiler/demunge demunged>namespace)) @@ -100,16 +100,16 @@ ([x keyword?] x) ([x symbol?] #?(:clj (clojure.lang.Keyword/intern x) :cljs (cljs.core/Keyword. (>namespace x) (>name x) (.-str x) nil))) - ([x str?] #?(:clj (clojure.lang.Keyword/intern x) - ;; TODO TYPED below - :cljs (let [parts (.split x "/")] - (if (== (alength parts) 2) - (cljs.core/Keyword. (aget parts 0) (aget parts 1) x nil) - (cljs.core/Keyword. nil (aget parts 0) x nil))))) - ([ns-str t/nil?, name-str str?] + ([x dstr/string?] #?(:clj (clojure.lang.Keyword/intern x) + ;; TODO TYPED below + :cljs (let [parts (.split x "/")] + (if (== (alength parts) 2) + (cljs.core/Keyword. (aget parts 0) (aget parts 1) x nil) + (cljs.core/Keyword. nil (aget parts 0) x nil))))) + ([ns-str t/nil?, name-str dstr/string?] #?(:clj (clojure.lang.Keyword/intern ns-str name-str) :cljs (cljs.core/Keyword. ns-str name-str name-str nil))) - ([ns-str str?, name-str str?] + ([ns-str dstr/string?, name-str dstr/string?] #?(:clj (clojure.lang.Keyword/intern ns-str name-str) :cljs (cljs.core/Keyword. ns-str name-str (>str ns-str "/" name-str) nil)))) @@ -117,18 +117,18 @@ "Outputs a symbol (possibly qualified, meta-able identifier)." > symbol? ([x symbol?] x) - ([x str?] #?(:clj (clojure.lang.Symbol/intern x) - ;; TODO TYPED below - :cljs (let [i (.indexOf x "/")] - (if (< i 1) - (>symbol nil x) - (>symbol (.substring x 0 i) - (.substring x (inc i) (.-length x))))))) + ([x dstr/string?] #?(:clj (clojure.lang.Symbol/intern x) + ;; TODO TYPED below + :cljs (let [i (.indexOf x "/")] + (if (< i 1) + (>symbol nil x) + (>symbol (.substring x 0 i) + (.substring x (inc i) (.-length x))))))) ([x keyword?] (>symbol (>namespace x) (>name x))) - ([ns-str t/nil?, name-str str?] + ([ns-str t/nil?, name-str dstr/string?] #?(:clj (clojure.lang.Symbol/intern ns-str name-str) :cljs (cljs.core/Symbol. ns-str name-str name-str nil nil))) - ([ns-str str?, name-str str?] + ([ns-str dstr/string?, name-str dstr/string?] #?(:clj (clojure.lang.Symbol/intern ns-str name-str) :cljs (cljs.core/Symbol. ns-str name-str (>str ns-str "/" name-str) nil nil))) @@ -145,7 +145,7 @@ ;; ===== UUIDs ===== ;; -(def uuid? (t/isa? #?(:clj java.util.UUID :cljs cljs.core/UUID))) +(def uuid? (t/isa|direct? #?(:clj java.util.UUID :cljs cljs.core/UUID))) (t/defn >uuid > uuid? ([] @@ -162,7 +162,7 @@ (hex) (hex) (hex) (hex) (hex) (hex) (hex) (hex) (hex) (hex) (hex) (hex))))))) - #?(:cljs ([x str?] (cljs.core/UUID. (.toLowerCase s) nil)))) + #?(:cljs ([x dstr/string?] (cljs.core/UUID. (.toLowerCase s) nil)))) ;; ===== Delimited identifiers ===== ;; @@ -170,7 +170,7 @@ (defrecord ^{:doc "A delimited identifier. Defaults to delimiting all qualifiers by the pipe symbol instead of slashes or dots."} - DelimitedIdent [qualifiers #_(t/of (t/and str? (t/not (fn1 contains? \|))))] + DelimitedIdent [qualifiers #_(t/of (t/and dstr/string? (t/not (fn1 contains? \|))))] fipp.ednize/IOverride fipp.ednize/IEdn (-edn [this] (tagged-literal '| (>symbol (??str/join "|" qualifiers))))) @@ -180,7 +180,7 @@ (t/defn >delim-ident "Computes the delimited identifier of `x`." ([x delim-ident?] x) - ([x str?] (-> x (??str/split #"\.|\||/") (DelimitedIdent.))) + ([x dstr/string?] (-> x (??str/split #"\.|\||/") (DelimitedIdent.))) ([x named?] (DelimitedIdent. (??/concat (some-> (>namespace x) (??str/split #"\.|\||/")) (-> x >name (??str/split #"\.|\||/"))))) @@ -193,8 +193,8 @@ (concat (-> x >namespace (str/split #"\.|\||/")) (-> x >name (str/split #"\.|\||/")))) (fn? x) (DelimitedIdent. - #?(:clj (or (some-> (-> x >meta :name) >name (str/split #"\.|\||/")) - (-> x class .getName clojure.lang.Compiler/demunge (str/split #"\.|\||/"))) - :cljs (if (-> x .-name str/blank?) - [""] - (-> x .-name demunge-str (str/split #"\.|\||/"))))) + #?(:clj (or (some-> (-> x >meta :name) >name (str/split #"\.|\||/")) + (-> x class .getName clojure.lang.Compiler/demunge (str/split #"\.|\||/"))) + :cljs (if (-> x .-name str/blank?) + [""] + (-> x .-name demunge-str (str/split #"\.|\||/"))))) diff --git a/src/quantum/core/data/set.cljc b/src/quantum/core/data/set.cljc index 67789bad..0ca09d77 100644 --- a/src/quantum/core/data/set.cljc +++ b/src/quantum/core/data/set.cljc @@ -1,30 +1,201 @@ -(ns - ^{:doc "Useful set-related functions. Includes a dispatch function, |xset?|, - from which |subset|, |superset|, |proper-subset?|, and so on may be called." - :attribution "alexandergunnarson"} - quantum.core.data.set - (:refer-clojure :exclude - [+ -, and or not, compare, split-at hash-set]) - (:require - [clojure.core :as core] - [clojure.set :as set] - [clojure.data.avl :as avl] - [linked.core :as linked] - [quantum.core.vars :as var - :refer [defalias defaliases]] - [quantum.core.error :as err - :refer [>ex-info TODO]] - [quantum.core.fn :as fn] - [quantum.untyped.core.data.set :as uset] -#?@(:clj - [[clojure.data.finger-tree :as ftree] - [seqspert.hash-set] - [clojure.data.int-map :as imap]])) +(ns quantum.core.data.set + "A set may be thought of as a special type of Map whose keys and vals are identical." + (:refer-clojure :exclude + [+ -, and or not, compare, split-at hash-set]) + (:require + ;; TODO TYPED excise + [clojure.core :as core] + #?(:clj [clojure.data.finger-tree :as ftree]) + #?(:clj [clojure.data.int-map :as imap]) + ;; TODO TYPED excise + [clojure.set :as set] + ;; TODO TYPED excise + [clojure.data.avl :as avl] + [linked.core :as linked] + [quantum.core.vars :as var + :refer [defalias defaliases]] + ;; TODO TYPED excise + [quantum.untyped.core.data.set :as uset] + ;; TODO TYPED excise + [quantum.untyped.core.error :as uerr] + #?(:clj [seqspert.hash-set])) #?(:clj (:import - java.util.HashSet + [it.unimi.dsi.fastutil.doubles DoubleOpenHashSet] [it.unimi.dsi.fastutil.ints IntOpenHashSet] [it.unimi.dsi.fastutil.longs LongOpenHashSet] - [it.unimi.dsi.fastutil.doubles DoubleOpenHashSet]))) + [java.util HashSet]))) + +;; ===== Sets ===== ;; + +#?(:clj (def java-set? (t/isa? java.util.Set))) + +;; ----- Identity Sets (identity-based equality) ----- ;; + + (def +identity-set? t/none?) + (def !+identity-set? t/none?) + (def ?!+identity-set? (t/or +identity-set? !+identity-set?)) + + (var/def !identity-set? + "`java.util.IdentityHashSet` doesn't exist." + #?(:clj t/none? :cljs (t/isa? js/Set))) + +#?(:clj (def !!identity-set? t/none?)) + + (def identity-set? (t/or ?!+identity-set? !identity-set? #?(:cljs !!identity-set?))) + +;; ----- Hash Sets (value-based equality) ----- ;; + +(def +hash-set? (t/isa? #?(:clj clojure.lang.PersistentHashSet + :cljs cljs.core/PersistentHashSet))) +(def !+hash-set? (t/isa? #?(:clj clojure.lang.PersistentHashSet$TransientHashSet + :cljs cljs.core/TransientHashSet))) +(def ?!+hash-set? (t/or +hash-set? !+hash-set?)) + +(def !hash-set|byte? #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.ByteOpenHashSet) + :cljs t/none?)) +(def !hash-set|char? #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.CharOpenHashSet) + :cljs t/none?)) +(def !hash-set|short? #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.ShortOpenHashSet) + :cljs t/none?)) +(def !hash-set|int? #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.IntOpenHashSet) + :cljs t/none?)) +(def !hash-set|long? #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.LongOpenHashSet) + :cljs t/none?)) +(def !hash-set|float? #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.FloatOpenHashSet) + :cljs t/none?)) +(def !hash-set|double? #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.DoubleOpenHashSet) + :cljs t/none?)) + +(def !hash-set|ref? #?(:clj (t/or (t/isa? java.util.HashSet) + (t/isa? it.unimi.dsi.fastutil.objects.ReferenceOpenHashSet)) + :cljs t/none?)) + +(def !hash-set? + (t/or !hash-set|ref? + !hash-set|byte? !hash-set|short? !hash-set|char? !hash-set|int? !hash-set|long? + !hash-set|float? !hash-set|double?)) + +#?(:clj +(var/def !!hash-set? + "CLJ technically can have a `!!hash-set?` via `java.util.concurrent.ConcurrentHashMap` with same + KVs but this hasn't been implemented yet." + t/none?)) + +(def hash-set? (t/or ?!+hash-set? !hash-set? #?(:clj !!hash-set?))) + +;; ----- Unsorted Sets ----- ;; + +(def +unsorted-set? +hash-set?) +(def !+unsorted-set? !+hash-set?) +(def ?!+unsorted-set? ?!+hash-set?) + +(def !unsorted-set|byte? !hash-set|byte?) +(def !unsorted-set|short? !hash-set|char?) +(def !unsorted-set|char? !hash-set|short?) +(def !unsorted-set|int? !hash-set|int?) +(def !unsorted-set|long? !hash-set|long?) +(def !unsorted-set|float? !hash-set|float?) +(def !unsorted-set|double? !hash-set|double?) +(def !unsorted-set|ref? !hash-set|ref?) + +(def !unsorted-set? + (t/or !unsorted-set|ref? + !unsorted-set|byte? !unsorted-set|short? !unsorted-set|char? + !unsorted-set|int? !unsorted-set|long? + !unsorted-set|float? !unsorted-set|double?)) + +#?(:clj (def !!unsorted-set? !!hash-set?)) + (def unsorted-set? hash-set?) + +;; ----- Sorted Sets ----- ;; + +(def +sorted-set? (t/isa? #?(:clj clojure.lang.PersistentTreeSet + :cljs cljs.core/PersistentTreeSet))) +(def !+sorted-set? t/none?) +(def ?!+sorted-set? (t/or +sorted-set? !+sorted-set?)) + +(def !sorted-set|byte? #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.ByteSortedSet) + :cljs t/none?)) +(def !sorted-set|short? #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.ShortSortedSet) + :cljs t/none?)) +(def !sorted-set|char? #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.CharSortedSet) + :cljs t/none?)) +(def !sorted-set|int? #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.IntSortedSet) + :cljs t/none?)) +(def !sorted-set|long? #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.LongSortedSet) + :cljs t/none?)) +(def !sorted-set|float? #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.FloatSortedSet) + :cljs t/none?)) +(def !sorted-set|double? #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.DoubleSortedSet) + :cljs t/none?)) + +(var/def !sorted-set|ref? + "CLJS technically can have a `!sorted-set|ref?` via `goog.structs.AVLTree` with same KVs but this + hasn't been implemented yet." + #?(:clj (t/isa? java.util.TreeSet) :cljs t/none?)) + +(def !sorted-set? + (t/or !sorted-set|ref? + !sorted-set|byte? !sorted-set|short? !sorted-set|char? !sorted-set|int? !sorted-set|long? + !sorted-set|float? !sorted-set|double?)) + +#?(:clj +(var/def !!sorted-set? + "CLJ technically can have a `!!sorted-set?` via a `java.util.concurrent.ConcurrentSkipListMap` + with same KVs but this hasn't been implemented yet." + t/none?)) + +(def sorted-set? + (t/or ?!+sorted-set? !sorted-set? #?@(:clj [!!sorted-set? (t/isa? java.util.SortedSet)]))) + +;; ----- Other Sets ----- ;; + +(def +insertion-ordered-set? (or (isa? linked.set.LinkedSet) + ;; This is true, but we have replaced OrderedSet with LinkedSet + #_(:clj (isa? flatland.ordered.set.OrderedSet)))) +(def !+insertion-ordered-set? t/none? + ;; This is true, but we have replaced OrderedSet with LinkedSet + #_(t/isa? flatland.ordered.set.TransientOrderedSet)) +(def ?!+insertion-ordered-set? (t/or +insertion-ordered-set? !+insertion-ordered-set?)) + +(def !insertion-ordered-set? #?(:clj (t/isa? java.util.LinkedHashSet) :cljs t/none?)) + +#?(:clj +(var/def !!insertion-ordered-set? + "CLJ technically can have this via a `java.util.concurrent.ConcurrentLinkedHashMap with same KVs + but this hasn't been implemented yet." + t/none?)) + +(def insertion-ordered-set? + (t/or ?!+insertion-ordered-set? !insertion-ordered-set? #?(:clj !!insertion-ordered-set?))) + +;; ----- General Sets ----- ;; + +(def !+set? (t/isa? #?(:clj clojure.lang.ITransientSet + :cljs cljs.core/ITransientSet))) + +(var/defalias ut/+set|built-in?) + +(def +set? (t/isa? #?(:clj clojure.lang.IPersistentSet + :cljs cljs.core/ISet))) + +(def ?!+set? (t/or !+set? +set?)) + +(def !set|byte? #?(:clj (t/isa? it.unimi.dsi.fastutil.bytes.ByteSet) :cljs t/none?)) +(def !set|short? #?(:clj (t/isa? it.unimi.dsi.fastutil.shorts.ShortSet) :cljs t/none?)) +(def !set|char? #?(:clj (t/isa? it.unimi.dsi.fastutil.chars.CharSet) :cljs t/none?)) +(def !set|int? #?(:clj (t/isa? it.unimi.dsi.fastutil.ints.IntSet) :cljs t/none?)) +(def !set|long? #?(:clj (t/isa? it.unimi.dsi.fastutil.longs.LongSet) :cljs t/none?)) +(def !set|float? #?(:clj (t/isa? it.unimi.dsi.fastutil.floats.FloatSet) :cljs t/none?)) +(def !set|double? #?(:clj (t/isa? it.unimi.dsi.fastutil.doubles.DoubleSet) :cljs t/none?)) +(def !set|ref? (t/or !unsorted-set|ref? !sorted-set|ref?)) + +(def !set? (t/or !set|ref? + !set|byte? !set|short? !set|char? !set|int? !set|long? + !set|float? !set|double?)) + +#?(:clj (def !!set? (t/or !!unsorted-set? !!sorted-set?))) + (def set? (t/or ?!+set? !set? #?@(:clj [!!set? (t/isa? java.util.Set)]))) ; ============ STRUCTURES ============ @@ -51,7 +222,7 @@ (defn ->set "Like `clojure.core/set`" - [xs] (TODO)) + [xs] (uerr/TODO)) #?(:clj (defn !bit-set @@ -60,17 +231,17 @@ - has a rigid `logicalSize`|capacity - attempts to `get`, `set` or `clear` bits at indices exceeding the size cause an `IndexOutOfBoundsException`" - [& args] (TODO))) + [& args] (uerr/TODO))) #?(:clj (defn !bit-set-frame {:see-also "net/openhft/chronicle/algo/bitset/SingleThreadedFlatBitSetFrame"} - [& args] (TODO))) + [& args] (uerr/TODO))) #?(:clj (defn !!bit-set-frame {:see-also "net/openhft/chronicle/algo/bitset/ConcurrentFlatBitSetFrame"} - [& args] (TODO))) + [& args] (uerr/TODO))) ;; ===== Comparison ===== ;; @@ -102,7 +273,7 @@ (core/and (hash-set? s0) (hash-set? s1)) (#?(:clj seqspert.hash-set/parallel-splice-hash-sets :cljs seqspert.hash-set/sequential-splice-hash-sets) s0 s1) - :else (throw (>ex-info "Could not perform parallel union; can try sequential.")))) + :else (throw (ex-info "Could not perform parallel union; can try sequential." {})))) ([s0 s1 & ss] (reduce punion (punion s0 s1) ss)))) diff --git a/src/quantum/core/data/tuple.cljc b/src/quantum/core/data/tuple.cljc index 81d5a71f..b5011929 100644 --- a/src/quantum/core/data/tuple.cljc +++ b/src/quantum/core/data/tuple.cljc @@ -1,4 +1,6 @@ (ns quantum.core.data.tuple + (:refer-clojure :exclude + [map-entry?]) (:require [quantum.core.type :as t] [quantum.core.vars @@ -6,9 +8,9 @@ ;; TODO TYPED excise [quantum.untyped.core.data.tuple :as u])) - ;; clojure.lang.Tuple was discontinued; we won't support it for now - (def tuple? (t/isa? quantum.untyped.core.data.tuple.Tuple)) +;; clojure.lang.Tuple was discontinued; we won't support it for now +(def tuple? (t/isa? quantum.untyped.core.data.tuple.Tuple)) -#?(:clj (def map-entry? (t/isa? java.util.Map$Entry))) +(def map-entry? (t/isa|direct? #?(:clj java.util.Map$Entry :cljs cljs.core/IMapEntry))) #?(:clj (defalias u/tuple)) diff --git a/src/quantum/core/fn.cljc b/src/quantum/core/fn.cljc index 96f40123..a21f9f55 100644 --- a/src/quantum/core/fn.cljc +++ b/src/quantum/core/fn.cljc @@ -8,6 +8,7 @@ [clojure.core :as core] [clojure.walk] [quantum.core.core :as qcore] + [quantum.core.typed :as t] [quantum.untyped.core.form.evaluate :refer [case-env compile-if]] [quantum.untyped.core.form.generate @@ -22,6 +23,9 @@ :refer [aritoid gen-constantly gen-call gen-positional-nthas gen-ntha gen-conja gen-reversea gen-mapa]]))) +;; TODO TYPED move to `data.fn`? +(def multimethod? (t/isa? #?(:clj clojure.lang.MultiFn :cljs cljs.core/IMultiFn))) + (t/defn ^:inline identity [x t/any? > (t/type x)] x) ;; ===== `fn`: Positional functions ===== ;; diff --git a/src/quantum/core/io/core.cljc b/src/quantum/core/io/core.cljc index 5e5e1b95..1d289a78 100644 --- a/src/quantum/core/io/core.cljc +++ b/src/quantum/core/io/core.cljc @@ -30,6 +30,7 @@ :refer [defalias]] [quantum.core.spec :as s :refer [validate]] + [quantum.core.type :as t] [quantum.core.macros :as macros :refer [defnt]]) #?(:clj (:import @@ -39,6 +40,10 @@ FileInputStream FileOutputStream FileNotFoundException)))) + ;; TODO TYPED move? + ;; `js/File` isn't always available! Use an abstraction +#?(:clj (def file? (t/isa? java.io.File))) + (defonce clj-ext (atom :cljd)) ; Clojure data ; All this isn't just IO, it's persisting, which is a smallish subset From 32e2e75605b6c0e92c7800b1c5359f91f923a93b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 18:29:57 -0600 Subject: [PATCH 330/810] Add in some more todo fns --- resources-dev/defnt.cljc | 8 ++++++++ src/quantum/core/collections_typed.cljc | 7 ++++--- 2 files changed, 12 insertions(+), 3 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index c90ddac1..9cc15292 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -212,6 +212,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x x] identical? - [x x] indexed? - [x x] integer? + - [ ] filter - [ |] find-keyword - [x x] float - [x x] float? @@ -221,9 +222,11 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x x] int? - [x x] keyword - [x x] keyword? + - [x x] list? - [ |] locking - [x x] long - [x x] long? + - [ ] map - [x x] map? - [x x] map-entry? - [ ] mod @@ -238,6 +241,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x x] number? - [x |] numerator - [ ] odd? + - [ ] peek + - [ ] pop - [ ] pos? - [ ] pos-int? - [x x] qualified-ident? @@ -245,7 +250,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x x] qualified-symbol? - [x |] ratio? - [ ] rational? + - [x x] reduce - [ ] rem + - [ ] remove - [x x] set? - [x x] short - [x x] short? @@ -256,6 +263,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x x] string? - [x x] symbol - [x x] symbol? + - [. .] transduce - [x x] uuid? - [.] clojure.lang.Numbers https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/Numbers.java diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index e8072a09..14e31c99 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -48,6 +48,7 @@ ;; ===== Access functions ===== ;; ;; TODO for CLJS we should do !+vector +;; TODO TYPED (t/defn get "Retrieve the value in `xs` associated with the key `k`. @@ -154,8 +155,7 @@ ;; ===== Reductive functions ===== ;; -;; TODO: conditionally optional arities etc. for t/fn - +;; TODO TYPED conditionally optional arities etc. for t/fn (var/def rf? "Reducing function" (t/ftype "seed arity" [] "completing arity" [t/any?] @@ -175,6 +175,7 @@ #?(:clj (t/defn reduce-indexed "Made public in case future specializations want to use it." + {:incorporated '{cljs.core/ci-reduce "9/25/2018"}} ([rf rf?, init t/any?, xs (t/or dstr/string? vec/!+vector? arr/array?), i0 t/numerically-integer?] (let [ct (count xs)] (loop [i (p/>int i0), ret init] @@ -225,7 +226,7 @@ We would specialize on `clojure.lang.Range` and `clojure.lang.LongRange` but they do not expose their `step` field so we have to use their implementation of `reduce`." - {:incorporated '{clojure.core/reduce "9/25/2018" + :incorporated '{clojure.core/reduce "9/25/2018" clojure.core/reduce-kv "9/25/2018" clojure.core.protocols "9/25/2018" cljs.core/reduce "9/26/2018" From 676f6217e46ede0d42fe87b5afc1b44c0bfb0c01 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 20:47:34 -0600 Subject: [PATCH 331/810] Added a bunch more todo fns, chunking impls --- resources-dev/defnt.cljc | 88 ++++++++++++++++++++-- src-untyped/quantum/untyped/core/type.cljc | 15 ++-- src/quantum/core/cache.cljc | 7 +- src/quantum/core/collections_typed.cljc | 68 +++++++++++------ src/quantum/core/data/collections.cljc | 21 +++--- src/quantum/core/data/meta.cljc | 11 ++- src/quantum/core/data/vector.cljc | 21 +++--- 7 files changed, 167 insertions(+), 64 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 9cc15292..7f72f9bb 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -2,8 +2,6 @@ #?(:clj (def thread? (isa? java.lang.Thread))) -(def delay? (isa? #?(:clj clojure.lang.Delay :cljs cljs.core/Delay))) - #?(:clj (def class? (isa? java.lang.Class))) ;; TODO for CLJS based on untyped impl @@ -186,61 +184,115 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative [.] : in progress [-] : done as far as possible but not truly complete [x] : actually done - [|] : not possible / N/A / refused + [|] : not possible / N/A + [!] : refused - List of semi-approximately topologically ordered namespaces to make typed: - [.] clojure.core / cljs.core - [x x] = - [. .] == + - [. .] < + - [ ] and - [ ] any? + - [ ] apply + - [ ] assoc + - [ ] assoc! - [x x] associative? - [. .] boolean - [x x] boolean? + - [ ] butlast - [x x] byte - [x x] byte? - [x x] char - [x x] char? + - [ |] cast + - [x x] chunk + - [x x] chunk-append + - [x x] chunk-buffer + - [x x] chunk-cons + - [x x] chunk-first + - [x x] chunk-next + - [x x] chunk-rest + - [x x] chunked-seq? - [ |] class - [x x] compare + - [ ] concat + - [ ] cond + - [ ] cons - [ ] conj - [ ] contains? + - [x x] count - [x x] counted? - [x |] decimal? + - [ ] defmacro + - [. .] defn + - [ ] defrecord + - [ ] deftype + - [ ] delay + - [x x] delay? - [x |] denominator - [x x] double - [x x] double? + - [. .] empty? - [ ] even? + - [ ] force - [x x] identical? + - [ ] if-not (not as performant as we thought) - [x x] indexed? + - [. .] int - [x x] integer? + - [x x] false? - [ ] filter - [ |] find-keyword + - [ ] ffirst + - [ ] first - [x x] float - [x x] float? + - [. .] fn + - [x x] fn? + - [ ] fnext + - [ ] gensym + - [ ] hash-map + - [ ] hash-set - [x x] ident? + - [x x] ifn? - [| ] infinite? + - [ ] instance? - [x x] int - [x x] int? - [x x] keyword - [x x] keyword? + - [ ] last + - [ ] lazy-seq + - [ ] let + - [ ] list + - [ ] list* - [x x] list? - [ |] locking - [x x] long - [x x] long? + - [ ] loop - [ ] map - [x x] map? - [x x] map-entry? + - [x x] meta - [ ] mod - [x x] name - [x x] namespace - [ ] nat-int? - [ ] neg? - [ ] neg-int? + - [ ] next + - [ ] nfirst - [x x] nil? + - [ ] nnext + - [ ] nth + - [ ] not - [x x] not= - [x |] ns-name - [x x] number? - [x |] numerator - [ ] odd? + - [ ] or - [ ] peek - [ ] pop - [ ] pos? @@ -250,9 +302,14 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x x] qualified-symbol? - [x |] ratio? - [ ] rational? + - [x x] record? - [x x] reduce - [ ] rem - [ ] remove + - [ ] rest + - [ ] second + - [ ] seq + - [x x] seq? - [x x] set? - [x x] short - [x x] short? @@ -260,11 +317,28 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x x] simple-keyword? - [x x] simple-symbol? - [x x] some? + - [x x] sorted? + - [ ] sorted-map + - [ ] sorted-map-by + - [ ] sorted-set + - [ ] sorted-set-by + - [ ] spread + - [. .] str - [x x] string? - [x x] symbol - [x x] symbol? + - [ ] to-array - [. .] transduce + - [x x] true? - [x x] uuid? + - [. .] vary-meta + - [ ] vec + - [ ] vector + - [x x] vector? + - [! !] when + - [! !] when-not + - [x x] with-meta + - [x ] zero? - [.] clojure.lang.Numbers https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/Numbers.java - [ ] add @@ -353,6 +427,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] xor - [.] clojure.lang.RT https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/RT.java + - [x] count + - [x] countFrom - [.] clojure.lang.Util https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/Util.java - [ ] classOf @@ -387,7 +463,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [.] quantum.core.fn - [ ] `apply` - especially with `t/defn` as the caller - - [ ] quantum.core.cache + - [.] quantum.core.cache - [ ] quantum.core.type-old - [.] quantum.core.data.primitive - [.] quantum.core.data.string @@ -484,10 +560,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] dec - [ ] isZero - [ ] isNeg - - [ ] inc - - [ ] dec - - [ ] isZero - - [ ] isNeg - [ ] isPos - [x] add - [ ] subtract diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 3f520f2c..29f7ae3d 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -8,13 +8,10 @@ boolean? byte? bytes? char? short? int? long? float? double? isa? nil? any? class? tagged-literal? #?(:cljs object?) - number? decimal? bigdec? integer? ratio? true? false? keyword? symbol? - array? associative? coll? counted? indexed? iterable? list? map? map-entry? record? - seq? seqable? sequential? set? sorted? vector? fn? ifn? meta - delay? ref volatile? + ref fn]) (:require [clojure.core :as c] @@ -635,10 +632,14 @@ ;; ===== Functions ===== ;; ;; Used by `quantum.untyped.core.analyze` -(def fn? (isa? #?(:clj clojure.lang.Fn :cljs js/Function))) +(def fn? #?(:clj (isa? clojure.lang.Fn) + :cljs (or (isa? js/Function) (isa|direct? cljs.core/Fn)))) ;; Used by `quantum.untyped.core.analyze` via `t/callable?` -(def ifn? (isa? #?(:clj clojure.lang.IFn :cljs cljs.core/IFn))) +(uvar/def ifn? + "Note that in CLJS, `cljs.core/ifn?` checks if something is either `fn?` or if it satisfies + `cljs.core/IFn`. By contrast, this type encompasses only direct implementers of `cljs.core/IFn`." + (isa|direct? #?(:clj clojure.lang.IFn :cljs cljs.core/IFn))) ;; Used by `quantum.untyped.core.analyze` via `t/callable?` (def fnt? (and fn? (>expr (fn-> c/meta ::type)))) @@ -649,7 +650,7 @@ (uvar/def callable? "The set of all objects that are able to called/invoked by being in functor position (first element of an unquoted list) within a typed context." - (or ifn? fnt?)) + (or fn? ifn? fnt?)) ;; ===== Metadata ===== ;; diff --git a/src/quantum/core/cache.cljc b/src/quantum/core/cache.cljc index 8a1cc8ff..8d6b47b9 100644 --- a/src/quantum/core/cache.cljc +++ b/src/quantum/core/cache.cljc @@ -1,12 +1,17 @@ (ns quantum.core.cache (:refer-clojure :exclude [memoize]) (:require + [quantum.core.typed :as t] + ;; TODO TYPED excise [quantum.untyped.core.cache :as u] + ;; TODO TYPED excise [quantum.untyped.core.vars :as uvar :refer [defaliases]])) +(def delay? (t/isa? #?(:clj clojure.lang.Delay :cljs cljs.core/Delay))) + +;; TODO TYPED (defaliases u memoize* memoize #?(:clj defmemoized) callable-times init! clear!) - diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index 14e31c99..935a6911 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -102,30 +102,13 @@ necessary." ...) -;; ----- Iterators ----- ;; +;; ===== Iterators ===== ;; (t/defn ^:inline >iterator [x (t/isa|direct? #?(:clj java.lang.Iterable :cljs cljs.core/IIterable))] #?(:clj (.iterator x) :cljs (cljs.core/-iterator ^not-native x))) -;; ----- Chunking ----- ;; - -(t/defn chunk-buffer > chunk-buffer? [capacity num/numerically-int?] - (clojure.lang.ChunkBuffer. (p/>int capacity))) - -(t/defn ^:inline chunk [b dc/chunk-buffer? > dc/chunk?] (.chunk b)) -(t/defn ^:inline chunk-append [b dc/chunk-buffer?, x p/ref? > dc/chunk?] (.add b x)) - -(t/defn ^:inline chunk-first [xs dc/chunked-seq? > dc/chunk?] (.chunkedFirst xs)) -(t/defn ^:inline chunk-rest [xs dc/chunked-seq? > dc/chunk?] (.chunkedMore xs)) -(t/defn ^:inline chunk-next [xs dc/chunked-seq? > dc/chunk?] (.chunkedNext xs)) - -(t/defn chunk-cons [chunk dc/chunk?, the-rest dc/iseq?] - (if (num/zero? (count chunk)) ;; TODO TYPED replace this condition with `empty` - the-rest - (clojure.lang.ChunkedCons. chunk the-rest))) - -;; ----- Sequences ----- ;; +;; ===== Sequences ===== ;; ;; TODO use `core/sequence` implementation to produce whatever is `reducible?` but not currently ;; `seqable?` @@ -153,6 +136,45 @@ (t/defn- ^:inline string-seq>underlying-string [xs (t/isa? clojure.lang.StringSeq) > (t/assume dstr/string?)] (.s xs)) +;; ----- Chunking ----- ;; + +(t/defn >chunk-buffer > chunk-buffer? [capacity num/numerically-int?] + #?(:clj (clojure.lang.ChunkBuffer. (p/>int capacity)) + ;; TODO TYPED need to define `make-array` ahead of time + :clj (cljs.core/ChunkBuffer. (?/make-array capacity) 0))) + +(t/defn ^:inline chunk + "For CLJS, it's a little unsafe to assume that a `dc/chunk?` is output but we accept the risk." + [b dc/chunk-buffer? > #?(:clj dc/chunk? :cljs (t/assume dc/chunk?))] (.chunk b)) + +(t/defn ^:inline chunk-append + "For CLJS, it's a little unsafe to assume that a `dc/chunk?` is output but we accept the risk." + [b dc/chunk-buffer?, x p/ref? > #?(:clj dc/chunk? :cljs (t/assume dc/chunk?))] (.add b x)) + +(t/defn ^:inline chunk-first + "For CLJS, it's a little unsafe to assume that a `dc/chunk?` is output but we accept the risk." + [xs dc/chunked-seq? > #?(:clj dc/chunk? :cljs (t/assume dc/chunk?))] + (#?(:clj .chunkedFirst :cljs -chunked-first) xs)) + +(t/defn ^:inline chunk-rest + "For CLJS, it's a little unsafe to assume that a `dc/chunk?` is output but we accept the risk." + [xs dc/chunked-seq? > #?(:clj dc/chunk? :cljs (t/assume dc/chunk?))] + (#?(:clj .chunkedMore :cljs -chunked-rest) xs)) + +(t/defn ^:inline chunk-next + "For CLJS, it's a little unsafe to assume that a `dc/chunk?` is output but we accept the risk." +#?(:cljs ([xs dc/chunked-next? > #?(:clj dc/chunk? :cljs (t/assume dc/chunk?))] + (cljs.core/-chunked-next xs))) + ([xs dc/chunked-seq? > #?(:clj dc/chunk? :cljs (t/assume dc/chunk?))] + #?(:clj (.chunkedNext xs) + :cljs (-> xs chunk-rest >seq)))) + +(t/defn chunk-cons > chunked-cons? [chunk dc/chunk?, the-rest dc/iseq?] + (if (num/zero? (count chunk)) ;; TODO TYPED replace this condition with `empty` + the-rest + #?(:clj (clojure.lang.ChunkedCons. chunk the-rest) + :cljs (cljs.core/ChunkedCons. chunk the-rest nil nil)))) + ;; ===== Reductive functions ===== ;; ;; TODO TYPED conditionally optional arities etc. for t/fn @@ -362,10 +384,10 @@ ;; TODO make sure !+vector is handled for CLJS (t/defn ^:inline count > dnum/std-integer? {:todo #{"handle persistent maps"} - :incorporated {clojure.lang.RT/count "9/2018" - clojure.lang.RT/countFrom "9/2018" - clojure.core/count "9/2018" - cljs.core/count "9/26/2018"}} + :incorporated '{clojure.lang.RT/count "9/2018" + clojure.lang.RT/countFrom "9/2018" + clojure.core/count "9/2018" + cljs.core/count "9/26/2018"}} ;; Counted ([x p/nil? > #?(:clj p/long? :cljs dnum/nip?)] 0) #?(:cljs ([xs dstr/string? > (t/assume dnum/nip?)] (.-length xs))) diff --git a/src/quantum/core/data/collections.cljc b/src/quantum/core/data/collections.cljc index c9b160f7..4940abf9 100644 --- a/src/quantum/core/data/collections.cljc +++ b/src/quantum/core/data/collections.cljc @@ -43,15 +43,18 @@ #?(:clj (def string-seq? (t/isa? clojure.lang.StringSeq))) -;; TODO CLJS -(def chunk-buffer? #?(:clj (t/isa? clojure.lang.ChunkBuffer) - :cljs ...)) +(def chunk-buffer? (t/isa? #?(:clj clojure.lang.ChunkBuffer :cljs cljs.core/ChunkBuffer))) -;; TODO CLJS -(def chunk? #?(:clj (t/isa? clojure.lang.IChunk) - :cljs ...)) +(def chunk? (t/isa|direct? #?(:clj clojure.lang.IChunk :cljs cljs.core/IChunk))) + +(def chunked-cons? (t/isa? #?(:clj clojure.lang.ChunkedCons :cljs cljs.core/ChunkedCons))) + +(var/def chunked-seq? + "Note that `cljs.core/IChunkedSeq` has no interface for `chunked-next`, unliked + `clojure.lang.IChunkedSeq`." + (t/isa|direct? #?(:clj clojure.lang.IChunkedSeq :cljs cljs.core/IChunkedSeq))) -(def chunked-seq? (t/isa? #?(:clj clojure.lang.IChunkedSeq :cljs cljs.core/ChunkedSeq))) +#?(:cljs (def chunked-next? (t/isa|direct? #?(:cljs cljs.core/IChunkedNext)))) (def indexed-seq? (t/isa? #?(:clj clojure.lang.IndexedSeq :cljs cljs.core/IndexedSeq))) @@ -84,10 +87,10 @@ ;; ===== End sequences ===== ;; -(def record? (t/isa? #?(:clj clojure.lang.IRecord :cljs cljs.core/IRecord))) +(def record? (t/isa|direct? #?(:clj clojure.lang.IRecord :cljs cljs.core/IRecord))) (def sorted? - (t/or (t/isa? #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) + (t/or (t/isa|direct? #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) #?@(:clj [(t/isa? java.util.SortedMap) (t/isa? java.util.SortedSet)] :cljs [(t/isa? goog.structs.AvlTree)]) diff --git a/src/quantum/core/data/meta.cljc b/src/quantum/core/data/meta.cljc index c00cb726..56f70bdd 100644 --- a/src/quantum/core/data/meta.cljc +++ b/src/quantum/core/data/meta.cljc @@ -7,20 +7,21 @@ [quantum.core.type :as t])) (def meta? (t/? map/+map?)) -(def metable? (t/isa? #?(:clj clojure.lang.IMeta :cljs cljs.core/IMeta))) -(def with-metable? (t/isa? #?(:clj clojure.lang.IObj :cljs cljs.core/IWithMeta))) +(def metable? (t/isa|direct? #?(:clj clojure.lang.IMeta :cljs cljs.core/IMeta))) +(def with-metable? (t/isa|direct? #?(:clj clojure.lang.IObj :cljs cljs.core/IWithMeta))) (t/defn ^:inline >meta "Returns the (possibly nil) metadata of ->`x`." > meta? - [x metable?] (#?(:clj .meta :cljs cljs.core/-meta) x)) + ([x metable?] (#?(:clj .meta :cljs cljs.core/-meta) x)) + ([x t/any?] nil)) (t/defn ^:inline with-meta "Returns an object of the same type and value as ->`x`, with ->`meta'` as its metadata." > with-metable? ([x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))] (#?(:clj .withMeta :cljs cljs.core/-with-meta) x meta')) - #?(:cljs ([x goog/isFunction, meta' meta?] + #?(:cljs ([x (t/isa? js/Function), meta' meta?] (cljs.core/MetaFn. x meta')))) (t/defn ^:inline reset-meta! @@ -33,6 +34,8 @@ #_(t/defn update-meta "Returns an object of the same type and value as ->`x`, with its metadata updated by ->`f`." ;; TODO `f` should more specifically be able to handle the args arity and specs + {:incorporated '{clojure.core/vary-meta "9/2018" + cljs.core/vary-meta "9/2018"}} [x (t/and with-metable? metable?) f (t/fn meta? [& (t/type-of %args)]) & args _] (with-meta x (apply f (meta x) args))) diff --git a/src/quantum/core/data/vector.cljc b/src/quantum/core/data/vector.cljc index 533dc6ec..4e3fb980 100644 --- a/src/quantum/core/data/vector.cljc +++ b/src/quantum/core/data/vector.cljc @@ -46,16 +46,18 @@ ;; because supports .push etc. (t/isa? js/Array)))) -;; svec = "spliceable vector" -(def svector? (t/isa? clojure.core.rrb_vector.rrbt.Vector)) +(def svector? + "The set of spliceable vectors." + (t/isa? #?(:clj clojure.core.rrb_vector.rrbt.Vector + :cljs clojure.core.rrb-vector.rrbt.Vector))) -(def +vector? (t/isa? #?(:clj clojure.lang.IPersistentVector - :cljs cljs.core/IVector))) +(def +vector? (t/isa|direct? #?(:clj clojure.lang.IPersistentVector + :cljs cljs.core/IVector))) (defalias ut/+vector|built-in) -(def !+vector? (t/isa? #?(:clj clojure.lang.ITransientVector - :cljs cljs.core/ITransientVector))) +(def !+vector? (t/isa|direct? #?(:clj clojure.lang.ITransientVector + :cljs cljs.core/ITransientVector))) (def ?!+vector? (t/or +vector? !+vector?)) @@ -92,7 +94,7 @@ ;; TODO TYPED below -(defalias vector core/vector) +(defalias vector core/vector) (defalias +vector vector) (def !+vector (rcomp vector transient)) @@ -146,11 +148,6 @@ _ (subsvec coll a b)))) -(def svector? - (partial instance? - #?(:clj clojure.core.rrb_vector.rrbt.Vector - :cljs clojure.core.rrb-vector.rrbt.Vector))) - #?(:clj (defalias ^{:doc "Creates a new vector capable of storing homogenous items of type t, From 3b113b31d3ee31a8dfe07efb89ef94f22061ca06 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 21:20:44 -0600 Subject: [PATCH 332/810] Add more vars --- resources-dev/defnt.cljc | 150 +++++++++++++++++++++++++++++++++++---- src/quantum/core/fn.cljc | 2 +- 2 files changed, 136 insertions(+), 16 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 7f72f9bb..7e98631c 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -61,6 +61,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - t/type >>>>>> (PRIORITY 1) <<<<<< - dependent types: `[x arr/array? > (t/type x)]` + - (t/== x) + - dependent type such that the passed input must be identical to x - Analysis - This is accepted by the type system without knowing the type: (java.math.BigInteger. 1 (-> (ByteBuffer/allocate (int 8)) (.putLong x) .array)) @@ -188,23 +190,55 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative [!] : refused - List of semi-approximately topologically ordered namespaces to make typed: - [.] clojure.core / cljs.core + - [! !] .. + - [. .] < + - [. .] <= - [x x] = - [. .] == - - [. .] < + - [. .] > + - [. .] >= + - [. .] + + - [. .] +' + - [. .] - + - [. .] -' + - [! !] -> + - [! !] ->> + - [. .] * + - [. .] *' + - [. .] / + - [ ] add-watch + - [ |] agent - [ ] and - [ ] any? - [ ] apply + - [! |] assert-args - [ ] assoc - [ ] assoc! - [x x] associative? - - [. .] boolean + - [ ] binding + - [ ] binding-conveyor-fn + - [. .] bit-and + - [. .] bit-and-not + - [x .] bit-clear + - [x .] bit-flip + - [x .] bit-not + - [. .] bit-or + - [x .] bit-set + - [x .] bit-shift-left + - [x .] bit-shift-right + - [x .] bit-test + - [. .] bit-xor + - [x .] boolean - [x x] boolean? + - [ ] bound-fn + - [ ] bound-fn* - [ ] butlast - [x x] byte - [x x] byte? - [x x] char - [x x] char? - [ |] cast + - [! |] check-valid-options - [x x] chunk - [x x] chunk-append - [x x] chunk-buffer @@ -215,50 +249,71 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x x] chunked-seq? - [ |] class - [x x] compare + - [ ] complement - [ ] concat - [ ] cond - - [ ] cons - [ ] conj + - [ ] cons + - [ ] constantly - [ ] contains? - [x x] count - [x x] counted? + - [x ] dec + - [x ] dec' - [x |] decimal? - [ ] defmacro + - [! !] defmethod — rejected because t/defn supersedes + - [! !] defmulti — rejected because t/defn supersedes - [. .] defn - [ ] defrecord - [ ] deftype - [ ] delay - [x x] delay? - [x |] denominator + - [ ] disj + - [ ] disj! + - [ ] dissoc + - [ ] dissoc! - [x x] double - [x x] double? - [. .] empty? - [ ] even? - - [ ] force - - [x x] identical? - - [ ] if-not (not as performant as we thought) - - [x x] indexed? - - [. .] int - - [x x] integer? - [x x] false? - [ ] filter + - [ ] find - [ |] find-keyword + - [ |] find-var - [ ] ffirst - - [ ] first + - [x ] first - [x x] float - [x x] float? - [. .] fn - [x x] fn? - [ ] fnext + - [ ] force - [ ] gensym + - [ ] get + - [ ] get-method + - [ ] get-thread-bindings - [ ] hash-map - [ ] hash-set - [x x] ident? + - [x x] identical? + - [x x] identity + - [ ] if-let + - [ ] if-not (not as performant as we thought) + - [ ] if-some - [x x] ifn? + - [x ] inc + - [x ] inc' + - [x x] indexed? - [| ] infinite? - [ ] instance? - - [x x] int + - [x .] int - [x x] int? + - [x x] integer? + - [ ] key + - [ ] keys - [x x] keyword - [x x] keyword? - [ ] last @@ -274,14 +329,18 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] map - [x x] map? - [x x] map-entry? + - [ ] max - [x x] meta + - [ ] methods + - [ ] min - [ ] mod - [x x] name - [x x] namespace + - [! |] nary-inline - [ ] nat-int? - [ ] neg? - [ ] neg-int? - - [ ] next + - [x ] next - [ ] nfirst - [x x] nil? - [ ] nnext @@ -295,22 +354,41 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] or - [ ] peek - [ ] pop + - [ ] pop-thread-bindings - [ ] pos? - [ ] pos-int? + - [ ] prefer-method + - [ ] prefers + - [ ] push-thread-bindings - [x x] qualified-ident? - [x x] qualified-keyword? - [x x] qualified-symbol? + - [ ] quot - [x |] ratio? - [ ] rational? + - [ ] rationalize - [x x] record? - [x x] reduce + - [! |] reduce1 + - [ ] release-pending-sends - [ ] rem - [ ] remove - - [ ] rest + - [ ] remove-all-methods + - [ ] remove-method + - [x ] rest + - [ ] reverse + - [ ] rseq - [ ] second - - [ ] seq + - [ ] select-keys + - [ ] send + - [ ] send-off + - [ ] send-via + - [x x] seq - [x x] seq? - [x x] set? + - [ ] set-agent-send-executor! + - [ ] set-agent-send-off-executor! + - [ ] setup-reference - [x x] short - [x x] short? - [x x] simple-ident? @@ -325,18 +403,41 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] spread - [. .] str - [x x] string? + - [ ] subvec - [x x] symbol - [x x] symbol? - - [ ] to-array + - [x ] to-array - [. .] transduce - [x x] true? + - [x ] unchecked-add + - [x ] unchecked-add-int + - [x ] unchecked-dec + - [x ] unchecked-dec-int + - [x ] unchecked-divide + - [x ] unchecked-divide-int + - [x ] unchecked-inc + - [x ] unchecked-inc-int + - [x ] unchecked-multiply + - [x ] unchecked-multiply-int + - [x ] unchecked-negate + - [x ] unchecked-negate-int + - [x ] unchecked-remainder-int + - [x ] unchecked-subtract + - [x ] unchecked-subtract-int + - [x .] unsigned-bit-shift-right - [x x] uuid? + - [ ] val + - [ ] vals - [. .] vary-meta - [ ] vec - [ ] vector - [x x] vector? - [! !] when + - [ ] when-let - [! !] when-not + - [ ] when-some + - [ ] with-bindings + - [ ] with-bindings* - [x x] with-meta - [x ] zero? - [.] clojure.lang.Numbers @@ -427,8 +528,27 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] xor - [.] clojure.lang.RT https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/RT.java + - [ ] assoc + - [.] booleanCast + - [ ] chunkIteratorSeq + - [ ] conj - [x] count - [x] countFrom + - [.] doubleCast + - [ ] first + - [.] floatCast + - [.] intCast + - [x] isReduced + - [ ] iter + - [.] longCast + - [ ] more + - [ ] nextID + - [ ] rest + - [x] seq + - [ ] seqToTypedArray + - [ ] subvec + - [ ] toArray + - [.] uncheckedIntCast - [.] clojure.lang.Util https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/Util.java - [ ] classOf diff --git a/src/quantum/core/fn.cljc b/src/quantum/core/fn.cljc index a21f9f55..be53bc17 100644 --- a/src/quantum/core/fn.cljc +++ b/src/quantum/core/fn.cljc @@ -26,7 +26,7 @@ ;; TODO TYPED move to `data.fn`? (def multimethod? (t/isa? #?(:clj clojure.lang.MultiFn :cljs cljs.core/IMultiFn))) -(t/defn ^:inline identity [x t/any? > (t/type x)] x) +(t/defn ^:inline identity [x t/any? > (t/== x)] x) ;; ===== `fn`: Positional functions ===== ;; From bbf037f5236dee280c7e3057cb1be9f78d5c4817 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 23:04:47 -0600 Subject: [PATCH 333/810] Finished clojure.core and close to cljs.core --- resources-dev/defnt.cljc | 405 ++++++++++++++++++++++++++++++++++++++- 1 file changed, 397 insertions(+), 8 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 7e98631c..588c48fb 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -1,3 +1,5 @@ +Note that for anything built-in js/, the `t/isa?` predicates might need some special help + ;; TO MOVE #?(:clj (def thread? (isa? java.lang.Thread))) @@ -206,20 +208,63 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [. .] * - [. .] *' - [. .] / + - [! |] accessor + - [ ] aclone + - [ ] add-tap - [ ] add-watch - [ |] agent + - [ ] agent-error + - [ ] aget — TODO check out unchecked-aget, checked-aget, checked-aget' + - [. x] alength + - [ ] alias + - [ ] all-ns + - [ ] alter + - [ ] alter-meta! + - [ ] alter-var-root + - [ ] amap + - [ ] ancestors - [ ] and - [ ] any? - [ ] apply + - [ ] areduce + - [| ] array + - [| .] array? — TODO also look at goog/isArrayLike + - [| ] array-chunk + - [| ] array-copy + - [| ] array-copy-downward + - [| ] array-iter + - [ ] array-map + - [| ] array-seq + - [! !] as-> + - [ ] aset — TODO check out unchecked-aset, checked-aset, checked-aset' + - [ ] aset-boolean + - [ ] aset-byte + - [ ] aset-char + - [ ] aset-double + - [ ] aset-float + - [ ] aset-int + - [ ] aset-long + - [ ] aset-short + - [ ] assert - [! |] assert-args - [ ] assoc - [ ] assoc! + - [ ] assoc-in - [x x] associative? + - [ ] atom + - [ ] await + - [ ] await1 + - [ ] await-for + - [ ] bases + - [ ] bigdec + - [ ] bigint + - [ ] biginteger - [ ] binding - [ ] binding-conveyor-fn - [. .] bit-and - [. .] bit-and-not - [x .] bit-clear + - [| ] bit-count - [x .] bit-flip - [x .] bit-not - [. .] bit-or @@ -230,14 +275,25 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [. .] bit-xor - [x .] boolean - [x x] boolean? + - [ ] boolean-array + - [ ] booleans + - [ ] bound? - [ ] bound-fn - [ ] bound-fn* + - [ ] bounded-count - [ ] butlast - - [x x] byte + - [. .] byte - [x x] byte? - - [x x] char - - [x x] char? + - [ ] byte-array + - [ ] bytes + - [ ] bytes? + - [ ] case - [ |] cast + - [ ] cat + - [. .] char — TODO (.fromCharCode js/String ) might be useful + - [x x] char? + - [ ] char-array + - [ ] chars - [! |] check-valid-options - [x x] chunk - [x x] chunk-append @@ -248,91 +304,245 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x x] chunk-rest - [x x] chunked-seq? - [ |] class + - [x |] class? + - [! |] clojure-version + - [| ] clone + - [| ] cloneable? + - [ ] coll? + - [ ] commute + - [ ] comp + - [. .] comparator - [x x] compare + - [ ] compare-and-set! + - [| ] compare-indexed + - [ ] compile - [ ] complement + - [ ] completing - [ ] concat - [ ] cond + - [! !] cond-> + - [! !] cond->> + - [ ] condp - [ ] conj + - [ ] conj! - [ ] cons - [ ] constantly - [ ] contains? - [x x] count - [x x] counted? + - [ |] create-ns + - [! !] create-struct + - [ ] cycle - [x ] dec - [x ] dec' + - [ ] declare - [x |] decimal? + - [ ] dedupe + - [! |] definline - [ ] defmacro - [! !] defmethod — rejected because t/defn supersedes - [! !] defmulti — rejected because t/defn supersedes - [. .] defn + - [. .] defn- + - [ ] defonce - [ ] defrecord + - [! !] defstruct - [ ] deftype - [ ] delay - [x x] delay? + - [ ] deliver - [x |] denominator + - [ ] deref + - [ ] derive + - [ ] descendants + - [ ] destructure - [ ] disj - [ ] disj! - [ ] dissoc - [ ] dissoc! - - [x x] double + - [ ] distinct + - [ ] distinct? + - [ ] doall + - [ ] dorun + - [ ] doseq + - [ ] dosync + - [ ] dotimes + - [ ] doto + - [. .] double - [x x] double? + - [ ] double-array + - [ ] doubles + - [ ] drop + - [ ] drop-last + - [ ] drop-while + - [ ] eduction + - [ |] elide-top-frames + - [ ] empty - [. .] empty? + - [| ] enable-console-print! + - [ ] enumeration-seq + - [ ] ensure + - [ ] ensure-reduced + - [| ] equiv-sequential + - [ ] error-handler + - [ ] error-mode + - [| ] es6-iterator + - [ ] eval - [ ] even? + - [ ] every? + - [ ] every-pred + - [ ] ex-data + - [ ] ex-info + - [| ] extend-object! - [x x] false? + - [ ] file-seq - [ ] filter + - [! |] filter-key + - [ ] filterv - [ ] find - [ |] find-keyword + - [x |] find-ns - [ |] find-var + - [| ] fix - [ ] ffirst - [x ] first - - [x x] float + - [ ] flatten + - [. .] float - [x x] float? + - [ ] float-array + - [ ] floats + - [ ] flush - [. .] fn - [x x] fn? + - [| ] fn->comparator - [ ] fnext + - [ ] fnil + - [ ] for - [ ] force + - [ ] format + - [ ] frequencies + - [ ] future + - [ ] future? + - [ ] future-call + - [ ] future-cancel + - [ ] future-cancelled? + - [ ] future-done? - [ ] gensym - [ ] get + - [ ] get-in - [ ] get-method - [ ] get-thread-bindings + - [ ] get-validator + - [ ] group-by + - [ ] halt-when + - [ ] hash + - [| ] hash-coll + - [| ] hash-combine + - [| ] hash-imap + - [| ] hash-iset + - [| ] hash-keyword - [ ] hash-map + - [ ] hash-ordered-coll + - [ ] hash-unordered-coll - [ ] hash-set + - [| ] hash-string* + - [| ] hash-string - [x x] ident? - [x x] identical? - [x x] identity - [ ] if-let - [ ] if-not (not as performant as we thought) - [ ] if-some + - [| ] ifind? - [x x] ifn? + - [ ] import + - [| ] imul - [x ] inc - [x ] inc' - [x x] indexed? - [| ] infinite? + - [ ] inst? + - [ ] inst-ms - [ ] instance? - [x .] int - [x x] int? + - [ ] int-array + - [| ] int-rotate-left + - [ ] intern + - [ ] into + - [ ] ints - [x x] integer? + - [ ] interleave + - [ ] interpose + - [ ] into-array + - [ |] is-annotation? + - [ |] is-runtime-annotation? + - [ ] isa? + - [| x] iterable? + - [ ] iterate + - [ ] iterator-seq + - [ ] io! + - [| ] js-delete + - [| ] js-invoke + - [| ] js-keys + - [| ] js-mod + - [| ] js-obj + - [ ] juxt + - [ ] keep + - [ ] keep-indexed - [ ] key - [ ] keys - [x x] keyword - [x x] keyword? + - [| ] keyword-identical? - [ ] last + - [ ] lazy-cat - [ ] lazy-seq - [ ] let + - [! !] letfn — we just don't use it very much + - [ ] line-seq - [ ] list - [ ] list* - [x x] list? + - [ ] load + - [ ] load-reader + - [ ] load-string + - [ ] loaded-libs - [ |] locking - - [x x] long + - [. .] long - [x x] long? + - [ ] long-array + - [ ] longs - [ ] loop + - [| ] m3-seed + - [| ] m3-C1 + - [| ] m3-C2 + - [| ] m3-mix-K1 + - [| ] m3-mix-H1 + - [| ] m3-fmix + - [| ] m3-hash-int + - [| ] m3-hash-unencoded-chars + - [ ] macroexpand + - [ ] macroexpand-1 + - [ ] make-array + - [ ] make-hierarchy - [ ] map - [x x] map? - [x x] map-entry? + - [ ] map-indexed + - [ ] mapcat + - [ ] mapv - [ ] max + - [ ] max-key + - [ ] memfn + - [ ] memoize + - [ ] merge + - [ ] merge-with - [x x] meta - [ ] methods - [ ] min + - [ ] min-key + - [ ] mix-collection-hash - [ ] mod - [x x] name - [x x] namespace @@ -340,44 +550,135 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] nat-int? - [ ] neg? - [ ] neg-int? + - [ ] newline - [x ] next - [ ] nfirst - [x x] nil? + - [| ] nil-iter - [ ] nnext - - [ ] nth - [ ] not + - [ ] not-any? + - [ ] not-empty + - [ ] not-every? - [x x] not= + - [ ] ns + - [x |] ns-aliases + - [x |] ns-imports + - [x |] ns-interns + - [x |] ns-map - [x |] ns-name + - [x |] ns-publics + - [x |] ns-refers + - [ ] ns-resolve + - [ |] ns-unalias + - [x |] ns-unmap + - [ ] nth + - [ ] nthnext + - [ ] nthrest + - [ ] num - [x x] number? - [x |] numerator + - [| x] object? + - [ ] object-array - [ ] odd? - [ ] or + - [ ] parents + - [ ] partial + - [ ] partition + - [ ] partition-all + - [ ] partition-by + - [ ] pcalls - [ ] peek + - [ ] persistent! + - [ ] pmap - [ ] pop + - [ ] pop! - [ ] pop-thread-bindings - [ ] pos? - [ ] pos-int? + - [ ] pr + - [ ] pr-on + - [ ] pr-str + - [| ] pr-str* + - [ ] preserving-reduced + - [| ] prim-seq + - [ ] print-str + - [ ] println-str + - [ ] prn-str - [ ] prefer-method - [ ] prefers + - [ ] print + - [ ] printf + - [ ] println + - [! |] print-dup + - [! |] print-method + - [ ] prn + - [ ] promise - [ ] push-thread-bindings + - [ ] pvalues - [x x] qualified-ident? - [x x] qualified-keyword? - [x x] qualified-symbol? - [ ] quot + - [ ] rand + - [ ] rand-int + - [ ] rand-nth + - [ ] random-sample + - [ ] range - [x |] ratio? - [ ] rational? - [ ] rationalize + - [ ] re-find + - [ ] re-groups + - [ ] re-matcher + - [ ] re-matches + - [ ] re-pattern + - [ ] re-seq + - [ ] read + - [ ] read-line + - [ ] read-string + - [ ] read+string + - [ ] reader-conditional + - [ ] reader-conditional? + - [ ] realized? - [x x] record? - [x x] reduce + - [x x] reduce-kv + - [| ] reduceable? + - [x x] reduced - [! |] reduce1 + - [ ] reductions + - [ ] ref + - [ ] ref-history-count + - [ ] ref-min-history + - [ ] ref-max-history + - [ ] ref-set + - [ ] refer + - [ ] refer-clojure - [ ] release-pending-sends - [ ] rem - [ ] remove - [ ] remove-all-methods - [ ] remove-method + - [ |] remove-ns + - [ ] remove-tap + - [ ] remove-watch + - [ ] repeat + - [ ] repeatedly + - [ ] replace + - [ ] require + - [ ] reset! + - [ ] reset-meta! + - [ ] reset-vals! + - [ ] resolve - [x ] rest + - [ ] restart-agent + - [ ] resultset-seq - [ ] reverse + - [ ] reversible? - [ ] rseq + - [ ] rsubseq + - [ ] run! - [ ] second - [ ] select-keys - [ ] send @@ -385,61 +686,149 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] send-via - [x x] seq - [x x] seq? + - [ ] seqable? + - [ ] seque + - [ ] sequence + - [ ] sequential? + - [ ] set - [x x] set? - [ ] set-agent-send-executor! - [ ] set-agent-send-off-executor! + - [ ] set-error-handler! + - [ ] set-error-mode! + - [| ] set-print-err-fn! + - [| ] set-print-fn! + - [ ] set-validator! - [ ] setup-reference - - [x x] short + - [. .] short - [x x] short? + - [ ] short-array + - [ ] shorts + - [ ] shuffle + - [ ] shutdown-agents - [x x] simple-ident? - [x x] simple-keyword? - [x x] simple-symbol? + - [ ] slurp + - [ ] some - [x x] some? + - [ ] some-> + - [ ] some->> + - [ ] some-fn + - [ ] sort + - [ ] sort-by - [x x] sorted? - [ ] sorted-map - [ ] sorted-map-by - [ ] sorted-set - [ ] sorted-set-by + - [ ] special-symbol? + - [ ] spread + - [ ] spit + - [ ] split-at + - [ ] split-with - [ ] spread - [. .] str - [x x] string? + - [| ] string-iter + - [! |] struct + - [! |] struct-map + - [ ] subs + - [ ] subseq - [ ] subvec + - [ ] supers + - [ ] swap! + - [ ] swap-vals! - [x x] symbol - [x x] symbol? + - [| ] symbol-identical? + - [ ] sync + - [| ] system-time + - [ ] tagged-literal + - [ ] tagged-literal? + - [ ] take + - [ ] take-last + - [ ] take-nth + - [ ] take-while + - [ ] tap> + - [ ] test + - [x |] the-ns + - [ ] thread-bound? + - [ ] throw-if + - [ ] time - [x ] to-array + - [ ] to-array-2d + - [ ] trampoline - [. .] transduce + - [ ] transient + - [ ] tree-seq - [x x] true? + - [ ] type + - [| ] type->str - [x ] unchecked-add - [x ] unchecked-add-int + - [. .] unchecked-byte + - [. .] unchecked-char - [x ] unchecked-dec - [x ] unchecked-dec-int - [x ] unchecked-divide - [x ] unchecked-divide-int + - [. .] unchecked-double + - [. .] unchecked-float - [x ] unchecked-inc - [x ] unchecked-inc-int + - [. .] unchecked-int + - [. .] unchecked-long - [x ] unchecked-multiply - [x ] unchecked-multiply-int - [x ] unchecked-negate - [x ] unchecked-negate-int - [x ] unchecked-remainder-int + - [. .] unchecked-short - [x ] unchecked-subtract - [x ] unchecked-subtract-int + - [| ] undefined? + - [ ] underive + - [ ] unreduced - [x .] unsigned-bit-shift-right + - [ ] update + - [ ] update-in + - [ ] uri? + - [! !] use - [x x] uuid? - [ ] val - [ ] vals + - [x x] var? + - [ ] var-get + - [ ] var-set - [. .] vary-meta - [ ] vec - [ ] vector - [x x] vector? + - [x x] volatile? + - [ ] volatile! + - [ ] vreset! + - [ ] vswap! - [! !] when + - [ ] when-first - [ ] when-let - [! !] when-not - [ ] when-some + - [! !] while - [ ] with-bindings - [ ] with-bindings* + - [ ] with-in-str + - [ ] with-loading-context + - [ ] with-local-vars - [x x] with-meta + - [ ] with-open + - [ ] with-out-str + - [ ] with-precision + - [ ] with-redefs + - [ ] with-redefs-fn + - [ ] xml-seq - [x ] zero? + - [ ] zipmap - [.] clojure.lang.Numbers https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/Numbers.java - [ ] add From e7e0137e44540bc9bc4a81f6284252387746e343 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 27 Sep 2018 23:30:00 -0600 Subject: [PATCH 334/810] Went through cljs.core --- resources-dev/defnt.cljc | 63 +++++++++++++++++++++++++++++++++------- 1 file changed, 52 insertions(+), 11 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 588c48fb..f79c4d39 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -232,7 +232,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [| ] array-chunk - [| ] array-copy - [| ] array-copy-downward + - [| ] array-index-of - [| ] array-iter + - [| !] array-list - [ ] array-map - [| ] array-seq - [! !] as-> @@ -303,8 +305,10 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x x] chunk-next - [x x] chunk-rest - [x x] chunked-seq? + - [| ] chunkIteratorSeq - [ |] class - [x |] class? + - [| ] clj->js - [! |] clojure-version - [| ] clone - [| ] cloneable? @@ -330,7 +334,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] contains? - [x x] count - [x x] counted? - - [ |] create-ns + - [ ] create-ns - [! !] create-struct - [ ] cycle - [x ] dec @@ -338,6 +342,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] declare - [x |] decimal? - [ ] dedupe + - [| ] default-dispatch-val - [! |] definline - [ ] defmacro - [! !] defmethod — rejected because t/defn supersedes @@ -351,6 +356,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] delay - [x x] delay? - [ ] deliver + - [| ] demunge - [x |] denominator - [ ] deref - [ ] derive @@ -358,6 +364,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] destructure - [ ] disj - [ ] disj! + - [| ] dispatch-fn - [ ] dissoc - [ ] dissoc! - [ ] distinct @@ -383,16 +390,21 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] enumeration-seq - [ ] ensure - [ ] ensure-reduced + - [| ] equiv-map - [| ] equiv-sequential - [ ] error-handler - [ ] error-mode + - [| ] es6-entries-iterator - [| ] es6-iterator + - [| ] es6-set-entries-iterator - [ ] eval - [ ] even? - [ ] every? - [ ] every-pred + - [| ] ex-cause - [ ] ex-data - [ ] ex-info + - [| ] ex-message - [| ] extend-object! - [x x] false? - [ ] file-seq @@ -401,12 +413,15 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] filterv - [ ] find - [ |] find-keyword - - [x |] find-ns + - [| ] find-macros-ns + - [x ] find-ns + - [| ] find-ns-obj - [ |] find-var - [| ] fix - [ ] ffirst - [x ] first - [ ] flatten + - [| ] flatten1 - [. .] float - [x x] float? - [ ] float-array @@ -478,6 +493,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ |] is-annotation? - [ |] is-runtime-annotation? - [ ] isa? + - [| ] iter - [| x] iterable? - [ ] iterate - [ ] iterator-seq @@ -487,10 +503,13 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [| ] js-keys - [| ] js-mod - [| ] js-obj + - [| ] js-reserved-arr + - [| ] js->clj - [ ] juxt - [ ] keep - [ ] keep-indexed - [ ] key + - [| ] key->js - [ ] keys - [x x] keyword - [x x] keyword? @@ -543,9 +562,12 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] min - [ ] min-key - [ ] mix-collection-hash + - [| ] mk-bound-fn - [ ] mod + - [| ] munge - [x x] name - [x x] namespace + - [x ] namespace? - [! |] nary-inline - [ ] nat-int? - [ ] neg? @@ -564,9 +586,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] ns - [x |] ns-aliases - [x |] ns-imports - - [x |] ns-interns + - [x ] ns-interns - [x |] ns-map - - [x |] ns-name + - [x ] ns-name - [x |] ns-publics - [x |] ns-refers - [ ] ns-resolve @@ -578,6 +600,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] num - [x x] number? - [x |] numerator + - [| ] obj-map - [| x] object? - [ ] object-array - [ ] odd? @@ -590,6 +613,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] pcalls - [ ] peek - [ ] persistent! + - [| ] persistent-array-map-seq - [ ] pmap - [ ] pop - [ ] pop! @@ -598,21 +622,27 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] pos-int? - [ ] pr - [ ] pr-on + - [| !] pr-seq-writer + - [| !] pr-sequential-writer - [ ] pr-str - [| ] pr-str* - - [ ] preserving-reduced - - [| ] prim-seq - - [ ] print-str - - [ ] println-str - - [ ] prn-str + - [| ] pr-str-with-opts - [ ] prefer-method - [ ] prefers + - [ ] preserving-reduced + - [| ] prn-str-with-opts + - [| ] prim-seq - [ ] print - - [ ] printf - - [ ] println - [! |] print-dup + - [| !] print-meta? - [! |] print-method + - [| !] print-prefix-map + - [ ] print-str + - [ ] printf + - [ ] println + - [ ] println-str - [ ] prn + - [ ] prn-str - [ ] promise - [ ] push-thread-bindings - [ ] pvalues @@ -620,11 +650,14 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x x] qualified-keyword? - [x x] qualified-symbol? - [ ] quot + - [| ] quote-string - [ ] rand - [ ] rand-int - [ ] rand-nth - [ ] random-sample + - [| ] random-uuid - [ ] range + - [| ] ranged-iterator - [x |] ratio? - [ ] rational? - [ ] rationalize @@ -655,6 +688,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] ref-set - [ ] refer - [ ] refer-clojure + - [| x] regexp? - [ ] release-pending-sends - [ ] rem - [ ] remove @@ -686,6 +720,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] send-via - [x x] seq - [x x] seq? + - [| ] seq-iter - [ ] seqable? - [ ] seque - [ ] sequence @@ -696,6 +731,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] set-agent-send-off-executor! - [ ] set-error-handler! - [ ] set-error-mode! + - [| ] set-from-indexed-seq - [| ] set-print-err-fn! - [| ] set-print-fn! - [ ] set-validator! @@ -731,6 +767,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [. .] str - [x x] string? - [| ] string-iter + - [| !] string-print + - [| ] strip-ns - [! |] struct - [! |] struct-map - [ ] subs @@ -760,6 +798,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] to-array-2d - [ ] trampoline - [. .] transduce + - [| ] transformer-iterator - [ ] transient - [ ] tree-seq - [x x] true? @@ -795,6 +834,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] update-in - [ ] uri? - [! !] use + - [| ] uuid - [x x] uuid? - [ ] val - [ ] vals @@ -826,6 +866,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] with-precision - [ ] with-redefs - [ ] with-redefs-fn + - [| !] write-all - [ ] xml-seq - [x ] zero? - [ ] zipmap From d47fb09faaf3902d52319b1c56f0652e081ee9aa Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 28 Sep 2018 00:07:11 -0600 Subject: [PATCH 335/810] Finish cljs.core macros, and clj corresponding RT --- resources-dev/defnt.cljc | 179 ++++++++++++++++++++---------- src/quantum/core/data/string.cljc | 1 + 2 files changed, 120 insertions(+), 60 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index f79c4d39..4e6baa7f 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -191,11 +191,11 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative [|] : not possible / N/A [!] : refused - List of semi-approximately topologically ordered namespaces to make typed: - - [.] clojure.core / cljs.core + - [.] clojure.core / cljs.core (note that many things unexpectedly have associated macros) - [! !] .. - [. .] < - [. .] <= - - [x x] = + - [. .] = — look at coercive-= - [. .] == - [. .] > - [. .] >= @@ -209,13 +209,13 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [. .] *' - [. .] / - [! |] accessor - - [ ] aclone + - [x ] aclone - [ ] add-tap - [ ] add-watch - [ |] agent - [ ] agent-error - - [ ] aget — TODO check out unchecked-aget, checked-aget, checked-aget' - - [. x] alength + - [ ] aget — TODO check out unchecked-aget, checked-aget, checked-aget' and CLJS macro + - [x x] alength - [ ] alias - [ ] all-ns - [ ] alter @@ -223,7 +223,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] alter-var-root - [ ] amap - [ ] ancestors - - [ ] and + - [ ] and — NOTE that CLJS macro has some secrets - [ ] any? - [ ] apply - [ ] areduce @@ -238,7 +238,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] array-map - [| ] array-seq - [! !] as-> - - [ ] aset — TODO check out unchecked-aset, checked-aset, checked-aset' + - [ ] aset — TODO check out unchecked-aset, checked-aset, checked-aset' and CLJS macro - [ ] aset-boolean - [ ] aset-byte - [ ] aset-char @@ -273,6 +273,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x .] bit-set - [x .] bit-shift-left - [x .] bit-shift-right + - [| ] bit-shift-right-zero-fill - [x .] bit-test - [. .] bit-xor - [x .] boolean @@ -284,7 +285,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] bound-fn* - [ ] bounded-count - [ ] butlast - - [. .] byte + - [x .] byte - [x x] byte? - [ ] byte-array - [ ] bytes @@ -292,7 +293,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] case - [ |] cast - [ ] cat - - [. .] char — TODO (.fromCharCode js/String ) might be useful + - [x .] char — TODO (.fromCharCode js/String ) might be useful - [x x] char? - [ ] char-array - [ ] chars @@ -312,6 +313,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [! |] clojure-version - [| ] clone - [| ] cloneable? + - [| ] coercive-= + - [| ] coercive-not + - [| ] coercive-not= - [ ] coll? - [ ] commute - [ ] comp @@ -329,9 +333,10 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] condp - [ ] conj - [ ] conj! - - [ ] cons + - [x ] cons - [ ] constantly - - [ ] contains? + - [x ] contains? + - [| ] copy-arguments - [x x] count - [x x] counted? - [ ] create-ns @@ -350,6 +355,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [. .] defn - [. .] defn- - [ ] defonce + - [! !] defprotocol - [ ] defrecord - [! !] defstruct - [ ] deftype @@ -375,7 +381,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] dosync - [ ] dotimes - [ ] doto - - [. .] double + - [x .] double - [x x] double? - [ ] double-array - [ ] doubles @@ -395,6 +401,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] error-handler - [ ] error-mode - [| ] es6-entries-iterator + - [| !] es6-iterable - [| ] es6-iterator - [| ] es6-set-entries-iterator - [ ] eval @@ -405,13 +412,16 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] ex-data - [ ] ex-info - [| ] ex-message + - [| ] exists? - [| ] extend-object! + - [! !] extend-protocol + - [! !] extend-type - [x x] false? - [ ] file-seq - [ ] filter - [! |] filter-key - [ ] filterv - - [ ] find + - [x ] find - [ |] find-keyword - [| ] find-macros-ns - [x ] find-ns @@ -422,7 +432,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x ] first - [ ] flatten - [| ] flatten1 - - [. .] float + - [x .] float - [x x] float? - [ ] float-array - [ ] floats @@ -442,8 +452,10 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] future-cancel - [ ] future-cancelled? - [ ] future-done? + - [| ] gen-apply-to + - [| ] gen-apply-to-simple - [ ] gensym - - [ ] get + - [x ] get - [ ] get-in - [ ] get-method - [ ] get-thread-bindings @@ -463,13 +475,14 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [| ] hash-string* - [| ] hash-string - [x x] ident? - - [x x] identical? + - [x .] identical? — NOTE CLJS has macro - [x x] identity - [ ] if-let - [ ] if-not (not as performant as we thought) - [ ] if-some - [| ] ifind? - [x x] ifn? + - [| !] implements? - [ ] import - [| ] imul - [x ] inc @@ -478,7 +491,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [| ] infinite? - [ ] inst? - [ ] inst-ms - - [ ] instance? + - [ ] instance? — NOTE CLJS has macro - [x .] int - [x x] int? - [ ] int-array @@ -498,19 +511,25 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] iterate - [ ] iterator-seq - [ ] io! + - [| ] js-arguments + - [| ] js-comment + - [| ] js-debugger - [| ] js-delete + - [| ] js-in + - [| ] js-inline-comment - [| ] js-invoke - [| ] js-keys - [| ] js-mod - [| ] js-obj - [| ] js-reserved-arr + - [| ] js-str - [| ] js->clj - [ ] juxt - [ ] keep - [ ] keep-indexed - [ ] key - [| ] key->js - - [ ] keys + - [x ] keys - [x x] keyword - [x x] keyword? - [| ] keyword-identical? @@ -528,7 +547,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] load-string - [ ] loaded-libs - [ |] locking - - [. .] long + - [x .] long - [x x] long? - [ ] long-array - [ ] longs @@ -575,14 +594,14 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] newline - [x ] next - [ ] nfirst - - [x x] nil? + - [x .] nil? — NOTE `nil?` macro in CLJS has some secrets - [| ] nil-iter - [ ] nnext - - [ ] not + - [ ] not — look at `coercive-not` - [ ] not-any? - [ ] not-empty - [ ] not-every? - - [x x] not= + - [x .] not= — look at `coercive-not=` - [ ] ns - [x |] ns-aliases - [x |] ns-imports @@ -594,7 +613,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] ns-resolve - [ |] ns-unalias - [x |] ns-unmap - - [ ] nth + - [x ] nth - [ ] nthnext - [ ] nthrest - [ ] num @@ -602,20 +621,20 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x |] numerator - [| ] obj-map - [| x] object? - - [ ] object-array + - [x ] object-array - [ ] odd? - - [ ] or + - [ ] or — NOTE that CLJS macro has some secrets - [ ] parents - [ ] partial - [ ] partition - [ ] partition-all - [ ] partition-by - [ ] pcalls - - [ ] peek + - [x ] peek - [ ] persistent! - [| ] persistent-array-map-seq - [ ] pmap - - [ ] pop + - [x ] pop - [ ] pop! - [ ] pop-thread-bindings - [ ] pos? @@ -679,6 +698,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x x] reduce-kv - [| ] reduceable? - [x x] reduced + - [x x] reduced? - [! |] reduce1 - [ ] reductions - [ ] ref @@ -689,6 +709,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] refer - [ ] refer-clojure - [| x] regexp? + - [| ] reify - [ ] release-pending-sends - [ ] rem - [ ] remove @@ -701,6 +722,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] repeatedly - [ ] replace - [ ] require + - [| !] require-macros - [ ] reset! - [ ] reset-meta! - [ ] reset-vals! @@ -713,6 +735,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] rseq - [ ] rsubseq - [ ] run! + - [! !] satisfies? - [ ] second - [ ] select-keys - [ ] send @@ -736,12 +759,13 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [| ] set-print-fn! - [ ] set-validator! - [ ] setup-reference - - [. .] short + - [x .] short - [x x] short? - [ ] short-array - [ ] shorts - [ ] shuffle - [ ] shutdown-agents + - [| !] simple-benchmark - [x x] simple-ident? - [x x] simple-keyword? - [x x] simple-symbol? @@ -759,6 +783,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] sorted-set - [ ] sorted-set-by - [ ] special-symbol? + - [| ] specify + - [| ] specify! - [ ] spread - [ ] spit - [ ] split-at @@ -791,6 +817,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] tap> - [ ] test - [x |] the-ns + - [| !] this-as - [ ] thread-bound? - [ ] throw-if - [ ] time @@ -806,38 +833,40 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [| ] type->str - [x ] unchecked-add - [x ] unchecked-add-int - - [. .] unchecked-byte - - [. .] unchecked-char + - [x .] unchecked-byte + - [x .] unchecked-char - [x ] unchecked-dec - [x ] unchecked-dec-int - [x ] unchecked-divide - [x ] unchecked-divide-int - - [. .] unchecked-double - - [. .] unchecked-float + - [x .] unchecked-double + - [x .] unchecked-float - [x ] unchecked-inc - [x ] unchecked-inc-int - - [. .] unchecked-int - - [. .] unchecked-long + - [x .] unchecked-int + - [x .] unchecked-long - [x ] unchecked-multiply - [x ] unchecked-multiply-int - [x ] unchecked-negate - [x ] unchecked-negate-int - [x ] unchecked-remainder-int - - [. .] unchecked-short + - [x .] unchecked-short - [x ] unchecked-subtract - [x ] unchecked-subtract-int - - [| ] undefined? + - [| ] undefined? — NOTE has macro too - [ ] underive - [ ] unreduced + - [| !] unsafe-cast - [x .] unsigned-bit-shift-right - [ ] update - [ ] update-in - [ ] uri? - [! !] use + - [| !] use-macros - [| ] uuid - [x x] uuid? - [ ] val - - [ ] vals + - [x ] vals - [x x] var? - [ ] var-get - [ ] var-set @@ -870,6 +899,59 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] xml-seq - [x ] zero? - [ ] zipmap + - [.] clojure.lang.RT + https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/RT.java + - [ ] aclone + - [ ] addURL + - [ ] aget + - [.] alength + - [ ] aset + - [ ] assoc + - [ ] baseLoader + - [.] booleanCast + - [.] byteCast + - [ ] canSeq + - [.] charCast + - [ ] chunkIteratorSeq + - [ ] conj + - [ ] cons + - [ ] contains + - [x] count + - [x] countFrom + - [ ] dissoc + - [.] doubleCast + - [ ] find + - [ ] first + - [.] floatCast + - [ ] get + - [.] intCast + - [x] isReduced + - [ ] iter + - [ ] keys + - [ ] load + - [.] longCast + - [ ] more + - [ ] nextID + - [ ] nth + - [ ] object_array + - [ ] peek + - [ ] pop + - [ ] readString + - [ ] rest + - [x] seq + - [ ] seqToTypedArray + - [.] shortCast + - [ ] subvec + - [ ] toArray + - [.] uncheckedByteCast + - [.] uncheckedShortCast + - [.] uncheckedCharCast + - [.] uncheckedIntCast + - [.] uncheckedLongCast + - [.] uncheckedFloatCast + - [.] uncheckedDoubleCast + - [ ] vals + - [ ] vector - [.] clojure.lang.Numbers https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/Numbers.java - [ ] add @@ -956,29 +1038,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] unsignedShiftRight - [ ] unsignedShiftRightInt - [ ] xor - - [.] clojure.lang.RT - https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/RT.java - - [ ] assoc - - [.] booleanCast - - [ ] chunkIteratorSeq - - [ ] conj - - [x] count - - [x] countFrom - - [.] doubleCast - - [ ] first - - [.] floatCast - - [.] intCast - - [x] isReduced - - [ ] iter - - [.] longCast - - [ ] more - - [ ] nextID - - [ ] rest - - [x] seq - - [ ] seqToTypedArray - - [ ] subvec - - [ ] toArray - - [.] uncheckedIntCast - [.] clojure.lang.Util https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/Util.java - [ ] classOf diff --git a/src/quantum/core/data/string.cljc b/src/quantum/core/data/string.cljc index e29be7f8..3d1b1b72 100644 --- a/src/quantum/core/data/string.cljc +++ b/src/quantum/core/data/string.cljc @@ -115,6 +115,7 @@ (def string? (t/isa? #?(:clj java.lang.String :cljs js/String))) +;; TODO TYPED — `str` macro in CLJS has some secrets (t/defn >string "Creates an immutable string." {:incorporated '{clojure.core/str "9/27/2018" From 62cd39f8883b673e2cb882b6d56f84ff437983be Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 28 Sep 2018 00:45:46 -0600 Subject: [PATCH 336/810] Finish going through clojure.lang.RT --- resources-dev/clojure-lang-rt-temp.java | 1771 +++++++++++++++++++++++ resources-dev/defnt.cljc | 62 +- src/quantum/core/data/primitive.cljc | 3 +- 3 files changed, 1832 insertions(+), 4 deletions(-) create mode 100644 resources-dev/clojure-lang-rt-temp.java diff --git a/resources-dev/clojure-lang-rt-temp.java b/resources-dev/clojure-lang-rt-temp.java new file mode 100644 index 00000000..ddd2cb37 --- /dev/null +++ b/resources-dev/clojure-lang-rt-temp.java @@ -0,0 +1,1771 @@ +package clojure.lang; + +import java.net.MalformedURLException; +import java.util.concurrent.atomic.AtomicInteger; +import java.util.concurrent.Callable; +import java.util.*; +import java.util.regex.Matcher; +import java.util.regex.Pattern; +import java.io.*; +import java.lang.reflect.Array; +import java.math.BigDecimal; +import java.math.BigInteger; +import java.security.AccessController; +import java.security.PrivilegedAction; +import java.net.URL; +import java.net.JarURLConnection; +import java.nio.charset.Charset; +import java.net.URLConnection; + +public class RT{ + +static public final Object[] EMPTY_ARRAY = new Object[]{}; +static public final Comparator DEFAULT_COMPARATOR = new DefaultComparator(); + +private static final class DefaultComparator implements Comparator, Serializable { + public int compare(Object o1, Object o2){ + return Util.compare(o1, o2); + } + + private Object readResolve() throws ObjectStreamException { + // ensures that we aren't hanging onto a new default comparator for every + // sorted set, etc., we deserialize + return DEFAULT_COMPARATOR; + } +} + +static AtomicInteger id = new AtomicInteger(1); + +static public void addURL(Object url) throws MalformedURLException{ + URL u = (url instanceof String) ? (new URL((String) url)) : (URL) url; + ClassLoader ccl = Thread.currentThread().getContextClassLoader(); + if(ccl instanceof DynamicClassLoader) + ((DynamicClassLoader)ccl).addURL(u); + else + throw new IllegalAccessError("Context classloader is not a DynamicClassLoader"); +} + +public static boolean checkSpecAsserts = Boolean.getBoolean("clojure.spec.check-asserts"); +public static boolean instrumentMacros = ! Boolean.getBoolean("clojure.spec.skip-macros"); +static volatile boolean CHECK_SPECS = false; + + +static public int nextID(){ + return id.getAndIncrement(); +} + +////////////// Collections support ///////////////////////////////// + +static public boolean canSeq(Object coll){ + return coll instanceof ISeq + || coll instanceof Seqable + || coll == null + || coll instanceof Iterable + || coll.getClass().isArray() + || coll instanceof CharSequence + || coll instanceof Map; +} + +static public Iterator iter(Object coll){ + if(coll instanceof Iterable) + return ((Iterable)coll).iterator(); + else if(coll == null) + return new Iterator(){ + public boolean hasNext(){ + return false; + } + + public Object next(){ + throw new NoSuchElementException(); + } + + public void remove(){ + throw new UnsupportedOperationException(); + } + }; + else if(coll instanceof Map){ + return ((Map)coll).entrySet().iterator(); + } + else if(coll instanceof String){ + final String s = (String) coll; + return new Iterator(){ + int i = 0; + + public boolean hasNext(){ + return i < s.length(); + } + + public Object next(){ + return s.charAt(i++); + } + + public void remove(){ + throw new UnsupportedOperationException(); + } + }; + } + else if(coll.getClass().isArray()){ + return ArrayIter.createFromObject(coll); + } + else + return iter(seq(coll)); +} + +static public ISeq keys(Object coll){ + if(coll instanceof IPersistentMap) + return APersistentMap.KeySeq.createFromMap((IPersistentMap)coll); + else + return APersistentMap.KeySeq.create(seq(coll)); +} + +static public ISeq vals(Object coll){ + if(coll instanceof IPersistentMap) + return APersistentMap.ValSeq.createFromMap((IPersistentMap)coll); + else + return APersistentMap.ValSeq.create(seq(coll)); +} + +static public IPersistentCollection conj(IPersistentCollection coll, Object x){ + if(coll == null) + return new PersistentList(x); + return coll.cons(x); +} + +static public ISeq cons(Object x, Object coll){ + //ISeq y = seq(coll); + if(coll == null) + return new PersistentList(x); + else if(coll instanceof ISeq) + return new Cons(x, (ISeq) coll); + else + return new Cons(x, seq(coll)); +} + +static public Object first(Object x){ + if(x instanceof ISeq) + return ((ISeq) x).first(); + ISeq seq = seq(x); + if(seq == null) + return null; + return seq.first(); +} + +static public ISeq next(Object x){ + if(x instanceof ISeq) + return ((ISeq) x).next(); + ISeq seq = seq(x); + if(seq == null) + return null; + return seq.next(); +} + +static public ISeq more(Object x){ + if(x instanceof ISeq) + return ((ISeq) x).more(); + ISeq seq = seq(x); + if(seq == null) + return PersistentList.EMPTY; + return seq.more(); +} + +//static public Seqable more(Object x){ +// Seqable ret = null; +// if(x instanceof ISeq) +// ret = ((ISeq) x).more(); +// else +// { +// ISeq seq = seq(x); +// if(seq == null) +// ret = PersistentList.EMPTY; +// else +// ret = seq.more(); +// } +// if(ret == null) +// ret = PersistentList.EMPTY; +// return ret; +//} + +static public Object peek(Object x){ + if(x == null) + return null; + return ((IPersistentStack) x).peek(); +} + +static public Object pop(Object x){ + if(x == null) + return null; + return ((IPersistentStack) x).pop(); +} + +static public Object get(Object coll, Object key){ + if(coll instanceof ILookup) + return ((ILookup) coll).valAt(key); + return getFrom(coll, key); +} + +static Object getFrom(Object coll, Object key){ + if(coll == null) + return null; + else if(coll instanceof Map) { + Map m = (Map) coll; + return m.get(key); + } + else if(coll instanceof IPersistentSet) { + IPersistentSet set = (IPersistentSet) coll; + return set.get(key); + } + else if(key instanceof Number && (coll instanceof String || coll.getClass().isArray())) { + int n = ((Number) key).intValue(); + if(n >= 0 && n < count(coll)) + return nth(coll, n); + return null; + } + else if(coll instanceof ITransientSet) { + ITransientSet set = (ITransientSet) coll; + return set.get(key); + } + + return null; +} + +static public Object get(Object coll, Object key, Object notFound){ + if(coll instanceof ILookup) + return ((ILookup) coll).valAt(key, notFound); + return getFrom(coll, key, notFound); +} + +static Object getFrom(Object coll, Object key, Object notFound){ + if(coll == null) + return notFound; + else if(coll instanceof Map) { + Map m = (Map) coll; + if(m.containsKey(key)) + return m.get(key); + return notFound; + } + else if(coll instanceof IPersistentSet) { + IPersistentSet set = (IPersistentSet) coll; + if(set.contains(key)) + return set.get(key); + return notFound; + } + else if(key instanceof Number && (coll instanceof String || coll.getClass().isArray())) { + int n = ((Number) key).intValue(); + return n >= 0 && n < count(coll) ? nth(coll, n) : notFound; + } + else if(coll instanceof ITransientSet) { + ITransientSet set = (ITransientSet) coll; + if(set.contains(key)) + return set.get(key); + return notFound; + } + return notFound; + +} + +static public Associative assoc(Object coll, Object key, Object val){ + if(coll == null) + return new PersistentArrayMap(new Object[]{key, val}); + return ((Associative) coll).assoc(key, val); +} + +static public Object contains(Object coll, Object key){ + if(coll == null) + return F; + else if(coll instanceof Associative) + return ((Associative) coll).containsKey(key) ? T : F; + else if(coll instanceof IPersistentSet) + return ((IPersistentSet) coll).contains(key) ? T : F; + else if(coll instanceof Map) { + Map m = (Map) coll; + return m.containsKey(key) ? T : F; + } + else if(coll instanceof Set) { + Set s = (Set) coll; + return s.contains(key) ? T : F; + } + else if(key instanceof Number && (coll instanceof String || coll.getClass().isArray())) { + int n = ((Number) key).intValue(); + return n >= 0 && n < count(coll); + } + else if(coll instanceof ITransientSet) + return ((ITransientSet)coll).contains(key) ? T : F; + else if(coll instanceof ITransientAssociative2) + return (((ITransientAssociative2)coll).containsKey(key)) ? T : F; + throw new IllegalArgumentException("contains? not supported on type: " + coll.getClass().getName()); +} + +static public Object find(Object coll, Object key){ + if(coll == null) + return null; + else if(coll instanceof Associative) + return ((Associative) coll).entryAt(key); + else if(coll instanceof Map) { + Map m = (Map) coll; + if(m.containsKey(key)) + return MapEntry.create(key, m.get(key)); + return null; + } + else if(coll instanceof ITransientAssociative2) { + return ((ITransientAssociative2) coll).entryAt(key); + } + throw new IllegalArgumentException("find not supported on type: " + coll.getClass().getName()); +} + +//takes a seq of key,val,key,val + +//returns tail starting at val of matching key if found, else null +static public ISeq findKey(Keyword key, ISeq keyvals) { + while(keyvals != null) { + ISeq r = keyvals.next(); + if(r == null) + throw Util.runtimeException("Malformed keyword argslist"); + if(keyvals.first() == key) + return r; + keyvals = r.next(); + } + return null; +} + +static public Object dissoc(Object coll, Object key) { + if(coll == null) + return null; + return ((IPersistentMap) coll).without(key); +} + +static public Object nth(Object coll, int n){ + if(coll instanceof Indexed) + return ((Indexed) coll).nth(n); + return nthFrom(Util.ret1(coll, coll = null), n); +} + +static Object nthFrom(Object coll, int n){ + if(coll == null) + return null; + else if(coll instanceof CharSequence) + return Character.valueOf(((CharSequence) coll).charAt(n)); + else if(coll.getClass().isArray()) + return Reflector.prepRet(coll.getClass().getComponentType(),Array.get(coll, n)); + else if(coll instanceof RandomAccess) + return ((List) coll).get(n); + else if(coll instanceof Matcher) + return ((Matcher) coll).group(n); + + else if(coll instanceof Map.Entry) { + Map.Entry e = (Map.Entry) coll; + if(n == 0) + return e.getKey(); + else if(n == 1) + return e.getValue(); + throw new IndexOutOfBoundsException(); + } + + else if(coll instanceof Sequential) { + ISeq seq = RT.seq(coll); + coll = null; + for(int i = 0; i <= n && seq != null; ++i, seq = seq.next()) { + if(i == n) + return seq.first(); + } + throw new IndexOutOfBoundsException(); + } + else + throw new UnsupportedOperationException( + "nth not supported on this type: " + coll.getClass().getSimpleName()); +} + +static public Object nth(Object coll, int n, Object notFound){ + if(coll instanceof Indexed) { + Indexed v = (Indexed) coll; + return v.nth(n, notFound); + } + return nthFrom(coll, n, notFound); +} + +static Object nthFrom(Object coll, int n, Object notFound){ + if(coll == null) + return notFound; + else if(n < 0) + return notFound; + + else if(coll instanceof CharSequence) { + CharSequence s = (CharSequence) coll; + if(n < s.length()) + return Character.valueOf(s.charAt(n)); + return notFound; + } + else if(coll.getClass().isArray()) { + if(n < Array.getLength(coll)) + return Reflector.prepRet(coll.getClass().getComponentType(),Array.get(coll, n)); + return notFound; + } + else if(coll instanceof RandomAccess) { + List list = (List) coll; + if(n < list.size()) + return list.get(n); + return notFound; + } + else if(coll instanceof Matcher) { + Matcher m = (Matcher) coll; + if(n < m.groupCount()) + return m.group(n); + return notFound; + } + else if(coll instanceof Map.Entry) { + Map.Entry e = (Map.Entry) coll; + if(n == 0) + return e.getKey(); + else if(n == 1) + return e.getValue(); + return notFound; + } + else if(coll instanceof Sequential) { + ISeq seq = RT.seq(coll); + coll = null; + for(int i = 0; i <= n && seq != null; ++i, seq = seq.next()) { + if(i == n) + return seq.first(); + } + return notFound; + } + else + throw new UnsupportedOperationException( + "nth not supported on this type: " + coll.getClass().getSimpleName()); +} + +static public Object assocN(int n, Object val, Object coll){ + if(coll == null) + return null; + else if(coll instanceof IPersistentVector) + return ((IPersistentVector) coll).assocN(n, val); + else if(coll instanceof Object[]) { + //hmm... this is not persistent + Object[] array = ((Object[]) coll); + array[n] = val; + return array; + } + else + return null; +} + +static boolean hasTag(Object o, Object tag){ + return Util.equals(tag, RT.get(RT.meta(o), TAG_KEY)); +} + +/** + * ********************* Boxing/casts ****************************** + */ +static public char charCast(Object x){ + if(x instanceof Character) + return ((Character) x).charValue(); + + long n = ((Number) x).longValue(); + if(n < Character.MIN_VALUE || n > Character.MAX_VALUE) + throw new IllegalArgumentException("Value out of range for char: " + x); + + return (char) n; +} + +static public char charCast(byte x){ + char i = (char) x; + if(i != x) + throw new IllegalArgumentException("Value out of range for char: " + x); + return i; +} + +static public char charCast(short x){ + char i = (char) x; + if(i != x) + throw new IllegalArgumentException("Value out of range for char: " + x); + return i; +} + +static public char charCast(char x){ + return x; +} + +static public char charCast(int x){ + char i = (char) x; + if(i != x) + throw new IllegalArgumentException("Value out of range for char: " + x); + return i; +} + +static public char charCast(long x){ + char i = (char) x; + if(i != x) + throw new IllegalArgumentException("Value out of range for char: " + x); + return i; +} + +static public char charCast(float x){ + if(x >= Character.MIN_VALUE && x <= Character.MAX_VALUE) + return (char) x; + throw new IllegalArgumentException("Value out of range for char: " + x); +} + +static public char charCast(double x){ + if(x >= Character.MIN_VALUE && x <= Character.MAX_VALUE) + return (char) x; + throw new IllegalArgumentException("Value out of range for char: " + x); +} + +static public boolean booleanCast(Object x){ + if(x instanceof Boolean) + return ((Boolean) x).booleanValue(); + return x != null; +} + +static public boolean booleanCast(boolean x){ + return x; +} + +static public byte byteCast(Object x){ + if(x instanceof Byte) + return ((Byte) x).byteValue(); + long n = longCast(x); + if(n < Byte.MIN_VALUE || n > Byte.MAX_VALUE) + throw new IllegalArgumentException("Value out of range for byte: " + x); + + return (byte) n; +} + +static public byte byteCast(byte x){ + return x; +} + +static public byte byteCast(short x){ + byte i = (byte) x; + if(i != x) + throw new IllegalArgumentException("Value out of range for byte: " + x); + return i; +} + +static public byte byteCast(int x){ + byte i = (byte) x; + if(i != x) + throw new IllegalArgumentException("Value out of range for byte: " + x); + return i; +} + +static public byte byteCast(long x){ + byte i = (byte) x; + if(i != x) + throw new IllegalArgumentException("Value out of range for byte: " + x); + return i; +} + +static public byte byteCast(float x){ + if(x >= Byte.MIN_VALUE && x <= Byte.MAX_VALUE) + return (byte) x; + throw new IllegalArgumentException("Value out of range for byte: " + x); +} + +static public byte byteCast(double x){ + if(x >= Byte.MIN_VALUE && x <= Byte.MAX_VALUE) + return (byte) x; + throw new IllegalArgumentException("Value out of range for byte: " + x); +} + +static public short shortCast(Object x){ + if(x instanceof Short) + return ((Short) x).shortValue(); + long n = longCast(x); + if(n < Short.MIN_VALUE || n > Short.MAX_VALUE) + throw new IllegalArgumentException("Value out of range for short: " + x); + + return (short) n; +} + +static public short shortCast(byte x){ + return x; +} + +static public short shortCast(short x){ + return x; +} + +static public short shortCast(int x){ + short i = (short) x; + if(i != x) + throw new IllegalArgumentException("Value out of range for short: " + x); + return i; +} + +static public short shortCast(long x){ + short i = (short) x; + if(i != x) + throw new IllegalArgumentException("Value out of range for short: " + x); + return i; +} + +static public short shortCast(float x){ + if(x >= Short.MIN_VALUE && x <= Short.MAX_VALUE) + return (short) x; + throw new IllegalArgumentException("Value out of range for short: " + x); +} + +static public short shortCast(double x){ + if(x >= Short.MIN_VALUE && x <= Short.MAX_VALUE) + return (short) x; + throw new IllegalArgumentException("Value out of range for short: " + x); +} + +static public int intCast(Object x){ + if(x instanceof Integer) + return ((Integer)x).intValue(); + if(x instanceof Number) + { + long n = longCast(x); + return intCast(n); + } + return ((Character) x).charValue(); +} + +static public int intCast(char x){ + return x; +} + +static public int intCast(byte x){ + return x; +} + +static public int intCast(short x){ + return x; +} + +static public int intCast(int x){ + return x; +} + +static public int intCast(float x){ + if(x < Integer.MIN_VALUE || x > Integer.MAX_VALUE) + throw new IllegalArgumentException("Value out of range for int: " + x); + return (int) x; +} + +static public int intCast(long x){ + int i = (int) x; + if(i != x) + throw new IllegalArgumentException("Value out of range for int: " + x); + return i; +} + +static public int intCast(double x){ + if(x < Integer.MIN_VALUE || x > Integer.MAX_VALUE) + throw new IllegalArgumentException("Value out of range for int: " + x); + return (int) x; +} + +static public long longCast(Object x){ + if(x instanceof Integer || x instanceof Long) + return ((Number) x).longValue(); + else if (x instanceof BigInt) + { + BigInt bi = (BigInt) x; + if(bi.bipart == null) + return bi.lpart; + else + throw new IllegalArgumentException("Value out of range for long: " + x); + } + else if (x instanceof BigInteger) + { + BigInteger bi = (BigInteger) x; + if(bi.bitLength() < 64) + return bi.longValue(); + else + throw new IllegalArgumentException("Value out of range for long: " + x); + } + else if (x instanceof Byte || x instanceof Short) + return ((Number) x).longValue(); + else if (x instanceof Ratio) + return longCast(((Ratio)x).bigIntegerValue()); + else if (x instanceof Character) + return longCast(((Character) x).charValue()); + else + return longCast(((Number)x).doubleValue()); +} + +static public long longCast(byte x){ + return x; +} + +static public long longCast(short x){ + return x; +} + +static public long longCast(int x){ + return x; +} + +static public long longCast(float x){ + if(x < Long.MIN_VALUE || x > Long.MAX_VALUE) + throw new IllegalArgumentException("Value out of range for long: " + x); + return (long) x; +} + +static public long longCast(long x){ + return x; +} + +static public long longCast(double x){ + if(x < Long.MIN_VALUE || x > Long.MAX_VALUE) + throw new IllegalArgumentException("Value out of range for long: " + x); + return (long) x; +} + +static public float floatCast(Object x){ + if(x instanceof Float) + return ((Float) x).floatValue(); + + double n = ((Number) x).doubleValue(); + if(n < -Float.MAX_VALUE || n > Float.MAX_VALUE) + throw new IllegalArgumentException("Value out of range for float: " + x); + + return (float) n; + +} + +static public float floatCast(byte x){ + return x; +} + +static public float floatCast(short x){ + return x; +} + +static public float floatCast(int x){ + return x; +} + +static public float floatCast(float x){ + return x; +} + +static public float floatCast(long x){ + return x; +} + +static public float floatCast(double x){ + if(x < -Float.MAX_VALUE || x > Float.MAX_VALUE) + throw new IllegalArgumentException("Value out of range for float: " + x); + + return (float) x; +} + +static public double doubleCast(Object x){ + return ((Number) x).doubleValue(); +} + +static public double doubleCast(byte x){ + return x; +} + +static public double doubleCast(short x){ + return x; +} + +static public double doubleCast(int x){ + return x; +} + +static public double doubleCast(float x){ + return x; +} + +static public double doubleCast(long x){ + return x; +} + +static public double doubleCast(double x){ + return x; +} + +static public byte uncheckedByteCast(Object x){ + return ((Number) x).byteValue(); +} + +static public byte uncheckedByteCast(byte x){ + return x; +} + +static public byte uncheckedByteCast(short x){ + return (byte) x; +} + +static public byte uncheckedByteCast(int x){ + return (byte) x; +} + +static public byte uncheckedByteCast(long x){ + return (byte) x; +} + +static public byte uncheckedByteCast(float x){ + return (byte) x; +} + +static public byte uncheckedByteCast(double x){ + return (byte) x; +} + +static public short uncheckedShortCast(Object x){ + return ((Number) x).shortValue(); +} + +static public short uncheckedShortCast(byte x){ + return x; +} + +static public short uncheckedShortCast(short x){ + return x; +} + +static public short uncheckedShortCast(int x){ + return (short) x; +} + +static public short uncheckedShortCast(long x){ + return (short) x; +} + +static public short uncheckedShortCast(float x){ + return (short) x; +} + +static public short uncheckedShortCast(double x){ + return (short) x; +} + +static public char uncheckedCharCast(Object x){ + if(x instanceof Character) + return ((Character) x).charValue(); + return (char) ((Number) x).longValue(); +} + +static public char uncheckedCharCast(byte x){ + return (char) x; +} + +static public char uncheckedCharCast(short x){ + return (char) x; +} + +static public char uncheckedCharCast(char x){ + return x; +} + +static public char uncheckedCharCast(int x){ + return (char) x; +} + +static public char uncheckedCharCast(long x){ + return (char) x; +} + +static public char uncheckedCharCast(float x){ + return (char) x; +} + +static public char uncheckedCharCast(double x){ + return (char) x; +} + +static public int uncheckedIntCast(Object x){ + if(x instanceof Number) + return ((Number)x).intValue(); + return ((Character) x).charValue(); +} + +static public int uncheckedIntCast(byte x){ + return x; +} + +static public int uncheckedIntCast(short x){ + return x; +} + +static public int uncheckedIntCast(char x){ + return x; +} + +static public int uncheckedIntCast(int x){ + return x; +} + +static public int uncheckedIntCast(long x){ + return (int) x; +} + +static public int uncheckedIntCast(float x){ + return (int) x; +} + +static public int uncheckedIntCast(double x){ + return (int) x; +} + +static public long uncheckedLongCast(Object x){ + return ((Number) x).longValue(); +} + +static public long uncheckedLongCast(byte x){ + return x; +} + +static public long uncheckedLongCast(short x){ + return x; +} + +static public long uncheckedLongCast(int x){ + return x; +} + +static public long uncheckedLongCast(long x){ + return x; +} + +static public long uncheckedLongCast(float x){ + return (long) x; +} + +static public long uncheckedLongCast(double x){ + return (long) x; +} + +static public float uncheckedFloatCast(Object x){ + return ((Number) x).floatValue(); +} + +static public float uncheckedFloatCast(byte x){ + return x; +} + +static public float uncheckedFloatCast(short x){ + return x; +} + +static public float uncheckedFloatCast(int x){ + return x; +} + +static public float uncheckedFloatCast(long x){ + return x; +} + +static public float uncheckedFloatCast(float x){ + return x; +} + +static public float uncheckedFloatCast(double x){ + return (float) x; +} + +static public double uncheckedDoubleCast(Object x){ + return ((Number) x).doubleValue(); +} + +static public double uncheckedDoubleCast(byte x){ + return x; +} + +static public double uncheckedDoubleCast(short x){ + return x; +} + +static public double uncheckedDoubleCast(int x){ + return x; +} + +static public double uncheckedDoubleCast(long x){ + return x; +} + +static public double uncheckedDoubleCast(float x){ + return x; +} + +static public double uncheckedDoubleCast(double x){ + return x; +} + +static public IPersistentMap map(Object... init){ + if(init == null || init.length == 0) + return PersistentArrayMap.EMPTY; + else if(init.length <= PersistentArrayMap.HASHTABLE_THRESHOLD) + return PersistentArrayMap.createWithCheck(init); + return PersistentHashMap.createWithCheck(init); +} + +static public IPersistentMap mapUniqueKeys(Object... init){ + if(init == null) + return PersistentArrayMap.EMPTY; + else if(init.length <= PersistentArrayMap.HASHTABLE_THRESHOLD) + return new PersistentArrayMap(init); + return PersistentHashMap.create(init); +} + +static public IPersistentSet set(Object... init){ + return PersistentHashSet.createWithCheck(init); +} + +static public IPersistentVector vector(Object... init){ + return LazilyPersistentVector.createOwning(init); +} + +static public IPersistentVector subvec(IPersistentVector v, int start, int end){ + if(end < start || start < 0 || end > v.count()) + throw new IndexOutOfBoundsException(); + if(start == end) + return PersistentVector.EMPTY; + return new APersistentVector.SubVector(null, v, start, end); +} + +/** + * **************************************** list support ******************************* + */ + + +static public ISeq list(){ + return null; +} + +static public ISeq list(Object arg1){ + return new PersistentList(arg1); +} + +static public ISeq list(Object arg1, Object arg2){ + return listStar(arg1, arg2, null); +} + +static public ISeq list(Object arg1, Object arg2, Object arg3){ + return listStar(arg1, arg2, arg3, null); +} + +static public ISeq list(Object arg1, Object arg2, Object arg3, Object arg4){ + return listStar(arg1, arg2, arg3, arg4, null); +} + +static public ISeq list(Object arg1, Object arg2, Object arg3, Object arg4, Object arg5){ + return listStar(arg1, arg2, arg3, arg4, arg5, null); +} + +static public ISeq listStar(Object arg1, ISeq rest){ + return (ISeq) cons(arg1, rest); +} + +static public ISeq listStar(Object arg1, Object arg2, ISeq rest){ + return (ISeq) cons(arg1, cons(arg2, rest)); +} + +static public ISeq listStar(Object arg1, Object arg2, Object arg3, ISeq rest){ + return (ISeq) cons(arg1, cons(arg2, cons(arg3, rest))); +} + +static public ISeq listStar(Object arg1, Object arg2, Object arg3, Object arg4, ISeq rest){ + return (ISeq) cons(arg1, cons(arg2, cons(arg3, cons(arg4, rest)))); +} + +static public ISeq listStar(Object arg1, Object arg2, Object arg3, Object arg4, Object arg5, ISeq rest){ + return (ISeq) cons(arg1, cons(arg2, cons(arg3, cons(arg4, cons(arg5, rest))))); +} + +static public ISeq arrayToList(Object[] a) { + ISeq ret = null; + for(int i = a.length - 1; i >= 0; --i) + ret = (ISeq) cons(a[i], ret); + return ret; +} + +static public Object[] object_array(Object sizeOrSeq){ + if(sizeOrSeq instanceof Number) + return new Object[((Number) sizeOrSeq).intValue()]; + else + { + ISeq s = RT.seq(sizeOrSeq); + int size = RT.count(s); + Object[] ret = new Object[size]; + for(int i = 0; i < size && s != null; i++, s = s.next()) + ret[i] = s.first(); + return ret; + } +} + +static public Object[] toArray(Object coll) { + if(coll == null) + return EMPTY_ARRAY; + else if(coll instanceof Object[]) + return (Object[]) coll; + else if(coll instanceof Collection) + return ((Collection) coll).toArray(); + else if(coll instanceof Iterable) { + ArrayList ret = new ArrayList(); + for(Object o : (Iterable)coll) + ret.add(o); + return ret.toArray(); + } else if(coll instanceof Map) + return ((Map) coll).entrySet().toArray(); + else if(coll instanceof String) { + char[] chars = ((String) coll).toCharArray(); + Object[] ret = new Object[chars.length]; + for(int i = 0; i < chars.length; i++) + ret[i] = chars[i]; + return ret; + } + else if(coll.getClass().isArray()) { + ISeq s = (seq(coll)); + Object[] ret = new Object[count(s)]; + for(int i = 0; i < ret.length; i++, s = s.next()) + ret[i] = s.first(); + return ret; + } + else + throw Util.runtimeException("Unable to convert: " + coll.getClass() + " to Object[]"); +} + +static public Object[] seqToArray(ISeq seq){ + int len = length(seq); + Object[] ret = new Object[len]; + for(int i = 0; seq != null; ++i, seq = seq.next()) + ret[i] = seq.first(); + return ret; +} + + // supports java Collection.toArray(T[]) + static public Object[] seqToPassedArray(ISeq seq, Object[] passed){ + Object[] dest = passed; + int len = count(seq); + if (len > dest.length) { + dest = (Object[]) Array.newInstance(passed.getClass().getComponentType(), len); + } + for(int i = 0; seq != null; ++i, seq = seq.next()) + dest[i] = seq.first(); + if (len < passed.length) { + dest[len] = null; + } + return dest; + } + +static public Object seqToTypedArray(ISeq seq) { + Class type = (seq != null && seq.first() != null) ? seq.first().getClass() : Object.class; + return seqToTypedArray(type, seq); +} + +static public Object seqToTypedArray(Class type, ISeq seq) { + Object ret = Array.newInstance(type, length(seq)); + if(type == Integer.TYPE){ + for(int i = 0; seq != null; ++i, seq=seq.next()){ + Array.set(ret, i, intCast(seq.first())); + } + } else if(type == Byte.TYPE) { + for(int i = 0; seq != null; ++i, seq=seq.next()){ + Array.set(ret, i, byteCast(seq.first())); + } + } else if(type == Float.TYPE) { + for(int i = 0; seq != null; ++i, seq=seq.next()){ + Array.set(ret, i, floatCast(seq.first())); + } + } else if(type == Short.TYPE) { + for(int i = 0; seq != null; ++i, seq=seq.next()){ + Array.set(ret, i, shortCast(seq.first())); + } + } else if(type == Character.TYPE) { + for(int i = 0; seq != null; ++i, seq=seq.next()){ + Array.set(ret, i, charCast(seq.first())); + } + } else { + for(int i = 0; seq != null; ++i, seq=seq.next()){ + Array.set(ret, i, seq.first()); + } + } + return ret; +} + +///////////////////////////////// reader support //////////////////////////////// + +static Character readRet(int ret){ + if(ret == -1) + return null; + return box((char) ret); +} + +static public Character readChar(Reader r) throws IOException{ + int ret = r.read(); + return readRet(ret); +} + +static public Character peekChar(Reader r) throws IOException{ + int ret; + if(r instanceof PushbackReader) { + ret = r.read(); + ((PushbackReader) r).unread(ret); + } + else { + r.mark(1); + ret = r.read(); + r.reset(); + } + + return readRet(ret); +} + +static public int getLineNumber(Reader r){ + if(r instanceof LineNumberingPushbackReader) + return ((LineNumberingPushbackReader) r).getLineNumber(); + return 0; +} + +static public int getColumnNumber(Reader r){ + if(r instanceof LineNumberingPushbackReader) + return ((LineNumberingPushbackReader) r).getColumnNumber(); + return 0; +} + +static public LineNumberingPushbackReader getLineNumberingReader(Reader r){ + if(isLineNumberingReader(r)) + return (LineNumberingPushbackReader) r; + return new LineNumberingPushbackReader(r); +} + +static public boolean isLineNumberingReader(Reader r){ + return r instanceof LineNumberingPushbackReader; +} + +static public String resolveClassNameInContext(String className){ + //todo - look up in context var + return className; +} + +static public boolean suppressRead(){ + return booleanCast(SUPPRESS_READ.deref()); +} + +static public String printString(Object x){ + try { + StringWriter sw = new StringWriter(); + print(x, sw); + return sw.toString(); + } + catch(Exception e) { + throw Util.sneakyThrow(e); + } +} + +static public Object readString(String s){ + return readString(s, null); +} + +static public Object readString(String s, Object opts) { + PushbackReader r = new PushbackReader(new StringReader(s)); + return LispReader.read(r, opts); +} + +static public void print(Object x, Writer w) throws IOException{ + //call multimethod + if(PRINT_INITIALIZED.isBound() && RT.booleanCast(PRINT_INITIALIZED.deref())) + PR_ON.invoke(x, w); +//* + else { + boolean readably = booleanCast(PRINT_READABLY.deref()); + if(x instanceof Obj) { + Obj o = (Obj) x; + if(RT.count(o.meta()) > 0 && + ((readably && booleanCast(PRINT_META.deref())) + || booleanCast(PRINT_DUP.deref()))) { + IPersistentMap meta = o.meta(); + w.write("#^"); + if(meta.count() == 1 && meta.containsKey(TAG_KEY)) + print(meta.valAt(TAG_KEY), w); + else + print(meta, w); + w.write(' '); + } + } + if(x == null) + w.write("nil"); + else if(x instanceof ISeq || x instanceof IPersistentList) { + w.write('('); + printInnerSeq(seq(x), w); + w.write(')'); + } + else if(x instanceof String) { + String s = (String) x; + if(!readably) + w.write(s); + else { + w.write('"'); + //w.write(x.toString()); + for(int i = 0; i < s.length(); i++) { + char c = s.charAt(i); + switch(c) { + case '\n': + w.write("\\n"); + break; + case '\t': + w.write("\\t"); + break; + case '\r': + w.write("\\r"); + break; + case '"': + w.write("\\\""); + break; + case '\\': + w.write("\\\\"); + break; + case '\f': + w.write("\\f"); + break; + case '\b': + w.write("\\b"); + break; + default: + w.write(c); + } + } + w.write('"'); + } + } + else if(x instanceof IPersistentMap) { + w.write('{'); + for(ISeq s = seq(x); s != null; s = s.next()) { + IMapEntry e = (IMapEntry) s.first(); + print(e.key(), w); + w.write(' '); + print(e.val(), w); + if(s.next() != null) + w.write(", "); + } + w.write('}'); + } + else if(x instanceof IPersistentVector) { + IPersistentVector a = (IPersistentVector) x; + w.write('['); + for(int i = 0; i < a.count(); i++) { + print(a.nth(i), w); + if(i < a.count() - 1) + w.write(' '); + } + w.write(']'); + } + else if(x instanceof IPersistentSet) { + w.write("#{"); + for(ISeq s = seq(x); s != null; s = s.next()) { + print(s.first(), w); + if(s.next() != null) + w.write(" "); + } + w.write('}'); + } + else if(x instanceof Character) { + char c = ((Character) x).charValue(); + if(!readably) + w.write(c); + else { + w.write('\\'); + switch(c) { + case '\n': + w.write("newline"); + break; + case '\t': + w.write("tab"); + break; + case ' ': + w.write("space"); + break; + case '\b': + w.write("backspace"); + break; + case '\f': + w.write("formfeed"); + break; + case '\r': + w.write("return"); + break; + default: + w.write(c); + } + } + } + else if(x instanceof Class) { + w.write("#="); + w.write(((Class) x).getName()); + } + else if(x instanceof BigDecimal && readably) { + w.write(x.toString()); + w.write('M'); + } + else if(x instanceof BigInt && readably) { + w.write(x.toString()); + w.write('N'); + } + else if(x instanceof BigInteger && readably) { + w.write(x.toString()); + w.write("BIGINT"); + } + else if(x instanceof Var) { + Var v = (Var) x; + w.write("#=(var " + v.ns.name + "/" + v.sym + ")"); + } + else if(x instanceof Pattern) { + Pattern p = (Pattern) x; + w.write("#\"" + p.pattern() + "\""); + } + else w.write(x.toString()); + } + //*/ +} + +private static void printInnerSeq(ISeq x, Writer w) throws IOException{ + for(ISeq s = x; s != null; s = s.next()) { + print(s.first(), w); + if(s.next() != null) + w.write(' '); + } +} + +static public void formatAesthetic(Writer w, Object obj) throws IOException{ + if(obj == null) + w.write("null"); + else + w.write(obj.toString()); +} + +static public void formatStandard(Writer w, Object obj) throws IOException{ + if(obj == null) + w.write("null"); + else if(obj instanceof String) { + w.write('"'); + w.write((String) obj); + w.write('"'); + } + else if(obj instanceof Character) { + w.write('\\'); + char c = ((Character) obj).charValue(); + switch(c) { + case '\n': + w.write("newline"); + break; + case '\t': + w.write("tab"); + break; + case ' ': + w.write("space"); + break; + case '\b': + w.write("backspace"); + break; + case '\f': + w.write("formfeed"); + break; + default: + w.write(c); + } + } + else + w.write(obj.toString()); +} + +static public Object format(Object o, String s, Object... args) throws IOException{ + Writer w; + if(o == null) + w = new StringWriter(); + else if(Util.equals(o, T)) + w = (Writer) OUT.deref(); + else + w = (Writer) o; + doFormat(w, s, ArraySeq.create(args)); + if(o == null) + return w.toString(); + return null; +} + +static public ISeq doFormat(Writer w, String s, ISeq args) throws IOException{ + for(int i = 0; i < s.length();) { + char c = s.charAt(i++); + switch(Character.toLowerCase(c)) { + case '~': + char d = s.charAt(i++); + switch(Character.toLowerCase(d)) { + case '%': + w.write('\n'); + break; + case 't': + w.write('\t'); + break; + case 'a': + if(args == null) + throw new IllegalArgumentException("Missing argument"); + RT.formatAesthetic(w, RT.first(args)); + args = RT.next(args); + break; + case 's': + if(args == null) + throw new IllegalArgumentException("Missing argument"); + RT.formatStandard(w, RT.first(args)); + args = RT.next(args); + break; + case '{': + int j = s.indexOf("~}", i); //note - does not nest + if(j == -1) + throw new IllegalArgumentException("Missing ~}"); + String subs = s.substring(i, j); + for(ISeq sargs = RT.seq(RT.first(args)); sargs != null;) + sargs = doFormat(w, subs, sargs); + args = RT.next(args); + i = j + 2; //skip ~} + break; + case '^': + if(args == null) + return null; + break; + case '~': + w.write('~'); + break; + default: + throw new IllegalArgumentException("Unsupported ~ directive: " + d); + } + break; + default: + w.write(c); + } + } + return args; +} +///////////////////////////////// values ////////////////////////// + + +static public ClassLoader makeClassLoader(){ + return (ClassLoader) AccessController.doPrivileged(new PrivilegedAction(){ + public Object run(){ + try{ + Var.pushThreadBindings(RT.map(USE_CONTEXT_CLASSLOADER, RT.T)); +// getRootClassLoader(); + return new DynamicClassLoader(baseLoader()); + } + finally{ + Var.popThreadBindings(); + } + } + }); +} + +static public ClassLoader baseLoader(){ + if(Compiler.LOADER.isBound()) + return (ClassLoader) Compiler.LOADER.deref(); + else if(booleanCast(USE_CONTEXT_CLASSLOADER.deref())) + return Thread.currentThread().getContextClassLoader(); + return Compiler.class.getClassLoader(); +} + +static public InputStream resourceAsStream(ClassLoader loader, String name){ + if (loader == null) { + return ClassLoader.getSystemResourceAsStream(name); + } else { + return loader.getResourceAsStream(name); + } +} + +static public URL getResource(ClassLoader loader, String name){ + if (loader == null) { + return ClassLoader.getSystemResource(name); + } else { + return loader.getResource(name); + } +} + +static public Class classForName(String name, boolean load, ClassLoader loader) { + + try + { + Class c = null; + if (!(loader instanceof DynamicClassLoader)) + c = DynamicClassLoader.findInMemoryClass(name); + if (c != null) + return c; + return Class.forName(name, load, loader); + } + catch(ClassNotFoundException e) + { + throw Util.sneakyThrow(e); + } +} + +static public Class classForName(String name) { + return classForName(name, true, baseLoader()); +} + +static public Class classForNameNonLoading(String name) { + return classForName(name, false, baseLoader()); +} + +static public Class loadClassForName(String name) { + try + { + classForNameNonLoading(name); + } + catch(Exception e) + { + if (e instanceof ClassNotFoundException) + return null; + else + throw Util.sneakyThrow(e); + } + return classForName(name); +} + +static public float aget(float[] xs, int i){ + return xs[i]; +} + +static public float aset(float[] xs, int i, float v){ + xs[i] = v; + return v; +} + +static public int alength(float[] xs){ + return xs.length; +} + +static public float[] aclone(float[] xs){ + return xs.clone(); +} + +static public double aget(double[] xs, int i){ + return xs[i]; +} + +static public double aset(double[] xs, int i, double v){ + xs[i] = v; + return v; +} + +static public int alength(double[] xs){ + return xs.length; +} + +static public double[] aclone(double[] xs){ + return xs.clone(); +} + +static public int aget(int[] xs, int i){ + return xs[i]; +} + +static public int aset(int[] xs, int i, int v){ + xs[i] = v; + return v; +} + +static public int alength(int[] xs){ + return xs.length; +} + +static public int[] aclone(int[] xs){ + return xs.clone(); +} + +static public long aget(long[] xs, int i){ + return xs[i]; +} + +static public long aset(long[] xs, int i, long v){ + xs[i] = v; + return v; +} + +static public int alength(long[] xs){ + return xs.length; +} + +static public long[] aclone(long[] xs){ + return xs.clone(); +} + +static public char aget(char[] xs, int i){ + return xs[i]; +} + +static public char aset(char[] xs, int i, char v){ + xs[i] = v; + return v; +} + +static public int alength(char[] xs){ + return xs.length; +} + +static public char[] aclone(char[] xs){ + return xs.clone(); +} + +static public byte aget(byte[] xs, int i){ + return xs[i]; +} + +static public byte aset(byte[] xs, int i, byte v){ + xs[i] = v; + return v; +} + +static public int alength(byte[] xs){ + return xs.length; +} + +static public byte[] aclone(byte[] xs){ + return xs.clone(); +} + +static public short aget(short[] xs, int i){ + return xs[i]; +} + +static public short aset(short[] xs, int i, short v){ + xs[i] = v; + return v; +} + +static public int alength(short[] xs){ + return xs.length; +} + +static public short[] aclone(short[] xs){ + return xs.clone(); +} + +static public boolean aget(boolean[] xs, int i){ + return xs[i]; +} + +static public boolean aset(boolean[] xs, int i, boolean v){ + xs[i] = v; + return v; +} + +static public int alength(boolean[] xs){ + return xs.length; +} + +static public boolean[] aclone(boolean[] xs){ + return xs.clone(); +} + +static public Object aget(Object[] xs, int i){ + return xs[i]; +} + +static public Object aset(Object[] xs, int i, Object v){ + xs[i] = v; + return v; +} + +static public int alength(Object[] xs){ + return xs.length; +} + +static public Object[] aclone(Object[] xs){ + return xs.clone(); +} + + +} diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 4e6baa7f..83c1c4da 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -283,7 +283,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] bound? - [ ] bound-fn - [ ] bound-fn* - - [ ] bounded-count + - [x x] bounded-count - [ ] butlast - [x .] byte - [x x] byte? @@ -899,49 +899,104 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] xml-seq - [x ] zero? - [ ] zipmap + - [.] Intrinsics + - [ ] Java intrinsics - [.] clojure.lang.RT https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/RT.java - [ ] aclone - [ ] addURL - [ ] aget - [.] alength + - [ ] arrayToList - [ ] aset - [ ] assoc + - [ ] assocN - [ ] baseLoader - [.] booleanCast + - [x] boundedLength + - [x] box - [.] byteCast - [ ] canSeq - [.] charCast - - [ ] chunkIteratorSeq + - [!] chunkIteratorSeq + - [ ] classForName + - [ ] classForNameNonLoading + - [!] compile - [ ] conj - [ ] cons - [ ] contains - [x] count - [x] countFrom - [ ] dissoc + - [ ] doFormat - [.] doubleCast + - [!] errPrintWriter - [ ] find + - [ ] findKey - [ ] first - [.] floatCast + - [ ] format + - [ ] formatAesthetic + - [ ] formatStandard + - [!] fourth - [ ] get + - [ ] getColumnNumber + - [ ] getFrom + - [ ] getLineNumber + - [ ] getLineNumberingReader + - [ ] getResource + - [ ] hasTag + - [!] init - [.] intCast + - [ ] isLineNumberingReader - [x] isReduced - [ ] iter - [ ] keys - - [ ] load + - [x] keyword + - [!] lastModified + - [x] length + - [ ] list + - [ ] listStar + - [!] load + - [ ] loadClassForName + - [!] loadLibrary + - [!] loadResourceScript - [.] longCast + - [ ] makeClassLoader + - [ ] map + - [ ] mapUniqueKeys + - [!] maybeLoadResourceScript + - [x] meta - [ ] more - [ ] nextID - [ ] nth + - [ ] nthFrom - [ ] object_array - [ ] peek + - [ ] peekChar - [ ] pop + - [ ] print + - [ ] printInnerSeq + - [ ] printString + - [!] processCommandLine + - [ ] readChar - [ ] readString + - [ ] resolveClassNameInContext + - [ ] resourceAsStream - [ ] rest + - [!] second - [x] seq + - [x] seqFrom + - [!] seqOrElse + - [ ] seqToArray + - [ ] seqToPassedArray - [ ] seqToTypedArray + - [ ] set + - [!] setValues - [.] shortCast - [ ] subvec + - [ ] suppressRead + - [!] third - [ ] toArray - [.] uncheckedByteCast - [.] uncheckedShortCast @@ -951,6 +1006,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [.] uncheckedFloatCast - [.] uncheckedDoubleCast - [ ] vals + - [!] var - [ ] vector - [.] clojure.lang.Numbers https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/Numbers.java diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 8827cc5d..b37423dd 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -94,7 +94,8 @@ ([x int? > (t/assume (t/ref int?))] (Integer/valueOf x)) ([x long? > (t/assume (t/ref long?))] (Long/valueOf x)) ([x float? > (t/assume (t/ref float?))] (Float/valueOf x)) - ([x double? > (t/assume (t/ref double?))] (Double/valueOf x)))) + ([x double? > (t/assume (t/ref double?))] (Double/valueOf x)) + ([x t/ref?] x))) #?(:clj (t/defn ^:inline unbox From 457c18eadef96ad48a58642226e35151b9b00aef Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 28 Sep 2018 08:32:30 -0600 Subject: [PATCH 337/810] Add link to intrinsics --- resources-dev/defnt.cljc | 2 ++ 1 file changed, 2 insertions(+) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 83c1c4da..8687a0ea 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -900,6 +900,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x ] zero? - [ ] zipmap - [.] Intrinsics + https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/Intrinsics.java + - - [ ] Java intrinsics - [.] clojure.lang.RT https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/RT.java From 63a9bcf8741db4209f0376b8a35e75d725857389 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 28 Sep 2018 13:16:13 -0600 Subject: [PATCH 338/810] `PAtomic` --- src/quantum/core/refs.cljc | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/src/quantum/core/refs.cljc b/src/quantum/core/refs.cljc index c0ffbf64..3200170c 100644 --- a/src/quantum/core/refs.cljc +++ b/src/quantum/core/refs.cljc @@ -27,6 +27,42 @@ [java.util.concurrent.atomic AtomicReference AtomicBoolean AtomicInteger AtomicLong] [com.google.common.util.concurrent AtomicDouble]))) +(defprotocol PAtomic + (atomically-apply [target f] + "Atomically applies `f` to `target`, with the following caveats: + - Atomicity here means only that the effects of `f` on `target` are guaranteed to be rolled + back or undone in the case of a failed application of `f` (e.g. in the case of an exception). + This implies concurrency-safety only for concurrency-safe `target`s, not for `target`s safe + only for single-threaded use. + - Some implementations may run `f` multiple times in an effort to atomically apply it, so in + those cases `f` must be free of side-effects not applied to the `target`. + + It is the burden of the implementation to call the 1-arity function `f` in one of the following + ways: + + A) Given an immutable `target`, the `target` is supplied to `f`, and `f` returns an updated + immutable version of it. The original `target` is by definition unaffected. + - Example: Any built-in Clojure immutable data structure like a map, vector, set, etc. + B) Given a `target` consisting of a container for an immutable value, the immutable value in + question is supplied to `f`, and `f` returns an updated immutable value which is atomically + applied to the container. + - Example: A Clojure atom wrapping e.g. an immutable Clojure map + - Example: A 'box' type having a mutable, thread-unsafe field which may be set any number of + times to refer only to immutable values. + C) Given a `target` consisting of an 'opaque' structure that supports atomic modification, the + `target` is supplied to `f`, and `f` returns the modified/updated `target`. + - Example: A JDBC connection, in which the connection *itself* might not be modified but a + caller may request modifications to be transactionally (and thus atomically) + applied to the underlying DB. + - Example: A Redis cache to which transactional (and thus atomic) updates may be applied. + - Example: A version of (the mutable, thread-unsafe) `java.util.HashMap` which keeps track + of modifications made to it within an atomic function application and rolls them + back in the case of a failed application (e.g. in the case of an exception). + + This differs from `swap!` in that `swap!`, by convention, only supports case B), and that only + for concurrency-safe `target`s (if in a concurrent environment).")) + + (def atom? (t/isa?|direct #?(:clj clojure.lang.IAtom :cljs cljs.core/IAtom))) (def volatile? (t/isa? #?(:clj clojure.lang.Volatile :cljs cljs.core/Volatile))) From 3a35979f383b288560a847a36b46cbdea140fc31 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 28 Sep 2018 13:17:06 -0600 Subject: [PATCH 339/810] Add todo --- src/quantum/core/refs.cljc | 1 + 1 file changed, 1 insertion(+) diff --git a/src/quantum/core/refs.cljc b/src/quantum/core/refs.cljc index 3200170c..e65854e0 100644 --- a/src/quantum/core/refs.cljc +++ b/src/quantum/core/refs.cljc @@ -27,6 +27,7 @@ [java.util.concurrent.atomic AtomicReference AtomicBoolean AtomicInteger AtomicLong] [com.google.common.util.concurrent AtomicDouble]))) +;; TODO technically this belongs in like `quantum.core.data.effects` or something (defprotocol PAtomic (atomically-apply [target f] "Atomically applies `f` to `target`, with the following caveats: From b9bab99c419a55a8317c2942d929d166f2e2b5b1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 28 Sep 2018 17:37:08 -0600 Subject: [PATCH 340/810] Update docstring --- src/quantum/core/refs.cljc | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/quantum/core/refs.cljc b/src/quantum/core/refs.cljc index e65854e0..7635c9b3 100644 --- a/src/quantum/core/refs.cljc +++ b/src/quantum/core/refs.cljc @@ -28,8 +28,8 @@ [com.google.common.util.concurrent AtomicDouble]))) ;; TODO technically this belongs in like `quantum.core.data.effects` or something -(defprotocol PAtomic - (atomically-apply [target f] +(defprotocol IAtomic + (atomic-apply [target f] "Atomically applies `f` to `target`, with the following caveats: - Atomicity here means only that the effects of `f` on `target` are guaranteed to be rolled back or undone in the case of a failed application of `f` (e.g. in the case of an exception). @@ -60,9 +60,12 @@ of modifications made to it within an atomic function application and rolls them back in the case of a failed application (e.g. in the case of an exception). - This differs from `swap!` in that `swap!`, by convention, only supports case B), and that only - for concurrency-safe `target`s (if in a concurrent environment).")) + It is also the burden of the implementation to handle nested atomic applications on at least a + per-thread basis. That is, if `atomic-apply` is called inside of another `atomic-apply`, the + implementation must ensure that both calls are atomic, usually by making the inner one a no-op. + This differs from `core/swap!` in that `swap!`, by convention, only supports case B), and that + only for concurrency-safe `target`s (if in a concurrent environment).")) (def atom? (t/isa?|direct #?(:clj clojure.lang.IAtom :cljs cljs.core/IAtom))) From e0c5975c56dec979fa29646437179cbcab48eb30 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 28 Sep 2018 17:39:13 -0600 Subject: [PATCH 341/810] Clarify behavior --- src/quantum/core/refs.cljc | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/quantum/core/refs.cljc b/src/quantum/core/refs.cljc index 7635c9b3..ed5efbc9 100644 --- a/src/quantum/core/refs.cljc +++ b/src/quantum/core/refs.cljc @@ -61,8 +61,9 @@ back in the case of a failed application (e.g. in the case of an exception). It is also the burden of the implementation to handle nested atomic applications on at least a - per-thread basis. That is, if `atomic-apply` is called inside of another `atomic-apply`, the - implementation must ensure that both calls are atomic, usually by making the inner one a no-op. + per-thread basis. That is, if `atomic-apply` is called inside of another `atomic-apply` on the + same thread, the implementation must ensure that both calls are atomic, usually by making the + inner one a no-op. This differs from `core/swap!` in that `swap!`, by convention, only supports case B), and that only for concurrency-safe `target`s (if in a concurrent environment).")) From c4bf3a7673ea858d6a019e2bd450cafe30674280 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 28 Sep 2018 22:56:39 -0600 Subject: [PATCH 342/810] Add intrinsics --- resources-dev/defnt.cljc | 105 ++++++++++++++++++++++++++++++++++++++- 1 file changed, 104 insertions(+), 1 deletion(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 8687a0ea..3df317ce 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -901,7 +901,110 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] zipmap - [.] Intrinsics https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/Intrinsics.java - - + - [ ] Numbers.add(double,double) + - [ ] Numbers.and(long,long) + - [ ] Numbers.divide(double,double) + - [ ] Numbers.equiv(double,double) + - [ ] Numbers.equiv(long,long) + - [ ] Numbers.gt(long,long) + - [ ] Numbers.gt(double,double) + - [ ] Numbers.gte(long,long) + - [ ] Numbers.gte(double,double) + - [ ] Numbers.isPos(long) + - [ ] Numbers.isPos(double) + - [ ] Numbers.isNeg(long) + - [ ] Numbers.isNeg(double) + - [ ] Numbers.isZero(double) + - [ ] Numbers.isZero(long) + - [ ] Numbers.lt(long,long) + - [ ] Numbers.lt(double,double) + - [ ] Numbers.lte(long,long) + - [ ] Numbers.lte(double,double) + - [ ] Numbers.multiply(double,double) + - [ ] Numbers.or(long,long) + - [ ] Numbers.xor(long,long) + - [ ] Numbers.remainder(long,long) + - [ ] Numbers.shiftLeft(long,long) + - [ ] Numbers.shiftRight(long,long) + - [ ] Numbers.unsignedShiftRight(long,long) + - [ ] Numbers.minus(double) + - [ ] Numbers.minus(double,double) + - [ ] Numbers.inc(double) + - [ ] Numbers.dec(double) + - [ ] Numbers.quotient(long,long) + - [ ] Numbers.shiftLeftInt(int,int) + - [ ] Numbers.shiftRightInt(int,int) + - [ ] Numbers.unsignedShiftRightInt(int,int) + - [ ] Numbers.unchecked_int_add(int,int) + - [ ] Numbers.unchecked_int_subtract(int,int) + - [ ] Numbers.unchecked_int_negate(int) + - [ ] Numbers.unchecked_int_inc(int) + - [ ] Numbers.unchecked_int_dec(int) + - [ ] Numbers.unchecked_int_multiply(int,int) + - [ ] Numbers.unchecked_int_divide(int,int) + - [ ] Numbers.unchecked_int_remainder(int,int) + - [ ] Numbers.unchecked_add(long,long) + - [ ] Numbers.unchecked_add(double,double) + - [ ] Numbers.unchecked_minus(long) + - [ ] Numbers.unchecked_minus(double) + - [ ] Numbers.unchecked_minus(double,double) + - [ ] Numbers.unchecked_minus(long,long) + - [ ] Numbers.unchecked_multiply(long,long) + - [ ] Numbers.unchecked_multiply(double,double) + - [ ] Numbers.unchecked_inc(double) + - [ ] Numbers.unchecked_inc(long) + - [ ] Numbers.unchecked_dec(double) + - [ ] Numbers.unchecked_dec(long) + - [ ] RT.aget(short[],int) + - [ ] RT.aget(float[],int) + - [ ] RT.aget(double[],int) + - [ ] RT.aget(int[],int) + - [ ] RT.aget(long[],int) + - [ ] RT.aget(char[],int) + - [ ] RT.aget(byte[],int) + - [ ] RT.aget(boolean[],int) + - [ ] RT.aget(java.lang.Object[],int) + - [ ] RT.alength(int[]) + - [ ] RT.alength(long[]) + - [ ] RT.alength(char[]) + - [ ] RT.alength(java.lang.Object[]) + - [ ] RT.alength(byte[]) + - [ ] RT.alength(float[]) + - [ ] RT.alength(short[]) + - [ ] RT.alength(boolean[]) + - [ ] RT.alength(double[]) + - [ ] RT.doubleCast(long) + - [ ] RT.doubleCast(double) + - [ ] RT.doubleCast(float) + - [ ] RT.doubleCast(int) + - [ ] RT.doubleCast(short) + - [ ] RT.doubleCast(byte) + - [ ] RT.uncheckedDoubleCast(double) + - [ ] RT.uncheckedDoubleCast(float) + - [ ] RT.uncheckedDoubleCast(long) + - [ ] RT.uncheckedDoubleCast(int) + - [ ] RT.uncheckedDoubleCast(short) + - [ ] RT.uncheckedDoubleCast(byte) + - [ ] RT.longCast(long) + - [ ] RT.longCast(short) + - [ ] RT.longCast(byte) + - [ ] RT.longCast(int) + - [ ] RT.uncheckedIntCast(long) + - [ ] RT.uncheckedIntCast(double) + - [ ] RT.uncheckedIntCast(byte) + - [ ] RT.uncheckedIntCast(short) + - [ ] RT.uncheckedIntCast(char) + - [ ] RT.uncheckedIntCast(int) + - [ ] RT.uncheckedIntCast(float) + - [ ] RT.uncheckedLongCast(short) + - [ ] RT.uncheckedLongCast(float) + - [ ] RT.uncheckedLongCast(double) + - [ ] RT.uncheckedLongCast(byte) + - [ ] RT.uncheckedLongCast(long) + - [ ] RT.uncheckedLongCast(int) + - [ ] Util.equiv(long,long) + - [ ] Util.equiv(boolean,boolean) + - [ ] Util.equiv(double,double) - [ ] Java intrinsics - [.] clojure.lang.RT https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/RT.java From 3bff59e4bb09805c191448a76be5bc29bd7f6649 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 28 Sep 2018 23:05:16 -0600 Subject: [PATCH 343/810] quantum.core.test.defnt-equivalences moved --- .../quantum/test/untyped/core/type/defnt.cljc | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename src-dev/quantum/core/defnt_equivalences.cljc => test/quantum/test/untyped/core/type/defnt.cljc (100%) diff --git a/src-dev/quantum/core/defnt_equivalences.cljc b/test/quantum/test/untyped/core/type/defnt.cljc similarity index 100% rename from src-dev/quantum/core/defnt_equivalences.cljc rename to test/quantum/test/untyped/core/type/defnt.cljc From 08dbf57bdb3f6f7aaa3510a95be069f4487fe7d7 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 28 Sep 2018 23:29:51 -0600 Subject: [PATCH 344/810] Begin to do `t/isa?|direct` --- resources-dev/defnt.cljc | 10 +- src-untyped/quantum/untyped/core/classes.cljc | 13 +- src-untyped/quantum/untyped/core/core.cljc | 8 +- src-untyped/quantum/untyped/core/type.cljc | 20 ++- src/quantum/core/collections_typed.cljc | 6 +- src/quantum/core/data/collections.cljc | 28 ++-- src/quantum/core/data/identifiers.cljc | 4 +- src/quantum/core/data/meta.cljc | 4 +- src/quantum/core/data/tuple.cljc | 2 +- src/quantum/core/data/vector.cljc | 4 +- test/quantum/test/core/compare.cljc | 68 --------- test/quantum/test/untyped/core/type.cljc | 133 +++++++++++++++--- .../test/untyped/core/type/compare.cljc | 101 ++----------- .../quantum/test/untyped/core/type/defnt.cljc | 2 +- 14 files changed, 181 insertions(+), 222 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 3df317ce..d3be387c 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -61,6 +61,10 @@ TODO: Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: + - t/isa?|direct + - For CLJ, this is `instance?` for classes and `instance?` on the underlying interface + associated with a protocol + - For CLJS, this is `instance?` for classes and `implements?` for protocols - t/type >>>>>> (PRIORITY 1) <<<<<< - dependent types: `[x arr/array? > (t/type x)]` - (t/== x) @@ -91,17 +95,13 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative ;; - What the possible types of xs' are as a result (reduce rf init xs'))) - ([rf rf?, init t/any?, xs #?(:clj (t/isa? clojure.core.protocols/CollReduce) - :cljs (t/isa|direct? cljs.core/IReduce))] + :cljs (t/isa?|direct cljs.core/IReduce))] ;; TODO add `^not-native` to `xs` for CLJS (#?(:clj clojure.core.protocols/coll-reduce :cljs cljs.core/-reduce) xs rf init)) - (if (A) ...) should be (if ^boolean (A) ...) if A returns a `p/boolean?` - t/- : fix - (t/- (t/isa? java.util.Queue) (t/or ?!+queue? !!queue?)) - - t/isa|direct? - - For CLJ, this is `instance?` for classes and `instance?` on the underlying interface - associated with a protocol - - For CLJS, this is `instance?` for classes and `implements?` for protocols - t/value-of - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` - t/numerically : e.g. a double representing exactly what a float is able to represent diff --git a/src-untyped/quantum/untyped/core/classes.cljc b/src-untyped/quantum/untyped/core/classes.cljc index 5a9473d9..c9f343e8 100644 --- a/src-untyped/quantum/untyped/core/classes.cljc +++ b/src-untyped/quantum/untyped/core/classes.cljc @@ -1,7 +1,8 @@ (ns quantum.untyped.core.classes -#?(:clj - (:import - java.lang.reflect.Modifier))) + (:require + [quantum.untyped.core.core :as ucore]) +#?(:clj (:import + [java.lang.reflect Modifier]))) #?(:clj (defn final? [x] (and (class? x) (Modifier/isFinal (.getModifiers ^Class x))))) #?(:clj (defn interface? [x] (and (class? x) (.isInterface ^Class x)))) @@ -9,3 +10,9 @@ #?(:clj (defn primitive? [x] (and (class? x) (.isPrimitive ^Class x)))) #?(:clj (defn array? [x] (and (class? x) (.isArray ^Class x)))) +(defn protocol? [x] + #?(:clj (and (ucore/lookup? x) (-> x (get :on-interface) class?)) + ;; Unfortunately there's no better check in CLJS, at least as of 03/18/2018 + :cljs (and (fn? x) (= (str x) "function (){}")))) + +#?(:clj (defn protocol>class [x] (:on-interface x))) diff --git a/src-untyped/quantum/untyped/core/core.cljc b/src-untyped/quantum/untyped/core/core.cljc index edd287fd..e9f4e8c2 100644 --- a/src-untyped/quantum/untyped/core/core.cljc +++ b/src-untyped/quantum/untyped/core/core.cljc @@ -135,17 +135,11 @@ `core/any?))) :cljs (defalias core/any?)) -;; This is in here only because `protocol?` needs it; it's aliased later +;; This is in here only because `uclass/protocol?` needs it; it's aliased later (defn lookup? [x] #?(:clj (instance? clojure.lang.ILookup x) :cljs (satisfies? cljs.core/ILookup x))) -(defn protocol? [x] - #?(:clj (and (lookup? x) (-> x (get :on-interface) class?)) - ;; Unfortunately there's no better check in CLJS, at least as of 03/18/2018 - :cljs (and (fn? x) (= (str x) "function (){}")))) - - ;; From `quantum.untyped.core.collections.tree` — used in `quantum.untyped.core.macros` (defn walk diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 29f7ae3d..f2ca338e 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -18,6 +18,7 @@ [clojure.string :as str] [quantum.untyped.core.analyze.expr :refer [>expr #?(:cljs Expression)]] + [quantum.untyped.core.classes :as uclass] [quantum.untyped.core.collections :as uc] [quantum.untyped.core.collections.logic :refer [seq-and seq-or]] @@ -158,7 +159,7 @@ ;; ----- ProtocolType ----- ;; -(defns- isa?|protocol [p ucore/protocol?] +(defns- isa?|protocol [p uclass/protocol?] (ProtocolType. uhash/default uhash/default nil p nil)) ;; ----- ClassType ----- ;; @@ -207,12 +208,17 @@ ([t0 utr/type?, t1 utr/type? & ts (us/seq-of utr/type?) > utr/type?] (reduce - (- t0 t1) ts))) (defn isa? [x] - (ifs (ucore/protocol? x) + (ifs (uclass/protocol? x) (isa?|protocol x) (#?(:clj c/class? :cljs c/fn?) x) (isa?|class x))) +(defn isa?|direct [x] + (if (uclass/protocol? x) + #?(:clj (isa?|class (uclass/protocol>class x))) + (isa? x))) + ;; TODO clean up (defns >type "Coerces ->`x` to a type, recording its ->`name-sym` if provided." @@ -245,7 +251,7 @@ (Expression. sym x)) (c/nil? x) nil? - (ucore/protocol? x) + (uclass/protocol? x) (ProtocolType. uhash/default uhash/default nil x name-sym) (value x)) :cljs nil))) @@ -615,8 +621,8 @@ (isa? #?(:clj clojure.lang.PersistentList :cljs cljs.core/List)))) ;; Used by `quantum.untyped.core.analyze` -(def +vector|built-in? (t/isa? #?(:clj clojure.lang.PersistentVector - :cljs cljs.core/PersistentVector))) +(def +vector|built-in? (isa? #?(:clj clojure.lang.PersistentVector + :cljs cljs.core/PersistentVector))) ;; Used by `quantum.untyped.core.analyze` (def +map|built-in? @@ -633,13 +639,13 @@ ;; Used by `quantum.untyped.core.analyze` (def fn? #?(:clj (isa? clojure.lang.Fn) - :cljs (or (isa? js/Function) (isa|direct? cljs.core/Fn)))) + :cljs (or (isa? js/Function) ( cljs.core/Fn)))) ;; Used by `quantum.untyped.core.analyze` via `t/callable?` (uvar/def ifn? "Note that in CLJS, `cljs.core/ifn?` checks if something is either `fn?` or if it satisfies `cljs.core/IFn`. By contrast, this type encompasses only direct implementers of `cljs.core/IFn`." - (isa|direct? #?(:clj clojure.lang.IFn :cljs cljs.core/IFn))) + (isa?|direct #?(:clj clojure.lang.IFn :cljs cljs.core/IFn))) ;; Used by `quantum.untyped.core.analyze` via `t/callable?` (def fnt? (and fn? (>expr (fn-> c/meta ::type)))) diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index 935a6911..9f3f03eb 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -104,7 +104,7 @@ ;; ===== Iterators ===== ;; -(t/defn ^:inline >iterator [x (t/isa|direct? #?(:clj java.lang.Iterable :cljs cljs.core/IIterable))] +(t/defn ^:inline >iterator [x (t/isa?|direct #?(:clj java.lang.Iterable :cljs cljs.core/IIterable))] #?(:clj (.iterator x) :cljs (cljs.core/-iterator ^not-native x))) @@ -313,14 +313,14 @@ ;; NOTE We don't accept `xs` that implement `clojure.core.protocols/IKVReduce` only after ;; the fact because `IKVReduce` could inappropriately specialize on e.g. `Object` (^:inline [rf rf?, init t/any? - xs (t/isa|direct? #?(:clj clojure.core.protocols/IKVReduce + xs (t/isa?|direct #?(:clj clojure.core.protocols/IKVReduce :cljs cljs.core/IKVReduce))] (#?(:clj clojure.core.protocols/kv-reduce :cljs cljs.core/-kv-reduce) xs rf init)) ;; NOTE We don't accept `xs` that implement `clojure.core.protocols/CollReduce` only after ;; the fact because `CollReduce` inappropriately specializes on `Object` (^:inline [rf rf?, init t/any? - xs (t/isa|direct? #?(:clj clojure.core.protocols/CollReduce + xs (t/isa?|direct #?(:clj clojure.core.protocols/CollReduce :cljs cljs.core/IReduce))] (#?(:clj clojure.core.protocols/coll-reduce :cljs cljs.core/-reduce) xs rf init)) diff --git a/src/quantum/core/data/collections.cljc b/src/quantum/core/data/collections.cljc index 4940abf9..59f2d84b 100644 --- a/src/quantum/core/data/collections.cljc +++ b/src/quantum/core/data/collections.cljc @@ -17,9 +17,9 @@ ;; ===== Sequences and sequence-wrappers ===== ;; ;; Sequential (generally not efficient Lookup / RandomAccess) -(def iseqable? (t/isa|direct? #?(:clj clojure.lang.Seqable :cljs cljs.core/ISeqable))) +(def iseqable? (t/isa?|direct #?(:clj clojure.lang.Seqable :cljs cljs.core/ISeqable))) -(def iseq? (t/isa|direct? #?(:clj clojure.lang.ISeq :cljs cljs.core/ISeq))) +(def iseq? (t/isa?|direct #?(:clj clojure.lang.ISeq :cljs cljs.core/ISeq))) #?(:clj (def aseq? (t/isa? clojure.lang.ASeq))) @@ -45,16 +45,16 @@ (def chunk-buffer? (t/isa? #?(:clj clojure.lang.ChunkBuffer :cljs cljs.core/ChunkBuffer))) -(def chunk? (t/isa|direct? #?(:clj clojure.lang.IChunk :cljs cljs.core/IChunk))) +(def chunk? (t/isa?|direct #?(:clj clojure.lang.IChunk :cljs cljs.core/IChunk))) (def chunked-cons? (t/isa? #?(:clj clojure.lang.ChunkedCons :cljs cljs.core/ChunkedCons))) (var/def chunked-seq? "Note that `cljs.core/IChunkedSeq` has no interface for `chunked-next`, unliked `clojure.lang.IChunkedSeq`." - (t/isa|direct? #?(:clj clojure.lang.IChunkedSeq :cljs cljs.core/IChunkedSeq))) + (t/isa?|direct #?(:clj clojure.lang.IChunkedSeq :cljs cljs.core/IChunkedSeq))) -#?(:cljs (def chunked-next? (t/isa|direct? #?(:cljs cljs.core/IChunkedNext)))) +#?(:cljs (def chunked-next? (t/isa?|direct #?(:cljs cljs.core/IChunkedNext)))) (def indexed-seq? (t/isa? #?(:clj clojure.lang.IndexedSeq :cljs cljs.core/IndexedSeq))) @@ -87,10 +87,10 @@ ;; ===== End sequences ===== ;; -(def record? (t/isa|direct? #?(:clj clojure.lang.IRecord :cljs cljs.core/IRecord))) +(def record? (t/isa?|direct #?(:clj clojure.lang.IRecord :cljs cljs.core/IRecord))) (def sorted? - (t/or (t/isa|direct? #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) + (t/or (t/isa?|direct #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) #?@(:clj [(t/isa? java.util.SortedMap) (t/isa? java.util.SortedSet)] :cljs [(t/isa? goog.structs.AvlTree)]) @@ -103,7 +103,7 @@ (def editable? (t/isa? #?(:clj clojure.lang.IEditableCollection :cljs cljs.core/IEditableCollection))) -(def iindexed? (t/isa|direct? #?(:clj clojure.lang.Indexed :cljs cljs.core/IIndexed))) +(def iindexed? (t/isa?|direct #?(:clj clojure.lang.Indexed :cljs cljs.core/IIndexed))) ;; Indicates efficient lookup by (integer) index (via `get`) (def indexed? @@ -113,10 +113,10 @@ #?(:clj dstr/char-seq? :cljs dstr/string?) arr/array?)) -(def +associative? (t/isa|direct? #?(:clj clojure.lang.Associative +(def +associative? (t/isa?|direct #?(:clj clojure.lang.Associative :cljs cljs.core/IAssociative))) -(def !+associative? (t/isa|direct? #?(:clj clojure.lang.ITransientAssociative +(def !+associative? (t/isa?|direct #?(:clj clojure.lang.ITransientAssociative :cljs cljs.core/ITransientAssociative))) ;; Indicates whether `assoc?!` is supported @@ -126,7 +126,7 @@ (t/or (t/isa? #?(:clj clojure.lang.Sequential :cljs cljs.core/ISequential)) list? indexed?)) -(def icounted? (t/isa|direct? #?(:clj clojure.lang.Counted :cljs cljs.core/ICounted))) +(def icounted? (t/isa?|direct #?(:clj clojure.lang.Counted :cljs cljs.core/ICounted))) ;; If something is `counted?`, it is supposed to implement a constant-time `count` ;; `nil` is counted but this type ignores that @@ -149,7 +149,7 @@ set/set? arr/array?)) -(def iterable? (t/isa|direct? #?(:clj java.lang.Iterable :cljs cljs.core/IIterable))) +(def iterable? (t/isa?|direct #?(:clj java.lang.Iterable :cljs cljs.core/IIterable))) #?(:clj (def java-coll? (t/isa? java.util.Collection))) @@ -177,10 +177,10 @@ #?(:clj (t/isa? clojure.lang.IKVReduce)) #?(:clj (t/isa? clojure.lang.IReduceInit)) ;; We're ignoring indirect implementation for reasons noted in the `reduce` impl - (t/isa|direct? #?(:clj clojure.core.protocols/IKVReduce + (t/isa?|direct #?(:clj clojure.core.protocols/IKVReduce :cljs cljs.core/IKVReduce)) ;; We're ignoring indirect implementation for reasons noted in the `reduce` impl - (t/isa|direct? #?(:clj clojure.core.protocols/CollReduce + (t/isa?|direct #?(:clj clojure.core.protocols/CollReduce :cljs cljs.core/IReduce)) iseq? iseqable? diff --git a/src/quantum/core/data/identifiers.cljc b/src/quantum/core/data/identifiers.cljc index a244d814..f7f9719f 100644 --- a/src/quantum/core/data/identifiers.cljc +++ b/src/quantum/core/data/identifiers.cljc @@ -23,7 +23,7 @@ ;; ===== Nameability ===== ;; -(def named? (t/isa|direct? #?(:clj clojure.lang.Named :cljs cljs.core/INamed))) +(def named? (t/isa?|direct #?(:clj clojure.lang.Named :cljs cljs.core/INamed))) (t/defn demunged>namespace [s dstr/string?] TODO TYPED #_(subs s 0 (.lastIndexOf s "/"))) (t/defn demunged>name [s dstr/string?] TODO TYPED #_(subs s (inc (.lastIndexOf s "/")))) @@ -145,7 +145,7 @@ ;; ===== UUIDs ===== ;; -(def uuid? (t/isa|direct? #?(:clj java.util.UUID :cljs cljs.core/UUID))) +(def uuid? (t/isa?|direct #?(:clj java.util.UUID :cljs cljs.core/UUID))) (t/defn >uuid > uuid? ([] diff --git a/src/quantum/core/data/meta.cljc b/src/quantum/core/data/meta.cljc index 56f70bdd..adc5a15c 100644 --- a/src/quantum/core/data/meta.cljc +++ b/src/quantum/core/data/meta.cljc @@ -7,8 +7,8 @@ [quantum.core.type :as t])) (def meta? (t/? map/+map?)) -(def metable? (t/isa|direct? #?(:clj clojure.lang.IMeta :cljs cljs.core/IMeta))) -(def with-metable? (t/isa|direct? #?(:clj clojure.lang.IObj :cljs cljs.core/IWithMeta))) +(def metable? (t/isa?|direct #?(:clj clojure.lang.IMeta :cljs cljs.core/IMeta))) +(def with-metable? (t/isa?|direct #?(:clj clojure.lang.IObj :cljs cljs.core/IWithMeta))) (t/defn ^:inline >meta "Returns the (possibly nil) metadata of ->`x`." diff --git a/src/quantum/core/data/tuple.cljc b/src/quantum/core/data/tuple.cljc index b5011929..9544390f 100644 --- a/src/quantum/core/data/tuple.cljc +++ b/src/quantum/core/data/tuple.cljc @@ -11,6 +11,6 @@ ;; clojure.lang.Tuple was discontinued; we won't support it for now (def tuple? (t/isa? quantum.untyped.core.data.tuple.Tuple)) -(def map-entry? (t/isa|direct? #?(:clj java.util.Map$Entry :cljs cljs.core/IMapEntry))) +(def map-entry? (t/isa?|direct #?(:clj java.util.Map$Entry :cljs cljs.core/IMapEntry))) #?(:clj (defalias u/tuple)) diff --git a/src/quantum/core/data/vector.cljc b/src/quantum/core/data/vector.cljc index 4e3fb980..cc360c0b 100644 --- a/src/quantum/core/data/vector.cljc +++ b/src/quantum/core/data/vector.cljc @@ -51,12 +51,12 @@ (t/isa? #?(:clj clojure.core.rrb_vector.rrbt.Vector :cljs clojure.core.rrb-vector.rrbt.Vector))) -(def +vector? (t/isa|direct? #?(:clj clojure.lang.IPersistentVector +(def +vector? (t/isa?|direct #?(:clj clojure.lang.IPersistentVector :cljs cljs.core/IVector))) (defalias ut/+vector|built-in) -(def !+vector? (t/isa|direct? #?(:clj clojure.lang.ITransientVector +(def !+vector? (t/isa?|direct #?(:clj clojure.lang.ITransientVector :cljs cljs.core/ITransientVector))) (def ?!+vector? (t/or +vector? !+vector?)) diff --git a/test/quantum/test/core/compare.cljc b/test/quantum/test/core/compare.cljc index cc6e70d0..76a5b42f 100644 --- a/test/quantum/test/core/compare.cljc +++ b/test/quantum/test/core/compare.cljc @@ -4,74 +4,6 @@ [quantum.core.test :refer [deftest is testing]])) -(defn test:= - ([x]) - ([x y]) - ([x y & more])) - -(defn test:not= - ([x]) - ([x y]) - ([x y & more])) - -(defn test:< - ([x]) - ([x y]) - ([x y & more])) - -(defn test:<= - ([x] ) - ([x y]) - ([x y & more])) - -(defn test:> - ([x]) - ([x y]) - ([x y & more])) - -(defn test:>= - ([x]) - ([x y]) - ([x y & more])) - -(defn test:max - ([x]) - ([x y]) - ([x y & more])) - -(defn test:min - ([x]) - ([x y]) - ([x y & more])) - -(defn test:min-key - ([k x]) - ([k x y]) - ([k x y & more])) - -(defn test:max-key - ([k x]) - ([k x y]) - ([k x y & more])) - -(defn test:rcompare [x y]) -(defn test:least [coll & [?comparator]]) -(defn test:greatest [coll & [?comparator]]) -(defn test:least-or [a b else]) -(defn test:greatest-or [a b else]) - -(defn test:compare-bytes-lexicographically - [a b]) - -(defn test:extreme-comparator [comparator-n]) - -; ===== APPROXIMATION ===== ; - -(defn test:approx= - [x y eps]) - -(defn test:within-tolerance? [n total tolerance]) - (deftest test:comp-keys-into (is (= [0] (apply ns/comp-keys-into vector #(ns/< %1 %2) identity [0 2 3 4 4 3]))) (is (= [4 4] (apply ns/comp-keys-into vector #(ns/> %1 %2) identity [0 2 3 4 4 3]))) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 63fb1ba6..fb2277ed 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -1,4 +1,6 @@ (ns quantum.test.untyped.core.type + (:refer-clojure :exclude + [boolean? char? double? float? int? string?]) (:require [clojure.core :as core] [quantum.untyped.core.test @@ -9,17 +11,7 @@ #?@(:cljs [:refer [UniversalSetType EmptySetType NotType OrType AndType ProtocolType ClassType - ValueType]])] - [quantum.test.untyped.core.type.compare - :refer [i|>a+b i|>a0 i|>a1 i|>b0 i|>b1 - i|a i|b - i|<0 i|><1 i|><2 - - >a+b >a >b - a b - <0 ><1 ><2]]) + ValueType]])]) #?(:clj (:import [quantum.untyped.core.type.reifications UniversalSetType EmptySetType @@ -44,9 +36,106 @@ #?(:clj (def char-seq? (t/isa? CharSequence))) (def string? (t/isa? #?(:clj String :cljs js/String))) +;; ----- Example interface hierarchy ----- ;; + +(do + +(gen-interface :name i.>a+b) +(gen-interface :name i.>a0) +(gen-interface :name i.>a1) +(gen-interface :name i.>b0) +(gen-interface :name i.>b1) + +(gen-interface :name i.a :extends [i.>a0 i.>a1 i.>a+b]) +(gen-interface :name i.b :extends [i.>b0 i.>b1 i.>a+b]) + +(gen-interface :name i.<0) +(gen-interface :name i.><1) +(gen-interface :name i.><2) + +(def i|>a+b (t/isa? i.>a+b)) +(def i|>a0 (t/isa? i.>a0)) +(def i|>a1 (t/isa? i.>a1)) +(def i|>b0 (t/isa? i.>b0)) +(def i|>b1 (t/isa? i.>b1)) +(def i|a (t/isa? i.a)) +(def i|b (t/isa? i.b)) +(def i|<0 (t/isa? i.><0)) +(def i|><1 (t/isa? i.><1)) +(def i|><2 (t/isa? i.><2)) + +) + +;; ----- Hierarchy within existing non-interfaces ----- ;; + +(do (def >a+b (t/isa? java.util.AbstractCollection)) + (def >a (t/isa? java.util.AbstractList)) + (def >b (t/isa? java.util.AbstractSet)) + (def a (t/isa? java.util.ArrayList)) + (def b (t/isa? java.util.HashSet)) + (def <0 byte?) + (def ><1 short?) + (def ><2 long?)) + +(def Uc (t/isa? java.lang.Object)) + +;; ----- Example protocols ----- ;; + +(do + +(defprotocol AProtocolAll (a-protocol-all [this])) + +(extend-protocol AProtocolAll + nil (a-protocol-all [this]) + Object (a-protocol-all [this])) + +(defprotocol AProtocolString (a-protocol-string [this])) + +(extend-protocol AProtocolString + java.lang.String (a-protocol-string [this])) + +(defprotocol AProtocolNonNil (a-protocol-non-nil [this])) + +(extend-protocol AProtocolNonNil + Object (a-protocol-non-nil [this])) + +(defprotocol AProtocolOnlyNil (a-protocol-only-nil [this])) + +(extend-protocol AProtocolOnlyNil + nil (a-protocol-only-nil [this])) + +(defprotocol AProtocolNone (a-protocol-none [this])) + +(def protocol-types + (->> [AProtocolAll AProtocolString AProtocolNonNil AProtocolOnlyNil AProtocolNone] + (map t/>type) set)) + +) + + +(def C a) ; concrete class +(def A >a+b) ; abstract class +(def I Comparable) ; interface +(def P AProtocolAll) ; protocol + ;; ===== End type predicates ===== ;; -(defn test-equality [genf] +(defn- test-equality [genf] (let [a (genf) b (genf)] (testing "structural equality (`c/=`)" (is= a b)) @@ -275,11 +364,23 @@ (is= (utr/and-type>args (& i|>a+b i|>a0 i|a i|<0 i|><1)) [i|<0 i|><1])))) -(deftest test|protocol - (test-equality #(t/isa? utr/PType))) +(deftest test|isa?|protocol + (test-equality #(t/isa|protocol? P))) -(deftest test|class - (test-equality #(t/isa? Object))) +(deftest test|isa?|class + (test-equality #(t/isa|class? C)) + (test-equality #(t/isa|class? A)) + (test-equality #(t/isa|class? I))) + +(deftest test|isa?|direct + (test-equality #(t/isa|direct? utr/PType)) + (test-equality #(t/isa|direct? Object))) + +(deftest test|isa? + (test-equality #(t/isa? Object)) + (test-equality #(t/isa? clojure.lang.)) + (test-equality #(t/isa? Comparable)) + (test-equality #(t/isa? utr/PType))) (deftest test|value (test-equality #(t/value 1)) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 35ecd808..e61284ad 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -1,6 +1,16 @@ (ns quantum.test.untyped.core.type.compare (:require [clojure.core :as core] + [quantum.test.untyped.core.type + :refer [i|>a+b i|>a0 i|>a1 i|>b0 i|>b1 + i|a i|b + i|<0 i|><1 i|><2 + + >a+b >a >b + a b + <0 ><1 ><2]] [quantum.untyped.core.analyze.expr :as xp :refer [>expr]] [quantum.untyped.core.collections :as c] @@ -50,97 +60,6 @@ (is= 0 (t/compare (t/value 1) (>expr (fn [x] (core/== (long x) 1))))) (is= 0 (t/compare (t/value 1) (>expr (fn [x] (= (long x) 1)))))) -;; ----- Example interface hierarchy ----- ;; - -(do - -(gen-interface :name i.>a+b) -(gen-interface :name i.>a0) -(gen-interface :name i.>a1) -(gen-interface :name i.>b0) -(gen-interface :name i.>b1) - -(gen-interface :name i.a :extends [i.>a0 i.>a1 i.>a+b]) -(gen-interface :name i.b :extends [i.>b0 i.>b1 i.>a+b]) - -(gen-interface :name i.<0) -(gen-interface :name i.><1) -(gen-interface :name i.><2) - -(def i|>a+b (t/isa? i.>a+b)) -(def i|>a0 (t/isa? i.>a0)) -(def i|>a1 (t/isa? i.>a1)) -(def i|>b0 (t/isa? i.>b0)) -(def i|>b1 (t/isa? i.>b1)) -(def i|a (t/isa? i.a)) -(def i|b (t/isa? i.b)) -(def i|<0 (t/isa? i.><0)) -(def i|><1 (t/isa? i.><1)) -(def i|><2 (t/isa? i.><2)) - -) - -;; ----- Hierarchy within existing non-interfaces ----- ;; - -(do (def >a+b (t/isa? java.util.AbstractCollection)) - (def >a (t/isa? java.util.AbstractList)) - (def >b (t/isa? java.util.AbstractSet)) - (def a (t/isa? java.util.ArrayList)) - (def b (t/isa? java.util.HashSet)) - (def <0 t/byte?) - (def ><1 t/short?) - (def ><2 t/long?)) - -(def Uc (t/isa? java.lang.Object)) - -;; ----- Example protocols ----- ;; - -(do - -(defprotocol AProtocolAll (a-protocol-all [this])) - -(extend-protocol AProtocolAll - nil (a-protocol-all [this]) - Object (a-protocol-all [this])) - -(defprotocol AProtocolString (a-protocol-string [this])) - -(extend-protocol AProtocolString - java.lang.String (a-protocol-string [this])) - -(defprotocol AProtocolNonNil (a-protocol-non-nil [this])) - -(extend-protocol AProtocolNonNil - Object (a-protocol-non-nil [this])) - -(defprotocol AProtocolOnlyNil (a-protocol-only-nil [this])) - -(extend-protocol AProtocolOnlyNil - nil (a-protocol-only-nil [this])) - -(defprotocol AProtocolNone (a-protocol-none [this])) - -(def protocol-types - (->> [AProtocolAll AProtocolString AProtocolNonNil AProtocolOnlyNil AProtocolNone] - (map t/>type) set)) - -) - ;; TESTS ;; (defns type>type-combos diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index f670e09e..61ef11e2 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1,6 +1,6 @@ ;; See https://jsperf.com/js-property-access-comparison — all property accesses (at least of length 1) seem to be equal -(ns quantum.core.test.defnt-equivalences +(ns quantum.test.untyped.core.type.defnt (:refer-clojure :exclude [* boolean? char? count double? float? get int? ratio? seq zero?]) (:require From 55e5b3bd8bda70042ff9437605dcc9d4ec31dd17 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 28 Sep 2018 23:49:37 -0600 Subject: [PATCH 345/810] Extend `>form` --- src-untyped/quantum/untyped/core/form.cljc | 25 +++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index 88b8e867..73d7fac2 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -42,7 +42,30 @@ #?(:clj java.lang.String :cljs string) (>form [x] x) #?(:clj clojure.lang.Symbol - :cljs cljs.core.Symbol) (>form [x] (list 'quote x)) + :cljs cljs.core/Symbol) (>form [x] (list 'quote x)) + #?(:clj clojure.lang.Keyword + :cljs cljs.core/Keyword) (>form [x] x) + + #?(:clj clojure.lang.PersistentArrayMap + :cljs cljs.core/PersistentArrayMap) + (>form [x] (->> x (map (fn [[k v]] [(>form k) (>form v)])) (into (array-map)))) + + #?(:clj clojure.lang.PersistentHashMap + :cljs cljs.core/PersistentHashMap) + (>form [x] (->> x (map (fn [[k v]] [(>form k) (>form v)])) (into (hash-map)))) + + #?(:clj clojure.lang.PersistentVector + :cljs cljs.core/PersistentVector) + (>form [x] (->> x (mapv >form))) + + #?(:clj clojure.lang.PersistentList + :cljs cljs.core/PersistentList) + (>form [x] (->> x (map >form) list*)) + + #?(:clj clojure.lang.Var + :cljs cljs.core/Var) + (>form [x] #?(:clj (list 'var (symbol (-> x .-ns ns-name name) (-> x .-sym name))) + :cljs (.-sym x))) #?@(:clj [clojure.lang.Fn (>form [x] ;; TODO can probably use uconv to good effect here From 5f6667284371df28db8ec1264743458066dd8d7c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 28 Sep 2018 23:52:43 -0600 Subject: [PATCH 346/810] Ensure tests pass --- src-untyped/quantum/untyped/core/type.cljc | 6 ++-- test/quantum/test/untyped/core/type.cljc | 38 ++++++++++++---------- 2 files changed, 25 insertions(+), 19 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index f2ca338e..2fe79acf 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -8,7 +8,7 @@ boolean? byte? bytes? char? short? int? long? float? double? isa? nil? any? class? tagged-literal? #?(:cljs object?) - true? false? keyword? symbol? + true? false? keyword? string? symbol? fn? ifn? meta ref @@ -212,7 +212,9 @@ (isa?|protocol x) (#?(:clj c/class? :cljs c/fn?) x) - (isa?|class x))) + (isa?|class x) + + (throw (ex-info "`isa?` cannot be applied to" {:x x})))) (defn isa?|direct [x] (if (uclass/protocol? x) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index fb2277ed..e3c4cd9f 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -128,8 +128,8 @@ ) -(def C a) ; concrete class -(def A >a+b) ; abstract class +(def C java.util.AbstractCollection) ; concrete class +(def A java.util.AbstractCollection) ; abstract class (def I Comparable) ; interface (def P AProtocolAll) ; protocol @@ -146,11 +146,15 @@ (testing "collection equality" (is= 1 (count (hash-set a b)))))) +(defn- gen-meta [] {(rand) (rand)}) + (deftest test|universal-set - (test-equality #(UniversalSetType.))) + (test-equality #(UniversalSetType. nil)) + (test-equality #(UniversalSetType. (gen-meta)))) (deftest test|empty-set - (test-equality #(EmptySetType.))) + (test-equality #(EmptySetType. nil)) + (test-equality #(EmptySetType. (gen-meta)))) (deftest test|not (test-equality #(! (t/value 1))) @@ -240,8 +244,8 @@ (| double? char-seq?))) [double? char-seq?]) (is= (utr/or-type>args (| (| string? double?) - (| char-seq? t/number?))) - [char-seq? t/number?])) + (| char-seq? (t/isa? Number)))) + [char-seq? (t/isa? Number)])) (testing "#{<+ =} -> #{<+}" (is= (utr/or-type>args (| i|>a+b i|>a0 i|a)) [i|>a+b i|>a0])) @@ -365,22 +369,22 @@ [i|<0 i|><1])))) (deftest test|isa?|protocol - (test-equality #(t/isa|protocol? P))) + (test-equality #(@#'t/isa?|protocol P))) (deftest test|isa?|class - (test-equality #(t/isa|class? C)) - (test-equality #(t/isa|class? A)) - (test-equality #(t/isa|class? I))) + (test-equality #(@#'t/isa?|class C)) + (test-equality #(@#'t/isa?|class A)) + (test-equality #(@#'t/isa?|class I))) -(deftest test|isa?|direct - (test-equality #(t/isa|direct? utr/PType)) - (test-equality #(t/isa|direct? Object))) +#_(deftest test|isa?|direct + (test-equality #(t/isa?|direct utr/PType)) + (test-equality #(t/isa?|direct Object))) (deftest test|isa? - (test-equality #(t/isa? Object)) - (test-equality #(t/isa? clojure.lang.)) - (test-equality #(t/isa? Comparable)) - (test-equality #(t/isa? utr/PType))) + (test-equality #(t/isa? C)) + (test-equality #(t/isa? A)) + (test-equality #(t/isa? I)) + (test-equality #(t/isa? P))) (deftest test|value (test-equality #(t/value 1)) From df1432a00b8119aa01636b2a27a784ded2ad30e8 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 00:05:19 -0600 Subject: [PATCH 347/810] Add `DirectProtocolType` and do `t/isa?|direct` --- src-untyped/quantum/untyped/core/type.cljc | 21 +++---- .../untyped/core/type/reifications.cljc | 56 +++++++++++++++---- test/quantum/test/untyped/core/type.cljc | 9 ++- 3 files changed, 58 insertions(+), 28 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 2fe79acf..009c1570 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -54,7 +54,7 @@ :refer [->AndType ->OrType PType #?@(:cljs [UniversalSetType EmptySetType NotType OrType AndType - ProtocolType ClassType + ProtocolType DirectProtocolType ClassType ValueType])]] [quantum.untyped.core.vars :as uvar :refer [def- defmacro- update-meta]]) @@ -74,16 +74,6 @@ ;; ===== TODOS ===== ;; -#_(defmacro -> - ("Anything that is coercible to x" - [x] - ...) - ("Anything satisfying `from` that is coercible to `to`. - Will be coerced to `to`." - [from to])) - -#_(defmacro range-of) - (declare - create-logical-type nil? val? and or val|by-class?) @@ -162,6 +152,10 @@ (defns- isa?|protocol [p uclass/protocol?] (ProtocolType. uhash/default uhash/default nil p nil)) +#?(:cljs +(defns- isa?|protocol|direct [p uclass/protocol?] + (DirectProtocolType. uhash/default uhash/default nil p nil))) + ;; ----- ClassType ----- ;; (defns- isa?|class [c #?(:clj c/class? :cljs c/fn?)] @@ -218,7 +212,8 @@ (defn isa?|direct [x] (if (uclass/protocol? x) - #?(:clj (isa?|class (uclass/protocol>class x))) + #?(:clj (isa?|class (uclass/protocol>class x)) + :cljs (isa?|protocol|direct x)) (isa? x))) ;; TODO clean up @@ -689,7 +684,7 @@ ;; Used by `quantum.untyped.core.analyze` (def literal? - (or nil? boolean? symbol? keyword? str? #?(:clj long?) double? regex? #?(:clj tagged-literal?))) + (or nil? boolean? symbol? keyword? string? #?(:clj long?) double? regex? #?(:clj tagged-literal?))) ;; TODO this might not be right — quite possibly any seq is a valid form ;; TODO this has to be recursively true for seq, vector, map, and set diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index f3b55219..c8b064ae 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -71,8 +71,8 @@ ;; ----- NotType (`t/not` / `t/!`) ----- ;; (udt/deftype NotType - [^int ^:unsynchronized-mutable hash - ^int ^:unsynchronized-mutable hash-code + [#?(:clj ^int ^:unsynchronized-mutable hash :cljs ^number ^:mutable hash) + #?(:clj ^int ^:unsynchronized-mutable hash-code :cljs ^number ^:mutable hash-code) meta #_(t/? ::meta) t #_t/type?] {PType nil @@ -96,8 +96,8 @@ ;; ----- OrType (`t/or` / `t/|`) ----- ;; (udt/deftype OrType - [^int ^:unsynchronized-mutable hash - ^int ^:unsynchronized-mutable hash-code + [#?(:clj ^int ^:unsynchronized-mutable hash :cljs ^number ^:mutable hash) + #?(:clj ^int ^:unsynchronized-mutable hash-code :cljs ^number ^:mutable hash-code) meta #_(t/? ::meta) args #_(t/and t/indexed? (t/seq t/type?)) *logical-complement] @@ -127,8 +127,8 @@ ;; ----- AndType (`t/and` | `t/&`) ----- ;; (udt/deftype AndType - [^int ^:unsynchronized-mutable hash - ^int ^:unsynchronized-mutable hash-code + [#?(:clj ^int ^:unsynchronized-mutable hash :cljs ^number ^:mutable hash) + #?(:clj ^int ^:unsynchronized-mutable hash-code :cljs ^number ^:mutable hash-code) meta #_(t/? ::meta) args #_(t/and t/indexed? (t/seq t/type?)) *logical-complement] @@ -160,8 +160,8 @@ ;; ----- ProtocolType ----- ;; (udt/deftype ProtocolType - [^int ^:unsynchronized-mutable hash - ^int ^:unsynchronized-mutable hash-code + [#?(:clj ^int ^:unsynchronized-mutable hash :cljs ^number ^:mutable hash) + #?(:clj ^int ^:unsynchronized-mutable hash-code :cljs ^number ^:mutable hash-code) meta #_(t/? ::meta) p #_t/protocol? name #_(t/? symbol?)] @@ -185,11 +185,43 @@ (defns protocol-type>protocol [t protocol-type?] (.-p ^ProtocolType t)) +;; ----- DirectProtocolType ----- ;; + +#?(:cljs +(udt/deftype + ^{:doc "Differs from `ProtocolType` in that an `implements?` check is performed instead of a + `satisfies?` check, i.e. native-type protocol dispatch is ignored."} + DirectProtocolType + [^number ^:mutable hash + ^number ^:mutable hash-code + meta #_(t/? ::meta) + p #_t/protocol? + name #_(t/? symbol?)] + {PType nil + ?Fn {invoke ([_ x] (implements? p x))} + ?Meta {meta ([this] meta) + with-meta ([this meta'] (ProtocolType. hash hash-code meta' p name))} + ?Hash {hash ([this] (uhash/caching-set-ordered! hash ProtocolType p))} + ?Object {hash-code ([this] (uhash/caching-set-code! hash-code ProtocolType p)) + equals ([this that #_any?] + (or (== this that) + (and (instance? ProtocolType that) + (= p (.-p ^ProtocolType that)))))} + uform/PGenForm {>form ([this] (with-meta + (list 'quantum.untyped.core.type/isa?|protocol (:on p)) + meta))} + fedn/IOverride nil + fedn/IEdn {-edn ([this] (or name (>form this)))}})) + +#?(:cljs (defns direct-protocol-type? [x _] (instance? DirectProtocolType x))) + +#?(:cljs (defns direct-protocol-type>protocol [t direct-protocol-type?] (.-p t))) + ;; ----- ClassType ----- ;; (udt/deftype ClassType - [^int ^:unsynchronized-mutable hash - ^int ^:unsynchronized-mutable hash-code + [#?(:clj ^int ^:unsynchronized-mutable hash :cljs ^number ^:mutable hash) + #?(:clj ^int ^:unsynchronized-mutable hash-code :cljs ^number ^:mutable hash-code) meta #_(t/? ::meta) ^Class c #_t/class? name #_(t/? symbol?)] @@ -215,8 +247,8 @@ ;; ----- ValueType ----- ;; (udt/deftype ValueType - [^int ^:unsynchronized-mutable hash - ^int ^:unsynchronized-mutable hash-code + [#?(:clj ^int ^:unsynchronized-mutable hash :cljs ^number ^:mutable hash) + #?(:clj ^int ^:unsynchronized-mutable hash-code :cljs ^number ^:mutable hash-code) meta #_(t/? ::meta) v #_any?] {PType nil diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index e3c4cd9f..379b9cd2 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -376,9 +376,12 @@ (test-equality #(@#'t/isa?|class A)) (test-equality #(@#'t/isa?|class I))) -#_(deftest test|isa?|direct - (test-equality #(t/isa?|direct utr/PType)) - (test-equality #(t/isa?|direct Object))) +(deftest test|isa?|direct + (test-equality #(t/isa?|direct C)) + (test-equality #(t/isa?|direct A)) + (test-equality #(t/isa?|direct I)) + (test-equality #(t/isa?|direct P)) + #?(:clj (is (= (t/isa?|direct P) (t/isa? quantum.test.untyped.core.type.AProtocolAll))))) (deftest test|isa? (test-equality #(t/isa? C)) From 98c2a3ff5da5cd81913aae6b5e2d65987d8f5230 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 00:15:22 -0600 Subject: [PATCH 348/810] Fix some references --- resources-dev/defnt.cljc | 8 +- test/quantum/test/untyped/core/type.cljc | 29 +++--- .../test/untyped/core/type/compare.cljc | 91 ++++++++++--------- 3 files changed, 66 insertions(+), 62 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index d3be387c..7b40c776 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -61,14 +61,10 @@ TODO: Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - - t/isa?|direct - - For CLJ, this is `instance?` for classes and `instance?` on the underlying interface - associated with a protocol - - For CLJS, this is `instance?` for classes and `implements?` for protocols - t/type >>>>>> (PRIORITY 1) <<<<<< - dependent types: `[x arr/array? > (t/type x)]` - - (t/== x) - - dependent type such that the passed input must be identical to x + - (comp/t== x) + - dependent type such that the passed input must be identical to x - Analysis - This is accepted by the type system without knowing the type: (java.math.BigInteger. 1 (-> (ByteBuffer/allocate (int 8)) (.putLong x) .array)) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 379b9cd2..0b577ed8 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -22,19 +22,22 @@ ;; ===== Type predicates ===== ;; ;; Declared here instead of in `quantum.untyped.core.type` to avoid dependency -#?(:clj (def boolean? (t/isa? #?(:clj Boolean :cljs js/Boolean)))) -#?(:clj (def byte? (t/isa? Byte))) -#?(:clj (def short? (t/isa? Short))) -#?(:clj (def char? (t/isa? Character))) -#?(:clj (def int? (t/isa? Integer))) -#?(:clj (def long? (t/isa? Long))) -#?(:clj (def float? (t/isa? Float))) - (def double? (t/isa? #?(:clj Double :cljs js/Number))) - - (def primitive? (t/or boolean? #?@(:clj [byte? short? char? int? long? float?]) double?)) - -#?(:clj (def char-seq? (t/isa? CharSequence))) - (def string? (t/isa? #?(:clj String :cljs js/String))) +#?(:clj (def boolean? (t/isa? #?(:clj Boolean :cljs js/Boolean)))) +#?(:clj (def byte? (t/isa? Byte))) +#?(:clj (def short? (t/isa? Short))) +#?(:clj (def char? (t/isa? Character))) +#?(:clj (def int? (t/isa? Integer))) +#?(:clj (def long? (t/isa? Long))) +#?(:clj (def float? (t/isa? Float))) + (def double? (t/isa? #?(:clj Double :cljs js/Number))) + + (def primitive? (t/or boolean? #?@(:clj [byte? short? char? int? long? float?]) double?)) + +#?(:clj (def char-seq? (t/isa? CharSequence))) + (def string? (t/isa? #?(:clj String :cljs js/String))) + +#?(:clj (def comparable? (t/isa? Comparable))) +#?(:clj (def java-set? (t/isa? java.util.Set))) ;; ----- Example interface hierarchy ----- ;; diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index e61284ad..c593ecfe 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -1,7 +1,7 @@ (ns quantum.test.untyped.core.type.compare (:require [clojure.core :as core] - [quantum.test.untyped.core.type + [quantum.test.untyped.core.type :as tt :refer [i|>a+b i|>a0 i|>a1 i|>b0 i|>b1 i|a i|b i|a+b >a >b a b <0 ><1 ><2]] + ><0 ><1 ><2 + + AProtocolAll AProtocolNone AProtocolString AProtocolNonNil AProtocolOnlyNil + protocol-types + + Uc C A I P]] [quantum.untyped.core.analyze.expr :as xp :refer [>expr]] [quantum.untyped.core.collections :as c] @@ -465,15 +470,15 @@ (test-comparison <>ident a (| ><0 ><1))) (testing "Nilable" (testing "< nilabled: #{< <>}" - (test-comparison }" - (test-comparison nilabled: #{> <>}" - (test-comparison >< nilabled: #{>< <>}" - (test-comparison > nilabled: #{<>}" - (test-comparison <>ident t/long? (t/? t/string?))))) + (test-comparison <>ident t/long? (t/? t/string?))))) (testing "+ ValueType" (testing "arg <" (testing "+ arg <") @@ -502,11 +507,11 @@ (testing "+ ClassType" (testing "#{<}" (testing "Boxed Primitive" - (test-comparison <}" (test-comparison >a+b i|>a0 i|>a1 i|><0 i|><1))) (testing "#{< >< <>}" - (test-comparison >}" - (test-comparison <>ident t/string? (& t/char-seq? t/java-set?)) + (test-comparison <>ident t/string? (& tt/char-seq? tt/java-set?)) (test-comparison <>ident ><0 (& (! ><1) (! ><0))) (test-comparison <>ident a (& (! a) (! b)))) #_(testing "#{=}") ; Impossible for `AndType` @@ -542,30 +547,30 @@ #_(testing "#{= > <>}") ; Impossible for `AndType` (testing "#{= ><}" (test-comparison >ident i|a (& i|a i|><0 i|><1)) - (test-comparison >ident t/char-seq? (& t/char-seq? t/java-set?)) - (test-comparison >ident t/char-seq? (& t/char-seq? t/java-set? a))) + (test-comparison >ident tt/char-seq? (& tt/char-seq? tt/java-set?)) + (test-comparison >ident tt/char-seq? (& tt/char-seq? tt/java-set? a))) (testing "#{= >< <>}") ; <- TODO comparison should be >ident ;; TODO fix (testing "#{= <>}" - (test-comparison >ident a (& a t/java-set?))) + (test-comparison >ident a (& a tt/java-set?))) (testing "#{>}" (test-comparison >ident i|a (& i| ><}" (test-comparison ><0 i|><1)) - (test-comparison > >< <>}" (test-comparison ><0 a))) (testing "#{> <>}") ; <- TODO comparison should be 1 (testing "#{><}" (test-comparison ><0 i|><1)) - (test-comparison >< <>}") ; <- TODO comparison should be 3 (testing "#{<>}" - (test-comparison <>ident t/string? (& a t/java-set?)))) + (test-comparison <>ident t/string? (& a tt/java-set?)))) (testing "+ ValueType" (testing "#{<}" - (test-comparison }") ; not possible for `AndType`; `>` not possible for `ValueType` #_(testing "#{< = > ><}") ; not possible for `AndType`; `>` and `><` not possible for `ValueType` @@ -581,8 +586,8 @@ #_(testing "#{< ><}") ; `><` not possible for `ValueType` #_(testing "#{< >< <>}") ; `><` not possible for `ValueType` (testing "#{< <>}" - (test-comparison <>ident (t/value "a") (& t/char-seq? a)) - (test-comparison <>ident (t/value "a") (& t/char-seq? t/java-set?))) + (test-comparison <>ident (t/value "a") (& tt/char-seq? a)) + (test-comparison <>ident (t/value "a") (& tt/char-seq? tt/java-set?))) #_(testing "#{=}") ; not possible for `AndType` #_(testing "#{= >}") ; not possible for `AndType`; `>` not possible for `ValueType` #_(testing "#{= > ><}") ; not possible for `AndType`; `>` and `><` not possible for `ValueType` @@ -598,7 +603,7 @@ #_(testing "#{><}") ; `><` not possible for `ValueType` #_(testing "#{>< <>}") ; `><` not possible for `ValueType` (testing "#{<>}" - (test-comparison <>ident (t/value "a") (& a t/java-set?))))) + (test-comparison <>ident (t/value "a") (& a tt/java-set?))))) (testing "Expression" (testing "+ Expression") (testing "+ ProtocolType") @@ -611,7 +616,7 @@ (testing "+ ClassType") (testing "+ ValueType" (let [values #{t/universal-set t/empty-set nil {} 1 "" AProtocolAll - quantum.test.untyped.core.type.compare.AProtocolAll}] + quantum.test.untyped.core.type.AProtocolAll}] (doseq [v values] (test-comparison ident t/long? t/int?)) + (test-comparison =ident tt/long? tt/long?) + (test-comparison <>ident tt/long? tt/int?)) (testing "Boxed Primitive + Final Concrete" - (test-comparison <>ident t/long? t/string?)) + (test-comparison <>ident tt/long? t/string?)) (testing "Boxed Primitive + Extensible Concrete" (testing "< , >" - (test-comparison " - (test-comparison <>ident t/long? (t/isa? Thread)))) + (test-comparison <>ident tt/long? (t/isa? Thread)))) (testing "Boxed Primitive + Abstract" - (test-comparison <>ident t/long? (t/isa? java.util.AbstractCollection))) + (test-comparison <>ident tt/long? (t/isa? java.util.AbstractCollection))) (testing "Boxed Primitive + Interface" - (test-comparison <>ident t/long? t/char-seq?)) + (test-comparison <>ident tt/long? tt/char-seq?)) (testing "Final Concrete + Final Concrete" - (test-comparison =ident t/string? t/string?)) + (test-comparison =ident tt/string? tt/string?)) (testing "Final Concrete + Extensible Concrete" (testing "< , >" (test-comparison " - (test-comparison " - (test-comparison <>ident t/string? t/java-coll?))) + (test-comparison <>ident t/string? (t/isa? java.util.Collection)))) (testing "Extensible Concrete + Extensible Concrete" (test-comparison =ident t/object? t/object?) (testing "< , >" @@ -671,7 +676,7 @@ (test-comparison <>ident (t/isa? Thread) (t/isa? java.util.AbstractCollection)) (test-comparison <>ident (t/isa? java.util.AbstractCollection) (t/isa? Thread)))) (testing "Extensible Concrete + Interface" - (test-comparison >" @@ -680,20 +685,20 @@ (test-comparison <>ident (t/isa? java.util.AbstractList) (t/isa? java.util.AbstractQueue)))) (testing "Abstract + Interface" (testing "< , >" - (test-comparison <" - (test-comparison >", - (test-comparison <" - (test-comparison >" (test-comparison <>ident (t/value "a") t/byte?)))) @@ -715,9 +720,9 @@ (deftest test|= ;; Takes an inordinately long time to do `test-comparison 0 ...` even without instrumentation - (is= (| t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) - (& (| t/boolean? t/byte? t/char? t/short? t/int? t/long? t/float? t/double?) - (! t/boolean?))) + (is= (| tt/byte? tt/char? tt/short? tt/int? tt/long? tt/float? tt/double?) + (& (| tt/boolean? tt/byte? tt/char? tt/short? tt/int? tt/long? tt/float? tt/double?) + (! tt/boolean?))) (test-comparison 0 t/any? t/universal-set) (testing "universal class(-set) identity" (is (t/= t/val? (& t/any? t/val?))))) From 6ae332472e9193cbcedc19af1a8587e40f71429f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 08:28:36 -0600 Subject: [PATCH 349/810] Trying to standardize some test nss --- src-untyped/quantum/untyped/core/analyze.cljc | 2 +- .../quantum/untyped/core/type/defnt.cljc | 26 ++-- test/quantum/test/untyped/core/type.cljc | 6 +- .../quantum/test/untyped/core/type/defnt.cljc | 129 ++++++++---------- 4 files changed, 74 insertions(+), 89 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 6f56757e..74f3f012 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -324,7 +324,7 @@ (defns classes>class "Ensure that given a set of classes, that set consists of at most a class C and nil. If so, returns C. Otherwise, throws." - [cs (s/set-of (s/? class?)) > class?] + [cs (s/set-of (s/nilable class?)) > class?] (let [cs' (disj cs nil)] (if (-> cs' count (= 1)) (first cs') diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 102f872b..0b873790 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -60,7 +60,7 @@ ;; Internal specs -(s/def ::expanded-overload|arg-classes (s/vec-of t/class?)) +(s/def ::expanded-overload|arg-classes (s/vec-of class?)) (s/def ::expanded-overload|arg-types (s/seq-of t/type?)) ;; This is the overload after the input specs are split by their respective `t/or` constituents, @@ -72,7 +72,7 @@ :arglist-code|fn|hinted t/any? :arglist-code|reify|unhinted t/any? :body-form t/any? - :out-class (? t/class?) + :out-class (? class?) :out-type t/type? :positional-args-ct (s/and integer? #(>= % 0)) ;; When present, varargs are considered to be of class Object @@ -174,15 +174,15 @@ (defns class>simplest-class "This ensures that special overloads are not created for non-primitive subclasses of java.lang.Object (e.g. String, etc.)." - [c (? t/class?) > (? t/class?)] + [c (? class?) > (? class?)] (if (t/primitive-class? c) c java.lang.Object))) #?(:clj -(defns class>most-primitive-class [c (? t/class?), nilable? t/boolean? > (? t/class?)] +(defns class>most-primitive-class [c (? class?), nilable? t/boolean? > (? class?)] (if nilable? c (or (tcore/boxed->unboxed c) c)))) #?(:clj -(defns type>most-primitive-classes [t t/type? > (s/set-of (? t/class?))] +(defns type>most-primitive-classes [t t/type? > (s/set-of (? class?))] (let [cs (t/type>classes t) nilable? (or (-> t meta :quantum.core.type/ref?) (contains? cs nil))] (->> cs @@ -190,7 +190,7 @@ (r/join #{}))))) #?(:clj -(defns out-type>class [t t/type? > (? t/class?)] +(defns out-type>class [t t/type? > (? class?)] (if (-> t meta :quantum.core.type/ref?) java.lang.Object (let [cs (t/type>classes t) @@ -242,7 +242,7 @@ {:as opts :keys [lang _]} ::opts arg-bindings _ arg-types|satisfying-primitivization (s/vec-of t/type?) - arg-classes (s/vec-of t/class?) + arg-classes (s/vec-of class?) varargs-binding _ > ::expanded-overload] (let [;; Not sure if `nil` is the right approach for the value @@ -306,7 +306,7 @@ (mapv (fn [arg-classes #_::expanded-overload|arg-classes] (let [arg-types|satisfying-primitivization (c/mergev-with - (fn [_ t #_t/type? c #_t/class?] + (fn [_ t #_t/type? c #_class?] (cond-> t (t/primitive-class? c) (t/and c))) arg-types|expanded arg-classes)] (>expanded-overload overload-data fnt-globals opts @@ -367,7 +367,7 @@ (def fnt-method-sym 'invoke) -(defns- class>interface-part-name [c t/class? > string?] +(defns- class>interface-part-name [c class? > string?] (if (= c java.lang.Object) "Object" (let [illegal-pattern #"\|\+"] @@ -375,12 +375,12 @@ (err! "Class cannot contain pattern" {:class c :pattern illegal-pattern}) (-> c >name (str/replace "." "|")))))) -(defns fnt-overload>interface-sym [args-classes (s/seq-of t/class?), out-class t/class? > symbol?] +(defns fnt-overload>interface-sym [args-classes (s/seq-of class?), out-class class? > symbol?] (>symbol (str (->> args-classes (c/lmap class>interface-part-name) (str/join "+")) ">" (class>interface-part-name out-class)))) ;; TODO finish specing args -(defns fnt-overload>interface [args-classes _, out-class t/class?, gen-gensym fn?] +(defns fnt-overload>interface [args-classes _, out-class class?, gen-gensym fn?] (let [interface-sym (fnt-overload>interface-sym args-classes out-class) hinted-method-sym (ufth/with-type-hint fnt-method-sym (ufth/>interface-method-tag out-class)) @@ -393,7 +393,7 @@ #?(:clj (defns expanded-overload>reify-overload [{:as overload - :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, out-class t/class?]} + :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, out-class class?]} ::expanded-overload {:as opts :keys [gen-gensym _]} ::opts > ::reify|overload] @@ -482,7 +482,7 @@ ;; dynamic for testing purposes (def ^:dynamic **class>shorthand-tag|cache* *class>shorthand-tag|cache) -(defns class>shorthand-tag [c t/class?] +(defns class>shorthand-tag [c class?] (or (c/get @**class>shorthand-tag|cache* c) (-> (swap! **class>shorthand-tag|cache* (fn [{:as m :keys [remaining]}] diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 0b577ed8..343d300a 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -1,6 +1,6 @@ (ns quantum.test.untyped.core.type (:refer-clojure :exclude - [boolean? char? double? float? int? string?]) + [boolean? char? double? float? int? ratio? string?]) (:require [clojure.core :as core] [quantum.untyped.core.test @@ -33,6 +33,10 @@ (def primitive? (t/or boolean? #?@(:clj [byte? short? char? int? long? float?]) double?)) +#?(:clj (def comparable-primitive? (t/- primitive? boolean?))) + +#?(:clj (def ratio? (t/isa? clojure.lang.Ratio))) + #?(:clj (def char-seq? (t/isa? CharSequence))) (def string? (t/isa? #?(:clj String :cljs js/String))) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 61ef11e2..3faa2477 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -2,8 +2,9 @@ (ns quantum.test.untyped.core.type.defnt (:refer-clojure :exclude - [* boolean? char? count double? float? get int? ratio? seq zero?]) + [* count get seq]) (:require + [quantum.test.untyped.core.type :as tt] [quantum.untyped.core.type.defnt :as self :refer [fnt unsupported!]] [quantum.untyped.core.data.array @@ -27,26 +28,6 @@ [quantum.core.data Array] [quantum.core Numeric Primitive])) -;; ===== Type predicates ===== ;; -;; Declared here instead of in `quantum.untyped.core.type` to avoid dependency - -#?(:clj (def ratio? (t/isa? clojure.lang.Ratio))) - -#?(:clj (def boolean? (t/isa? #?(:clj Boolean :cljs js/Boolean)))) -#?(:clj (def byte? (t/isa? Byte))) -#?(:clj (def short? (t/isa? Short))) -#?(:clj (def char? (t/isa? Character))) -#?(:clj (def int? (t/isa? Integer))) -#?(:clj (def long? (t/isa? Long))) -#?(:clj (def float? (t/isa? Float))) - (def double? (t/isa? #?(:clj Double :cljs js/Number))) - - (def primitive? (t/or boolean? #?@(:clj [byte? short? char? int? long? float?]) double?)) - -#?(:clj (def comparable-primitive? (t/- primitive? boolean?))) - -;; ===== End type predicates ===== ;; - ;; Just in case (clojure.spec.test.alpha/unstrument) (do (require '[orchestra.spec.test :as st]) @@ -326,13 +307,13 @@ (let [actual (macroexpand ' (self/defn #_:inline >boolean - ([x boolean?] x) - ([x t/nil?] false) - ([x t/any?] true))) + ([x tt/boolean?] x) + ([x t/nil?] false) + ([x t/any?] true))) expected (case (env-lang) :clj - ($ (do ;; [x boolean?] + ($ (do ;; [x tt/boolean?] (def ~(tag "[Ljava.lang.Object;" '>boolean|__0|input0|types) (*<> (t/isa? Boolean))) @@ -340,7 +321,7 @@ (reify* [boolean>boolean] (~(tag "boolean" 'invoke) [~'_0__ ~(tag "boolean" 'x)] ~'x))) - ;; [x t/nil? -> (- t/nil? boolean?)] + ;; [x t/nil? -> (- t/nil? tt/boolean?)] (def ~(tag "[Ljava.lang.Object;" '>boolean|__1|input0|types) (*<> (t/value nil))) @@ -348,7 +329,7 @@ (reify* [Object>boolean] (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false))) - ;; [x t/any? -> (- t/any? t/nil? boolean?)] + ;; [x t/any? -> (- t/any? t/nil? tt/boolean?)] (def ~(tag "[Ljava.lang.Object;" '>boolean|__2|input0|types) (*<> t/any?)) @@ -368,7 +349,7 @@ (defn ~'>boolean {:quantum.core.type/type (t/fn t/any? - ~'[boolean?] + ~'[tt/boolean?] ~'[t/nil?] ~'[t/any?])} ([~'x00__] @@ -382,7 +363,7 @@ (unsupported! `>boolean [~'x00__] 0)))))) :cljs ($ (do (defn ~'>boolean [~'x] - (ifs (boolean? x) x + (ifs (tt/boolean? x) x (nil? x) false true)))))] (testing "code equivalence" (is-code= actual expected)) @@ -405,13 +386,13 @@ (macroexpand ' ;; Auto-upcasts to long or double (because 64-bit) unless you tell it otherwise ;; Will error if not all return values can be safely converted to the return spec - (self/defn #_:inline >int* > int? - ([x (t/- primitive? boolean?)] (Primitive/uncheckedIntCast x)) + (self/defn #_:inline >int* > tt/int? + ([x (t/- tt/primitive? tt/boolean?)] (Primitive/uncheckedIntCast x)) ([x (t/ref (t/isa? Number))] (.intValue x)))) expected (case (env-lang) :clj - ($ (do ;; [x (t/- primitive? boolean?)] + ($ (do ;; [x (t/- tt/primitive? tt/boolean?)] ;; These are non-primitivized (def ~(tag "[Ljava.lang.Object;" '>int*|__0|input0|types) @@ -452,7 +433,7 @@ ~'(. Primitive uncheckedIntCast x)))) ;; [x (t/ref (t/isa? Number)) - ;; -> (t/- (t/ref (t/isa? Number)) (t/- primitive? boolean?))] + ;; -> (t/- (t/ref (t/isa? Number)) (t/- tt/primitive? tt/boolean?))] (def ~(tag "[Ljava.lang.Object;" '>int*|__1|input0|types) (*<> ~(with-meta `(t/isa? Number) {:quantum.core.type/ref? true}))) @@ -463,8 +444,8 @@ (defn ~'>int* {:quantum.core.type/type - (t/fn ~'int? - ~'[(t/- primitive? boolean?)] + (t/fn ~'tt/int? + ~'[(t/- tt/primitive? tt/boolean?)] ~'[(t/ref (t/isa? Number))])} ([~'x00__] (ifs ((Array/get ~'>int*|__0|input0|types 0) ~'x00__) @@ -504,14 +485,14 @@ (self/defn #_:inline >|test ;; This is admittedly a place where inference might be nice, but luckily ;; there are no "sparse" combinations - #?(:clj ([a comparable-primitive? b comparable-primitive? > boolean?] + #?(:clj ([a comparable-primitive? b comparable-primitive? > tt/boolean?] (Numeric/gt a b)) - :cljs ([a double? b double? > (t/assume boolean?)] + :cljs ([a double? b double? > (t/assume tt/boolean?)] (cljs.core/> a b))))) expected (case (env-lang) :clj - ($ (do ;; [a t/comparable-primitive? b t/comparable-primitive? > boolean?] + ($ (do ;; [a t/comparable-primitive? b t/comparable-primitive? > tt/boolean?] ;; These are non-primitivized (def ~(tag "[Ljava.lang.Object;" '>|test|__0|input0|types) @@ -732,9 +713,9 @@ {:quantum.core.type/type (t/fn t/any? #?(:clj ~'[comparable-primitive? comparable-primitive? - :> boolean?] + :> tt/boolean?] :cljs ~'[double? double? - :> (t/assume boolean?)]))} + :> (t/assume tt/boolean?)]))} ([~'x00__ ~'x10__] (ifs ((Array/get ~'>|test|__0|input0|types 0) ~'x00__) @@ -878,11 +859,11 @@ (self/defn #_:inline >long* {:source "clojure.lang.RT.uncheckedLongCast"} > long? - ([x (t/- primitive? boolean?)] (Primitive/uncheckedLongCast x)) + ([x (t/- tt/boolean? tt/boolean?)] (Primitive/uncheckedLongCast x)) ([x (t/ref (t/isa? Number))] (.longValue x)))) expected (case (env-lang) - :clj ($ (do ;; [x (t/- primitive? boolean?)] + :clj ($ (do ;; [x (t/- tt/boolean? tt/boolean?)] (def ~(tag "[Ljava.lang.Object;" '>long*|__0|input0|types) (*<> (t/isa? java.lang.Byte) @@ -934,7 +915,7 @@ {:source "clojure.lang.RT.uncheckedLongCast" :quantum.core.type/type (t/fn ~'long? - ~'[(t/- primitive? boolean?)] + ~'[(t/- tt/boolean? tt/boolean?)] ~'[(t/ref (t/isa? Number))])} ([~'x00__] (ifs @@ -974,11 +955,11 @@ (let [actual (macroexpand ' (self/defn ref-output-type - ([x boolean? > (t/ref boolean?)] (Boolean. x)) - ([x byte? > (t/ref byte?)] (Byte. x)))) + ([x tt/boolean? > (t/ref tt/boolean?)] (Boolean. x)) + ([x byte? > (t/ref byte?)] (Byte. x)))) expected (case (env-lang) - :clj ($ (do ;; [x boolean? > (t/ref boolean?)] + :clj ($ (do ;; [x tt/boolean? > (t/ref tt/boolean?)] (def ~(tag "[Ljava.lang.Object;" 'ref-output-type|__0|input0|types) (*<> (t/isa? java.lang.Boolean))) @@ -997,8 +978,8 @@ (defn ~'ref-output-type {:quantum.core.type/type (t/fn t/any? - ~'[boolean? :> (t/ref boolean?)] - ~'[byte? :> (t/ref byte?)])} + ~'[tt/boolean? :> (t/ref tt/boolean?)] + ~'[byte? :> (t/ref byte?)])} ([~'x00__] (ifs ((Array/get ~'ref-output-type|__0|input0|types 0) ~'x00__) @@ -1028,11 +1009,11 @@ (eval '(do (is (identical? (defnt-reference) 1))))))) (deftest defnt-assume-test - (throws (eval '(self/defn defnt-assume-0 [> (t/assume t/int?)] "asd"))) - (throws (eval '(self/defn defnt-assume-1 [> (t/assume t/int?)] nil))) - (is= nil (do (eval '(self/defn defnt-assume-2 [> (t/assume t/int?)] (Object.))) + (throws (eval '(self/defn defnt-assume-0 [> (t/assume tt/int?)] "asd"))) + (throws (eval '(self/defn defnt-assume-1 [> (t/assume tt/int?)] nil))) + (is= nil (do (eval '(self/defn defnt-assume-2 [> (t/assume tt/int?)] (Object.))) nil)) - (is= nil (do (eval '(self/defn defnt-assume-3 [> (t/assume t/int?)] (or (Object.) nil))) + (is= nil (do (eval '(self/defn defnt-assume-3 [> (t/assume tt/int?)] (or (Object.) nil))) nil))) (self/defn >big-integer > (t/isa? java.math.BigInteger) @@ -1046,7 +1027,7 @@ {:source "clojure.lang.RT.longCast"} > long? ;; TODO multi-arity `t/-` - ([x (t/- (t/- (t/- primitive? boolean?) float?) double?)] (>long* x)) + ([x (t/- (t/- (t/- tt/boolean? tt/boolean?) float?) double?)] (>long* x)) ([x (t/and (t/or double? float?) ;; TODO add this back in #_(fnt [x (t/or t/double? t/float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] @@ -1063,10 +1044,10 @@ ([x (t/value true)] 1) ([x (t/value false)] 0) ([x t/string?] (Long/parseLong x)) - ([x t/string?, radix int?] (Long/parseLong x radix)))) + ([x t/string?, radix tt/int?] (Long/parseLong x radix)))) expected (case (env-lang) - :clj ($ (do #_[x (t/- primitive? boolean? float? double?)] + :clj ($ (do #_[x (t/- tt/boolean? tt/boolean? float? double?)] #_(def ~'>long|__0|input-types (*<> byte?)) (def ~'>long|__0 @@ -1089,7 +1070,7 @@ ;; Resolved from `(>long* x)` (.invoke >long*|__2 ~'x)))) - #_(def ~'>long|__3|input-types (*<> int?)) + #_(def ~'>long|__3|input-types (*<> tt/int?)) (def ~'>long|__3 (reify int>long (~(tag "long" 'invoke) [_## ~(tag "int" 'x)] @@ -1161,7 +1142,7 @@ (let* [~(tag "clojure.lang.Ratio" 'x) ~'x] ;; Resolved from `(>long (.bigIntegerValue x))` ;; In this case, `(t/compare (type-of '(.bigIntegerValue x)) overload-type)`: - ;; - `(t/- primitive? boolean? float? double?)` -> t/<> + ;; - `(t/- tt/boolean? tt/boolean? float? double?)` -> t/<> ;; - `(t/and (t/or double? float?) ...)` -> t/<> ;; - `(t/and (t/isa? clojure.lang.BigInt) ...)` -> t/<> ;; - `(t/and (t/isa? java.math.BigInteger) ...)` -> t/> @@ -1208,7 +1189,7 @@ #_[x t/string?] #_(def ~'>long|__13|input-types - (*<> t/string? int?)) + (*<> t/string? tt/int?)) (def ~'>long|__13 (reify Object+int>long (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x) ~(tag "int" 'radix)] @@ -1217,7 +1198,7 @@ #_(defn >long {:quantum.core.type/type (t/fn - [(t/- primitive? boolean? float? double?)] + [(t/- tt/boolean? tt/boolean? float? double?)] [(t/and (t/or t/double? t/float?) (fnt [x (t/or double? float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] @@ -1229,7 +1210,7 @@ [(t/value true)] [(t/value false)] [t/string?] - [t/string? int?])} + [t/string? tt/int?])} ([x0##] (ifs ((Array/get >long|__0|input-types 0) x0##) (.invoke >long|__0 x0##) ((Array/get >long|__1|input-types 0) x0##) @@ -1262,7 +1243,7 @@ ;; If we had combined this arity, `t/or`ing the `t/string?` means it wouldn't have been ;; handled any differently than `t/char-seq?` #?(:clj ([x t/string?] (StringBuilder. x))) - ([x #?(:clj (t/or t/char-seq? int?) + ([x #?(:clj (t/or t/char-seq? tt/int?) :cljs t/val?)] #?(:clj (StringBuilder. x) :cljs (StringBuffer. x))))) expected @@ -1301,7 +1282,7 @@ (t/fn ~'(t/isa? StringBuilder) ~'[] ~'[t/string?] - ~'[(t/or t/char-seq? int?)])} + ~'[(t/or t/char-seq? tt/int?)])} ([] (.invoke ~(tag "quantum.core.test.defnt_equivalences.>Object" '!str|__0|0))) ([~'x00__] @@ -1332,7 +1313,7 @@ :cljs (t/isa? StringBuffer)) [] #?(:clj [t/string?]) - [#?(:clj (t/or t/char-seq? t/int?) + [#?(:clj (t/or t/char-seq? tt/int?) :cljs t/val?)])) ~(case-env @@ -1345,19 +1326,19 @@ (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'x] (let* [^String x x] (StringBuilder. x))))) - ;; `(t/or t/char-seq? t/int?)` + ;; `(t/or t/char-seq? tt/int?)` (def ^Object>Object !str|__2 ; `t/char-seq?` (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'x] (let* [^CharSequence x x] (StringBuilder. x))))) - (def ^int>Object !str|__3 ; `t/int?` + (def ^int>Object !str|__3 ; `tt/int?` (reify int>Object (^java.lang.Object invoke [_# ^int ~'x] (StringBuilder. x)))) (defn !str ([ ] (.invoke !str|__0)) - ([a0] (ifs (t/string? a0) (.invoke !str|__1 a0) - (t/char-seq? a0) (.invoke !str|__2 a0) - (t/int? a0) (.invoke !str|__3 a0))))) + ([a0] (ifs (tt/string? a0) (.invoke !str|__1 a0) + (tt/char-seq? a0) (.invoke !str|__2 a0) + (tt/int? a0) (.invoke !str|__3 a0))))) :cljs `(do (defn !str ([] (StringBuffer.)) ([a0] (let* [x a0] (StringBuffer. x))))))) @@ -1449,24 +1430,24 @@ (macroexpand ' (self/defn #_:inline get ;; TODO `t/numerically - ([xs t/array? , k #_(t/numerically t/int?)] (#?(:clj Array/get :cljs aget) xs k)) - ([xs t/string?, k #_(t/numerically t/int?)] (.charAt xs k)) + ([xs t/array? , k #_(t/numerically tt/int?)] (#?(:clj Array/get :cljs aget) xs k)) + ([xs t/string?, k #_(t/numerically tt/int?)] (.charAt xs k)) ([xs !+vector?, k t/any?] #?(:clj (.valAt xs k) :cljs (TODO)))) ) ;; ----- expanded code ----- ;; `(do (swap! fn->spec assoc #'count (t/fn :> t/pos-integer? - [t/array? (t/numerically t/int?)] - [t/string? (t/numerically t/int?)] + [t/array? (t/numerically tt/int?)] + [t/string? (t/numerically tt/int?)] [!+vector? t/any?])) ...) ;; =====|=====|=====|=====|===== ;; -(self/defn zero? > boolean? - ([x (t/- primitive? boolean?)] (Numeric/isZero x))) +(self/defn zero? > tt/boolean? + ([x (t/- tt/boolean? tt/boolean?)] (Numeric/isZero x))) ; TODO CLJS version will come after #?(:clj From d5d08312bc157f6ae308e38341445981053b35bc Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 09:18:36 -0600 Subject: [PATCH 350/810] Remove the concept of symbolic analysis --- .../quantum/untyped/core/type/defnt.cljc | 88 ++++++++----------- 1 file changed, 38 insertions(+), 50 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 0b873790..b49457b6 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -72,7 +72,7 @@ :arglist-code|fn|hinted t/any? :arglist-code|reify|unhinted t/any? :body-form t/any? - :out-class (? class?) + :out-class (s/nilable class?) :out-type t/type? :positional-args-ct (s/and integer? #(>= % 0)) ;; When present, varargs are considered to be of class Object @@ -101,9 +101,8 @@ :fnt|type t/type?})) (s/def ::opts - (s/kv {:gen-gensym t/fn? - :lang ::lang - :symbolic-analysis? t/boolean?})) + (s/kv {:gen-gensym t/fn? + :lang ::lang})) (s/def ::overload-data (s/kv {:args (s/vec-of t/any?) @@ -174,15 +173,15 @@ (defns class>simplest-class "This ensures that special overloads are not created for non-primitive subclasses of java.lang.Object (e.g. String, etc.)." - [c (? class?) > (? class?)] + [c (s/nilable class?) > (s/nilable class?)] (if (t/primitive-class? c) c java.lang.Object))) #?(:clj -(defns class>most-primitive-class [c (? class?), nilable? t/boolean? > (? class?)] +(defns class>most-primitive-class [c (s/nilable class?), nilable? t/boolean? > (s/nilable class?)] (if nilable? c (or (tcore/boxed->unboxed c) c)))) #?(:clj -(defns type>most-primitive-classes [t t/type? > (s/set-of (? class?))] +(defns type>most-primitive-classes [t t/type? > (s/set-of (s/nilable class?))] (let [cs (t/type>classes t) nilable? (or (-> t meta :quantum.core.type/ref?) (contains? cs nil))] (->> cs @@ -190,7 +189,7 @@ (r/join #{}))))) #?(:clj -(defns out-type>class [t t/type? > (? class?)] +(defns out-type>class [t t/type? > (s/nilable class?)] (if (-> t meta :quantum.core.type/ref?) java.lang.Object (let [cs (t/type>classes t) @@ -319,51 +318,41 @@ "Given an `fnt` overload, computes a seq of 'expanded-overload groups'. Each expanded-overload group is the foundation for one `reify`. - Rather than rigging together something in which either: - 1) the Clojure compiler will try to cross its fingers and evaluate code meant to be evaluated in - ClojureScript - 2) we use a CLJS-in-CLJS compiler and alienate the mainstream CLJS-in-CLJ (cljsbuild) workflow, - which includes our own workflow - 3) we wait for CLJS-in-CLJS to become mainstream, which could take years if it really ever - happens - - we decide instead to evaluate types in languages in which the metalanguage (compiler language) - is the same as the object language (e.g. Clojure), and symbolically analyze types in the rest - (e.g. vanilla ClojureScript), deferring code analyzed as functions to be enforced at runtime." + We decide to evaluate types in languages in which the metalanguage (compiler language) is the + same as the object language. As such, for CLJS, we choose to use only a CLJS-in-CLJS / + bootstrapped compiler even if that means alienating the mainstream CLJS-in-CLJ workflow." [{:as overload-data :keys [args _, varargs _ arg-types|form _, arg-types _, pre-type|form _, post-type|form _]} ::overload-data {:as fnt-globals :keys [fn|name _, fnt|type _]} ::fnt-globals - {:as opts :keys [lang _, symbolic-analysis? _]} ::opts + {:as opts :keys [lang _]} ::opts > ::expanded-overload-groups] - (if symbolic-analysis? - (err! "Symbolic analysis not supported yet") - (let [;; TODO support varargs - varargs-binding (when varargs - ;; TODO this assertion is purely temporary until destructuring is - ;; supported - (assert (-> varargs :binding-form first (= :sym)))) - arg-bindings - (->> args - (mapv (fn [{[kind binding-] :binding-form}] - ;; TODO this assertion is purely temporary until destructuring is - ;; supported - (assert kind :sym) - binding-))) - arg-types|split - ;; NOTE Only `t/or`s are splittable for now - (->> arg-types - (c/map (fn [t] (if (utr/or-type? t) (utr/or-type>args t) [t])))) - arg-types|expanded-seq (->> arg-types|split - (apply ucombo/cartesian-product) - (c/map vec)) - expanded-overload-group-seq - (->> arg-types|expanded-seq - (mapv (fn [arg-types|expanded] ; TODO use this - (>expanded-overload-group overload-data fnt-globals opts - arg-bindings varargs-binding arg-types|expanded))))] - (kw-map arg-types|expanded-seq arg-types|split expanded-overload-group-seq - overload-data))))) + (let [;; TODO support varargs + varargs-binding (when varargs + ;; TODO this assertion is purely temporary until destructuring is + ;; supported + (assert (-> varargs :binding-form first (= :sym)))) + arg-bindings + (->> args + (mapv (fn [{[kind binding-] :binding-form}] + ;; TODO this assertion is purely temporary until destructuring is + ;; supported + (assert kind :sym) + binding-))) + arg-types|split + ;; NOTE Only `t/or`s are splittable for now + (->> arg-types + (c/map (fn [t] (if (utr/or-type? t) (utr/or-type>args t) [t])))) + arg-types|expanded-seq (->> arg-types|split + (apply ucombo/cartesian-product) + (c/map vec)) + expanded-overload-group-seq + (->> arg-types|expanded-seq + (mapv (fn [arg-types|expanded] ; TODO use this + (>expanded-overload-group overload-data fnt-globals opts + arg-bindings varargs-binding arg-types|expanded))))] + (kw-map arg-types|expanded-seq arg-types|split expanded-overload-group-seq + overload-data)))) (def fnt-method-sym 'invoke) @@ -663,7 +652,6 @@ fn|meta :quantum.core.specs/meta} (s/validate args (case kind :defn :quantum.core.defnt/defnt :fn :quantum.core.defnt/fnt)) - symbolic-analysis? false ; TODO parameterize this fnt|output-type|form (or (second output-spec) `t/any?) fnt|output-type (eval fnt|output-type|form) gen-gensym-base (ufgen/>reproducible-gensym|generator) @@ -676,7 +664,7 @@ overloads-data (->> overloads (mapv #(fnt|parsed-overload>overload-data % fnt|output-type))) fnt|type (fnt|overloads-data>type overloads-data fnt|output-type) fnt-globals (kw-map fn|meta fn|name fnt|output-type|form fnt|type) - opts (kw-map gen-gensym lang symbolic-analysis?) + opts (kw-map gen-gensym lang) expanded-overload-groups-by-fnt-overload (->> overloads-data (mapv #(fnt|overload-data>expanded-overload-groups % fnt-globals opts))) From eb392bbdc2a7343fe9384e7dfc52a7c25cdad5c2 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 09:30:30 -0600 Subject: [PATCH 351/810] `uast/quoted` now has an appropriate type --- src-untyped/quantum/untyped/core/analyze.cljc | 2 +- src-untyped/quantum/untyped/core/analyze/ast.cljc | 4 +++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 74f3f012..4a97b8e2 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -393,7 +393,7 @@ nil @whole-node)))) (defns- analyze-seq|quote [env ::env, [_ _ & body _ :as form] _ > uast/quoted?] - (uast/quoted env form (tcore/most-primitive-class-of body))) + (uast/quoted env form (t/value (list* body)))) (defns- analyze-seq|new [env ::env, [_ _ & [c|form _ #_class? & args _ :as body] _ :as form] _ > uast/new-node?] diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index ec124e29..c75a32a2 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -105,7 +105,9 @@ fipp.ednize/IEdn (-edn [this] (list `quoted form type))) -(defn quoted [form t] (Quoted. nil (ufth/with-type-hint form (>type-hint form t)) t)) +(defn quoted + ([form t] (quoted nil form t)) + ([env form t] (Quoted. nil (ufth/with-type-hint form (>type-hint form t)) t))) (defn quoted? [x] (instance? Quoted x)) From 8f386bfa1865c78b56124784fec6d2dc40243291 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 09:36:24 -0600 Subject: [PATCH 352/810] Add some todos and numerate priorities --- resources-dev/defnt.cljc | 45 +++++++++++++++++++++++----------------- 1 file changed, 26 insertions(+), 19 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 7b40c776..55e84e69 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -44,8 +44,6 @@ Note that for anything built-in js/, the `t/isa?` predicates might nee >boolean is different than `truthy?` -We should not rely on the value of dynamic vars e.g. `*math-context*` unless specifically typed - Sometimes you want (byte ) to fail at runtime rather than fail at runtime when you can't know everything about the input's range These two should be defined in the (whatever) data namespace: @@ -61,15 +59,32 @@ TODO: Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - - t/type >>>>>> (PRIORITY 1) <<<<<< - - dependent types: `[x arr/array? > (t/type x)]` - - (comp/t== x) - - dependent type such that the passed input must be identical to x - - Analysis - - This is accepted by the type system without knowing the type: + [1 .] This is accepted by the type system without knowing the type: (java.math.BigInteger. 1 (-> (ByteBuffer/allocate (int 8)) (.putLong x) .array)) So, constructors need the same kind of lookup that dot calls have + [2 .] t/type + - dependent types: `[x arr/array? > (t/type x)]` + [3] t/value-of + - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` + [4] - t/input-type + - `(t/input-type >namespace :?)` meaning the possible input types to the first input to `>namespace` + - `(t/input-type reduce :_ :_ :?)` + - Then if those fns ever get extended then it should trigger a chain-reaction of recompilations + [5] - No trailing `>` means `> ?` + - ? : type inference + - use logic programming and variable unification e.g. `?1` `?2` ? + - For this situation: `?` is `(t/- dc/counted?)` + ([n dnum/std-integer?, xs dc/counted?] (count xs)) + ([n dnum/std-integer?, xs ?] ...) + - (comp/t== x) + - dependent type such that the passed input must be identical to x + - Analysis + - Better analysis of compound literals + - Literal vectors need to be analyzed — (t/finite-of t/built-in-vector? a-type b-type ...) + - Literal sets need to be analyzed — (t/finite-of t/built-in-set? a-type b-type ...) + - Literal maps need to be better analyzed — (t/finite-of t/built-in-map? [ak-type av-type] ...) + - Literal seqs need to be better analyzed — (t/finite-of t/built-in-list? [ak-type av-type] ...) - (if (dcoll/reduced? ret) ;; TODO TYPED `(ref/deref ret)` should realize it's dealing with a `reduced?` (ref/deref ret) @@ -98,21 +113,13 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - (if (A) ...) should be (if ^boolean (A) ...) if A returns a `p/boolean?` - t/- : fix - (t/- (t/isa? java.util.Queue) (t/or ?!+queue? !!queue?)) - - t/value-of - - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` - t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. - t/numerically-integer? - - ? : type inference - - use logic programming and variable unification e.g. `?1` `?2` ? - - For this situation: `?` is `(t/- dc/counted?)` - ([n dnum/std-integer?, xs dc/counted?] (count xs)) - ([n dnum/std-integer?, xs ?] ...) + - We should not rely on the value of dynamic vars e.g. `*math-context*` unless specifically typed + - We'll have to make a special class or *something* like that to ensure that typed bindings are only + bound within typed contexts. - t/extend-defn! - - t/input-type - - `(t/input-type >namespace :?)` meaning the possible input types to the first input to `>namespace` - - `(t/input-type reduce :_ :_ :?)` - - Then if those fns ever get extended then it should trigger a chain-reaction of recompilations - dc/of - (dc/of number?) ; implicitly the container is a `reducible?` - (dc/of map/+map? symbol? dstr/string?) From b31192a8876c3097c76c794fd06f347d630f0b26 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 09:37:31 -0600 Subject: [PATCH 353/810] A little cleanup --- src-untyped/quantum/untyped/core/type.cljc | 83 ++++++++++------------ 1 file changed, 39 insertions(+), 44 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 009c1570..c0804a1f 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -12,7 +12,7 @@ fn? ifn? meta ref - fn]) + type]) (:require [clojure.core :as c] [clojure.string :as str] @@ -167,7 +167,24 @@ "Creates a type whose extension is the singleton set containing only the value `v`." [v _] (ValueType. uhash/default uhash/default nil v)) -;; ----- General ----- ;; +;; ----- `isa?` / Class-Inheritance ----- ;; + +(defn isa? [x] + (ifs (uclass/protocol? x) + (isa?|protocol x) + + (#?(:clj c/class? :cljs c/fn?) x) + (isa?|class x) + + (throw (ex-info "`isa?` cannot be applied to" {:x x})))) + +(defn isa?|direct [x] + (if (uclass/protocol? x) + #?(:clj (isa?|class (uclass/protocol>class x)) + :cljs (isa?|protocol|direct x)) + (isa? x))) + +;; ------------------ (defns - "Computes the difference of `t0` from `t1`: (& t0 (! t1)) @@ -201,21 +218,6 @@ (atom nil)))))))))) ([t0 utr/type?, t1 utr/type? & ts (us/seq-of utr/type?) > utr/type?] (reduce - (- t0 t1) ts))) -(defn isa? [x] - (ifs (uclass/protocol? x) - (isa?|protocol x) - - (#?(:clj c/class? :cljs c/fn?) x) - (isa?|class x) - - (throw (ex-info "`isa?` cannot be applied to" {:x x})))) - -(defn isa?|direct [x] - (if (uclass/protocol? x) - #?(:clj (isa?|class (uclass/protocol>class x)) - :cljs (isa?|protocol|direct x)) - (isa? x))) - ;; TODO clean up (defns >type "Coerces ->`x` to a type, recording its ->`name-sym` if provided." @@ -282,18 +284,6 @@ For use with `defnt`." [t utr/type? > utr/type?] (update-meta t assoc :quantum.core.type/ref? true)) -;; TODO figure this out -#_(do (udt/deftype DeducibleSpec [*spec #_(t/atom-of t/spec?)] - {PSpec nil - fipp.ednize/IOverride nil - fipp.ednize/IEdn {-edn ([this] (list `deducible @*spec))} - ?Atom {swap! (([this f] (swap! *spec f))) - reset! ([this v] (reset! *spec v))}}) - -(defns deducible-spec? [x _] (instance? DeducibleSpec x)) - -(defns deducible [x spec? > deducible-spec?] (DeducibleSpec. (atom x)))) - ;; ===== Logical ===== ;; (defns >logical-complement @@ -421,14 +411,9 @@ (first simplified) (construct-fn uhash/default uhash/default nil simplified (atom nil)))))) -;; TODO do this? -#_(udt/deftype SequentialType) +;; ===== `t/ftype` ===== ;; -#_(defns of - "Creates a type that ... TODO" - [pred (<= iterable?), t utr/type?] (TODO)) - -(defn fn [out-type arity & arities] +(defn ftype [out-type arity & arities] (let [name- nil arities-form (cons arity arities) arities (->> arities-form @@ -470,14 +455,24 @@ (defns compare|out [x0 utr/fn-type?, x1 utr/fn-type? > ucomp/comparison?] (utcomp/compare (fn-type>output-type x0) (fn-type>output-type x1))) -(defn unkeyed - "Creates an unkeyed collection type, in which the collection may - or may not be sequential or even seqable, but must not have key-value - pairs like a map. - Examples of unkeyed collections include a vector (despite its associativity), - a list, and a set (despite its values doubling as keys). - A map is not an unkeyed collection." - [x] (TODO)) +;; ===== Dependent types ===== ;; + +(defns type + "Treated specially by the type analyzer. For runtime use, just defaults to `(t/value x)`." + [x _ > type?] (value x)) + +;; TODO figure this out +;; TODO move to reifications +#_(do (udt/deftype DeducibleType [*t #_(t/atom-of t/type?)] + {PSpec nil + fipp.ednize/IOverride nil + fipp.ednize/IEdn {-edn ([this] (list `deducible @*t))} + ?Atom {swap! (([this f] (swap! *t f))) + reset! ([this v] (reset! *t v))}}) + +(defns deducible-type? [x _] (instance? DeducibleType x)) + +(defns deducible [x type? > deducible-type?] (DeducibleType. (atom x)))) (defns ? "Arity 1: Computes a type denoting a nilable value satisfying `t`. From 309ddcc2f5a919447deb3cd3b19164400db8192b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 09:37:45 -0600 Subject: [PATCH 354/810] Move `unkeyed` here but probably will take it away --- src/quantum/core/data/collections.cljc | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/quantum/core/data/collections.cljc b/src/quantum/core/data/collections.cljc index 59f2d84b..acdde912 100644 --- a/src/quantum/core/data/collections.cljc +++ b/src/quantum/core/data/collections.cljc @@ -190,3 +190,12 @@ ;; Since reduction is preferred to "manual" `first`/`next` seq traversal, we prefer `reducible?` to ;; `seqable?` as the base type. (def seqable? reducible?) + +(t/defn unkeyed + "Creates an unkeyed collection type, in which the collection may + or may not be sequential or even seqable, but must not have key-value + pairs like a map. + Examples of unkeyed collections include a vector (despite its associativity), + a list, and a set (despite its values doubling as keys). + A map is not an unkeyed collection." + [x ...] (TODO)) From cfcfbf4d83a0e0286c5f9e3140d7dc3496c011ec Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 09:38:00 -0600 Subject: [PATCH 355/810] Add beginnings of `dependent-type` test --- .../quantum/test/untyped/core/type/defnt.cljc | 171 ++++++++++++------ 1 file changed, 114 insertions(+), 57 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 3faa2477..8f05a9f8 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -951,70 +951,46 @@ (is (identical? (>long* -1.1) (clojure.lang.RT/uncheckedLongCast -1.1))) (is (identical? (>long* (byte 1)) (clojure.lang.RT/uncheckedLongCast (byte 1))))))))) +#?(:clj (deftest ref-output-type-test + "Tests whether refs are output when requested instead of primitives" (let [actual (macroexpand ' (self/defn ref-output-type ([x tt/boolean? > (t/ref tt/boolean?)] (Boolean. x)) ([x byte? > (t/ref byte?)] (Byte. x)))) expected - (case (env-lang) - :clj ($ (do ;; [x tt/boolean? > (t/ref tt/boolean?)] - - (def ~(tag "[Ljava.lang.Object;" 'ref-output-type|__0|input0|types) - (*<> (t/isa? java.lang.Boolean))) - (def ~'ref-output-type|__0|0 - (reify* [boolean>Object] - (~(O 'invoke) [~'_0__ ~(tag "boolean" 'x)] (new ~'Boolean ~'x)))) - - ;; [x byte? > (t/ref byte?)] - - (def ~(tag "[Ljava.lang.Object;" 'ref-output-type|__1|input0|types) - (*<> (t/isa? java.lang.Byte))) - (def ~'ref-output-type|__1|0 - (reify* [byte>Object] - (~(O 'invoke) [~'_1__ ~(tag "byte" 'x)] (new ~'Byte ~'x)))) - - (defn ~'ref-output-type - {:quantum.core.type/type - (t/fn t/any? - ~'[tt/boolean? :> (t/ref tt/boolean?)] - ~'[byte? :> (t/ref byte?)])} - ([~'x00__] - (ifs - ((Array/get ~'ref-output-type|__0|input0|types 0) ~'x00__) - (.invoke ~(tag (str `boolean>Object) 'ref-output-type|__0|0) - ~'x00__) - ((Array/get ~'ref-output-type|__1|input0|types 0) ~'x00__) - (.invoke ~(tag (str `byte>Object) 'ref-output-type|__1|0) - ~'x00__) - (unsupported! `ref-output-type [~'x00__] 0)))))))] - (testing "code equivalence" (is-code= actual expected)))) - -(deftest defnt-reference-test - (let [actual - (macroexpand ' - (self/defn defnt-reference - ([] (>long* 1)))) - expected - (case (env-lang) - :clj ($ (do (def ~'defnt-reference|__0|0 - (reify* [>long] (~(tag "long" 'invoke) [~'_0__] ~'(>long* 1)))) - (defn ~'defnt-reference - {:quantum.core.type/type (t/fn t/any? [])} - ([] (.invoke ~(tag (str `>long) 'defnt-reference|__0|0)))))))] - (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" - (eval actual) - (eval '(do (is (identical? (defnt-reference) 1))))))) - -(deftest defnt-assume-test - (throws (eval '(self/defn defnt-assume-0 [> (t/assume tt/int?)] "asd"))) - (throws (eval '(self/defn defnt-assume-1 [> (t/assume tt/int?)] nil))) - (is= nil (do (eval '(self/defn defnt-assume-2 [> (t/assume tt/int?)] (Object.))) - nil)) - (is= nil (do (eval '(self/defn defnt-assume-3 [> (t/assume tt/int?)] (or (Object.) nil))) - nil))) + ($ (do ;; [x tt/boolean? > (t/ref tt/boolean?)] + + (def ~(tag "[Ljava.lang.Object;" 'ref-output-type|__0|input0|types) + (*<> (t/isa? java.lang.Boolean))) + (def ~'ref-output-type|__0|0 + (reify* [boolean>Object] + (~(O 'invoke) [~'_0__ ~(tag "boolean" 'x)] (new ~'Boolean ~'x)))) + + ;; [x byte? > (t/ref byte?)] + + (def ~(tag "[Ljava.lang.Object;" 'ref-output-type|__1|input0|types) + (*<> (t/isa? java.lang.Byte))) + (def ~'ref-output-type|__1|0 + (reify* [byte>Object] + (~(O 'invoke) [~'_1__ ~(tag "byte" 'x)] (new ~'Byte ~'x)))) + + (defn ~'ref-output-type + {:quantum.core.type/type + (t/fn t/any? + ~'[tt/boolean? :> (t/ref tt/boolean?)] + ~'[byte? :> (t/ref byte?)])} + ([~'x00__] + (ifs + ((Array/get ~'ref-output-type|__0|input0|types 0) ~'x00__) + (.invoke ~(tag (str `boolean>Object) 'ref-output-type|__0|0) + ~'x00__) + ((Array/get ~'ref-output-type|__1|input0|types 0) ~'x00__) + (.invoke ~(tag (str `byte>Object) 'ref-output-type|__1|0) + ~'x00__) + (unsupported! `ref-output-type [~'x00__] 0))))))] + (testing "code equivalence" (is-code= actual expected))))) (self/defn >big-integer > (t/isa? java.math.BigInteger) ([x ratio? > (* (t/isa? java.math.BigInteger))] (.bigIntegerValue x))) @@ -1306,6 +1282,87 @@ (is (instance? StringBuilder (!str (int 123)))) (is (instance? StringBuilder (!str (.subSequence "abc" 0 1))))))))) +(deftest defn-reference-test + "Tests that defnts referencing other defnts works" + (let [actual + (macroexpand ' + (self/defn defn-reference + ([] (>long* 1)))) + expected + (case (env-lang) + :clj ($ (do (def ~'defn-reference|__0|0 + (reify* [>long] (~(tag "long" 'invoke) [~'_0__] ~'(>long* 1)))) + (defn ~'defn-reference + {:quantum.core.type/type (t/fn t/any? [])} + ([] (.invoke ~(tag (str `>long) 'defn-reference|__0|0)))))))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do (is (identical? (defn-reference) 1))))))) + +(deftest defn-assume-test + "Tests that t/assume works properly in the context of `t/defn`" + (throws (eval '(self/defn defn-assume-0 [> (t/assume tt/int?)] "asd"))) + (throws (eval '(self/defn defn-assume-1 [> (t/assume tt/int?)] nil))) + (is= nil (do (eval '(self/defn defn-assume-2 [> (t/assume tt/int?)] (Object.))) + nil)) + (is= nil (do (eval '(self/defn defn-assume-3 [> (t/assume tt/int?)] (or (Object.) nil))) + nil))) + +(deftest dependent-type-test + (let [actual + (macroexpand ' + (self/defn dependent-type + ([x (t/or tt/boolean? tt/string?) > (type x)] x) + ;; This arity is the same as `identity` + ([x t/any? > (type x)] x))) + expected + (case (env-lang) + :clj + ($ (do ;; [x (t/or tt/boolean? tt/string?) > (type x)] + + ;; [x t/any? > (type x)] + + (def ~(tag "[Ljava.lang.Object;" 'dependent-type|__0|input0|types) + (*<> t/any?)) + ;; One `reify` because `t/any?` in CLJ does not have any `t/or`-separability + (def ~'dependent-type|__0|0 + (reify* [Object>Object boolean>boolean byte>byte short>short char>char + int>int long>long float>float double>double] + (~(tag "java.lang.Object" 'invoke) + [~'_0__ ~(tag "java.lang.Object" 'x)] ~(O 'x)) + (~(tag "boolean" 'invoke) + [~'_1__ ~(tag "boolean" 'x)] ~'x) + (~(tag "byte" 'invoke) + [~'_2__ ~(tag "byte" 'x)] ~'x) + (~(tag "short" 'invoke) + [~'_3__ ~(tag "short" 'x)] ~'x) + (~(tag "char" 'invoke) + [~'_4__ ~(tag "char" 'x)] ~'x) + (~(tag "int" 'invoke) + [~'_5__ ~(tag "int" 'x)] ~'x) + (~(tag "long" 'invoke) + [~'_6__ ~(tag "long" 'x)] ~'x) + (~(tag "float" 'invoke) + [~'_7__ ~(tag "float" 'x)] ~'x) + (~(tag "double" 'invoke) + [~'_8__ ~(tag "double" 'x)] ~'x))) + + (defn ~'dependent-type + {:quantum.core.type/type (t/fn t/any? ~'[t/any?])} + ([~'x00__] + ;; TODO elide check because `t/any?` doesn't require a check + ;; and all args are `t/=` `t/any?` + (ifs ((Array/get ~'dependent-type|__0|input0|types 0) ~'x00__) + (.invoke ~(tag (str `Object>Object) + 'dependent-type|__0|0) ~'x00__) + (unsupported! `dependent-type [~'x00__] 0)))))))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do (is= (dependent-type 1) 1) + (is= (dependent-type "") "")))))) + ;; ----- expanded code ----- ;; `(do (swap! fn->spec assoc #'!str From 26a3fd63e1f8cbf04d3970a7203561c00d15d502 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 09:58:59 -0600 Subject: [PATCH 356/810] Now cannot use dot op on target that might be nil --- src-untyped/quantum/untyped/core/analyze.cljc | 29 +++++++++---------- 1 file changed, 14 insertions(+), 15 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 4a97b8e2..3c968458 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -347,17 +347,16 @@ (if ?target-static-class-map (cond-> #{target-static-class} target-static-class-nilable? (conj nil)) (-> target :type t/type>classes)) - target-class-nilable? (contains? target-classes nil) target-class (classes>class target-classes)] - ;; TODO determine how to handle `target-class-nilable?`; for now we will just let it slip - ;; through to `NullPointerException` at runtime rather than create a potentially more - ;; helpful custom exception - (if-let [field (and (empty? args-forms) - (-> target-class class->fields|with-cache - (c/get (name method-or-field))))] - (analyze-seq|dot|field-access env form target method-or-field field) - (analyze-seq|dot|method-call env form target target-class - (boolean ?target-static-class-map) method-or-field args-forms)))))) + (if-let [target-class-nilable? (contains? target-classes nil)] + (err! "Cannot use the dot operator on a target that might be nil." + {:form form :target-form target-form :target-type (:type target)}) + (if-let [field (and (empty? args-forms) + (-> target-class class->fields|with-cache + (c/get (name method-or-field))))] + (analyze-seq|dot|field-access env form target method-or-field field) + (analyze-seq|dot|method-call env form target target-class + (boolean ?target-static-class-map) method-or-field args-forms))))))) ;; TODO move this (defns truthy-node? [{:as ast t [:type _]} _ > (t/? t/boolean?)] @@ -386,11 +385,11 @@ :type (apply t/or (->> [(:type @true-node) (:type @false-node)] (remove nil?)))}))] (case (truthy-node? pred-node) - true (do (log/ppr :warn "Predicate in `if` node is always true" {:pred pred-form}) - (assoc @true-node :env env)) - false (do (log/ppr :warn "Predicate in `if` node is always false" {:pred pred-form}) - (assoc @false-node :env env)) - nil @whole-node)))) + true (do (log/ppr :warn "Predicate in `if` node is always true" {:pred pred-form}) + (assoc @true-node :env env)) + false (do (log/ppr :warn "Predicate in `if` node is always false" {:pred pred-form}) + (assoc @false-node :env env)) + nil @whole-node)))) (defns- analyze-seq|quote [env ::env, [_ _ & body _ :as form] _ > uast/quoted?] (uast/quoted env form (t/value (list* body)))) From d95875522582b9237e7b7938868f38d73eb4778e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 10:35:59 -0600 Subject: [PATCH 357/810] `analyze-seq|new` now performs incremental type analysis --- resources-dev/defnt.cljc | 1 + src-untyped/quantum/untyped/core/analyze.cljc | 170 ++++++++++++------ 2 files changed, 112 insertions(+), 59 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 55e84e69..faf7dd70 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -59,6 +59,7 @@ TODO: Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: + ;; TODO test the new analyze-seq|new!!! [1 .] This is accepted by the type system without knowing the type: (java.math.BigInteger. 1 (-> (ByteBuffer/allocate (int 8)) (.putLong x) .array)) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 3c968458..9ecdaf73 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -48,42 +48,62 @@ #?(:clj (defns method? [x _] (instance? Method x))) #?(:clj -(defns class->methods [^Class c class? > map?] +(defns class>methods + "Returns all the public methods associated with a class, as a map from method name to methods." + [^Class c class? > map?] (->> (.getMethods c) - (c/remove+ (fn [^java.lang.reflect.Method x] - (java.lang.reflect.Modifier/isPrivate (.getModifiers x)))) - (c/map+ (fn [^java.lang.reflect.Method x] - (Method. (.getName x) (.getReturnType x) (.getParameterTypes x) - (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) - :static - :instance)))) - (c/group-by (fn [^Method x] (.-name x))) ; TODO all of these need to be into !vector and !hash-map - (c/map-vals+ (fn->> (c/group-by (fn [^Method x] (count (.-argtypes x)))) - (c/map-vals+ (fn->> (c/group-by (fn [^Method x] (.-kind x))))) - (r/join {}))) - (r/join {})))) - -(defonce class->methods|with-cache - (memoize (fn [c] (class->methods c)))) + (c/map+ (fn [^java.lang.reflect.Method x] + (Method. (.getName x) (.getReturnType x) (.getParameterTypes x) + (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) + :static + :instance)))) + (c/group-by (fn [^Method x] (.-name x))) ; TODO all of these need to be into !vector and !hash-map + (c/map-vals+ (fn->> (c/group-by (fn [^Method x] (count (.-argtypes x)))) + (c/map-vals+ (fn->> (c/group-by (fn [^Method x] (.-kind x))))) + (r/join {}))) + (r/join {})))) + +(defonce class>methods|with-cache + (memoize (fn [c] (class>methods c)))) +#?(:clj +(defrecord Constructor [^"[Ljava.lang.Class;" argtypes] + fipp.ednize/IOverride + fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "C") {:argtypes (vec argtypes)})))) + +#?(:clj (defns constructor? [x _] (instance? Constructor x))) + +#?(:clj +(defns class>constructors + "Returns all the public constructors associated with a class, as a vector." + [^Class c class? > vector?] + (->> (.getConstructors c) + (c/map (fn [^java.lang.reflect.Constructor x] (Constructor. (.getParameterTypes x))))))) + +(defonce class>constructors|with-cache + (memoize (fn [c] (class>constructors c)))) + +#?(:clj (defrecord Field [^String name ^Class class ^clojure.lang.Keyword kind] fipp.ednize/IOverride - fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "F") (into (array-map) this)))) + fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "F") (into (array-map) this))))) -(defns class->fields [^Class c class? > map?] +#?(:clj +(defns class>fields + "Returns all the public fields associated with a class, as a map from field name to field." + [^Class c class? > map?] (->> (.getFields c) - (c/remove+ (fn [^java.lang.reflect.Field x] - (java.lang.reflect.Modifier/isPrivate (.getModifiers x)))) - (c/map+ (fn [^java.lang.reflect.Field x] - [(.getName x) - (Field. (.getName x) (.getType x) - (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) - :static - :instance))])) - (r/join {}))) ; TODO !hash-map - -(def class->fields|with-cache - (memoize (fn [c] (class->fields c)))) + (c/map+ (fn [^java.lang.reflect.Field x] + [(.getName x) + (Field. (.getName x) (.getType x) + (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) + :static + :instance))])) + (r/join {})))) ; TODO !hash-map + +#?(:clj +(def class>fields|with-cache + (memoize (fn [c] (class>fields c))))) (defonce *analyze-depth (atom 0)) @@ -199,7 +219,18 @@ :body body :type body|type}))) +;; TODO move? +(defn class>type + "For converting a class in a reflective method, constructor, or field declaration to a type. + Unlike `t/isa?`, takes into account that non-primitive classes in Java aren't guaranteed to be + non-null." + [x] + (if (class? x) + (-> x t/>type (cond-> (not (t/primitive-class? x)) t/?)) + (uerr/not-supported! `class>type x))) + ;; TODO enhance this to use `t/fn` +;; TODO there's definitely array reflection going on here (defns methods->type "Creates a type given ->`methods`." [methods (s/seq-of t/any? #_method?) #_> #_t/type?] @@ -207,13 +238,6 @@ (let [methods|by-ct (->> methods (c/group-by (fn-> :argtypes count)) (sort-by first <)) - ;; non-primitive classes in Java aren't guaranteed to be non-null - >class-type (fn [x] - (ifs (class? x) - (-> x t/>type (cond-> (not (t/primitive-class? x)) t/?)) - (t/type? x) - x - (uerr/not-supported! `>class-type x))) partition-deep (fn partition-deep [t methods' arglist-size i|arg depth] (let [_ (when (> depth 3) (TODO)) @@ -226,10 +250,10 @@ (r/for [[c methods''] methods'|by-class t' t] (update t' :clauses conj - [(>class-type c) + [(class>type c) (if (= (inc depth) arglist-size) ;; here, methods'' count will be = 1 - (-> methods'' first :rtype >class-type) + (-> methods'' first :rtype class>type) (partition-deep (uxp/condpf-> t/<= (uxp/get (inc i|arg))) methods'' @@ -239,7 +263,7 @@ (r/for [[ct methods'] methods|by-ct t (uxp/casef count)] (if (zero? ct) - (c/assoc-in t [:cases 0] (-> methods' first :rtype >class-type)) + (c/assoc-in t [:cases 0] (-> methods' first :rtype class>type)) (c/assoc-in t [:cases ct] (partition-deep (uxp/condpf-> t/<= (uxp/get 0)) methods' ct 0 0)))))) #?(:clj @@ -269,7 +293,7 @@ [env ::env, form _, target uast/node?, target-class class?, static? t/boolean? method-form simple-symbol?, args-forms _ #_(seq-of form?) > uast/method-call?] ;; TODO cache type by method - (if-not-let [methods-for-name (-> target-class class->methods|with-cache + (if-not-let [methods-for-name (-> target-class class>methods|with-cache (c/get (name method-form)))] (if (empty? args-forms) (err! "No such method or field in class" {:class target-class :method-or-field method-form}) @@ -336,7 +360,7 @@ method-or-field (if (symbol? ?method-or-field) ?method-or-field (first ?method-or-field)) args-forms (if (symbol? ?method-or-field) ?args (rest ?method-or-field))] (if (t/= (:type target) t/nil?) - (err! "Cannot use the dot operator on nil." {:form form}) + (err! "Cannot use the dot operator on a target of nil type." {:form form}) (let [;; `nilable?` because technically any non-primitive in Java is nilable and we can't ;; necessarily rely on all e.g. "@nonNull" annotations {:as ?target-static-class-map @@ -350,14 +374,57 @@ target-class (classes>class target-classes)] (if-let [target-class-nilable? (contains? target-classes nil)] (err! "Cannot use the dot operator on a target that might be nil." - {:form form :target-form target-form :target-type (:type target)}) + {:form form :target-type (:type target)}) (if-let [field (and (empty? args-forms) - (-> target-class class->fields|with-cache + (-> target-class class>fields|with-cache (c/get (name method-or-field))))] (analyze-seq|dot|field-access env form target method-or-field field) (analyze-seq|dot|method-call env form target target-class (boolean ?target-static-class-map) method-or-field args-forms))))))) +;; TODO this is not the right approach for CLJS +;; TODO use a similar approach for `analyze-seq|dot|method-call` +(defns- analyze-seq|new + [env ::env, [_ _ & [c|form _ & args _ :as body] _ :as form] _ > uast/new-node?] + (let [c|analyzed (analyze* env c|form)] + (if-not (and (-> c|analyzed :type t/value-type?) + (-> c|analyzed :type utr/value-type>value class?)) + (err! "Supplied non-class to `new` form" {:x c|form}) + (let [c (-> c|analyzed :type utr/value-type>value) + constructors (-> c class>constructors|with-cache) + args-ct (count args) + constructors-for-ct (->> constructors + (c/filter (fn [{:keys [^"[Ljava.lang.Object;" argtypes]}] + (= (alength argtypes) args-ct))))] + (if (empty? constructors-for-ct) + (err! "No constructors for class match the arg ct" {:class c :args|form args}) + (let [{:keys [args|analyzed]} + (->> args + (reducei + (fn [{:as ret :keys [constructors']} arg i|arg] + (let [arg|analyzed (analyze* env arg) + constructors'' + (->> constructors' + (c/filter (fn [{:keys [^"[Ljava.lang.Object;" argtypes]}] + (t/<= (:type arg|analyzed) + (class>type (aget argtypes i|arg))))))] + (if (empty? constructors'') + (err! "No constructors for class match the arg type at index" + {:class c + :args|form args + :arg-type (:type arg|analyzed) + :i|arg i|arg}) + (-> ret + (assoc :constructors' constructors'') + (update :args|analyzed conj arg|analyzed))))) + {:constructors' constructors :args|analyzed []}))] + (uast/new-node + {:env env + :form (list* 'new c|form (map :form args|analyzed)) + :class c + :args args|analyzed + :type (t/isa? c)}))))))) + ;; TODO move this (defns truthy-node? [{:as ast t [:type _]} _ > (t/? t/boolean?)] (ifs (or (t/= t t/nil?) (t/= t t/false?)) false @@ -394,21 +461,6 @@ (defns- analyze-seq|quote [env ::env, [_ _ & body _ :as form] _ > uast/quoted?] (uast/quoted env form (t/value (list* body)))) -(defns- analyze-seq|new - [env ::env, [_ _ & [c|form _ #_class? & args _ :as body] _ :as form] _ > uast/new-node?] - (let [c|analyzed (analyze* env c|form)] - (if-not (and (-> c|analyzed :type t/value-type?) - (-> c|analyzed :type utr/value-type>value class?)) - (err! "Supplied non-class to `new` form" {:x c|form}) - (let [c (-> c|analyzed :type utr/value-type>value) - args|analyzed (mapv #(analyze* env %) args)] - (uast/new-node - {:env env - :form (list* 'new c|form (map :form args|analyzed)) - :class c - :args args|analyzed - :type (t/isa? c)}))))) - (defns- analyze-seq|throw [env ::env, form _ [arg _ :as body] _ > uast/throw-node?] (if (-> body count (not= 1)) (err! "Must supply exactly one input to `throw`; supplied" {:body body}) From 6c149c410da648db1cb012004d6b3cb698dd74ef Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 14:11:55 -0600 Subject: [PATCH 358/810] Quick test for `analyze-seq|new` --- src-untyped/quantum/untyped/core/analyze.cljc | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 9ecdaf73..4ff44b39 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -389,7 +389,7 @@ (let [c|analyzed (analyze* env c|form)] (if-not (and (-> c|analyzed :type t/value-type?) (-> c|analyzed :type utr/value-type>value class?)) - (err! "Supplied non-class to `new` form" {:x c|form}) + (err! "Supplied non-class to `new` form" {:form form}) (let [c (-> c|analyzed :type utr/value-type>value) constructors (-> c class>constructors|with-cache) args-ct (count args) @@ -411,13 +411,13 @@ (if (empty? constructors'') (err! "No constructors for class match the arg type at index" {:class c - :args|form args + :form form :arg-type (:type arg|analyzed) :i|arg i|arg}) (-> ret (assoc :constructors' constructors'') (update :args|analyzed conj arg|analyzed))))) - {:constructors' constructors :args|analyzed []}))] + {:constructors' constructors-for-ct :args|analyzed []}))] (uast/new-node {:env env :form (list* 'new c|form (map :form args|analyzed)) From 3ffc17a841b70fc35fdd7e6e93943c4a7e9ce2b5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 15:16:30 -0600 Subject: [PATCH 359/810] Slightly better factoring --- src-untyped/quantum/untyped/core/analyze.cljc | 36 ++++++++++--------- 1 file changed, 20 insertions(+), 16 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 4ff44b39..ec9ef27d 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -382,6 +382,25 @@ (analyze-seq|dot|method-call env form target target-class (boolean ?target-static-class-map) method-or-field args-forms))))))) +(defns- analyze-seq|new|gen-incrementally-analyze + [env ::env, form _, constructor-class class?] + (fn [{:as ret :keys [constructors']} arg i|arg] + (let [arg|analyzed (analyze* env arg) + constructors'' + (->> constructors' + (c/filter (fn [{:keys [^"[Ljava.lang.Object;" argtypes]}] + (t/<= (:type arg|analyzed) + (class>type (aget argtypes i|arg))))))] + (if (empty? constructors'') + (err! "No constructors for class match the arg type at index" + {:class constructor-class + :form form + :arg-type (:type arg|analyzed) + :i|arg i|arg}) + (-> ret + (assoc :constructors' constructors'') + (update :args|analyzed conj arg|analyzed)))))) + ;; TODO this is not the right approach for CLJS ;; TODO use a similar approach for `analyze-seq|dot|method-call` (defns- analyze-seq|new @@ -401,22 +420,7 @@ (let [{:keys [args|analyzed]} (->> args (reducei - (fn [{:as ret :keys [constructors']} arg i|arg] - (let [arg|analyzed (analyze* env arg) - constructors'' - (->> constructors' - (c/filter (fn [{:keys [^"[Ljava.lang.Object;" argtypes]}] - (t/<= (:type arg|analyzed) - (class>type (aget argtypes i|arg))))))] - (if (empty? constructors'') - (err! "No constructors for class match the arg type at index" - {:class c - :form form - :arg-type (:type arg|analyzed) - :i|arg i|arg}) - (-> ret - (assoc :constructors' constructors'') - (update :args|analyzed conj arg|analyzed))))) + (analyze-seq|new|gen-incrementally-analyze env form c) {:constructors' constructors-for-ct :args|analyzed []}))] (uast/new-node {:env env From 3739b783fac1e18c1882a75d70ab584928bff178 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 15:48:01 -0600 Subject: [PATCH 360/810] Add `^:val` special metadata directive --- src-untyped/quantum/untyped/core/analyze.cljc | 45 +++++++++++++------ .../quantum/untyped/core/type/defnt.cljc | 6 ++- src/quantum/core/data/primitive.cljc | 4 +- .../quantum/test/untyped/core/type/defnt.cljc | 12 ++--- 4 files changed, 45 insertions(+), 22 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index ec9ef27d..a86e627f 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -37,7 +37,9 @@ [quantum.untyped.core.vars :as uvar :refer [update-meta]])) -; ----- REFLECTION ----- ; +(def special-metadata-keys #{:val}) + +;; ----- Reflection support ----- ;; #?(:clj (defrecord Method @@ -105,6 +107,8 @@ (def class>fields|with-cache (memoize (fn [c] (class>fields c))))) +;; ----- End reflection support ----- ;; + (defonce *analyze-depth (atom 0)) (defn add-file-context-from [to from] @@ -328,13 +332,19 @@ (update :form seq)) call-data-with-ret-type (update call-data-with-arg-types :type - (fn [ret-type] (->> call-data-with-arg-types :args (mapv :type) ret-type))) + (fn [ret-type] (->> call-data-with-arg-types :args (mapv :type) ret-type + (<- (maybe-add-val-assumption-to-type form))))) ?cast-type (?cast-call->type target-class method-form) _ (when ?cast-type (log/ppr :warn "Not yet able to statically validate whether primitive cast will succeed at runtime" {:form form}) #_(s/validate (-> with-ret-type :args first :type) #(t/>= % (t/numerically ?cast-type))))] (uast/method-call call-data-with-ret-type))))))) +(defn- assume-val-for-form? [form] (-> form meta :val true?)) + +(defns- maybe-add-val-assumption-to-type [t t/type?, form _ > t/type?] + (cond-> t (assume-val-for-form? form) (t/and t/val?))) + (defns- analyze-seq|dot|field-access [env ::env, form _, target _, field-form simple-symbol?, field (t/isa? Field) > uast/field-access?] @@ -343,7 +353,7 @@ :form form :target target :field field-form - :type (-> field :class t/>type)})) + :type (-> field :class t/>type (maybe-add-val-assumption-to-type form))})) (defns classes>class "Ensure that given a set of classes, that set consists of at most a class C and nil. @@ -649,15 +659,17 @@ (defns- analyze-seq [env ::env, form _] (let [expanded-form (ufeval/macroexpand form)] - (if (ucomp/== form expanded-form) - (analyze-seq* env expanded-form) - (let [expanded (analyze* env expanded-form)] - (uast/macro-call - {:env env - :unexpanded-form form - :form (:form expanded) - :expanded expanded - :type (:type expanded)}))))) + (if-let [no-expansion? (ucomp/== form expanded-form)] + (analyze-seq* env expanded-form) + (let [expanded-form' (-> expanded-form + (update-meta merge (select-keys (meta form) special-metadata-keys))) + expanded (analyze* env expanded-form')] + (uast/macro-call + {:env env + :unexpanded-form form + :form (:form expanded) + :expanded expanded + :type (:type expanded)}))))) (defns ?resolve-with-env [sym symbol?, env ::env] (if-let [[_ local] (find env sym)] @@ -685,7 +697,7 @@ (TODO "Unsure of what to do in this case" (kw-map env form resolved)))))) (defns- analyze* [env ::env, form _ > uast/node?] - (when (> (swap! *analyze-depth inc) 100) (throw (ex-info "Stack too deep" {:form form}))) + (when (> (swap! *analyze-depth inc) 200) (throw (ex-info "Stack too deep" {:form form}))) (ifs (symbol? form) (analyze-symbol env form) (t/literal? form) @@ -699,7 +711,12 @@ (analyze-seq env form) (throw (ex-info "Unrecognized form" {:form form})))) -(defns analyze > uast/node? +(defns analyze + "Special metadata directives are defined in `special-metadata-keys`. They include: + - `:val` : Causes the analyzer to assume that the return value of the dot-form satisfies + `t/val?`. Useful for doing method/dot-chaining in which the methods return + non-primitives." + > uast/node? ([form _] (analyze {} form)) ([env ::env, form _] (reset! *analyze-depth 0) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index b49457b6..ee81bfe5 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -644,7 +644,11 @@ (kw-map args varargs body-codelist|pre-analyze arg-types|form arg-types, pre-type|form pre-type, post-type|form post-type))) -(defns fnt|code [kind #{:fn :defn}, lang ::lang, args _] +(defns fnt|code + "Special metadata directives include: + - `:inline` : Applicable within the metadata of `t/fn` or `t/defn`. A directive to inline the + function if possible." + [kind #{:fn :defn}, lang ::lang, args _] (let [{:as args' :keys [:quantum.core.specs/fn|name :quantum.core.defnt/overloads diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index b37423dd..a684b431 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -398,7 +398,9 @@ ([x int?] (Numeric/bitAnd (long 0xFFFFFFFF) x)) ;; TODO TYPED there is reflection here but there shouldn't be ([x long?] (java.math.BigInteger. (int 1) - (-> (ByteBuffer/allocate (int 8)) (.putLong x) .array))))) ; TODO reflection + (-> ^:val (ByteBuffer/allocate (int 8)) + ^:val (.putLong x) + .array))))) ; TODO reflection ;; TODO TYPED awaiting `>long` #_(:clj (t/defn ubyte>byte [x long? > long?] (-> x >byte >long))) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 8f05a9f8..eca639e8 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -958,7 +958,7 @@ (macroexpand ' (self/defn ref-output-type ([x tt/boolean? > (t/ref tt/boolean?)] (Boolean. x)) - ([x byte? > (t/ref byte?)] (Byte. x)))) + ([x tt/byte? > (t/ref tt/byte?)] (Byte. x)))) expected ($ (do ;; [x tt/boolean? > (t/ref tt/boolean?)] @@ -968,7 +968,7 @@ (reify* [boolean>Object] (~(O 'invoke) [~'_0__ ~(tag "boolean" 'x)] (new ~'Boolean ~'x)))) - ;; [x byte? > (t/ref byte?)] + ;; [x tt/byte? > (t/ref tt/byte?)] (def ~(tag "[Ljava.lang.Object;" 'ref-output-type|__1|input0|types) (*<> (t/isa? java.lang.Byte))) @@ -980,7 +980,7 @@ {:quantum.core.type/type (t/fn t/any? ~'[tt/boolean? :> (t/ref tt/boolean?)] - ~'[byte? :> (t/ref byte?)])} + ~'[tt/byte? :> (t/ref tt/byte?)])} ([~'x00__] (ifs ((Array/get ~'ref-output-type|__0|input0|types 0) ~'x00__) @@ -1214,12 +1214,12 @@ (let [actual (macroexpand ' (self/defn !str > #?(:clj (t/isa? StringBuilder) - :cljs (t/isa? StringBuffer)) + :cljs (t/isa? StringBuffer)) ([] #?(:clj (StringBuilder.) :cljs (StringBuffer.))) ;; If we had combined this arity, `t/or`ing the `t/string?` means it wouldn't have been ;; handled any differently than `t/char-seq?` #?(:clj ([x t/string?] (StringBuilder. x))) - ([x #?(:clj (t/or t/char-seq? tt/int?) + ([x #?(:clj (t/or tt/char-seq? tt/int?) :cljs t/val?)] #?(:clj (StringBuilder. x) :cljs (StringBuffer. x))))) expected @@ -1258,7 +1258,7 @@ (t/fn ~'(t/isa? StringBuilder) ~'[] ~'[t/string?] - ~'[(t/or t/char-seq? tt/int?)])} + ~'[(t/or tt/char-seq? tt/int?)])} ([] (.invoke ~(tag "quantum.core.test.defnt_equivalences.>Object" '!str|__0|0))) ([~'x00__] From 6562e35849714fac0a7bec6c7564f60a37b52f59 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 16:40:09 -0600 Subject: [PATCH 361/810] Greatly clean up incremental analysis for dot call sites --- src-untyped/quantum/untyped/core/analyze.cljc | 193 +++++++----------- 1 file changed, 79 insertions(+), 114 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index a86e627f..bebdc153 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -43,7 +43,7 @@ #?(:clj (defrecord Method - [^String name ^Class rtype ^"[Ljava.lang.Class;" argtypes ^clojure.lang.Keyword kind] + [^String name ^Class out-class ^"[Ljava.lang.Class;" arg-classes ^clojure.lang.Keyword kind] fipp.ednize/IOverride fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "M") (into (array-map) this))))) @@ -59,9 +59,9 @@ (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) :static :instance)))) - (c/group-by (fn [^Method x] (.-name x))) ; TODO all of these need to be into !vector and !hash-map - (c/map-vals+ (fn->> (c/group-by (fn [^Method x] (count (.-argtypes x)))) - (c/map-vals+ (fn->> (c/group-by (fn [^Method x] (.-kind x))))) + (c/group-by (fn [^Method x] (:name x))) ; TODO all of these need to be into !vector and !hash-map + (c/map-vals+ (fn->> (c/group-by (fn [^Method x] (count (:arg-classes x)))) + (c/map-vals+ (fn->> (c/group-by (fn [^Method x] (:kind x))))) (r/join {}))) (r/join {})))) @@ -69,9 +69,9 @@ (memoize (fn [c] (class>methods c)))) #?(:clj -(defrecord Constructor [^"[Ljava.lang.Class;" argtypes] +(defrecord Constructor [^"[Ljava.lang.Class;" arg-classes] fipp.ednize/IOverride - fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "C") {:argtypes (vec argtypes)})))) + fipp.ednize/IEdn (-edn [this] (tagged-literal (symbol "C") {:arg-classes (vec arg-classes)})))) #?(:clj (defns constructor? [x _] (instance? Constructor x))) @@ -233,43 +233,6 @@ (-> x t/>type (cond-> (not (t/primitive-class? x)) t/?)) (uerr/not-supported! `class>type x))) -;; TODO enhance this to use `t/fn` -;; TODO there's definitely array reflection going on here -(defns methods->type - "Creates a type given ->`methods`." - [methods (s/seq-of t/any? #_method?) #_> #_t/type?] - ;; TODO room for plenty of optimization here - (let [methods|by-ct (->> methods - (c/group-by (fn-> :argtypes count)) - (sort-by first <)) - partition-deep - (fn partition-deep [t methods' arglist-size i|arg depth] - (let [_ (when (> depth 3) (TODO)) - methods'|by-class - (->> methods' - ;; TODO optimize further via `group-by-into` - (c/group-by (fn-> :argtypes (c/get i|arg))) - ;; classes will be sorted from most to least specific - (sort-by (fn-> first t/>type) t/<))] - (r/for [[c methods''] methods'|by-class - t' t] - (update t' :clauses conj - [(class>type c) - (if (= (inc depth) arglist-size) - ;; here, methods'' count will be = 1 - (-> methods'' first :rtype class>type) - (partition-deep - (uxp/condpf-> t/<= (uxp/get (inc i|arg))) - methods'' - arglist-size - (inc i|arg) - (inc depth)))]))))] - (r/for [[ct methods'] methods|by-ct - t (uxp/casef count)] - (if (zero? ct) - (c/assoc-in t [:cases 0] (-> methods' first :rtype class>type)) - (c/assoc-in t [:cases ct] (partition-deep (uxp/condpf-> t/<= (uxp/get 0)) methods' ct 0 0)))))) - #?(:clj (defns ?cast-call->type "Given a cast call like `clojure.lang.RT/uncheckedBooleanCast`, returns the @@ -290,60 +253,85 @@ (uncheckedDoubleCast doubleCast) t/double? nil)))) +(defn- assume-val-for-form? [form] (-> form meta :val true?)) + +(defns- analyze-seq|call-site|incrementally-analyze + [env ::env, form _, target-class class?, args|form _, call-sites-for-ct _, kinds-str string? + > (s/kv {:args|analyzed vector?})] + (let [{:as ret :keys [call-sites args|analyzed]} + (->> args|form + (reducei + (fn [{:as ret :keys [call-sites]} arg|form i|arg] + (let [arg|analyzed (analyze* env arg|form) + arg|analyzed|type (:type arg|analyzed) + call-sites' + (->> call-sites + (c/filter + (fn [{:keys [^"[Ljava.lang.Object;" arg-classes]}] + (t/<= arg|analyzed|type + (class>type (aget arg-classes i|arg))))))] + (if (empty? call-sites') + (err! (str "No " kinds-str " for class match the arg type at index") + {:class target-class + :form form + :arg-type arg|analyzed|type + :i|arg i|arg}) + (-> ret + (assoc :call-sites call-sites') + (update :args|analyzed conj arg|analyzed))))) + {:call-sites call-sites-for-ct :args|analyzed []}))] + (if (-> call-sites count (> 1)) + (err! (str "Multiple " kinds-str " for class match the arg types") + {:class target-class + :form form + (keyword kinds-str) call-sites + :arg-types (mapv :type args|analyzed)}) + ret))) + +(defns- analyze-seq|dot|method-call|incrementally-analyze + [env ::env, form _, target uast/node?, target-class class?, method-form _, args|form _ + methods-for-ct-and-kind (s/seq-of t/any?) > uast/method-call?] + (let [{:keys [args|analyzed call-sites]} + (analyze-seq|call-site|incrementally-analyze env form target-class args|form + methods-for-ct-and-kind "methods") + ?cast-type (?cast-call->type target-class method-form) + ;; TODO enable the below: + ;; (s/validate (-> with-ret-type :args first :type) #(t/>= % (t/numerically ?cast-type))) + _ (when ?cast-type + (log/ppr :warn + "Not yet able to statically validate whether primitive cast will succeed at runtime" + {:form form}))] + (uast/method-call + {:env env + :form form + :target target + :method method-form + :args args|analyzed + :type (-> call-sites first :out-class)}))) + (defns- analyze-seq|dot|method-call "A note will be made of what methods match the argument types. If only one method is found, that is noted too. If no matching method is found, an exception is thrown." [env ::env, form _, target uast/node?, target-class class?, static? t/boolean? - method-form simple-symbol?, args-forms _ #_(seq-of form?) > uast/method-call?] + method-form simple-symbol?, args|form _ #_(seq-of form?) > uast/method-call?] ;; TODO cache type by method (if-not-let [methods-for-name (-> target-class class>methods|with-cache (c/get (name method-form)))] - (if (empty? args-forms) + (if (empty? args|form) (err! "No such method or field in class" {:class target-class :method-or-field method-form}) (err! "No such method in class" {:class target-class :methods method-form})) - (if-not-let [methods-for-count (c/get methods-for-name (c/count args-forms))] + (if-not-let [methods-for-ct (c/get methods-for-name (c/count args|form))] (err! "Incorrect number of arguments for method" {:class target-class :method method-form - :possible-counts (set (keys methods-for-name))}) - (let [static?>kind (fn [static?] (if static? :static :instance))] - (if-not-let [methods (c/get methods-for-count (static?>kind static?))] - (err! (istr "Method found for arg-count, but was ~(static?>kind (not static?)), not ~(static?>kind static?)") - {:class target-class :method method-form :args args-forms}) - (let [args-ct (c/count args-forms) - call-data - {:env env - :form ['. (-> target :form ufth/un-type-hint) method-form] - :target target - :method method-form - :args [] - :type (methods->type methods #_(count arg-forms))} - call-data-with-arg-types - (-> (r/fori [arg-form args-forms - call-data' call-data - i|arg] - (let [arg-node (analyze* env arg-form)] - ;; TODO can incrementally calculate return value, but possibly not - ;; worth it - (-> call-data' - (update :form conj (:form arg-node)) - (update :args conj arg-node)))) - (update :form seq)) - call-data-with-ret-type - (update call-data-with-arg-types :type - (fn [ret-type] (->> call-data-with-arg-types :args (mapv :type) ret-type - (<- (maybe-add-val-assumption-to-type form))))) - ?cast-type (?cast-call->type target-class method-form) - _ (when ?cast-type - (log/ppr :warn "Not yet able to statically validate whether primitive cast will succeed at runtime" {:form form}) - #_(s/validate (-> with-ret-type :args first :type) #(t/>= % (t/numerically ?cast-type))))] - (uast/method-call call-data-with-ret-type))))))) - -(defn- assume-val-for-form? [form] (-> form meta :val true?)) - -(defns- maybe-add-val-assumption-to-type [t t/type?, form _ > t/type?] - (cond-> t (assume-val-for-form? form) (t/and t/val?))) + :possible-counts (->> methods-for-name keys (apply sorted-set))}) + (let [[kind non-kind] (if static? [:static :instance] [:instance :static])] + (if-not-let [methods-for-ct-and-kind (c/get methods-for-ct kind)] + (err! (istr "Method found for arg-count, but was ~non-kind, not ~kind") + {:class target-class :method method-form :args args|form}) + (analyze-seq|dot|method-call|incrementally-analyze env form target target-class + method-form args|form methods-for-ct-and-kind)))))) (defns- analyze-seq|dot|field-access [env ::env, form _, target _, field-form simple-symbol?, field (t/isa? Field) @@ -392,46 +380,24 @@ (analyze-seq|dot|method-call env form target target-class (boolean ?target-static-class-map) method-or-field args-forms))))))) -(defns- analyze-seq|new|gen-incrementally-analyze - [env ::env, form _, constructor-class class?] - (fn [{:as ret :keys [constructors']} arg i|arg] - (let [arg|analyzed (analyze* env arg) - constructors'' - (->> constructors' - (c/filter (fn [{:keys [^"[Ljava.lang.Object;" argtypes]}] - (t/<= (:type arg|analyzed) - (class>type (aget argtypes i|arg))))))] - (if (empty? constructors'') - (err! "No constructors for class match the arg type at index" - {:class constructor-class - :form form - :arg-type (:type arg|analyzed) - :i|arg i|arg}) - (-> ret - (assoc :constructors' constructors'') - (update :args|analyzed conj arg|analyzed)))))) - ;; TODO this is not the right approach for CLJS -;; TODO use a similar approach for `analyze-seq|dot|method-call` (defns- analyze-seq|new - [env ::env, [_ _ & [c|form _ & args _ :as body] _ :as form] _ > uast/new-node?] + [env ::env, [_ _ & [c|form _ & args|form _ :as body] _ :as form] _ > uast/new-node?] (let [c|analyzed (analyze* env c|form)] (if-not (and (-> c|analyzed :type t/value-type?) (-> c|analyzed :type utr/value-type>value class?)) (err! "Supplied non-class to `new` form" {:form form}) (let [c (-> c|analyzed :type utr/value-type>value) constructors (-> c class>constructors|with-cache) - args-ct (count args) + args-ct (count args|form) constructors-for-ct (->> constructors (c/filter (fn [{:keys [^"[Ljava.lang.Object;" argtypes]}] (= (alength argtypes) args-ct))))] (if (empty? constructors-for-ct) - (err! "No constructors for class match the arg ct" {:class c :args|form args}) - (let [{:keys [args|analyzed]} - (->> args - (reducei - (analyze-seq|new|gen-incrementally-analyze env form c) - {:constructors' constructors-for-ct :args|analyzed []}))] + (err! "No constructors for class match the arg ct" {:class c :args|form args|form}) + (let [{:keys [args|analyzed call-sites]} + (analyze-seq|call-site|incrementally-analyze env form c args|form + "constructors")] (uast/new-node {:env env :form (list* 'new c|form (map :form args|analyzed)) @@ -661,8 +627,7 @@ (let [expanded-form (ufeval/macroexpand form)] (if-let [no-expansion? (ucomp/== form expanded-form)] (analyze-seq* env expanded-form) - (let [expanded-form' (-> expanded-form - (update-meta merge (select-keys (meta form) special-metadata-keys))) + (let [expanded-form' (-> expanded-form (update-meta merge (meta form))) expanded (analyze* env expanded-form')] (uast/macro-call {:env env From a0c57daeeeb3d5ba34a39c5d2ebeda765205d801 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 16:41:52 -0600 Subject: [PATCH 362/810] Better naming --- src-untyped/quantum/untyped/core/analyze.cljc | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index bebdc153..2848328a 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -255,7 +255,7 @@ (defn- assume-val-for-form? [form] (-> form meta :val true?)) -(defns- analyze-seq|call-site|incrementally-analyze +(defns- analyze-seq|method-or-constructor-call|incrementally-analyze [env ::env, form _, target-class class?, args|form _, call-sites-for-ct _, kinds-str string? > (s/kv {:args|analyzed vector?})] (let [{:as ret :keys [call-sites args|analyzed]} @@ -292,8 +292,8 @@ [env ::env, form _, target uast/node?, target-class class?, method-form _, args|form _ methods-for-ct-and-kind (s/seq-of t/any?) > uast/method-call?] (let [{:keys [args|analyzed call-sites]} - (analyze-seq|call-site|incrementally-analyze env form target-class args|form - methods-for-ct-and-kind "methods") + (analyze-seq|method-or-constructor-call|incrementally-analyze env form target-class + args|form methods-for-ct-and-kind "methods") ?cast-type (?cast-call->type target-class method-form) ;; TODO enable the below: ;; (s/validate (-> with-ret-type :args first :type) #(t/>= % (t/numerically ?cast-type))) @@ -330,7 +330,7 @@ (if-not-let [methods-for-ct-and-kind (c/get methods-for-ct kind)] (err! (istr "Method found for arg-count, but was ~non-kind, not ~kind") {:class target-class :method method-form :args args|form}) - (analyze-seq|dot|method-call|incrementally-analyze env form target target-class + (analyze-seq|method-or-constructor-call|incrementally-analyze env form target target-class method-form args|form methods-for-ct-and-kind)))))) (defns- analyze-seq|dot|field-access From d83f36cdd622495feb06c3d5cf1c86aae1815a4f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 16:42:48 -0600 Subject: [PATCH 363/810] Fix naming error --- src-untyped/quantum/untyped/core/analyze.cljc | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 2848328a..9e9d08d7 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -330,7 +330,7 @@ (if-not-let [methods-for-ct-and-kind (c/get methods-for-ct kind)] (err! (istr "Method found for arg-count, but was ~non-kind, not ~kind") {:class target-class :method method-form :args args|form}) - (analyze-seq|method-or-constructor-call|incrementally-analyze env form target target-class + (analyze-seq|dot|method-call|incrementally-analyze env form target target-class method-form args|form methods-for-ct-and-kind)))))) (defns- analyze-seq|dot|field-access @@ -396,8 +396,8 @@ (if (empty? constructors-for-ct) (err! "No constructors for class match the arg ct" {:class c :args|form args|form}) (let [{:keys [args|analyzed call-sites]} - (analyze-seq|call-site|incrementally-analyze env form c args|form - "constructors")] + (analyze-seq|method-or-constructor-call|incrementally-analyze env form c + args|form "constructors")] (uast/new-node {:env env :form (list* 'new c|form (map :form args|analyzed)) From 62cf08367da3443a4b98e501e694691ce21d4003 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 18:01:56 -0600 Subject: [PATCH 364/810] Overhaul comparison operators to be a lot nicer --- resources-dev/defnt.cljc | 1 + src-untyped/quantum/untyped/core/compare.cljc | 116 +++++++++++------- src-untyped/quantum/untyped/core/core.cljc | 2 + .../quantum/untyped/core/data/set.cljc | 69 ++++++++--- src-untyped/quantum/untyped/core/loops.cljc | 1 - src/quantum/core/compare.cljc | 27 +--- test/quantum/test/untyped/core/data/set.cljc | 6 +- 7 files changed, 139 insertions(+), 83 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index faf7dd70..a3dbcbe4 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -1298,6 +1298,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - quantum.core.data.bits - quantum.core.convert.primitive - List of corresponding untyped namespaces to incorporate: + - [ ] quantum.untyped.core.compare - [ ] quantum.untyped.core.core - [ ] quantum.untyped.core.ns - [ ] quantum.untyped.core.vars diff --git a/src-untyped/quantum/untyped/core/compare.cljc b/src-untyped/quantum/untyped/core/compare.cljc index 762016ee..7567486c 100644 --- a/src-untyped/quantum/untyped/core/compare.cljc +++ b/src-untyped/quantum/untyped/core/compare.cljc @@ -5,56 +5,88 @@ [quantum.untyped.core.core :as ucore :refer [defaliases]] [quantum.untyped.core.fn - :refer [fn']])) + :refer [fn']] + [quantum.untyped.core.logic + :refer [fn-or ifs]])) (ucore/log-this-ns) (def == identical?) (def not== (comp not identical?)) -(def ^:const ident 1) -(def ^:const >ident 3) - -(def comparisons #{ident >ident}) -(def comparison? comparisons) - -(defn invert [c #_comparison? #_> #_comparison?] - (case c - -1 >ident - 1 = [c] (or (= c >ident) (= c =ident))) -(defn comparison> [c] (= c >ident)) -(defn comparison>< [c] (= c > [c] (= c <>ident)) - -(defn compf< [compf x0 x1] (comparison< (compf x0 x1))) -(defn compf<= [compf x0 x1] (comparison<= (compf x0 x1))) -(defn compf= [compf x0 x1] (comparison= (compf x0 x1))) -(defn compf-not= [compf x0 x1] (comparison-not= (compf x0 x1))) -(defn compf>= [compf x0 x1] (comparison>= (compf x0 x1))) -(defn compf> [compf x0 x1] (comparison> (compf x0 x1))) -(defn compf>< [compf x0 x1] (comparison>< (compf x0 x1))) -(defn compf<> [compf x0 x1] (comparison<> (compf x0 x1))) - -(defn comp< [x0 x1] (compf< compare x0 x1)) -(defn comp<= [x0 x1] (compf<= compare x0 x1)) -(defn comp= [x0 x1] (compf= compare x0 x1)) -(defn comp-not= [x0 x1] (compf-not= compare x0 x1)) -(defn comp>= [x0 x1] (compf>= compare x0 x1)) -(defn comp> [x0 x1] (compf> compare x0 x1)) -(defn comp>< [x0 x1] (compf>< compare x0 x1)) -(defn comp<> [x0 x1] (compf<> compare x0 x1)) +(def comparison= zero?) +(def comparison< neg?) +(def comparison<= (fn-or comparison< comparison=)) +(def comparison-not= (comp not comparison=)) +(def comparison>= (fn-or comparison> comparison=)) +(def comparison> pos?) +(defn comp< ([ x0 x1] (comp< compare x0 x1)) + ([compf x0 x1] (comparison< (compf x0 x1)))) +(defn comp<= ([ x0 x1] (comp<= compare x0 x1)) + ([compf x0 x1] (comparison<= (compf x0 x1)))) +(defn comp= ([ x0 x1] (comp= compare x0 x1)) + ([compf x0 x1] (comparison= (compf x0 x1)))) +(defn comp-not= ([ x0 x1] (comp-not= compare x0 x1)) + ([compf x0 x1] (comparison-not= (compf x0 x1)))) +(defn comp>= ([ x0 x1] (comp>= compare x0 x1)) + ([compf x0 x1] (comparison>= (compf x0 x1)))) +(defn comp> ([ x0 x1] (comp> compare x0 x1)) + ([compf x0 x1] (comparison> (compf x0 x1)))) + +;; TODO deprecate (def class->comparator {#?@(:clj [Class (fn [^Class a ^Class b] (.compareTo (.getName a) (.getName b)))])}) + +(defn rcompare + "Reverse comparator." + {:adapted-from "taoensso.encore, possibly via weavejester.medley"} + [a b] (compare b a)) + +(defn comp-extrema-of + "Returns the extreme elements of `xs` according to comparator `compf` and `comparisonf` in O(n) + time." + ([comparisonf xs] (comp-extrema-of comparisonf compare xs)) + ([comparisonf compf xs] + (->> xs + (reduce + (fn ([[extremum extrema :as ret] x] + (if (identical? extremum ucore/sentinel) + [x [x]] + (let [c (int (compf x extremum))] + (ifs (comparison= c) + [x (conj extrema x)] + (comparisonf c) + [x [x]] + ret))))) + [ucore/sentinel []]) + second))) + +(defn comp-mins-of + "Returns the 'min' elements of `xs` according to comparator `compf` in O(n) time." + ([xs] (comp-mins-of compare xs)) + ([compf xs] (comp-extrema-of comparison< compf xs))) + +(defn comp-maxes-of + "Returns the 'max' elements of `xs` according to comparator `compf` in O(n) time." + ([xs] (comp-mins-of compare xs)) + ([compf xs] (comp-extrema-of comparison> compf xs))) + +(defn gen-comp-extremum|rf [compf comparisonf] + (fn ([] nil) ([prev x] (if (comparisonf (compf x prev)) x prev)))) + +(defn gen-comp-min|rf [compf] (gen-comp-extremum|rf compf comparison<)) + +(defn comp-min-of + "Returns the 'min' element of `xs` according to comparator `compf` in O(n) time." + ([xs] (comp-min-of compare xs)) + ([compf xs] (->> xs (reduce (gen-comp-min|rf compf))))) + +(defn gen-comp-max|rf [compf] (gen-comp-extremum|rf compf comparison>)) + +(defn comp-max-of + "Returns the 'max' element of `xs` according to comparator `compf` in O(n) time." + ([xs] (comp-max-of compare xs)) + ([compf xs] (->> xs (reduce (gen-comp-max|rf compf))))) diff --git a/src-untyped/quantum/untyped/core/core.cljc b/src-untyped/quantum/untyped/core/core.cljc index e9f4e8c2..c51c297d 100644 --- a/src-untyped/quantum/untyped/core/core.cljc +++ b/src-untyped/quantum/untyped/core/core.cljc @@ -37,6 +37,8 @@ (defn >sentinel [] #?(:clj (Object.) :cljs #js {})) (def >object >sentinel) +(defonce sentinel (>sentinel)) + ;; From `quantum.untyped.core.form.evaluate` — used below in `defalias` (defn cljs-env? diff --git a/src-untyped/quantum/untyped/core/data/set.cljc b/src-untyped/quantum/untyped/core/data/set.cljc index 101b13ad..3a542145 100644 --- a/src-untyped/quantum/untyped/core/data/set.cljc +++ b/src-untyped/quantum/untyped/core/data/set.cljc @@ -45,33 +45,74 @@ (defalias + union) -;; ===== Comparison ===== ;; +;; ===== Set-specific comparison ===== ;; + +(def ^:const ident 1) ; superset +(def ^:const >ident 3) ; disjoint + +(def comparisons #{ident >ident}) +(def comparison? comparisons) + +(defn invert-comparison [c #_comparison? #_> #_comparison?] + (case c + -1 >ident + 1 ident + >ident ;; TODO do fewer comparisons here (let [diff0 (- s0 s1), diff1 (- s1 s0)] (if (empty? diff0) (if (empty? diff1) - ucomp/=ident - ucomp/ident + >ident (if (some #(contains? s1 %) s0) - ucomp/>ident))))))) + >ident))))))) + +(defn comparison< [c] (identical? c = [c] (or (identical? c >ident) (identical? c =ident))) +(defn comparison> [c] (identical? c >ident)) +(defn comparison>< [c] (identical? c > [c] (identical? c <>ident)) + +(defn comp< ([ x0 x1] (comp< compare x0 x1)) + ([compf x0 x1] (comparison< (compf x0 x1)))) +(defn comp<= ([ x0 x1] (comp<= compare x0 x1)) + ([compf x0 x1] (comparison<= (compf x0 x1)))) +(defn comp= ([ x0 x1] (comp= compare x0 x1)) + ([compf x0 x1] (comparison= (compf x0 x1)))) +(defn comp-not= ([ x0 x1] (comp-not= compare x0 x1)) + ([compf x0 x1] (comparison-not= (compf x0 x1)))) +(defn comp>= ([ x0 x1] (comp>= compare x0 x1)) + ([compf x0 x1] (comparison>= (compf x0 x1)))) +(defn comp> ([ x0 x1] (comp> compare x0 x1)) + ([compf x0 x1] (comparison> (compf x0 x1)))) +(defn comp>< ([ x0 x1] (comp>< compare x0 x1)) + ([compf x0 x1] (comparison>< (compf x0 x1)))) +(defn comp<> ([ x0 x1] (comp<> compare x0 x1)) + ([compf x0 x1] (comparison<> (compf x0 x1)))) -(defn < [x0 x1] (ucomp/compf< compare x0 x1)) +(defn < [x0 x1] (comp< x0 x1)) (defalias proper-subset? <) -(defn <= [x0 x1] (ucomp/compf<= compare x0 x1)) +(defn <= [x0 x1] (comp<= x0 x1)) (defalias subset? <=) -(defn >= [x0 x1] (ucomp/compf>= compare x0 x1)) +(defn >= [x0 x1] (comp>= x0 x1)) (defalias superset? >=) -(defn > [x0 x1] (ucomp/compf> compare x0 x1)) +(defn > [x0 x1] (comp> x0 x1)) (defalias proper-superset? >) -(defn >< [x0 x1] (ucomp/compf>< compare x0 x1)) -(defn <> [x0 x1] (ucomp/compf<> compare x0 x1)) +(defn >< [x0 x1] (comp>< x0 x1)) +(defn <> [x0 x1] (comp<> x0 x1)) (defalias disjoint? <>) diff --git a/src-untyped/quantum/untyped/core/loops.cljc b/src-untyped/quantum/untyped/core/loops.cljc index ba5a82bd..dc072013 100644 --- a/src-untyped/quantum/untyped/core/loops.cljc +++ b/src-untyped/quantum/untyped/core/loops.cljc @@ -25,7 +25,6 @@ (next xs0') (next xs1')))))) - ;; TODO incorporate into `quantum.core.loops` #?(:clj (defmacro doseq diff --git a/src/quantum/core/compare.cljc b/src/quantum/core/compare.cljc index ea88fa67..1043cf96 100644 --- a/src/quantum/core/compare.cljc +++ b/src/quantum/core/compare.cljc @@ -30,7 +30,8 @@ [quantum.core.reducers :as red :refer [reduce, transduce]] [quantum.core.vars - :refer [defalias defaliases]]) + :refer [defalias defaliases]] + [quantum.untyped.core.compare :as ucomp]) #?(:cljs (:require-macros [quantum.core.compare :as self :refer [< > <= >=]])) @@ -209,28 +210,8 @@ (defn reduce-comp-keys [ compf kf xs] (transduce (gen-comp-keys-into:rf vector compf kf ) xs)) ; TODO use this/> (defn reduce-comp-keys-into [initf compf kf xs] (transduce (gen-comp-keys-into:rf initf compf kf ) xs)) ; TODO use this/> -(defn rcompare - "Reverse comparator." - {:attribution "taoensso.encore, possibly via weavejester.medley"} - [x y] (compare y x)) - -(defn greatest - "Returns the 'greatest' element in coll in O(n) time." - {:attribution "taoensso.encore, possibly via weavejester.medley"} - [coll & [?comparator]] - (let [comparator (or ?comparator rcompare)] - (reduce - (fn ([] nil) ([a b] (if (pos? (comparator a b)) b a))) - coll))) - -(defn least - "Returns the 'least' element in coll in O(n) time." - {:attribution "taoensso.encore, possibly via weavejester.medley"} - [coll & [?comparator]] - (let [comparator (or ?comparator rcompare)] - (reduce - (fn ([] nil) ([a b] (if (neg? (comparator a b)) b a))) - coll))) + +(defaliases ucomp greatest least rcompare) (defn unsorted-by "Returns which elements are unsorted, as by `kf` and `comparef`." diff --git a/test/quantum/test/untyped/core/data/set.cljc b/test/quantum/test/untyped/core/data/set.cljc index 2ef7ebcf..4e4f7029 100644 --- a/test/quantum/test/untyped/core/data/set.cljc +++ b/test/quantum/test/untyped/core/data/set.cljc @@ -11,11 +11,11 @@ the inputs are internally commutative if applicable (e.g. if `a` is an `AndType`, ensures that it is commutative). The basis comparison is the first input." - [c #_ucomp/comparisons a #_set? b #_set?] + [c #_uset/comparisons a #_set? b #_set?] `(let [c# ~c, a# ~a, b# ~b] ;; Symmetry - (is= c# (uset/compare a# b#)) - (is= (ucomp/invert c#) (uset/compare b# a#))))) + (is= c# (uset/compare a# b#)) + (is= (uset/invert-comparison c#) (uset/compare b# a#))))) (deftest test|set (testing "< , >" From 64d415a3e078337a8bdadb747f7cb14c9f3677cf Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 18:12:02 -0600 Subject: [PATCH 365/810] `call-sites>most-specific` --- resources-dev/defnt.cljc | 15 +++++--- src-untyped/quantum/untyped/core/analyze.cljc | 36 ++++++++++++++++--- src-untyped/quantum/untyped/core/compare.cljc | 4 +-- .../quantum/untyped/core/type/compare.cljc | 27 +++++++------- .../quantum/untyped/core/type/defnt.cljc | 4 +-- src/quantum/core/type.cljc | 3 +- 6 files changed, 62 insertions(+), 27 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index a3dbcbe4..790c09e0 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -59,11 +59,16 @@ TODO: Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - ;; TODO test the new analyze-seq|new!!! - [1 .] This is accepted by the type system without knowing the type: - (java.math.BigInteger. 1 (-> (ByteBuffer/allocate (int 8)) (.putLong x) .array)) - - So, constructors need the same kind of lookup that dot calls have + [1 .] Fix `analyze-seq|method-or-constructor-call|incrementally-analyze` : + Error Message: No methods for class match the arg type at index + Data: + {:class quantum.core.Numeric, + :form (. Numeric bitAnd (short 255) x), + :arg-type (quantum.untyped.core.type/or + (quantum.untyped.core.type/value nil) + (quantum.untyped.core.type/isa? short)), + :i|arg 0} + quantum.untyped.core.error/>err (error.cljc:169) [2 .] t/type - dependent types: `[x arr/array? > (t/type x)]` [3] t/value-of diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 9e9d08d7..0f88f92e 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -33,6 +33,7 @@ [quantum.untyped.core.spec :as s] [quantum.untyped.core.type :as t :refer [?]] + [quantum.untyped.core.type.compare :as utcomp] [quantum.untyped.core.type.reifications :as utr] [quantum.untyped.core.vars :as uvar :refer [update-meta]])) @@ -253,8 +254,34 @@ (uncheckedDoubleCast doubleCast) t/double? nil)))) +;; TODO use this (defn- assume-val-for-form? [form] (-> form meta :val true?)) +(defns- maybe-with-assume-val [c class?, form _ > t/type?] + (if (assume-val-for-form? form) + (t/isa? c) + (t/? (t/isa? c)))) + +;; TODO move? +(defns- compare-class-specificity [c0 class?, c1 class?] + (case (utcomp/compare|class+class* c0 c1) + -1 -1 + (0 2 3) 0 + 1 1)) + +(defns- call-sites>most-specific + "Time complexity = O(m•n) where m = # of call sites and n = # of args per call site." + [call-sites (s/vec-of t/any? #_(s/array-of class?)) > (s/vec-of t/any? #_(s/array-of class?))] + (let [^"[Ljava.lang.Object;" sample-arg-classes (-> call-sites first :arg-classes) + args-ct (alength sample-arg-classes)] + (->> (range args-ct) + (reduce + (fn [call-sites' i] + (->> call-sites' + (c/map+ (fn [{:keys [^"[Ljava.lang.Object;" arg-classes]}] (aget arg-classes i))) + (ucomp/comp-mins-of compare-class-specificity))) + call-sites)))) + (defns- analyze-seq|method-or-constructor-call|incrementally-analyze [env ::env, form _, target-class class?, args|form _, call-sites-for-ct _, kinds-str string? > (s/kv {:args|analyzed vector?})] @@ -279,9 +306,10 @@ (-> ret (assoc :call-sites call-sites') (update :args|analyzed conj arg|analyzed))))) - {:call-sites call-sites-for-ct :args|analyzed []}))] + {:call-sites call-sites-for-ct :args|analyzed []})) + call-sites (cond-> call-sites (-> call-sites count (> 1)) call-sites>most-specific)] (if (-> call-sites count (> 1)) - (err! (str "Multiple " kinds-str " for class match the arg types") + (err! (str "Multiple, equally specific " kinds-str " for class match the arg types") {:class target-class :form form (keyword kinds-str) call-sites @@ -307,7 +335,7 @@ :target target :method method-form :args args|analyzed - :type (-> call-sites first :out-class)}))) + :type (-> call-sites first :out-class (maybe-with-assume-val form))}))) (defns- analyze-seq|dot|method-call "A note will be made of what methods match the argument types. @@ -341,7 +369,7 @@ :form form :target target :field field-form - :type (-> field :class t/>type (maybe-add-val-assumption-to-type form))})) + :type (-> field :class (maybe-with-assume-val form))})) (defns classes>class "Ensure that given a set of classes, that set consists of at most a class C and nil. diff --git a/src-untyped/quantum/untyped/core/compare.cljc b/src-untyped/quantum/untyped/core/compare.cljc index 7567486c..943a3e6b 100644 --- a/src-untyped/quantum/untyped/core/compare.cljc +++ b/src-untyped/quantum/untyped/core/compare.cljc @@ -65,12 +65,12 @@ second))) (defn comp-mins-of - "Returns the 'min' elements of `xs` according to comparator `compf` in O(n) time." + "Returns the equally 'min' elements of `xs` according to comparator `compf` in O(n) time." ([xs] (comp-mins-of compare xs)) ([compf xs] (comp-extrema-of comparison< compf xs))) (defn comp-maxes-of - "Returns the 'max' elements of `xs` according to comparator `compf` in O(n) time." + "Returns the equally 'max' elements of `xs` according to comparator `compf` in O(n) time." ([xs] (comp-mins-of compare xs)) ([compf xs] (comp-extrema-of comparison> compf xs))) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index 295a3629..c719878b 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -11,10 +11,11 @@ ;; TODO remove this dependency [quantum.untyped.core.classes :as uclass] [quantum.untyped.core.compare :as ucomp - :refer [== ident >ident comparison?]] + :refer [==]] [quantum.untyped.core.core :as ucore] [quantum.untyped.core.data.bits :as ubit] - [quantum.untyped.core.data.set :as uset] + [quantum.untyped.core.data.set :as uset + :refer [ident >ident comparison?]] [quantum.untyped.core.defnt :refer [defns defns-]] [quantum.untyped.core.error @@ -294,7 +295,7 @@ ;; TODO take away var indirection once done (def- compare|dispatch - (let [inverted (fn [f] (fn [t0 t1] (ucomp/invert (f t1 t0))))] + (let [inverted (fn [f] (fn [t0 t1] (uset/invert-comparison (f t1 t0))))] {UniversalSetType {UniversalSetType #'fn= EmptySetType #'compare|universal+empty @@ -408,44 +409,44 @@ (defns < "Computes whether the extension of type ->`t0` is a strict subset of that of ->`t1`." ([t1 type?] #(< % t1)) - ([t0 type?, t1 type? > boolean?] (ucomp/compf< compare t0 t1))) + ([t0 type?, t1 type? > boolean?] (uset/comp< compare t0 t1))) (defns <= "Computes whether the extension of type ->`t0` is a (lax) subset of that of ->`t1`." ([t1 type?] #(<= % t1)) - ([t0 type?, t1 type? > boolean?] (ucomp/compf<= compare t0 t1))) + ([t0 type?, t1 type? > boolean?] (uset/comp<= compare t0 t1))) (defns = "Computes whether the extension of type ->`t0` is equal to that of ->`t1`." ([t1 type?] #(= % t1)) - ([t0 type?, t1 type? > boolean?] (ucomp/compf= compare t0 t1))) + ([t0 type?, t1 type? > boolean?] (uset/comp= compare t0 t1))) (defns not= "Computes whether the extension of type ->`t0` is not equal to that of ->`t1`." ([t1 type?] #(not= % t1)) - ([t0 type?, t1 type? > boolean?] (ucomp/compf-not= compare t0 t1))) + ([t0 type?, t1 type? > boolean?] (uset/comp-not= compare t0 t1))) (defns >= "Computes whether the extension of type ->`t0` is a (lax) superset of that of ->`t1`." ([t1 type?] #(>= % t1)) - ([t0 type?, t1 type? > boolean?] (ucomp/compf>= compare t0 t1))) + ([t0 type?, t1 type? > boolean?] (uset/comp>= compare t0 t1))) (defns > "Computes whether the extension of type ->`t0` is a strict superset of that of ->`t1`." ([t1 type?] #(> % t1)) - ([t0 type?, t1 type? > boolean?] (ucomp/compf> compare t0 t1))) + ([t0 type?, t1 type? > boolean?] (uset/comp> compare t0 t1))) (defns >< "Computes whether it is the case that the intersect of the extensions of type ->`t0` and ->`t1` is non-empty, and neither ->`t0` nor ->`t1` share a subset/equality/superset relationship." ([t1 type?] #(>< % t1)) - ([t0 type?, t1 type? > boolean?] (ucomp/compf>< compare t0 t1))) + ([t0 type?, t1 type? > boolean?] (uset/comp>< compare t0 t1))) (defns <> "Computes whether the respective extensions of types ->`t0` and ->`t1` are disjoint." ([t1 type?] #(<> % t1)) - ([t0 type? t1 type? > boolean?] (ucomp/compf<> compare t0 t1))) + ([t0 type? t1 type? > boolean?] (uset/comp<> compare t0 t1))) ;; ===== FnType ===== ;; @@ -453,9 +454,9 @@ (defns combine-comparisons "Used in `t/compare|in` and `t/compare|out`. Might be used for other things too in the future. Commutative in the 2-ary arity." - ([cs _ #_(seq-of ucomp/comparison?) > ucomp/comparison?] + ([cs _ #_(seq-of uset/comparison?) > uset/comparison?] (reduce (fn [c' c] (combine-comparisons c' c)) (first cs) (rest cs))) - ([^long c0 ucomp/comparison?, ^long c1 ucomp/comparison? > ucomp/comparison?] + ([^long c0 uset/comparison?, ^long c1 uset/comparison? > uset/comparison?] (case c0 -1 (case c1 -1 dynamic-dispatch-fn|type-decl [{:keys [fnt|output-type|form _, fnt|type _]} ::fnt-globals expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups)] - (list* `t/fn fnt|output-type|form + (list* `t/ftype fnt|output-type|form (->> expanded-overload-groups-by-fnt-overload (map (fn [{{:keys [arg-types|form pre-type|form post-type|form]} :overload-data}] (cond-> (or arg-types|form []) @@ -617,7 +617,7 @@ (cond-> arg-types pre-type (conj :| pre-type) post-type (conj :> post-type)))) - (apply t/fn fnt|output-type))) + (apply t/ftype fnt|output-type))) (defns fnt|parsed-overload>overload-data [{:as in {:keys [args _, varargs _] diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index 55ae0654..929519de 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -15,7 +15,8 @@ (defaliases ut ;; Generators ? * isa? - fn ; TODO TYPED rename + ; fn ; TODO TYPED rename + ftype value ;; Combinators and or - if not From 6728eec7b77f14d50af93bf3da5e08a7ea24998d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 18:36:04 -0600 Subject: [PATCH 366/810] Fix some analysis errors --- src-untyped/quantum/untyped/core/analyze.cljc | 45 ++++++++++--------- src-untyped/quantum/untyped/core/type.cljc | 12 +++++ 2 files changed, 35 insertions(+), 22 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 0f88f92e..f210b725 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -224,16 +224,6 @@ :body body :type body|type}))) -;; TODO move? -(defn class>type - "For converting a class in a reflective method, constructor, or field declaration to a type. - Unlike `t/isa?`, takes into account that non-primitive classes in Java aren't guaranteed to be - non-null." - [x] - (if (class? x) - (-> x t/>type (cond-> (not (t/primitive-class? x)) t/?)) - (uerr/not-supported! `class>type x))) - #?(:clj (defns ?cast-call->type "Given a cast call like `clojure.lang.RT/uncheckedBooleanCast`, returns the @@ -254,13 +244,22 @@ (uncheckedDoubleCast doubleCast) t/double? nil)))) -;; TODO use this +;; TODO move? +(defns class>type + "For converting a class in a reflective method, constructor, or field declaration to a type. + Unlike `t/isa?`, takes into account that non-primitive classes in Java aren't guaranteed to be + non-null." + [x class? > t/type?] + (let [matching-boxed-class (t/unboxed-class->boxed-class x)] + (-> (or matching-boxed-class x) t/isa? (cond-> (not matching-boxed-class) t/?)))) + (defn- assume-val-for-form? [form] (-> form meta :val true?)) (defns- maybe-with-assume-val [c class?, form _ > t/type?] - (if (assume-val-for-form? form) - (t/isa? c) - (t/? (t/isa? c)))) + (let [matching-boxed-class (t/unboxed-class->boxed-class c)] + (-> (or matching-boxed-class c) + t/isa? + (cond-> (and (not matching-boxed-class) (not (assume-val-for-form? form))) t/?)))) ;; TODO move? (defns- compare-class-specificity [c0 class?, c1 class?] @@ -288,7 +287,7 @@ (let [{:as ret :keys [call-sites args|analyzed]} (->> args|form (reducei - (fn [{:as ret :keys [call-sites]} arg|form i|arg] + (fn [{:as ret :keys [args|analyzed call-sites]} arg|form i|arg] (let [arg|analyzed (analyze* env arg|form) arg|analyzed|type (:type arg|analyzed) call-sites' @@ -299,10 +298,12 @@ (class>type (aget arg-classes i|arg))))))] (if (empty? call-sites') (err! (str "No " kinds-str " for class match the arg type at index") - {:class target-class - :form form - :arg-type arg|analyzed|type - :i|arg i|arg}) + {:class target-class + :form form + :arg|type arg|analyzed|type + :arg|analyzed-form (:form arg|analyzed) + :i|arg i|arg + :arg-types-so-far (mapv :type args|analyzed)}) (-> ret (assoc :call-sites call-sites') (update :args|analyzed conj arg|analyzed))))) @@ -419,13 +420,13 @@ constructors (-> c class>constructors|with-cache) args-ct (count args|form) constructors-for-ct (->> constructors - (c/filter (fn [{:keys [^"[Ljava.lang.Object;" argtypes]}] - (= (alength argtypes) args-ct))))] + (c/filter (fn [{:keys [^"[Ljava.lang.Object;" arg-classes]}] + (= (alength arg-classes) args-ct))))] (if (empty? constructors-for-ct) (err! "No constructors for class match the arg ct" {:class c :args|form args|form}) (let [{:keys [args|analyzed call-sites]} (analyze-seq|method-or-constructor-call|incrementally-analyze env form c - args|form "constructors")] + args|form constructors-for-ct "constructors")] (uast/new-node {:env env :form (list* 'new c|form (map :form args|analyzed)) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index c0804a1f..d06cda4a 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -482,6 +482,18 @@ ;; ===== Etc. ===== ;; +;; TODO figure out the best place to put this +#?(:clj +(def unboxed-class->boxed-class + {Boolean/TYPE Boolean + Byte/TYPE Byte + Short/TYPE Short + Character/TYPE Character + Integer/TYPE Integer + Long/TYPE Long + Float/TYPE Float + Double/TYPE Double})) + ;; TODO figure out the best place to put this #?(:clj (def boxed-class->unboxed-symbol From 121778889c4a4461a21a2cfb42ceca4a5310d86d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 18:36:56 -0600 Subject: [PATCH 367/810] Update todo --- resources-dev/defnt.cljc | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 790c09e0..ac0b1010 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -59,16 +59,20 @@ TODO: Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - [1 .] Fix `analyze-seq|method-or-constructor-call|incrementally-analyze` : - Error Message: No methods for class match the arg type at index + [1 .] Fix `quantum.untyped.core.analyze`: + Error Message: Multiple, equally specific methods for class match the arg types Data: - {:class quantum.core.Numeric, - :form (. Numeric bitAnd (short 255) x), - :arg-type (quantum.untyped.core.type/or - (quantum.untyped.core.type/value nil) - (quantum.untyped.core.type/isa? short)), - :i|arg 0} - quantum.untyped.core.error/>err (error.cljc:169) + {:class java.nio.ByteBuffer, + :form (. (.putLong (ByteBuffer/allocate (int 8)) x) array), + :methods [#M{:name 'array', + :out-class java.lang.Object, + :arg-classes #class<>[], + :kind :instance} + #M{:name 'array', + :out-class '[B', + :arg-classes #class<>[], + :kind :instance}], + :arg-types []} [2 .] t/type - dependent types: `[x arr/array? > (t/type x)]` [3] t/value-of From 7770a5c72c476c32e9d08c857d30dd90427a9b06 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 22:45:15 -0600 Subject: [PATCH 368/810] `with-distinct-arg-class-seqs` --- src-untyped/quantum/untyped/core/analyze.cljc | 98 ++++++++++++------- src/quantum/core/data/primitive.cljc | 3 +- 2 files changed, 63 insertions(+), 38 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index f210b725..634940c4 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -40,6 +40,30 @@ (def special-metadata-keys #{:val}) +;; TODO move? +(defns class>type + "For converting a class in a reflective method, constructor, or field declaration to a type. + Unlike `t/isa?`, takes into account that non-primitive classes in Java aren't guaranteed to be + non-null." + [x class? > t/type?] + (let [matching-boxed-class (t/unboxed-class->boxed-class x)] + (-> (or matching-boxed-class x) t/isa? (cond-> (not matching-boxed-class) t/?)))) + +(defn- assume-val-for-form? [form] (-> form meta :val true?)) + +(defns- maybe-with-assume-val [c class?, form _ > t/type?] + (let [matching-boxed-class (t/unboxed-class->boxed-class c)] + (-> (or matching-boxed-class c) + t/isa? + (cond-> (and (not matching-boxed-class) (not (assume-val-for-form? form))) t/?)))) + +;; TODO move? +(defns- compare-class-specificity [c0 class?, c1 class?] + (case (utcomp/compare|class+class* c0 c1) + -1 -1 + (0 2 3) 0 + 1 1)) + ;; ----- Reflection support ----- ;; #?(:clj @@ -52,19 +76,40 @@ #?(:clj (defns class>methods - "Returns all the public methods associated with a class, as a map from method name to methods." + "Returns all the public methods associated with a class, as a map from: + method-name -> arg-count -> kind=static|instance -> methods" [^Class c class? > map?] - (->> (.getMethods c) - (c/map+ (fn [^java.lang.reflect.Method x] - (Method. (.getName x) (.getReturnType x) (.getParameterTypes x) - (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) - :static - :instance)))) - (c/group-by (fn [^Method x] (:name x))) ; TODO all of these need to be into !vector and !hash-map - (c/map-vals+ (fn->> (c/group-by (fn [^Method x] (count (:arg-classes x)))) - (c/map-vals+ (fn->> (c/group-by (fn [^Method x] (:kind x))))) + (let [with-most-specific-out-class + (fn->> (ucomp/comp-min-of + (fn [m0 m1] (compare-class-specificity (:out-class m0) (:out-class m1))))) + ;; Because even though it's not supposed to be the case that there is ever more than one + ;; method with the same combination of name, kind (static/instance), and arg classes, only + ;; differing by return type, it *has* happened on Java version "1.8.0_162", Mac OS X, JVM + ;; version "25.162-b12", with the `ByteBuffer.array()` public instance method which maps to + ;; to overloads, one which returns `Object` and one which returns `byte[]`. + ;; See also this link for the claim that this is impossible according to the Java 1.8 spec + ;; (http://docs.oracle.com/javase/specs/jls/se8/html/jls-8.html#jls-8.4.2) and that the bug + ;; only exists in Java 6 or 7 on Oracle's JDK, OpenJDK, and IBM's JDK: https://stackoverflow.com/questions/5561436/can-two-java-methods-have-same-name-with-different-return-types + with-distinct-arg-class-seqs + (fn->> (c/group-by (fn-> :arg-classes vec)) + vals + (c/map with-most-specific-out-class))] + (->> (.getMethods c) + (c/map+ (fn [^java.lang.reflect.Method x] + (Method. (.getName x) (.getReturnType x) (.getParameterTypes x) + (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) + :static + :instance)))) + (c/group-by (fn [^Method x] (:name x))) ; TODO all of these need to be into !vector and !hash-map + (c/map-vals+ + (fn->> (c/group-by (fn [^Method x] (count (:arg-classes x)))) + (c/map-vals+ + (fn->> (c/group-by (fn [^Method x] (:kind x))) + (c/map-vals+ with-distinct-arg-class-seqs) (r/join {}))) - (r/join {})))) + (r/join {}))) + (r/join {}))))) + (defonce class>methods|with-cache (memoize (fn [c] (class>methods c)))) @@ -244,30 +289,6 @@ (uncheckedDoubleCast doubleCast) t/double? nil)))) -;; TODO move? -(defns class>type - "For converting a class in a reflective method, constructor, or field declaration to a type. - Unlike `t/isa?`, takes into account that non-primitive classes in Java aren't guaranteed to be - non-null." - [x class? > t/type?] - (let [matching-boxed-class (t/unboxed-class->boxed-class x)] - (-> (or matching-boxed-class x) t/isa? (cond-> (not matching-boxed-class) t/?)))) - -(defn- assume-val-for-form? [form] (-> form meta :val true?)) - -(defns- maybe-with-assume-val [c class?, form _ > t/type?] - (let [matching-boxed-class (t/unboxed-class->boxed-class c)] - (-> (or matching-boxed-class c) - t/isa? - (cond-> (and (not matching-boxed-class) (not (assume-val-for-form? form))) t/?)))) - -;; TODO move? -(defns- compare-class-specificity [c0 class?, c1 class?] - (case (utcomp/compare|class+class* c0 c1) - -1 -1 - (0 2 3) 0 - 1 1)) - (defns- call-sites>most-specific "Time complexity = O(m•n) where m = # of call sites and n = # of args per call site." [call-sites (s/vec-of t/any? #_(s/array-of class?)) > (s/vec-of t/any? #_(s/array-of class?))] @@ -303,7 +324,12 @@ :arg|type arg|analyzed|type :arg|analyzed-form (:form arg|analyzed) :i|arg i|arg - :arg-types-so-far (mapv :type args|analyzed)}) + :arg-types + (vec (concat (mapv :type args|analyzed) + [arg|analyzed|type] + (repeat (- (count args|form) + (count args|analyzed)) + :unanalyzed)))}) (-> ret (assoc :call-sites call-sites') (update :args|analyzed conj arg|analyzed))))) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index a684b431..abd60bba 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -396,11 +396,10 @@ ([x byte?] (Numeric/bitAnd (short 0xFF) x)) ([x short?] (Numeric/bitAnd (int 0xFFFF) x)) ([x int?] (Numeric/bitAnd (long 0xFFFFFFFF) x)) - ;; TODO TYPED there is reflection here but there shouldn't be ([x long?] (java.math.BigInteger. (int 1) (-> ^:val (ByteBuffer/allocate (int 8)) ^:val (.putLong x) - .array))))) ; TODO reflection + .array))))) ;; TODO TYPED awaiting `>long` #_(:clj (t/defn ubyte>byte [x long? > long?] (-> x >byte >long))) From 923b7000b9b8919d56985fffe62d19d395e0c2e1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 22:45:51 -0600 Subject: [PATCH 369/810] Update comment --- src-untyped/quantum/untyped/core/analyze.cljc | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 634940c4..ec6bbc2d 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -82,11 +82,12 @@ (let [with-most-specific-out-class (fn->> (ucomp/comp-min-of (fn [m0 m1] (compare-class-specificity (:out-class m0) (:out-class m1))))) - ;; Because even though it's not supposed to be the case that there is ever more than one - ;; method with the same combination of name, kind (static/instance), and arg classes, only - ;; differing by return type, it *has* happened on Java version "1.8.0_162", Mac OS X, JVM - ;; version "25.162-b12", with the `ByteBuffer.array()` public instance method which maps to - ;; to overloads, one which returns `Object` and one which returns `byte[]`. + ;; We have to use `with-distinct-arg-class-seqs` Because even though it's not supposed to + ;; be the case that there is ever more than one method with the same combination of name, + ;; kind (static/instance), and arg classes, only differing by return type, it *has* + ;; happened on Java version "1.8.0_162", Mac OS X, JVM version "25.162-b12", with the + ;; `ByteBuffer.array()` public instance method which maps to two overloads, one which + ;; returns `Object` and one which returns `byte[]`. ;; See also this link for the claim that this is impossible according to the Java 1.8 spec ;; (http://docs.oracle.com/javase/specs/jls/se8/html/jls-8.html#jls-8.4.2) and that the bug ;; only exists in Java 6 or 7 on Oracle's JDK, OpenJDK, and IBM's JDK: https://stackoverflow.com/questions/5561436/can-two-java-methods-have-same-name-with-different-return-types From df02385b9b0dcc2e055235303093388a498ba867 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 22:46:36 -0600 Subject: [PATCH 370/810] Update todos --- resources-dev/defnt.cljc | 22 ++++--------------- src-untyped/quantum/untyped/core/analyze.cljc | 14 ++++++------ 2 files changed, 11 insertions(+), 25 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index ac0b1010..4095c709 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -59,29 +59,15 @@ TODO: Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - [1 .] Fix `quantum.untyped.core.analyze`: - Error Message: Multiple, equally specific methods for class match the arg types - Data: - {:class java.nio.ByteBuffer, - :form (. (.putLong (ByteBuffer/allocate (int 8)) x) array), - :methods [#M{:name 'array', - :out-class java.lang.Object, - :arg-classes #class<>[], - :kind :instance} - #M{:name 'array', - :out-class '[B', - :arg-classes #class<>[], - :kind :instance}], - :arg-types []} - [2 .] t/type + [1 .] t/type - dependent types: `[x arr/array? > (t/type x)]` - [3] t/value-of + [2] t/value-of - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` - [4] - t/input-type + [3] - t/input-type - `(t/input-type >namespace :?)` meaning the possible input types to the first input to `>namespace` - `(t/input-type reduce :_ :_ :?)` - Then if those fns ever get extended then it should trigger a chain-reaction of recompilations - [5] - No trailing `>` means `> ?` + [4] - No trailing `>` means `> ?` - ? : type inference - use logic programming and variable unification e.g. `?1` `?2` ? - For this situation: `?` is `(t/- dc/counted?)` diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index ec6bbc2d..e8ec9492 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -96,12 +96,12 @@ vals (c/map with-most-specific-out-class))] (->> (.getMethods c) - (c/map+ (fn [^java.lang.reflect.Method x] - (Method. (.getName x) (.getReturnType x) (.getParameterTypes x) - (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) - :static - :instance)))) - (c/group-by (fn [^Method x] (:name x))) ; TODO all of these need to be into !vector and !hash-map + (c/map+ (fn [^java.lang.reflect.Method x] + (Method. (.getName x) (.getReturnType x) (.getParameterTypes x) + (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) + :static + :instance)))) + (c/group-by (fn [^Method x] (:name x))) ; TODO all of these need to be into !vector and !hash-map (c/map-vals+ (fn->> (c/group-by (fn [^Method x] (count (:arg-classes x)))) (c/map-vals+ @@ -109,7 +109,7 @@ (c/map-vals+ with-distinct-arg-class-seqs) (r/join {}))) (r/join {}))) - (r/join {}))))) + (r/join {}))))) (defonce class>methods|with-cache From b7eaa1b59615ab63759154ac6cada7b850f07a65 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 23:34:10 -0600 Subject: [PATCH 371/810] Add some documentation, clean up dependent type tests --- resources-dev/defnt.cljc | 18 +--- src-untyped/quantum/untyped/core/type.cljc | 3 +- .../quantum/untyped/core/type/defnt.cljc | 42 +++++++-- src/quantum/core/collections_typed.cljc | 6 +- .../quantum/test/untyped/core/type/defnt.cljc | 91 ++++++++----------- 5 files changed, 81 insertions(+), 79 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 4095c709..46a56c71 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -67,7 +67,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - `(t/input-type >namespace :?)` meaning the possible input types to the first input to `>namespace` - `(t/input-type reduce :_ :_ :?)` - Then if those fns ever get extended then it should trigger a chain-reaction of recompilations - [4] - No trailing `>` means `> ?` + [4] - Direct dispatch + [5] - No trailing `>` means `> ?` - ? : type inference - use logic programming and variable unification e.g. `?1` `?2` ? - For this situation: `?` is `(t/- dc/counted?)` @@ -1364,19 +1365,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - Instead of e.g. `ns-` or `var-` we can do `ns-val` and `var-val` - Should we type `when`, `let`? -- With `defnt`, protocols and interfaces aren't needed. You can just create `t/fn`s that you can - then conform your fns to. -- `dotyped`, `defnt`, and `fnt` create typed contexts in which their internal forms are analyzed - and overloads are resolved. -- `defnt` is intended to catch many runtime errors at compile time, but cannot catch all of them; - types will very often have to be validated at runtime. - [ ] Compile-Time (Direct) Dispatch - [x] Any argument, if it requires a non-nilable primitive-like value, will be marked as a - primitive. - [x] If nilable, there will be one overload for nil and one for primitive. - [x] When a `fnt` with type overloads is referenced outside of a typed context, then the overload - resolution will be done via Runtime Dispatch. - TODO Should we take into account 'actual' types (not just 'declared' types) when performing dispatch / overload resolution? - Let's take the example of `(defnt abcde [] (f (rand/int-between -10 -2)))`. @@ -1453,5 +1442,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - Not yet; wait for it to come out of alpha [—] Support for compilers in which the metalanguage differs from the object language (i.e. 'normal' non-CLJS-in-CLJS CLJS) - - This will have to be approached later. We'll figure it out; maybe just not yet. + - This will have to be approached later. We may or may not choose to figure it out, but it seems + promising enough. " diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index d06cda4a..de234094 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -458,7 +458,8 @@ ;; ===== Dependent types ===== ;; (defns type - "Treated specially by the type analyzer. For runtime use, just defaults to `(t/value x)`." + "Treated specially by the type analyzer when used within the type declaration of a function input. + For runtime use, just defaults to `(t/value x)`." [x _ > type?] (value x)) ;; TODO figure this out diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 908a77a7..9d73305a 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -644,11 +644,7 @@ (kw-map args varargs body-codelist|pre-analyze arg-types|form arg-types, pre-type|form pre-type, post-type|form post-type))) -(defns fnt|code - "Special metadata directives include: - - `:inline` : Applicable within the metadata of `t/fn` or `t/defn`. A directive to inline the - function if possible." - [kind #{:fn :defn}, lang ::lang, args _] +(defns fn|code [kind #{:fn :defn}, lang ::lang, args _] (let [{:as args' :keys [:quantum.core.specs/fn|name :quantum.core.defnt/overloads @@ -687,5 +683,37 @@ :defn `(~'do ~@fn-codelist))] code)) -#?(:clj (defmacro fnt [& args] (fnt|code :fn (ufeval/env-lang) args))) -#?(:clj (defmacro defn [& args] (fnt|code :defn (ufeval/env-lang) args))) +#?(:clj +(defmacro fnt + "With `t/fn`, protocols, interfaces, and multimethods become unnecessary. The preferred method of + dispatch becomes the function alone. + + `t/fn` is intended to catch many runtime errors at compile time, but cannot catch all of them. + + `t/fn`, along with `t/defn`, `t/dotyped`, and others, creates a typed context in which its + internal forms are analyzed, type-consistency is checked, and type-dispatch is resolved at + compile time inasmuch as possible, and at runtime only when necessary. + + Within the type system, primitives are always preferred to boxed values. All values that can be + primitives (i.e. ones that are `t/<=` w.r.t. a `(t/isa? )`) are treated + as primitives unless specifically marked otherwise with the `t/ref` metadata-adding directive. + + Compile-Time (Direct) Dispatch characteristics + - Any input, if its type is `t/<=` a non-nil primitive (boxed or not) class, it will be marked + as a primitive in the corresponding `reify`. + - If an input is a nilable primitive, its nilability will not result in only one `reify` + overload with a boxed input, but rather will result in two `reify` overloads — one + corresponding to a nil input and another for the primitive input. + + Runtime (Dynamic) Dispatch characteristics + - Compile-Time Dispatch is preferred to Runtime Dispatch in all but the following situations, in + which Compile-Time Dispatch is not possible: + - When a typed function (or a typed object with function-like characteristics such as a + `t/deftype`) is referenced outside of a typed context. + + Metadata directives special to `t/fn` include: + - `:inline` : Applicable within the metadata of `t/fn` or `t/defn`. A directive to inline the + function if possible." + [& args] (fn|code :fn (ufeval/env-lang) args))) + +#?(:clj (defmacro defn [& args] (fn|code :defn (ufeval/env-lang) args))) diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index 9f3f03eb..d96131a9 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -132,10 +132,6 @@ :cljs (when-not (num/zero? (count xs)) ; TODO use `empty?` instead (cljs.core/IndexedSeq. xs 0 nil))))) -;; TODO move to better place? -(t/defn- ^:inline string-seq>underlying-string - [xs (t/isa? clojure.lang.StringSeq) > (t/assume dstr/string?)] (.s xs)) - ;; ----- Chunking ----- ;; (t/defn >chunk-buffer > chunk-buffer? [capacity num/numerically-int?] @@ -263,7 +259,7 @@ (^:inline [rf rf?, init t/any?, xs (t/or dstr/string? vec/!+vector? arr/array?)] (reduce-indexed rf init xs 0)) #?(:clj (^:inline [rf rf?, init t/any?, xs dc/string-seq?] - (reduce-indexed rf init (string-seq>underlying-string xs) (.index xs)))) + (reduce-indexed rf init ^:val (.s xs) (.index xs)))) #?(:clj (^:inline [rf rf?, init t/any?, xs dc/array-seq?] (reduce-indexed rf init (.array xs) (.index xs)))) ;; Vector's chunked seq is faster than its iterator diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index eca639e8..ad4c8c58 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1310,58 +1310,45 @@ nil))) (deftest dependent-type-test - (let [actual - (macroexpand ' - (self/defn dependent-type - ([x (t/or tt/boolean? tt/string?) > (type x)] x) - ;; This arity is the same as `identity` - ([x t/any? > (type x)] x))) - expected - (case (env-lang) - :clj - ($ (do ;; [x (t/or tt/boolean? tt/string?) > (type x)] - - ;; [x t/any? > (type x)] - - (def ~(tag "[Ljava.lang.Object;" 'dependent-type|__0|input0|types) - (*<> t/any?)) - ;; One `reify` because `t/any?` in CLJ does not have any `t/or`-separability - (def ~'dependent-type|__0|0 - (reify* [Object>Object boolean>boolean byte>byte short>short char>char - int>int long>long float>float double>double] - (~(tag "java.lang.Object" 'invoke) - [~'_0__ ~(tag "java.lang.Object" 'x)] ~(O 'x)) - (~(tag "boolean" 'invoke) - [~'_1__ ~(tag "boolean" 'x)] ~'x) - (~(tag "byte" 'invoke) - [~'_2__ ~(tag "byte" 'x)] ~'x) - (~(tag "short" 'invoke) - [~'_3__ ~(tag "short" 'x)] ~'x) - (~(tag "char" 'invoke) - [~'_4__ ~(tag "char" 'x)] ~'x) - (~(tag "int" 'invoke) - [~'_5__ ~(tag "int" 'x)] ~'x) - (~(tag "long" 'invoke) - [~'_6__ ~(tag "long" 'x)] ~'x) - (~(tag "float" 'invoke) - [~'_7__ ~(tag "float" 'x)] ~'x) - (~(tag "double" 'invoke) - [~'_8__ ~(tag "double" 'x)] ~'x))) - - (defn ~'dependent-type - {:quantum.core.type/type (t/fn t/any? ~'[t/any?])} - ([~'x00__] - ;; TODO elide check because `t/any?` doesn't require a check - ;; and all args are `t/=` `t/any?` - (ifs ((Array/get ~'dependent-type|__0|input0|types 0) ~'x00__) - (.invoke ~(tag (str `Object>Object) - 'dependent-type|__0|0) ~'x00__) - (unsupported! `dependent-type [~'x00__] 0)))))))] - (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" - (eval actual) - (eval '(do (is= (dependent-type 1) 1) - (is= (dependent-type "") "")))))) + (testing "Output type dependent on non-splittable input" + (let [actual + (macroexpand ' + (self/defn dependent-type-0 + ([x (t/or tt/boolean? tt/string?) > (type x)] x)) + expected + (case (env-lang) + :clj + ($ (do ...)))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do ...))))) + (testing "Output type dependent on primitive-splittable input" + (let [actual + (macroexpand ' + (self/defn dependent-type-1 + ([x t/any? > (type x)] x))) + expected + (case (env-lang) + :clj + ($ (do ...)))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do ...))))) + (testing "Input type dependent on other input type" + (let [actual + (macroexpand ' + (self/defn dependent-type-2 + ([a tt/byte?, b (type a)] a))) + expected + (case (env-lang) + :clj + ($ (do ...)))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do ...)))))) ;; ----- expanded code ----- ;; From 52f98b484bb0b19da4ce00f401a9471aaf22bd16 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 29 Sep 2018 23:44:24 -0600 Subject: [PATCH 372/810] Flesh out more docs and tests --- resources-dev/defnt.cljc | 35 ++++++-------- .../quantum/test/untyped/core/type/defnt.cljc | 46 +++++++++++++++++-- 2 files changed, 58 insertions(+), 23 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 46a56c71..4be73b63 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -13,7 +13,7 @@ Note that for anything built-in js/, the `t/isa?` predicates might nee ;; ===== quantum.core.system #?(:clj -(defnt pid [> (? t/string?)] +(t/defn pid [> (? t/string?)] (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) (.getName)))) @@ -67,7 +67,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - `(t/input-type >namespace :?)` meaning the possible input types to the first input to `>namespace` - `(t/input-type reduce :_ :_ :?)` - Then if those fns ever get extended then it should trigger a chain-reaction of recompilations - [4] - Direct dispatch + [4] - Direct dispatch needs to actually work correctly in `t/defn` [5] - No trailing `>` means `> ?` - ? : type inference - use logic programming and variable unification e.g. `?1` `?2` ? @@ -135,10 +135,12 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - t/declare - declare-fnt (a way to do protocols/interfaces) - extend-fnt! - - defnt (t/defn) + - `t/defn` - Arity elision: if any type in an arity is `t/none?` then elide it and emit a warning - `([x bigint?] x)` - t/defn- + - Not just a private var for the dynamic dispatch, but needs to be private for purposes of the + analyzer when doing direct dispatch. Should emit a warning, not just fail. - (t/and (t/or a b) c) should -> (t/or (t/and a c) (t/and b c)) for purposes of separating dispatches - t/extend-defn! - `(t/extend-defn! id/>name (^:inline [x namespace?] (-> x .getName id/>name)))` @@ -161,11 +163,10 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative ([xs (t/input-type educe :_ :_ :?)] (educe empty?|rf x))) - handle varargs - [& args _] shouldn't result in `t/any?` but rather like `t/reducible?` or whatever - - do the defnt-equivalences + - do the defnt-equivalences / `t/defn` test namespace - a linting warning that you can narrow the type to whatever the deduced type is from whatever wider declared type there is - - the option of creating a `defnt` that isn't extensible? Or at least in which the input types are limited in the same way per-overload output types are limited by the per-fn output type? - - dealing with `apply`... + - the option of creating a `t/defn` that isn't extensible? Or at least in which the input types are limited in the same way per-overload output types are limited by the per-fn output type? - t/defmacro - t/deftype - t/dotyped @@ -175,13 +176,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [xs (t/fn [x (t/isa? clojure.lang.Range)] ...)] - No return value means that it should infer - NOTE on namespace organization: - - [quantum.untyped.core.ns :refer [namespace?]] - instead of - [quantum.untyped.core.type.predicates :refer [namespace?]] - because not all predicates (type-related or otherwise) can be thought of ahead of time to be put - in one giant namespace - - Same with the `core.convert` namespace too - - Conversion functions belong in the namespace that their destination types belong in + - Conversion functions belong in the namespace that their destination types belong in, not in one + giant namespace of all conversion - TODO transition the quantum.core.* namespaces: ->>>>>> TODO need to add *all* quantum namespaces in here - Legend: @@ -1363,12 +1359,11 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative ([x0] (identity x0)) ([x0 x1] (conj x0 x1)))}} - Instead of e.g. `ns-` or `var-` we can do `ns-val` and `var-val` - - Should we type `when`, `let`? [ ] Compile-Time (Direct) Dispatch - TODO Should we take into account 'actual' types (not just 'declared' types) when performing dispatch / overload resolution? - - Let's take the example of `(defnt abcde [] (f (rand/int-between -10 -2)))`. + - Let's take the example of `(t/defn abcde [] (f (rand/int-between -10 -2)))`. - Let's say `rand/int-between`'s output is labeled `t/int?`. However, we know based on further static analysis of its implementation that the output is not only `t/int?` but also `t/neg?`, or perhaps even further, `(< -10 % -2)`. @@ -1392,13 +1387,13 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative output type). - One option (Option A) is to turn off compile-time overload resolution during development. This would mean it might get very slow during that time. But if it's in - the same `defnt` (ignoring `extend-defnt!` for a minute) — like a recursive call — you + the same `t/defn` (ignoring `t/extend-defn!` for a minute) — like a recursive call — you could always leave on compile-time resolution for that. - Option B — probably better (though we'd still like to have all this configurable) — is to have each function know its dependencies (this would actually have the bonus property of enabling `clojure.tools.namespace.repl/refresh`-style function-level smart auto-recompilation which is nice). So let's go back to the previous example. - `abcde` could keep track of (or the `defnt` ns could keep track of it, but you get the + `abcde` could keep track of (or the `t/defn` ns could keep track of it, but you get the point) the fact that it depends on `rand/int-between` and `f`. It has a compile-time- resolvable call site that depends only on the output type of `rand/int-between` so if `rand/int-between`'s computed/actual output type (when given the inputs in question) @@ -1417,16 +1412,16 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative [x] `fn` generation - Performs a worst-case linear check of the typedefs, `cond`-style. [x] Interface generation - [x] Even if the `defnt` is redefined, you won't have interface problems. + [x] Even if the `t/defn` is redefined, you won't have interface problems. [ ] `reify` generation - Which `reify`s get generated is mainly up to the inputs but partially up to the fn body — If any typed fns are called in the fn body then this can change what gets generated. - TODO explain this more - Each of the `reify`s will keep their label (`__2__0` or whatever) as long as the original typedef of the `reify` is `t/=` to the new typedef of that reify - - If a redefined `defnt` doesn't have that type overload then the previous reify is uninterned + - If a redefined `t/defn` doesn't have that type overload then the previous reify is uninterned and thus made unavailable - - That way, according to the dynamicity tests in `quantum.test.core.defnt`, we can redefine + - That way, according to the dynamicity tests in `quantum.test.core.type.defn`, we can redefine implementations at will as long as the specs don't change - To make this process faster we maintain a set of typedefs so at least cheap c/= checks can be performed diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index ad4c8c58..b9d286d9 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1314,6 +1314,19 @@ (let [actual (macroexpand ' (self/defn dependent-type-0 + ([x tt/boolean? > (type x)] x)) + expected + (case (env-lang) + :clj + ($ (do ...)))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do ...))))) + (testing "Output type dependent on splittable but non-primitive-splittable input" + (let [actual + (macroexpand ' + (self/defn dependent-type-1 ([x (t/or tt/boolean? tt/string?) > (type x)] x)) expected (case (env-lang) @@ -1326,7 +1339,7 @@ (testing "Output type dependent on primitive-splittable input" (let [actual (macroexpand ' - (self/defn dependent-type-1 + (self/defn dependent-type-2 ([x t/any? > (type x)] x))) expected (case (env-lang) @@ -1339,7 +1352,7 @@ (testing "Input type dependent on other input type" (let [actual (macroexpand ' - (self/defn dependent-type-2 + (self/defn dependent-type-3 ([a tt/byte?, b (type a)] a))) expected (case (env-lang) @@ -1348,7 +1361,34 @@ (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) - (eval '(do ...)))))) + (eval '(do ...))))) + (testing "Output type dependent on input type which is dependent on other input type" + (let [actual + (macroexpand ' + (self/defn dependent-type-4 + ([a tt/byte?, b (type a) > (type b)] b))) + expected + (case (env-lang) + :clj + ($ (do ...)))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do ...))))) + (testing "Two input types directly depend on each other" + (let [actual + (macroexpand ' + (self/defn dependent-type-5 + ([a (type b), b (type a)] b)))] + (testing "functionality" + (throws? (eval actual))))) + (testing "Two input types indirectly depend on each other" + (let [actual + (macroexpand ' + (self/defn dependent-type-6 + ([a (type b), b (type c), c (type a)] b)))] + (testing "functionality" + (throws? (eval actual)))))) ;; ----- expanded code ----- ;; From 5aace6d8e3809be64e2bf68d761d5f11014e0568 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 30 Sep 2018 00:25:09 -0600 Subject: [PATCH 373/810] Fix bug in zero-arity t/fn --- src-untyped/quantum/untyped/core/analyze.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index e8ec9492..c30b28e1 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -575,7 +575,7 @@ {:input-nodes [] :out-type (if (= :fnt caller-kind) - (-> caller|type (get inputs-ct) first :output-type) + (-> caller|type utr/fn-type>arities (get inputs-ct) first :output-type) ;; We could do a little smarter analysis here but we'll keep it simple for now t/any?)} (->> body From ae36e0229740c6e2ed44703bfb7d94999a014ba9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 30 Sep 2018 00:25:19 -0600 Subject: [PATCH 374/810] Update todos --- resources-dev/defnt.cljc | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 4be73b63..7998dff3 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -67,8 +67,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - `(t/input-type >namespace :?)` meaning the possible input types to the first input to `>namespace` - `(t/input-type reduce :_ :_ :?)` - Then if those fns ever get extended then it should trigger a chain-reaction of recompilations - [4] - Direct dispatch needs to actually work correctly in `t/defn` - [5] - No trailing `>` means `> ?` + [4] - t/output-type + [5] - Direct dispatch needs to actually work correctly in `t/defn` + [6] - No trailing `>` means `> ?` - ? : type inference - use logic programming and variable unification e.g. `?1` `?2` ? - For this situation: `?` is `(t/- dc/counted?)` From f0dfdca37c7c012c14e88d88b73d9ceef24bdb8d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 30 Sep 2018 00:25:45 -0600 Subject: [PATCH 375/810] Support `t/defn` recursion via symboll --- src-untyped/quantum/untyped/core/type/defnt.cljc | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 9d73305a..dbf6457a 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -672,7 +672,8 @@ (>direct-dispatch fnt-globals opts expanded-overload-groups-by-fnt-overload) fn-codelist (case lang - :clj (->> `[~@(:form direct-dispatch) + :clj (->> `[(declare ~fn|name) ; for recursion + ~@(:form direct-dispatch) ~(>dynamic-dispatch-fn|form fnt-globals opts expanded-overload-groups-by-fnt-overload i-overload->direct-dispatch-data)] From 14d6b7d868436faf1e986e5514dc9bbc9b1d6c15 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 30 Sep 2018 00:26:00 -0600 Subject: [PATCH 376/810] Add a few nesting/shadowing dependent type tests --- .../quantum/test/untyped/core/type/defnt.cljc | 210 ++++++++++++------ 1 file changed, 137 insertions(+), 73 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index b9d286d9..23b074fb 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -33,8 +33,9 @@ (do (require '[orchestra.spec.test :as st]) (orchestra.spec.test/instrument)) -(defn O [form] (tag "java.lang.Object" form)) -(defn STR [form] (tag "java.lang.String" form)) +(defn O [form] (tag "java.lang.Object" form)) +(defn O<> [form] (tag "[Ljava.lang.Object;" form)) +(defn STR [form] (tag "java.lang.String" form)) #?(:clj (deftest test|pid @@ -46,7 +47,7 @@ expected ($ (do (def ~'pid|test|__0|0 (reify* [>Object] - (~(tag "java.lang.Object" 'invoke) [~'_0__] + (~(O 'invoke) [~'_0__] ~(STR '(. (. java.lang.management.ManagementFactory getRuntimeMXBean) getName))))) (defn ~'pid|test @@ -70,7 +71,7 @@ :clj ($ (do ;; [x t/any?] - (def ~(tag "[Ljava.lang.Object;" 'identity|uninlined|__0|input0|types) + (def ~(O<> 'identity|uninlined|__0|input0|types) (*<> t/any?)) ;; One `reify` because `t/any?` in CLJ does not have any `t/or`-separability (def ~'identity|uninlined|__0|0 @@ -129,20 +130,20 @@ ;; [t/string?] - (def ~(tag "[Ljava.lang.Object;" 'name|test|__0|input0|types) + (def ~(O<> 'name|test|__0|input0|types) (*<> (t/isa? java.lang.String))) (def ~'name|test|__0|0 (reify* [Object>Object] - (~(tag "java.lang.Object" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] + (~(O 'invoke) [~'_0__ ~(O 'x)] (let* [~(STR 'x) ~'x] ~(STR 'x))))) ;; [(t/isa? Named)] - (def ~(tag "[Ljava.lang.Object;" 'name|test|__1|input0|types) + (def ~(O<> 'name|test|__1|input0|types) (*<> (t/isa? Named))) (def ~'name|test|__1|0 (reify* [Object>Object] - (~(tag "java.lang.Object" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] + (~(O 'invoke) [~'_1__ ~(O 'x)] (let* [~(tag "clojure.lang.Named" 'x) ~'x] (t/validate ~(STR '(. x getName)) ~'(* t/string?)))))) @@ -190,7 +191,7 @@ :clj ($ (do ;; [x t/nil?] - (def ~(tag "[Ljava.lang.Object;" 'some?|test|__0|input0|types) + (def ~(O<> 'some?|test|__0|input0|types) (*<> (t/value nil))) (def ~'some?|test|__0|0 (reify* [Object>boolean] @@ -198,7 +199,7 @@ ;; [x t/any?] - (def ~(tag "[Ljava.lang.Object;" 'some?|test|__1|input0|types) + (def ~(O<> 'some?|test|__1|input0|types) (*<> t/any?)) (def ~'some?|test|__1|0 (reify* [Object>boolean boolean>boolean byte>boolean short>boolean @@ -251,7 +252,7 @@ :clj ($ (do ;; [x (t/isa? Reduced)] - (def ~(tag "[Ljava.lang.Object;" 'reduced?|test|__0|input0|types) + (def ~(O<> 'reduced?|test|__0|input0|types) (*<> (t/isa? Reduced))) (def ~'reduced?|test|__0|0 (reify* [Object>boolean] @@ -260,7 +261,7 @@ ;; [x t/any?] - (def ~(tag "[Ljava.lang.Object;" 'reduced?|test|__1|input0|types) + (def ~(O<> 'reduced?|test|__1|input0|types) (*<> t/any?)) (def ~'reduced?|test|__1|0 (reify* [Object>boolean boolean>boolean byte>boolean short>boolean @@ -315,7 +316,7 @@ :clj ($ (do ;; [x tt/boolean?] - (def ~(tag "[Ljava.lang.Object;" '>boolean|__0|input0|types) + (def ~(O<> '>boolean|__0|input0|types) (*<> (t/isa? Boolean))) (def ~'>boolean|__0|0 (reify* [boolean>boolean] @@ -323,7 +324,7 @@ ;; [x t/nil? -> (- t/nil? tt/boolean?)] - (def ~(tag "[Ljava.lang.Object;" '>boolean|__1|input0|types) + (def ~(O<> '>boolean|__1|input0|types) (*<> (t/value nil))) (def ~'>boolean|__1|0 (reify* [Object>boolean] @@ -331,7 +332,7 @@ ;; [x t/any? -> (- t/any? t/nil? tt/boolean?)] - (def ~(tag "[Ljava.lang.Object;" '>boolean|__2|input0|types) + (def ~(O<> '>boolean|__2|input0|types) (*<> t/any?)) (def ~'>boolean|__2|0 (reify* [Object>boolean boolean>boolean byte>boolean short>boolean @@ -395,7 +396,7 @@ ($ (do ;; [x (t/- tt/primitive? tt/boolean?)] ;; These are non-primitivized - (def ~(tag "[Ljava.lang.Object;" '>int*|__0|input0|types) + (def ~(O<> '>int*|__0|input0|types) (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Short) (t/isa? java.lang.Character) @@ -435,7 +436,7 @@ ;; [x (t/ref (t/isa? Number)) ;; -> (t/- (t/ref (t/isa? Number)) (t/- tt/primitive? tt/boolean?))] - (def ~(tag "[Ljava.lang.Object;" '>int*|__1|input0|types) + (def ~(O<> '>int*|__1|input0|types) (*<> ~(with-meta `(t/isa? Number) {:quantum.core.type/ref? true}))) (def ~'>int*|__1|0 (reify* [Object>int] @@ -495,7 +496,7 @@ ($ (do ;; [a t/comparable-primitive? b t/comparable-primitive? > tt/boolean?] ;; These are non-primitivized - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|input0|types) + (def ~(O<> '>|test|__0|input0|types) (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Short) (t/isa? java.lang.Character) @@ -503,7 +504,7 @@ (t/isa? java.lang.Long) (t/isa? java.lang.Float) (t/isa? java.lang.Double))) - (def ~(tag "[Ljava.lang.Object;" '>|test|__0|input1|types) + (def ~(O<> '>|test|__0|input1|types) (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Short) (t/isa? java.lang.Character) @@ -858,14 +859,14 @@ (macroexpand ' (self/defn #_:inline >long* {:source "clojure.lang.RT.uncheckedLongCast"} - > long? - ([x (t/- tt/boolean? tt/boolean?)] (Primitive/uncheckedLongCast x)) + > tt/long? + ([x (t/- tt/primitive? tt/boolean?)] (Primitive/uncheckedLongCast x)) ([x (t/ref (t/isa? Number))] (.longValue x)))) expected (case (env-lang) - :clj ($ (do ;; [x (t/- tt/boolean? tt/boolean?)] + :clj ($ (do ;; [x (t/- tt/primitive? tt/boolean?)] - (def ~(tag "[Ljava.lang.Object;" '>long*|__0|input0|types) + (def ~(O<> '>long*|__0|input0|types) (*<> (t/isa? java.lang.Byte) (t/isa? java.lang.Short) (t/isa? java.lang.Character) @@ -904,7 +905,7 @@ ;; [x (t/ref (t/isa? Number))] - (def ~(tag "[Ljava.lang.Object;" '>long*|__1|input0|types) + (def ~(O<> '>long*|__1|input0|types) (*<> ~(with-meta `(t/isa? Number) {:quantum.core.type/ref? true}))) (def ~'>long*|__1|0 (reify* [Object>long] @@ -915,7 +916,7 @@ {:source "clojure.lang.RT.uncheckedLongCast" :quantum.core.type/type (t/fn ~'long? - ~'[(t/- tt/boolean? tt/boolean?)] + ~'[(t/- tt/primitive? tt/boolean?)] ~'[(t/ref (t/isa? Number))])} ([~'x00__] (ifs @@ -962,7 +963,7 @@ expected ($ (do ;; [x tt/boolean? > (t/ref tt/boolean?)] - (def ~(tag "[Ljava.lang.Object;" 'ref-output-type|__0|input0|types) + (def ~(O<> 'ref-output-type|__0|input0|types) (*<> (t/isa? java.lang.Boolean))) (def ~'ref-output-type|__0|0 (reify* [boolean>Object] @@ -970,7 +971,7 @@ ;; [x tt/byte? > (t/ref tt/byte?)] - (def ~(tag "[Ljava.lang.Object;" 'ref-output-type|__1|input0|types) + (def ~(O<> 'ref-output-type|__1|input0|types) (*<> (t/isa? java.lang.Byte))) (def ~'ref-output-type|__1|0 (reify* [byte>Object] @@ -993,7 +994,7 @@ (testing "code equivalence" (is-code= actual expected))))) (self/defn >big-integer > (t/isa? java.math.BigInteger) - ([x ratio? > (* (t/isa? java.math.BigInteger))] (.bigIntegerValue x))) + ([x tt/ratio? > (* (t/isa? java.math.BigInteger))] (.bigIntegerValue x))) ;; NOTE would use `>long` but that's already an interface (deftest test|>long-checked @@ -1001,10 +1002,10 @@ (macroexpand ' (self/defn >long-checked {:source "clojure.lang.RT.longCast"} - > long? + > tt/long? ;; TODO multi-arity `t/-` - ([x (t/- (t/- (t/- tt/boolean? tt/boolean?) float?) double?)] (>long* x)) - ([x (t/and (t/or double? float?) + ([x (t/- tt/primitive? tt/boolean? tt/float? tt/double?)] (>long* x)) + ([x (t/and (t/or tt/double? tt/float?) ;; TODO add this back in #_(fnt [x (t/or t/double? t/float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] (>long* x)) @@ -1016,7 +1017,7 @@ ;; TODO add this back in #_(fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] (.longValue x)) - ([x ratio?] (-> x >big-integer >long-checked)) + ([x tt/ratio?] (-> x >big-integer >long-checked)) ([x (t/value true)] 1) ([x (t/value false)] 0) ([x t/string?] (Long/parseLong x)) @@ -1053,7 +1054,7 @@ ;; Resolved from `(>long* x)` (.invoke >long*|__3 ~'x)))) - #_(def ~'>long|__4|input-types (*<> long?)) + #_(def ~'>long|__4|input-types (*<> tt/long?)) (def ~'>long|__4 (reify long>long (~(tag "long" 'invoke) [_## ~(tag "long" 'x)] @@ -1226,31 +1227,31 @@ (case (env-lang) :clj ($ (do (def ~'!str|__0|0 (reify* [>Object] - (~(tag "java.lang.Object" 'invoke) [~'_0__] + (~(O 'invoke) [~'_0__] ~(tag "java.lang.StringBuilder" '(new StringBuilder))))) - (def ~(tag "[Ljava.lang.Object;" '!str|__1|input0|types) + (def ~(O<> '!str|__1|input0|types) (*<> (t/isa? java.lang.String))) (def ~'!str|__1|0 (reify* [Object>Object] - (~(tag "java.lang.Object" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] + (~(O 'invoke) [~'_1__ ~(O 'x)] (let* [~(Str 'x) ~'x] ~(tag "java.lang.StringBuilder" (list 'new 'StringBuilder (STR 'x))))))) - (def ~(tag "[Ljava.lang.Object;" '!str|__2|input0|types) + (def ~(O<> '!str|__2|input0|types) (*<> (t/isa? java.lang.CharSequence) (t/isa? java.lang.Integer))) (def ~'!str|__2|0 (reify* [Object>Object] - (~(tag "java.lang.Object" 'invoke) [~'_2__ ~(tag "java.lang.Object" 'x)] + (~(O 'invoke) [~'_2__ ~(O 'x)] (let* [~(tag "java.lang.CharSequence" 'x) ~'x] ~(tag "java.lang.StringBuilder" (list 'new 'StringBuilder (tag "java.lang.CharSequence" 'x))))))) (def ~'!str|__2|1 (reify* [int>Object] - (~(tag "java.lang.Object" 'invoke) [~'_3__ ~(tag "int" 'x)] + (~(O 'invoke) [~'_3__ ~(tag "int" 'x)] ~(tag "java.lang.StringBuilder" '(new StringBuilder x))))) (defn ~'!str @@ -1283,22 +1284,56 @@ (is (instance? StringBuilder (!str (.subSequence "abc" 0 1))))))))) (deftest defn-reference-test - "Tests that defnts referencing other defnts works" - (let [actual - (macroexpand ' - (self/defn defn-reference - ([] (>long* 1)))) - expected - (case (env-lang) - :clj ($ (do (def ~'defn-reference|__0|0 - (reify* [>long] (~(tag "long" 'invoke) [~'_0__] ~'(>long* 1)))) - (defn ~'defn-reference - {:quantum.core.type/type (t/fn t/any? [])} - ([] (.invoke ~(tag (str `>long) 'defn-reference|__0|0)))))))] - (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" - (eval actual) - (eval '(do (is (identical? (defn-reference) 1))))))) + (testing "`t/defn` references itself" + (let [actual + (macroexpand ' + (self/defn defn-self-reference + ([] nil) + ([x tt/long?] (defn-self-reference)))) + expected + (case (env-lang) + :clj ($ (do (declare ~'defn-self-reference) + (def ~'defn-self-reference|__0|0 + (reify* [>Object] + (~(O 'invoke) [~'_0__] nil))) + (def ~(O<> 'defn-self-reference|__1|input0|types) + (*<> (t/isa? java.lang.Long))) + (def ~'defn-self-reference|__1|0 + (reify* [long>Object] + (~(O 'invoke) [~'_1__ ~'x] (~'defn-self-reference)))) + (defn ~'defn-self-reference + {:quantum.core.type/type + (t/ftype t/any? [] [tt/long?])} + ([] (.invoke ~'defn-self-reference|__0|0)) + ([~'x00__] + (ifs + ((Array/get + ~'defn-self-reference|__1|input0|types + 0) + ~'x00__) + (.invoke ~(tag (str `long>Object) 'defn-self-reference|__1|0) ~'x00__) + (unsupported! `defn-self-reference [~'x00__] 0)))))))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do (is= (defn-self-reference) nil)))))) + (testing "`t/defn` references other `t/defn`" + (let [actual + (macroexpand ' + (self/defn defn-reference + ([] (>long* 1)))) + expected + (case (env-lang) + :clj ($ (do (declare ~'defn-reference) + (def ~'defn-reference|__0|0 + (reify* [>long] (~(tag "long" 'invoke) [~'_0__] ~'(>long* 1)))) + (defn ~'defn-reference + {:quantum.core.type/type (t/fn t/any? [])} + ([] (.invoke ~(tag (str `>long) 'defn-reference|__0|0)))))))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do (is (identical? (defn-reference) 1)))))))) (deftest defn-assume-test "Tests that t/assume works properly in the context of `t/defn`" @@ -1311,22 +1346,51 @@ (deftest dependent-type-test (testing "Output type dependent on non-splittable input" - (let [actual - (macroexpand ' - (self/defn dependent-type-0 - ([x tt/boolean? > (type x)] x)) - expected - (case (env-lang) - :clj - ($ (do ...)))] - (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" - (eval actual) - (eval '(do ...))))) + (testing "Not nested within another type" + (let [actual + (macroexpand ' + (self/defn dependent-type + ([x tt/boolean? > (type x)] x)) + expected + (case (env-lang) + :clj + ($ (do ...)))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do ...)))))) + (testing "Nested within another type" + (testing "Without arg shadowing" + (let [actual + (macroexpand ' + (self/defn dependent-type-nest + ([x tt/boolean? > (t/or t/number? (type x))] (if x x 1))) + expected + (case (env-lang) + :clj + ($ (do ...)))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do ...)))))) + (testing "With arg shadowing" + (let [actual + (macroexpand ' + (self/defn dependent-type-shadow + ([x tt/boolean? > (let [x (>long-checked "123")] + (t/or t/number? (type x)))] (if x x 1))) + expected + (case (env-lang) + :clj + ($ (do ...)))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do ...)))))))) (testing "Output type dependent on splittable but non-primitive-splittable input" (let [actual (macroexpand ' - (self/defn dependent-type-1 + (self/defn dependent-type-split ([x (t/or tt/boolean? tt/string?) > (type x)] x)) expected (case (env-lang) @@ -1339,7 +1403,7 @@ (testing "Output type dependent on primitive-splittable input" (let [actual (macroexpand ' - (self/defn dependent-type-2 + (self/defn dependent-type-psplit ([x t/any? > (type x)] x))) expected (case (env-lang) @@ -1352,7 +1416,7 @@ (testing "Input type dependent on other input type" (let [actual (macroexpand ' - (self/defn dependent-type-3 + (self/defn dependent-type-input ([a tt/byte?, b (type a)] a))) expected (case (env-lang) @@ -1365,7 +1429,7 @@ (testing "Output type dependent on input type which is dependent on other input type" (let [actual (macroexpand ' - (self/defn dependent-type-4 + (self/defn dependent-type-2input ([a tt/byte?, b (type a) > (type b)] b))) expected (case (env-lang) @@ -1378,14 +1442,14 @@ (testing "Two input types directly depend on each other" (let [actual (macroexpand ' - (self/defn dependent-type-5 + (self/defn dependent-type-directin ([a (type b), b (type a)] b)))] (testing "functionality" (throws? (eval actual))))) (testing "Two input types indirectly depend on each other" (let [actual (macroexpand ' - (self/defn dependent-type-6 + (self/defn dependent-type-indirectin ([a (type b), b (type c), c (type a)] b)))] (testing "functionality" (throws? (eval actual)))))) From 2707fc275a3856619edf9eaaa348974de6afdb7f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 30 Sep 2018 00:39:19 -0600 Subject: [PATCH 377/810] Inject opts into each analysis call --- src-untyped/quantum/untyped/core/analyze.cljc | 128 +++++++++--------- 1 file changed, 67 insertions(+), 61 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index c30b28e1..fdfd4ba5 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -191,6 +191,8 @@ (s/def ::env (s/map-of symbol? t/any?)) +(s/def ::opts (s/map-of keyword? t/any?)) + (declare analyze*) (defns- analyze-non-map-seqable @@ -200,9 +202,9 @@ The first argument is the current deduced type of the overall AST node; the second is the deduced type of the current sub-AST-node."}} - [env ::env, form _, empty-form _, rf _] + [opts ::opts, env ::env, form _, empty-form _, rf _] (-> (reducei - (fn [accum form' i] (rf accum (analyze* (:env accum) form') i)) + (fn [accum form' i] (rf accum (analyze* opts (:env accum) form') i)) {:env env :form (transient empty-form) :body (transient [])} form) (update :form (fn-> persistent! (add-file-context-from form))) @@ -211,12 +213,12 @@ (defns- analyze-map {:todo #{"If the map is bound to a variable, preserve type info for it such that lookups can start out with a guarantee of a certain type."}} - [env ::env, form _] + [opts ::opts, env ::env, form _] (TODO "analyze-map") #_(->> form (reduce-kv (fn [{env' :env forms :form} form'k form'v] - (let [ast-node-k (analyze* env' form'k) - ast-node-v (analyze* env' form'v)] + (let [ast-node-k (analyze* opts env' form'k) + ast-node-v (analyze* opts env' form'v)] (->expr-info {:env env' :form (assoc! forms (:form ast-node-k) (:form ast-node-v)) ;; TODO fix; we want the types of the keys and vals to be deduced @@ -224,7 +226,7 @@ (->expr-info {:env env :form (transient {})})) (persistent!-and-add-file-context-from form))) -(defns- analyze-seq|do [env ::env, [_ _ & body|form _ :as form] _ > uast/do?] +(defns- analyze-seq|do [opts ::opts, env ::env, [_ _ & body|form _ :as form] _ > uast/do?] (if (empty? body|form) (uast/do {:env env :unexpanded-form form @@ -232,7 +234,7 @@ :body [] :type t/nil?}) (let [{expanded-form :form body :body} - (analyze-non-map-seqable env body|form [] + (analyze-non-map-seqable opts env body|form [] (fn [accum ast-data _] ;; The env should be the same as whatever it was originally because no new scopes ;; are created @@ -247,22 +249,23 @@ ;; the others :type (-> body c/last :type)})))) -(defns analyze-seq|let*|bindings [env ::env, bindings|form _] +(defns analyze-seq|let*|bindings [opts ::opts, env ::env, bindings|form _] (->> bindings|form (c/partition-all+ 2) (reduce (fn [{env' :env !bindings :form :keys [bindings-map]} [sym form :as binding|form]] - (let [node (analyze* env' form)] ; environment is additive with each binding + (let [node (analyze* opts env' form)] ; environment is additive with each binding {:env (assoc env' sym node) :form (conj! (conj! !bindings sym) (:form node)) :bindings-map (assoc bindings-map sym node)})) {:env env :form (transient []) :bindings-map {}}) (<- (update :form (fn-> persistent! (add-file-context-from bindings|form)))))) -(defns analyze-seq|let* [env ::env, [_ _, bindings|form _ & body|form _ :as form] _ > uast/let*?] +(defns analyze-seq|let* + [opts ::opts, env ::env, [_ _, bindings|form _ & body|form _ :as form] _ > uast/let*?] (let [{env' :env bindings|form' :form :keys [bindings-map]} - (analyze-seq|let*|bindings env bindings|form) + (analyze-seq|let*|bindings opts env bindings|form) {body|form' :form body|type :type body :body} - (analyze-seq|do env' (list* 'do body|form))] + (analyze-seq|do opts env' (list* 'do body|form))] (uast/let* {:env env :unexpanded-form form :form (list* 'let* bindings|form' (rest body|form')) @@ -304,13 +307,13 @@ call-sites)))) (defns- analyze-seq|method-or-constructor-call|incrementally-analyze - [env ::env, form _, target-class class?, args|form _, call-sites-for-ct _, kinds-str string? - > (s/kv {:args|analyzed vector?})] + [opts ::opts, env ::env, form _, target-class class?, args|form _, call-sites-for-ct _ + kinds-str string? > (s/kv {:args|analyzed vector?})] (let [{:as ret :keys [call-sites args|analyzed]} (->> args|form (reducei (fn [{:as ret :keys [args|analyzed call-sites]} arg|form i|arg] - (let [arg|analyzed (analyze* env arg|form) + (let [arg|analyzed (analyze* opts env arg|form) arg|analyzed|type (:type arg|analyzed) call-sites' (->> call-sites @@ -345,10 +348,10 @@ ret))) (defns- analyze-seq|dot|method-call|incrementally-analyze - [env ::env, form _, target uast/node?, target-class class?, method-form _, args|form _ - methods-for-ct-and-kind (s/seq-of t/any?) > uast/method-call?] + [opts ::opts, env ::env, form _, target uast/node?, target-class class?, method-form _ + args|form _ methods-for-ct-and-kind (s/seq-of t/any?) > uast/method-call?] (let [{:keys [args|analyzed call-sites]} - (analyze-seq|method-or-constructor-call|incrementally-analyze env form target-class + (analyze-seq|method-or-constructor-call|incrementally-analyze opts env form target-class args|form methods-for-ct-and-kind "methods") ?cast-type (?cast-call->type target-class method-form) ;; TODO enable the below: @@ -369,7 +372,7 @@ "A note will be made of what methods match the argument types. If only one method is found, that is noted too. If no matching method is found, an exception is thrown." - [env ::env, form _, target uast/node?, target-class class?, static? t/boolean? + [opts ::opts, env ::env, form _, target uast/node?, target-class class?, static? t/boolean? method-form simple-symbol?, args|form _ #_(seq-of form?) > uast/method-call?] ;; TODO cache type by method (if-not-let [methods-for-name (-> target-class class>methods|with-cache @@ -386,11 +389,11 @@ (if-not-let [methods-for-ct-and-kind (c/get methods-for-ct kind)] (err! (istr "Method found for arg-count, but was ~non-kind, not ~kind") {:class target-class :method method-form :args args|form}) - (analyze-seq|dot|method-call|incrementally-analyze env form target target-class + (analyze-seq|dot|method-call|incrementally-analyze opts env form target target-class method-form args|form methods-for-ct-and-kind)))))) (defns- analyze-seq|dot|field-access - [env ::env, form _, target _, field-form simple-symbol?, field (t/isa? Field) + [opts ::opts, env ::env, form _, target _, field-form simple-symbol?, field (t/isa? Field) > uast/field-access?] (uast/field-access {:env env @@ -409,8 +412,9 @@ (err! "Found more than one class" cs)))) ;; TODO type these arguments; e.g. check that ?method||field, if present, is an unqualified symbol -(defns- analyze-seq|dot [env ::env, [_ _, target-form _, ?method-or-field _ & ?args _ :as form] _] - (let [target (analyze* env target-form) +(defns- analyze-seq|dot + [opts ::opts, env ::env, [_ _, target-form _, ?method-or-field _ & ?args _ :as form] _] + (let [target (analyze* opts env target-form) method-or-field (if (symbol? ?method-or-field) ?method-or-field (first ?method-or-field)) args-forms (if (symbol? ?method-or-field) ?args (rest ?method-or-field))] (if (t/= (:type target) t/nil?) @@ -432,14 +436,14 @@ (if-let [field (and (empty? args-forms) (-> target-class class>fields|with-cache (c/get (name method-or-field))))] - (analyze-seq|dot|field-access env form target method-or-field field) - (analyze-seq|dot|method-call env form target target-class + (analyze-seq|dot|field-access opts env form target method-or-field field) + (analyze-seq|dot|method-call opts env form target target-class (boolean ?target-static-class-map) method-or-field args-forms))))))) ;; TODO this is not the right approach for CLJS (defns- analyze-seq|new - [env ::env, [_ _ & [c|form _ & args|form _ :as body] _ :as form] _ > uast/new-node?] - (let [c|analyzed (analyze* env c|form)] + [opts ::opts, env ::env, [_ _ & [c|form _ & args|form _ :as body] _ :as form] _ > uast/new-node?] + (let [c|analyzed (analyze* opts env c|form)] (if-not (and (-> c|analyzed :type t/value-type?) (-> c|analyzed :type utr/value-type>value class?)) (err! "Supplied non-class to `new` form" {:form form}) @@ -452,7 +456,7 @@ (if (empty? constructors-for-ct) (err! "No constructors for class match the arg ct" {:class c :args|form args|form}) (let [{:keys [args|analyzed call-sites]} - (analyze-seq|method-or-constructor-call|incrementally-analyze env form c + (analyze-seq|method-or-constructor-call|incrementally-analyze opts env form c args|form constructors-for-ct "constructors")] (uast/new-node {:env env @@ -469,14 +473,14 @@ (defns- analyze-seq|if "Performs conditional branch pruning." - [env ::env, [_ _ & [pred-form _, true-form _, false-form _ :as body] _ :as form] _ + [opts ::opts, env ::env, [_ _ & [pred-form _, true-form _, false-form _ :as body] _ :as form] _ > uast/node?] (if-not (<= 2 (count body) 3) (err! "`if` accepts exactly 3 arguments: one predicate test and two branches; received" {:body body}) - (let [pred-node (analyze* env pred-form) - true-node (delay (analyze* env true-form)) - false-node (delay (analyze* env false-form)) + (let [pred-node (analyze* opts env pred-form) + true-node (delay (analyze* opts env true-form)) + false-node (delay (analyze* opts env false-form)) whole-node (delay (uast/if-node @@ -494,13 +498,13 @@ (assoc @false-node :env env)) nil @whole-node)))) -(defns- analyze-seq|quote [env ::env, [_ _ & body _ :as form] _ > uast/quoted?] +(defns- analyze-seq|quote [opts ::opts, env ::env, [_ _ & body _ :as form] _ > uast/quoted?] (uast/quoted env form (t/value (list* body)))) -(defns- analyze-seq|throw [env ::env, form _ [arg _ :as body] _ > uast/throw-node?] +(defns- analyze-seq|throw [opts ::opts, env ::env, form _ [arg _ :as body] _ > uast/throw-node?] (if (-> body count (not= 1)) (err! "Must supply exactly one input to `throw`; supplied" {:body body}) - (let [arg|analyzed (analyze* env arg)] + (let [arg|analyzed (analyze* opts env arg)] ;; TODO this is not quite true for CLJS but it's good practice at least (if-not (-> arg|analyzed :type (t/<= t/throwable?)) (err! "`throw` requires a throwable; received" {:arg arg :type (:type arg|analyzed)}) @@ -567,7 +571,7 @@ (apply t/or)))) (defns- call>input-nodes+out-type - [env _, caller|node _, caller|type _, caller-kind _, inputs-ct _, body _ + [opts ::opts, env ::env, caller|node _, caller|type _, caller-kind _, inputs-ct _, body _ > (s/kv {:input-nodes t/any? #_(s/seq-of ast/node?) :out-type t/type?})] (dissoc @@ -579,7 +583,7 @@ ;; We could do a little smarter analysis here but we'll keep it simple for now t/any?)} (->> body - (c/map+ #(analyze* env %)) + (c/map+ #(analyze* opts env %)) (reducei (fn [{:as ret :keys [dispatch-type]} input|analyzed i] (if (= :fnt caller-kind) @@ -610,19 +614,19 @@ (defns- analyze-seq* "Analyze a seq after it has been macro-expanded. The ->`form` is post- incremental macroexpansion." - [env ::env, [caller|form _ & body _ :as form] _ > uast/node?] + [opts ::opts, env ::env, [caller|form _ & body _ :as form] _ > uast/node?] (case caller|form - do (analyze-seq|do env form) - let* (analyze-seq|let* env form) + do (analyze-seq|do opts env form) + let* (analyze-seq|let* opts env form) deftype* (TODO "deftype*") fn* (TODO "fn*") def (TODO "def") - . (analyze-seq|dot env form) - if (analyze-seq|if env form) - quote (analyze-seq|quote env form) - new (analyze-seq|new env form) - throw (analyze-seq|throw env form) - (let [caller|node (analyze* env caller|form) + . (analyze-seq|dot opts env form) + if (analyze-seq|if opts env form) + quote (analyze-seq|quote opts env form) + new (analyze-seq|new opts env form) + throw (analyze-seq|throw opts env form) + (let [caller|node (analyze* opts env caller|form) caller|type (:type caller|node) inputs-ct (count body)] ;; TODO fix this line of code and extend t/compare so the comparison checks below @@ -669,7 +673,7 @@ :fn nil) {:keys [input-nodes out-type]} (call>input-nodes+out-type - env caller|node caller|type caller-kind inputs-ct body) + opts env caller|node caller|type caller-kind inputs-ct body) call-node (uast/call-node {:env env @@ -679,12 +683,12 @@ :type out-type})] call-node))))) -(defns- analyze-seq [env ::env, form _] +(defns- analyze-seq [opts ::opts, env ::env, form _] (let [expanded-form (ufeval/macroexpand form)] (if-let [no-expansion? (ucomp/== form expanded-form)] - (analyze-seq* env expanded-form) + (analyze-seq* opts env expanded-form) (let [expanded-form' (-> expanded-form (update-meta merge (meta form))) - expanded (analyze* env expanded-form')] + expanded (analyze* opts env expanded-form')] (uast/macro-call {:env env :unexpanded-form form @@ -692,18 +696,19 @@ :expanded expanded :type (:type expanded)}))))) -(defns ?resolve-with-env [sym symbol?, env ::env] +(defns ?resolve-with-env [opts ::opts, env ::env, sym symbol?] (if-let [[_ local] (find env sym)] {:value local} (let [resolved (ns-resolve *ns* sym)] (ifs resolved {:value resolved} (some-> sym namespace symbol resolve class?) - {:value (analyze-seq|dot env (list '. (-> sym namespace symbol) (-> sym name symbol)))} + {:value (analyze-seq|dot + opts env (list '. (-> sym namespace symbol) (-> sym name symbol)))} nil)))) -(defns- analyze-symbol [env ::env, form symbol? > uast/symbol?] - (if-not-let [{resolved :value} (?resolve-with-env form env)] +(defns- analyze-symbol [opts ::opts, env ::env, form symbol? > uast/symbol?] + (if-not-let [{resolved :value} (?resolve-with-env opts env form)] (err! "Could not resolve symbol" {:sym form}) (uast/symbol env form resolved (ifs (uast/node? resolved) @@ -717,19 +722,19 @@ t/any? (TODO "Unsure of what to do in this case" (kw-map env form resolved)))))) -(defns- analyze* [env ::env, form _ > uast/node?] +(defns- analyze* [opts ::opts, env ::env, form _ > uast/node?] (when (> (swap! *analyze-depth inc) 200) (throw (ex-info "Stack too deep" {:form form}))) (ifs (symbol? form) - (analyze-symbol env form) + (analyze-symbol opts env form) (t/literal? form) (uast/literal env form (t/>type form)) (or (vector? form) (set? form)) - (analyze-non-map-seqable env form (empty form) (fn stop [& [a b :as args]] (prl! args) (err! "STOP"))) + (analyze-non-map-seqable opts env form (empty form) (fn stop [& [a b :as args]] (prl! args) (err! "STOP"))) (map? form) - (analyze-map env form) + (analyze-map opts env form) (seq? form) - (analyze-seq env form) + (analyze-seq opts env form) (throw (ex-info "Unrecognized form" {:form form})))) (defns analyze @@ -739,6 +744,7 @@ non-primitives." > uast/node? ([form _] (analyze {} form)) - ([env ::env, form _] + ([env ::env, form _] (analyze {} env form)) + ([opts ::opts, env ::env, form _] (reset! *analyze-depth 0) - (analyze* env form))) + (analyze* opts env form))) From bd135ade0f51bf8e59e398f4f14c6bdd005eba97 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 30 Sep 2018 01:30:33 -0600 Subject: [PATCH 378/810] A few walkthroughs for dependent types --- .../quantum/test/untyped/core/type/defnt.cljc | 166 +++++++++++++----- 1 file changed, 121 insertions(+), 45 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 23b074fb..abeeaaee 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1306,13 +1306,11 @@ (t/ftype t/any? [] [tt/long?])} ([] (.invoke ~'defn-self-reference|__0|0)) ([~'x00__] - (ifs - ((Array/get - ~'defn-self-reference|__1|input0|types - 0) - ~'x00__) - (.invoke ~(tag (str `long>Object) 'defn-self-reference|__1|0) ~'x00__) - (unsupported! `defn-self-reference [~'x00__] 0)))))))] + (ifs + ((Array/get ~'defn-self-reference|__1|input0|types 0) ~'x00__) + (.invoke ~(tag (str `long>Object) 'defn-self-reference|__1|0) + ~'x00__) + (unsupported! `defn-self-reference [~'x00__] 0)))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) @@ -1350,6 +1348,8 @@ (let [actual (macroexpand ' (self/defn dependent-type + ;; 1. Expand/analyze `tt/boolean?` -> `(t/isa? Boolean)` + ;; 2. Expand/analyze `(type x)` -> `(t/isa? Boolean)` ([x tt/boolean? > (type x)] x)) expected (case (env-lang) @@ -1364,6 +1364,12 @@ (let [actual (macroexpand ' (self/defn dependent-type-nest + #_"1. Analyze `x` = `tt/boolean?` + -> Put `x` in env as `(t/isa? Boolean)` + 2. Analyze out-type = `(t/or t/number? (type x))` + 1. Analyze `(type x)` + -> `(t/isa? Boolean)` + -> `(t/or (t/isa? Number) (t/isa? Boolean))`" ([x tt/boolean? > (t/or t/number? (type x))] (if x x 1))) expected (case (env-lang) @@ -1373,24 +1379,48 @@ (testing "functionality" (eval actual) (eval '(do ...)))))) - (testing "With arg shadowing" - (let [actual - (macroexpand ' - (self/defn dependent-type-shadow - ([x tt/boolean? > (let [x (>long-checked "123")] - (t/or t/number? (type x)))] (if x x 1))) - expected - (case (env-lang) - :clj - ($ (do ...)))] - (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" - (eval actual) - (eval '(do ...)))))))) + (testing "With arg shadowing" + (let [actual + (macroexpand ' + (self/defn dependent-type-nest-shadow + #_"1. Analyze `x` = `tt/boolean?` + -> Put `x` in env as `(t/isa? Boolean)` + 2. Analyze out-type = `(let [x (>long-checked \"123\")] + (t/or t/number? (type x)))` + 1. Analyze `(>long-checked \"123\")` + -> Put `x` in env as `(t/isa? Long)` + 2. Analyze `(t/or t/number? (type x))` + 1. Analyze `(type x)` + -> `(t/isa? Long)` + -> `(t/or (t/isa? Number) (t/isa? Long))`" + ([x tt/boolean? > (let [x (>long-checked "123")] + (t/or t/number? (type x)))] (if x x 1))) + expected + (case (env-lang) + :clj + ($ (do ...)))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do ...)))))))) (testing "Output type dependent on splittable but non-primitive-splittable input" (let [actual (macroexpand ' (self/defn dependent-type-split + #_"1. Analyze `x` = `(t/or tt/boolean? tt/string?)`. Splittable. + 2. Split `(t/or tt/boolean? tt/string?)`: + [[x tt/boolean? > (type x)] + [x tt/string? > (type x)]] + 3. Analyze split 0. + 1. Analyze `x` = `tt/boolean?` + -> Put `x` in env as `(t/isa? Boolean)` + 2. Analyze out-type = `(type x)` + -> `(t/isa? Boolean)` + 4. Analyze split 1. + 1. Analyze `x` = `tt/string?` + -> Put `x` in env as `(t/isa? String)` + 2. Analyze out-type = `(type x)` + -> `(t/isa? String)`" ([x (t/or tt/boolean? tt/string?) > (type x)] x)) expected (case (env-lang) @@ -1404,6 +1434,16 @@ (let [actual (macroexpand ' (self/defn dependent-type-psplit + #_"1. Analyze `x` = `t/any?`. Primitive-splittable. + 2. Split `t/any?`: + [[x tt/boolean? > (type x)] + [x ... > (type x)]] + 3. Analyze split 0. + 1. Analyze `x` = `tt/boolean?` + -> Put `x` in env as `(t/isa? Boolean)` + 2. Analyze out-type = `(type x)` + -> `(t/isa? Boolean)` + 4. Analyze rest of splits in the same way." ([x t/any? > (type x)] x))) expected (case (env-lang) @@ -1414,35 +1454,67 @@ (eval actual) (eval '(do ...))))) (testing "Input type dependent on other input type" - (let [actual - (macroexpand ' - (self/defn dependent-type-input - ([a tt/byte?, b (type a)] a))) - expected - (case (env-lang) - :clj - ($ (do ...)))] - (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" - (eval actual) - (eval '(do ...))))) + (testing "Dependent type is not for first input" + (let [actual + (macroexpand ' + (self/defn dependent-type-input + #_"1. Analyze `a` = `tt/byte?` + -> Put `a` in env as `(t/isa? Byte)` + 2. Analyze `b` = `(type a)` + -> Put `b` in env as `(t/isa? Byte)`" + ([a tt/byte?, b (type a)] a))) + expected + (case (env-lang) + :clj + ($ (do ...)))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do ...))))) + (testing "Dependent type is for first input" + (let [actual + (macroexpand ' + (self/defn dependent-type-input-first + #_"1. Analyze `a` = `(type b)`. + 2. Analyze `b` = `tt/byte?` + -> Put `b` in env as `(t/isa? Byte)` + -> Put `a` in env as `(t/isa? Byte)`" + ([a (type b), b tt/byte?] a))) + expected + (case (env-lang) + :clj + ($ (do ...)))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do ...)))))) (testing "Output type dependent on input type which is dependent on other input type" - (let [actual - (macroexpand ' - (self/defn dependent-type-2input - ([a tt/byte?, b (type a) > (type b)] b))) - expected - (case (env-lang) - :clj - ($ (do ...)))] - (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" - (eval actual) - (eval '(do ...))))) + (testing "First input not splittable; second input not splittable" + (let [actual + (macroexpand ' + (self/defn dependent-type-2input + #_"1. Analyze `a` = `tt/byte?` + -> Put `a` in env as `(t/isa? Byte)` + 2. Analyze `b` = `(type a)` + -> Put `b` in env as `(t/isa? Byte)` + 3. Analyze out-type = `(type b)` + -> `(t/isa? Byte)`" + ([a tt/byte?, b (type a) > (type b)] b))) + expected + (case (env-lang) + :clj + ($ (do ...)))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do ...)))))) (testing "Two input types directly depend on each other" (let [actual (macroexpand ' (self/defn dependent-type-directin + #_"1. Analyze `a` = `(type b)` + 1. Analyze `b` = `(type a)` + -> ERROR: `a` already in stack; circular dependency detected" ([a (type b), b (type a)] b)))] (testing "functionality" (throws? (eval actual))))) @@ -1450,6 +1522,10 @@ (let [actual (macroexpand ' (self/defn dependent-type-indirectin + #_"1. Analyze `a` = `(type b)` + 1. Analyze `b` = `(type c)` + 1. Analyze `c` = `(type a)` + -> ERROR `a` already in stack; circular dependency detected" ([a (type b), b (type c), c (type a)] b)))] (testing "functionality" (throws? (eval actual)))))) From 0b71e709c2c91e743ea5b6c737741a753517caad Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 30 Sep 2018 02:41:00 -0600 Subject: [PATCH 379/810] Put up giant complicated example that makes actual sense --- .../quantum/test/untyped/core/type/defnt.cljc | 202 +++++++++++++++++- 1 file changed, 194 insertions(+), 8 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index abeeaaee..73ee3436 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1505,19 +1505,205 @@ :clj ($ (do ...)))] (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do ...))))) + (testing "First input splittable; second input not splittable" + (let [actual + (macroexpand ' + (self/defn dependent-type-2input-0split + #_"1. Analyze `a` = `(t/or tt/boolean? tt/byte?)`. Splittable. + 2. Split: + [[a tt/boolean?, b (type a) > (type b)] + [a tt/byte? , b (type a) > (type b)]] + 3. Analyze split 0. + 1. Analyze `a` = `tt/boolean?` + -> Put `a` in env as `(t/isa? Boolean)` + 2. Analyze `b` = `(type a)` + -> Put `b` in env as `(t/isa? Boolean)` + 3. Analyze out-type = `(type b)` + -> `(t/isa? Boolean)` + 4. Analyze split 1 in the same way." + ([a (t/or tt/boolean? tt/byte?), b (type a) > (type b)] b))) + expected + (case (env-lang) + :clj + ($ (do ...)))] + (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) (eval '(do ...)))))) - (testing "Two input types directly depend on each other" + (testing "Combination/integration test" (let [actual (macroexpand ' - (self/defn dependent-type-directin - #_"1. Analyze `a` = `(type b)` - 1. Analyze `b` = `(type a)` - -> ERROR: `a` already in stack; circular dependency detected" - ([a (type b), b (type a)] b)))] + (self/defn dependent-type-combo + #_"1. Analyze `a` = `(type (>long-checked \"23\"))` + 1. Analyze `(>long-checked \"23\")` + -> `(t/value 23)` + -> Put `out` in env as `(t/value 23)`" + [out (type (>long-checked "23"))] + (self/fn dependent-type-combo-inner + #_"1. Analyze `a` = `(t/or tt/boolean? (type b))` + - Put `a` on queue + 1. Analyze `tt/boolean?` + -> `(t/isa? Boolean)` + 2. Analyze `(type b)` + 1. Analyze `b` = `(t/or tt/byte? (type d))` + - Put `b` on queue + 1. Analyze `tt/byte?` + -> `(t/isa? Byte)` + 2. Analyze `(type d)` + 1. Analyze `d` = `(let [b (t/- tt/char? tt/long?)] + (t/or tt/char? (type b) (type c)))` + - Put `d` on queue + 1. Analyze `b` = `(t/- tt/char? tt/long?)` + -> Put `b` in env as `t/none?` + 2. Analyze `(t/or tt/char? (type b) (type c))` + 1. Analyze `tt/char?` + -> `(t/isa? Character)` + 2. Analyze `(type b)` + -> `t/none-type?` <-- be careful of this + 3. Analyze `(type c)` + 1. Analyze `c` = `(t/or tt/short? tt/char?)` + 1. Analyze `tt/short?` + -> `(t/isa? Short)` + 2. Analyze `tt/char?` + -> `(t/isa? Character)` + -> `c` candidate is: + `(t/or (t/isa? Short) (t/isa? Character))` + Splittable. + - Split: + [[a (t/or tt/boolean? (type b)) + b (t/or tt/byte? (type d)) + c (t/isa? Short) + d (let [b (t/- tt/char? tt/long?)] + (t/or tt/char? (type b) (type c))) + > (t/or (type b) (type d))] + [a (t/or tt/boolean? (type b)) + b (t/or tt/byte? (type d)) + c (t/isa? Character) + d (let [b (t/- tt/char? tt/long?)] + (t/or tt/char? (type b) (type c))) + > (t/or (type b) (type d))]] + - We continue with only Split 0 for brevity. Other + splits should be handled the same. + -> Put `c` in env as `(t/isa? Short)` + -> `(t/isa? Short)` + -> `(t/or (t/isa? Character) + t/none-type? + (t/isa? Short))` + - Remove `b` from env + - Remove `d` from queue + -> `d` candidate is: + `(t/or (t/isa? Character) + t/none-type? + (t/isa? Short))`. + Splittable. + - Split: + [[a (t/or tt/boolean? (type b)) + b (t/or tt/byte? (type d)) + c (t/isa? Short) + d (t/isa? Character) + > (t/or (type b) (type d))] + [a (t/or tt/boolean? (type b)) + b (t/or tt/byte? (type d)) + c (t/isa? Short) + d t/none-type? + > (t/or (type b) (type d))] + [a (t/or tt/boolean? (type b)) + b (t/or tt/byte? (type d)) + c (t/isa? Short) + d (t/isa? Short) + > (t/or (type b) (type d))]] + - We continue with only Split 0 for brevity. Other splits + should be handled the same. + -> Put `d` in env as `(t/isa? Character)` + -> `(t/isa? Character)` + -> `(t/isa? Character)` + - Remove `b` from queue + -> `b` candidate is: + `(t/or (t/isa? Byte) (t/isa? Character))` + Splittable. + - Split: + [[a (t/or tt/boolean? (type b)) + b (t/isa? Byte) + c (t/isa? Short) + d (t/isa? Character) + > (t/or (type b) (type d))] + [a (t/or tt/boolean? (type b)) + b (t/isa? Character) + c (t/isa? Short) + d (t/isa? Character) + > (t/or (type b) (type d))]] + - We continue with only Split 0 for brevity. Other splits should be + handled the same. + -> Put `b` in env as `(t/isa? Byte)` + -> `(t/isa? Byte)` + - Remove `a` from queue + -> `a` candidate is: + `(t/or (t/isa? Boolean) (t/isa? Byte))` + Splittable. + - Split: + [[a (t/isa? Boolean) + b (t/isa? Byte) + c (t/isa? Short) + d (t/isa? Character) + > (t/or (type b) (type d))] + [a (t/isa? Byte) + b (t/isa? Character) + c (t/isa? Short) + d (t/isa? Character) + > (t/or (type b) (type d))]] + - We continue with only Split 0 for brevity. Other splits should be handled + the same. + -> Put `a` in env as `(t/isa? Boolean)` + 2. Analyze out-type = `(t/or (type b) (type d))` + -> (Cutting obvious corners) `(t/or (t/isa? Byte) (t/isa? Character))` + - No splitting necessary because out-type + - All input types are in env and output-type was analyzed. DONE" + ([a (t/or tt/boolean? (type b)) + b (t/or tt/byte? (type d)) + c (t/or tt/short? tt/char?) + d (let [b (t/- tt/char? tt/long?)] + (t/or tt/char? (type b) (type c))) + > (t/or (type b) (type d))] b))) + expected + (case (env-lang) + :clj + ($ (do ...)))] + (testing "code equivalence" (is-code= actual expected)) (testing "functionality" - (throws? (eval actual))))) + (eval actual) + (eval '(do ...))))) + (testing "Two input types directly depend on each other" + (testing "Symbolically" + (let [actual + (macroexpand ' + (self/defn dependent-type-directin + #_"1. Analyze `a` = `(type b)` + - Put `a` on queue + 1. Analyze `b` = `(type a)` + - Put `b` on queue + -> ERROR: `a` not in environment and `a` already on queue; circular + dependency detected" + ([a (type b), b (type a)] b)))] + (testing "functionality" + (throws? (eval actual))))) + (testing "Non-symbolically" + (let [actual + (macroexpand ' + (self/defn dependent-type-directin + #_"1. Analyze `a` = `(type b)` + - Put `a` on queue + 1. Analyze `b` = `(type [a])` + - Put `b` on queue + 1. Analyze `[a]` + 1. Analyze `a` + -> ERROR: `a` not in environment and `a` already on queue; + circular dependency detected" + ([a (type b), b (type [a])] b)))] + (testing "functionality" + (throws? (eval actual)))))) (testing "Two input types indirectly depend on each other" (let [actual (macroexpand ' @@ -1525,7 +1711,7 @@ #_"1. Analyze `a` = `(type b)` 1. Analyze `b` = `(type c)` 1. Analyze `c` = `(type a)` - -> ERROR `a` already in stack; circular dependency detected" + -> ERROR `a` already in queue; circular dependency detected" ([a (type b), b (type c), c (type a)] b)))] (testing "functionality" (throws? (eval actual)))))) From 5027761ebfaf3ca8edcb6cecf4da7df60065f00e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 30 Sep 2018 02:43:01 -0600 Subject: [PATCH 380/810] Update doc --- test/quantum/test/untyped/core/type/defnt.cljc | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 73ee3436..a241966b 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1711,7 +1711,8 @@ #_"1. Analyze `a` = `(type b)` 1. Analyze `b` = `(type c)` 1. Analyze `c` = `(type a)` - -> ERROR `a` already in queue; circular dependency detected" + -> ERROR `a` not in environment and `a` already in queue; circular + dependency detected" ([a (type b), b (type c), c (type a)] b)))] (testing "functionality" (throws? (eval actual)))))) From f6bbad233ddaf58425f4841f9c292a402f796ac8 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 30 Sep 2018 02:48:54 -0600 Subject: [PATCH 381/810] Fun little comment --- test/quantum/test/untyped/core/type/defnt.cljc | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index a241966b..116a7530 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1543,6 +1543,11 @@ -> Put `out` in env as `(t/value 23)`" [out (type (>long-checked "23"))] (self/fn dependent-type-combo-inner + ;; This test overview was put up in ~30 minutes during a seemingly random walk of + ;; thoughts without any testing or research whatsoever that happened to actually + ;; coalesce into a working, clear, simple algorithm for handling dependent types. + ;; Not sure if listening to Bach Passacaglia & Fugue In C Minor for organ and + ;; then orchestra helped, but there you go :) #_"1. Analyze `a` = `(t/or tt/boolean? (type b))` - Put `a` on queue 1. Analyze `tt/boolean?` From 1d700b90cee119358c5afe6c0e3fe1b8d7840a53 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 30 Sep 2018 10:21:16 -0600 Subject: [PATCH 382/810] `analyze-arg-syms`; working toward dependent type impl! --- src-untyped/quantum/untyped/core/analyze.cljc | 164 ++++++++++++------ 1 file changed, 107 insertions(+), 57 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index fdfd4ba5..7c53e67c 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -611,6 +611,7 @@ (get inputs-ct)))}))) :dispatchable-overloads-seq)) +;; TODO break this fn up. It's "clean" but just not broken up (defns- analyze-seq* "Analyze a seq after it has been macro-expanded. The ->`form` is post- incremental macroexpansion." @@ -626,62 +627,69 @@ quote (analyze-seq|quote opts env form) new (analyze-seq|new opts env form) throw (analyze-seq|throw opts env form) - (let [caller|node (analyze* opts env caller|form) - caller|type (:type caller|node) - inputs-ct (count body)] - ;; TODO fix this line of code and extend t/compare so the comparison checks below - ;; will work with t/fn - (case (if (utr/fn-type? caller|type) - -1 - (t/compare caller|type t/callable?)) - (1 2) (err! "It is not known whether form can be called" {:node caller|node}) - 3 (err! "Form cannot be called" {:node caller|node}) - (-1 0) (let [caller-kind - (ifs (utr/fn-type? caller|type) :fnt - (t/<= caller|type t/keyword?) :keyword - (t/<= caller|type t/+map|built-in?) :map - (t/<= caller|type t/+vector|built-in?) :vector - (t/<= caller|type t/+set|built-in?) :set - (t/<= caller|type t/fn?) :fn - ;; If it's callable but not fn, we might have missed something in - ;; this dispatch so for now we throw - (err! "Don't know how how to handle non-fn callable" - {:caller caller|node})) - assert-valid-inputs-ct - (case caller-kind - (:keyword :map) - (when-not (or (= inputs-ct 1) (= inputs-ct 2)) - (err! (str "Keywords and `clojure.core` persistent maps must be " - "provided with exactly one or two inputs when calling " - "them") - {:inputs-ct inputs-ct :caller caller|node})) - - (:vector :set) - (when-not (= inputs-ct 1) - (err! (str "`clojure.core` persistent vectors and `clojure.core` " - "persistent sets must be provided with exactly one " - "input when calling them") - {:inputs-ct inputs-ct :caller caller|node})) - - :fnt - (when-not (-> caller|type utr/fn-type>arities (contains? inputs-ct)) - (err! "Unhandled number of inputs for fnt" - {:inputs-ct inputs-ct :caller caller|node})) - ;; For non-typed fns, unknown; we will have to risk runtime exception - ;; because we can't necessarily rely on metadata to tell us the - ;; whole truth - :fn nil) - {:keys [input-nodes out-type]} - (call>input-nodes+out-type - opts env caller|node caller|type caller-kind inputs-ct body) - call-node - (uast/call-node - {:env env - :form form - :caller caller|node - :args input-nodes - :type out-type})] - call-node))))) + (if-let [caller-form-dependent-type-call? + (and (:arglist-context? opts) + (case caller|form + (quantum.core.type/type + quantum.core.untyped.type/type) true + false))] + (analyze-dependent-type-call opts env form) + (let [caller|node (analyze* opts env caller|form) + caller|type (:type caller|node) + inputs-ct (count body)] + ;; TODO fix this line of code and extend t/compare so the comparison checks below + ;; will work with t/fn + (case (if (utr/fn-type? caller|type) + -1 + (t/compare caller|type t/callable?)) + (1 2) (err! "It is not known whether form can be called" {:node caller|node}) + 3 (err! "Form cannot be called" {:node caller|node}) + (-1 0) (let [caller-kind + (ifs (utr/fn-type? caller|type) :fnt + (t/<= caller|type t/keyword?) :keyword + (t/<= caller|type t/+map|built-in?) :map + (t/<= caller|type t/+vector|built-in?) :vector + (t/<= caller|type t/+set|built-in?) :set + (t/<= caller|type t/fn?) :fn + ;; If it's callable but not fn, we might have missed something in + ;; this dispatch so for now we throw + (err! "Don't know how how to handle non-fn callable" + {:caller caller|node})) + assert-valid-inputs-ct + (case caller-kind + (:keyword :map) + (when-not (or (= inputs-ct 1) (= inputs-ct 2)) + (err! (str "Keywords and `clojure.core` persistent maps must be " + "provided with exactly one or two inputs when calling " + "them") + {:inputs-ct inputs-ct :caller caller|node})) + + (:vector :set) + (when-not (= inputs-ct 1) + (err! (str "`clojure.core` persistent vectors and `clojure.core` " + "persistent sets must be provided with exactly one " + "input when calling them") + {:inputs-ct inputs-ct :caller caller|node})) + + :fnt + (when-not (-> caller|type utr/fn-type>arities (contains? inputs-ct)) + (err! "Unhandled number of inputs for fnt" + {:inputs-ct inputs-ct :caller caller|node})) + ;; For non-typed fns, unknown; we will have to risk runtime exception + ;; because we can't necessarily rely on metadata to tell us the + ;; whole truth + :fn nil) + {:keys [input-nodes out-type]} + (call>input-nodes+out-type + opts env caller|node caller|type caller-kind inputs-ct body) + call-node + (uast/call-node + {:env env + :form form + :caller caller|node + :args input-nodes + :type out-type})] + call-node))))) (defns- analyze-seq [opts ::opts, env ::env, form _] (let [expanded-form (ufeval/macroexpand form)] @@ -737,8 +745,28 @@ (analyze-seq opts env form) (throw (ex-info "Unrecognized form" {:form form})))) +;; ===== Dependent types functionality ===== ;; + + + +;; ===== End dependent types functionality ===== ;; + (defns analyze - "Special metadata directives are defined in `special-metadata-keys`. They include: + "Opts may include: + - :arglist-context? : p/boolean? + : If you use `analyze-arg-syms` you won't have to set this yourself. + : When this is enabled, each AST node is tagged with additional + : information about dependent type analysis, namely: + : - :arglist-syms|queue : (dc/set-of id/simple-symbol?) + : - :arglist-syms|unanalyzed : (dc/set-of id/simple-symbol?) + - :arg-sym->arg-type-form : (dc/map-of id/simple-symbol? t/any?) + : If you use `analyze-arg-syms` you won't have to set this yourself. + - :arglist-syms|queue : (dc/set-of id/simple-symbol?) + : If you use `analyze-arg-syms` you won't have to set this yourself. + - :arglist-syms|unanalyzed : (dc/set-of id/simple-symbol?) + : If you use `analyze-arg-syms` you won't have to set this yourself. + + Special metadata directives are defined in `special-metadata-keys`. They include: - `:val` : Causes the analyzer to assume that the return value of the dot-form satisfies `t/val?`. Useful for doing method/dot-chaining in which the methods return non-primitives." @@ -748,3 +776,25 @@ ([opts ::opts, env ::env, form _] (reset! *analyze-depth 0) (analyze* opts env form))) + +(s/def ::arg-sym->arg-type-form (s/map-of uid/simple-symbol? t/any?)) + +(defns analyze-arg-syms + ([arg-sym->arg-type-form ::arg-sym->arg-type-form] (analyze-arg-syms {} {})) + ([opts ::opts, env ::env arg-sym->arg-type-form ::arg-sym->arg-type-form] + (loop [env env + arglist-syms|queue #{} + arglist-syms|unanalyzed (-> arg-sym->arg-type-form keys set)] + (if (empty? arglist-syms|unanalyzed) + env ; TODO maybe `(select-keys env (keys arg-sym->arg-type-form))` ? + (let [arg-sym (first arglist-syms|unanalyzed) + arg-type-form (arg-sym->arg-type-form arg-sym) + analyzed (analyze (assoc opts :arglist-context? true + :arg-sym->arg-type-form arg-sym->arg-type-form + :arglist-syms|queue arglist-syms|queue + :arglist-syms|unanalyzed arglist-syms|unanalyzed) + env arg-type-form)] + (recur (:env analyzed) + (:arglist-syms|queue analyzed) + (:arglist-syms|unanalyzed analyzed))))) + ))) From 235520c4a3de55391685f38b06329ed11ff7519a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 1 Oct 2018 08:39:14 -0600 Subject: [PATCH 383/810] Add `atomic-apply-val` and `atomic-apply-vals` --- src/quantum/core/refs.cljc | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/src/quantum/core/refs.cljc b/src/quantum/core/refs.cljc index ed5efbc9..36591f3e 100644 --- a/src/quantum/core/refs.cljc +++ b/src/quantum/core/refs.cljc @@ -30,7 +30,7 @@ ;; TODO technically this belongs in like `quantum.core.data.effects` or something (defprotocol IAtomic (atomic-apply [target f] - "Atomically applies `f` to `target`, with the following caveats: + "Atomically applies `f` to `target`, outputting whatever `f` does, with the following caveats: - Atomicity here means only that the effects of `f` on `target` are guaranteed to be rolled back or undone in the case of a failed application of `f` (e.g. in the case of an exception). This implies concurrency-safety only for concurrency-safe `target`s, not for `target`s safe @@ -41,17 +41,17 @@ It is the burden of the implementation to call the 1-arity function `f` in one of the following ways: - A) Given an immutable `target`, the `target` is supplied to `f`, and `f` returns an updated + A) Given an immutable `target`, the `target` is supplied to `f`, and `f` outputs an updated immutable version of it. The original `target` is by definition unaffected. - Example: Any built-in Clojure immutable data structure like a map, vector, set, etc. B) Given a `target` consisting of a container for an immutable value, the immutable value in - question is supplied to `f`, and `f` returns an updated immutable value which is atomically + question is supplied to `f`, and `f` outputs an updated immutable value which is atomically applied to the container. - Example: A Clojure atom wrapping e.g. an immutable Clojure map - Example: A 'box' type having a mutable, thread-unsafe field which may be set any number of times to refer only to immutable values. C) Given a `target` consisting of an 'opaque' structure that supports atomic modification, the - `target` is supplied to `f`, and `f` returns the modified/updated `target`. + `target` is supplied to `f`, and `f` outputs the modified/updated `target`. - Example: A JDBC connection, in which the connection *itself* might not be modified but a caller may request modifications to be transactionally (and thus atomically) applied to the underlying DB. @@ -66,7 +66,16 @@ inner one a no-op. This differs from `core/swap!` in that `swap!`, by convention, only supports case B), and that - only for concurrency-safe `target`s (if in a concurrent environment).")) + only for concurrency-safe `target`s (if in a concurrent environment).") + (atomic-apply-val [target f] + "Atomically applies `f` to `target` in exactly the same way as `atomic-apply` but instead of + expecting an updated `target` as the output value of `f`, expects a tuple of + [, ], which `atomic-apply-val` then outputs.") + (atomic-apply-vals [target f] + "Atomically applies `f` to `target` in exactly the same way as `atomic-apply` but instead of + expecting an updated `target` as the output value of `f`, expects a tuple of + [, ]. `atomic-apply-vals`, similarly to `core/swap-vals!`, then outputs + [, , ].")) (def atom? (t/isa?|direct #?(:clj clojure.lang.IAtom :cljs cljs.core/IAtom))) From 5aa7a1cd82270374863d88547c7d37d193d9bbb3 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 1 Oct 2018 10:11:06 -0600 Subject: [PATCH 384/810] `atomic-apply-vals` is fn --- src/quantum/core/refs.cljc | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/src/quantum/core/refs.cljc b/src/quantum/core/refs.cljc index 36591f3e..18938409 100644 --- a/src/quantum/core/refs.cljc +++ b/src/quantum/core/refs.cljc @@ -70,12 +70,18 @@ (atomic-apply-val [target f] "Atomically applies `f` to `target` in exactly the same way as `atomic-apply` but instead of expecting an updated `target` as the output value of `f`, expects a tuple of - [, ], which `atomic-apply-val` then outputs.") - (atomic-apply-vals [target f] - "Atomically applies `f` to `target` in exactly the same way as `atomic-apply` but instead of - expecting an updated `target` as the output value of `f`, expects a tuple of - [, ]. `atomic-apply-vals`, similarly to `core/swap-vals!`, then outputs - [, , ].")) + [, ], which `atomic-apply-val` then outputs.")) + +(defn atomic-apply-vals + "Atomically applies `f` to `target` in exactly the same way as `atomic-apply` but instead of + expecting an updated `target` as the output value of `f`, expects a tuple of + [, ]. `atomic-apply-vals`, similarly to `core/swap-vals!`, then outputs + [, , ]." + [target f] + (atomic-apply-val target + (fn [target'] + (let [[target'' v] (f target')] + [target' target'' v])))) (def atom? (t/isa?|direct #?(:clj clojure.lang.IAtom :cljs cljs.core/IAtom))) From 70a778ad89d6b80d54c89c91bac13e7a2d370027 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 1 Oct 2018 10:39:31 -0600 Subject: [PATCH 385/810] Only one protocol fn is needed --- src/quantum/core/refs.cljc | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/src/quantum/core/refs.cljc b/src/quantum/core/refs.cljc index 18938409..699394a8 100644 --- a/src/quantum/core/refs.cljc +++ b/src/quantum/core/refs.cljc @@ -66,22 +66,20 @@ inner one a no-op. This differs from `core/swap!` in that `swap!`, by convention, only supports case B), and that - only for concurrency-safe `target`s (if in a concurrent environment).") - (atomic-apply-val [target f] - "Atomically applies `f` to `target` in exactly the same way as `atomic-apply` but instead of - expecting an updated `target` as the output value of `f`, expects a tuple of - [, ], which `atomic-apply-val` then outputs.")) + only for concurrency-safe `target`s (if in a concurrent environment).")) -(defn atomic-apply-vals +(defn atomic-apply-val "Atomically applies `f` to `target` in exactly the same way as `atomic-apply` but instead of expecting an updated `target` as the output value of `f`, expects a tuple of - [, ]. `atomic-apply-vals`, similarly to `core/swap-vals!`, then outputs - [, , ]." + [, ], which `atomic-apply-val` then outputs." [target f] - (atomic-apply-val target - (fn [target'] - (let [[target'' v] (f target')] - [target' target'' v])))) + (let [v-box (volatile! nil) + target'' (atomic-apply target + (fn [target'] + (let [[target'' v] (f target')] + (vreset! v-box v) + target'')))] + [target'' @v-box])) (def atom? (t/isa?|direct #?(:clj clojure.lang.IAtom :cljs cljs.core/IAtom))) From 6113aaeeb3f781cfac920f3b2b346d82868ad6bf Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 1 Oct 2018 10:54:08 -0600 Subject: [PATCH 386/810] Add caveat --- src/quantum/core/refs.cljc | 1 + 1 file changed, 1 insertion(+) diff --git a/src/quantum/core/refs.cljc b/src/quantum/core/refs.cljc index 699394a8..37e1ed5c 100644 --- a/src/quantum/core/refs.cljc +++ b/src/quantum/core/refs.cljc @@ -37,6 +37,7 @@ only for single-threaded use. - Some implementations may run `f` multiple times in an effort to atomically apply it, so in those cases `f` must be free of side-effects not applied to the `target`. + - Some implementations may run `f` in another thread. It is the burden of the implementation to call the 1-arity function `f` in one of the following ways: From 509b22ae08ff1120c437f838ed582834c99ff5f7 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 2 Oct 2018 02:54:26 -0600 Subject: [PATCH 387/810] Refine notions of these side effects --- src/quantum/core/refs.cljc | 89 ++++++++++++++++++++------------------ 1 file changed, 48 insertions(+), 41 deletions(-) diff --git a/src/quantum/core/refs.cljc b/src/quantum/core/refs.cljc index 37e1ed5c..3b00f3cb 100644 --- a/src/quantum/core/refs.cljc +++ b/src/quantum/core/refs.cljc @@ -28,16 +28,20 @@ [com.google.common.util.concurrent AtomicDouble]))) ;; TODO technically this belongs in like `quantum.core.data.effects` or something -(defprotocol IAtomic - (atomic-apply [target f] - "Atomically applies `f` to `target`, outputting whatever `f` does, with the following caveats: - - Atomicity here means only that the effects of `f` on `target` are guaranteed to be rolled - back or undone in the case of a failed application of `f` (e.g. in the case of an exception). - This implies concurrency-safety only for concurrency-safe `target`s, not for `target`s safe - only for single-threaded use. - - Some implementations may run `f` multiple times in an effort to atomically apply it, so in - those cases `f` must be free of side-effects not applied to the `target`. - - Some implementations may run `f` in another thread. +(defprotocol Transactional + (transact [target f] [target f opts] + "Transactionally applies `f` to `target`, outputting whatever `f` does. Subject to the + following caveats: + - Transactionality here means at least atomicity — i.e. that any effects of `f` on `target` are + guaranteed to be rolled back or undone in the case of a failed application of `f` (e.g. in + the case of an exception). + - Here transactionality says nothing whatsoever about referential integrity or durability; and + whether the operation is `Serializable`, `Linearizable`, or both is up to the implementation + and is marked as such. For example, targets intended only for single-threaded use do not satisfy linearizability ('thread-safety') by definition in multi-threaded contexts, but may + yet be atomic and thus satisfy this narrow definition of transactionality. + - Some implementations may run `f` multiple times in an effort to transactionally apply it, so + in those cases `f` must be free of side-effects not applied to the `target`. + - Some implementations may run `f` in another thread or even on another machine. It is the burden of the implementation to call the 1-arity function `f` in one of the following ways: @@ -46,41 +50,44 @@ immutable version of it. The original `target` is by definition unaffected. - Example: Any built-in Clojure immutable data structure like a map, vector, set, etc. B) Given a `target` consisting of a container for an immutable value, the immutable value in - question is supplied to `f`, and `f` outputs an updated immutable value which is atomically - applied to the container. + question is supplied to `f`, and `f` outputs an updated immutable value which is + transactionally applied to the container. - Example: A Clojure atom wrapping e.g. an immutable Clojure map - - Example: A 'box' type having a mutable, thread-unsafe field which may be set any number of - times to refer only to immutable values. - C) Given a `target` consisting of an 'opaque' structure that supports atomic modification, the - `target` is supplied to `f`, and `f` outputs the modified/updated `target`. + - Example: A 'box' type having a mutable, non-linearizable / thread-unsafe field which may + be set any number of times to refer only to immutable values. + C) Given a `target` consisting of an 'opaque' structure that supports transactional + modification, the `target` is supplied to `f`, and `f` outputs the modified/updated + `target`. - Example: A JDBC connection, in which the connection *itself* might not be modified but a - caller may request modifications to be transactionally (and thus atomically) - applied to the underlying DB. - - Example: A Redis cache to which transactional (and thus atomic) updates may be applied. - - Example: A version of (the mutable, thread-unsafe) `java.util.HashMap` which keeps track - of modifications made to it within an atomic function application and rolls them - back in the case of a failed application (e.g. in the case of an exception). - - It is also the burden of the implementation to handle nested atomic applications on at least a - per-thread basis. That is, if `atomic-apply` is called inside of another `atomic-apply` on the - same thread, the implementation must ensure that both calls are atomic, usually by making the - inner one a no-op. + caller may request modifications to be transactionally applied to the underlying + DB. + - Example: A Redis cache to which atomic updates may be applied. + - Example: A version of (the mutable, non-linearizable / thread-unsafe) `java.util.HashMap` + which keeps track of modifications made to it within an atomic function + application and rolls them back in the case of a failed application (e.g. in the + case of an exception). + + It is also the burden of the implementation to handle nested transactions on at least a per- + thread basis. That is, if `transact` is called inside of another `transact` on the same thread, + the implementation must ensure that both calls are transactional, usually by making the inner + one a no-op. This differs from `core/swap!` in that `swap!`, by convention, only supports case B), and that - only for concurrency-safe `target`s (if in a concurrent environment).")) - -(defn atomic-apply-val - "Atomically applies `f` to `target` in exactly the same way as `atomic-apply` but instead of - expecting an updated `target` as the output value of `f`, expects a tuple of - [, ], which `atomic-apply-val` then outputs." - [target f] - (let [v-box (volatile! nil) - target'' (atomic-apply target - (fn [target'] - (let [[target'' v] (f target')] - (vreset! v-box v) - target'')))] - [target'' @v-box])) + only for linearizable `target`s (if in a concurrent environment).")) + +(defprotocol + ^{:doc "A marker protocol — 'serializable' in the sense that its `transact` implementation + satisfies serializability, i.e. Isolation (the 'I' in ACID)."} + Serializable) + +(defprotocol + ^{:doc "A marker protocol — 'linearizable' i.e. 'strongly consistent' in the sense that reads + within its `transact` implementation are guaranteed to yield the most recently written + value. If combined with the `Serializable` marker protocol, this means that the 'most + recently written value' means the value of the `target` at the moment of the beginning of + the transaction, and thereafter the value of the `target` only as modified within the + transaction."} + Linearizable) (def atom? (t/isa?|direct #?(:clj clojure.lang.IAtom :cljs cljs.core/IAtom))) From 99ed96c02937b7510ea1f803100cf8e1d42baa1a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 2 Oct 2018 21:53:04 -0600 Subject: [PATCH 388/810] Remove unnecessary expression types --- .../quantum/untyped/core/analyze/expr.cljc | 77 +--------------- src/quantum/core/refs.cljc | 3 +- test/quantum/test/core/defnt.cljc | 91 ------------------- .../test/untyped/core/analyze/expr.cljc | 70 -------------- 4 files changed, 6 insertions(+), 235 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze/expr.cljc b/src-untyped/quantum/untyped/core/analyze/expr.cljc index b6993a44..63412853 100644 --- a/src-untyped/quantum/untyped/core/analyze/expr.cljc +++ b/src-untyped/quantum/untyped/core/analyze/expr.cljc @@ -1,7 +1,7 @@ (ns quantum.untyped.core.analyze.expr "An expression is an object whose form is retained and editable to form new objects." (:refer-clojure :exclude - [flatten get ==]) + [flatten ==]) (:require [clojure.core :as core] [quantum.untyped.core.form.generate.deftype :as udt #?@(:cljs [:include-macros true])] ; should be obvious but oh well @@ -53,75 +53,6 @@ fipp.ednize/IEdn (-edn [this] sym)) -;; ===== LOGIC ===== ;; - -(defrecord Expr|casef - [f #_t/fn?, cases #_t/+map?] - IExpr ICall - #?(:clj clojure.lang.IFn :cljs cljs.core/IFn) - (#?(:clj invoke :cljs -invoke) [_ x] - (let [dispatch (f x)] - (if-let [[_ then] (find cases dispatch)] - (if (call? then) (then x) then) - (err! "No matching clause found" {:dispatch dispatch})))) - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] - (if upr/*print-as-code?* - (list* `casef (expr>form f) (map upr/>group cases)) - (list* `casef f cases)))) - -(defn casef [f & cases] - (new Expr|casef f (->> cases (partition-all+ 2) (join {})))) - -(defrecord Expr|condpf-> - [pred #_t/fn?, f #_t/fn?, clauses #_(t/and* t/sequential? t/indexed?)] - IExpr ICall - #?(:clj clojure.lang.IFn :cljs cljs.core/IFn) - (#?(:clj invoke :cljs -invoke) [_ x] - (let [v (f x)] - (if-let [[_ then :as matching-clause] - (->> clauses - (filter (fn [clause] - (or (-> clause count (= 1)) - (let [[condition then] clause] - (pred v condition))))) - first)] - (if (call? then) (then x) then) - (err! "No matching clause found" {:v v})))) - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] - (if upr/*print-as-code?* - (list* `condpf-> - (expr>form pred) - (expr>form f) - (map upr/>group clauses)) - (list* `condpf-> pred f clauses)))) - -(defn condpf-> [pred f & clauses] - (new Expr|condpf-> pred f (->> clauses (partition-all+ 2) join))) - -(defrecord Expr|get [k] - IExpr - #?(:clj clojure.lang.IFn :cljs cljs.core/IFn) - (#?(:clj invoke :cljs -invoke) [this m] (core/get m k)) - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (list `get k))) - -(defn get [k] (new Expr|get k)) - -(defrecord Expr|fn [name arities] - IExpr - #?(:clj clojure.lang.IFn :cljs cljs.core/IFn) - (#?(:clj invoke :cljs -invoke) [this] ((core/get arities 0))) - (#?(:clj invoke :cljs -invoke) [this a0] ((core/get arities 1) a0)) - (#?(:clj invoke :cljs -invoke) [this a0 a1] ((core/get arities 2) a0 a1)) - fipp.ednize/IOverride - fipp.ednize/IEdn - (-edn [this] (concat [`fn] (when name [name]) arities))) - (udt/deftype ^{:doc "All possible behaviors of `form` (e.g. `get`/`update`/`conj`) are inherited except function-callability, which is used for calling the evaled form itself. @@ -154,9 +85,9 @@ (= evaled (.-evaled that)) (= form (.-form that))))))} ?Counted {count ([this] (count form))} - ?Indexed {nth ([this i] (with-form this (nth form i)))} - ?Lookup {get (([this k] (with-form this (core/get form k))) - #_([this k else] (with-form this (core/get form k else))))} ; TODO make it work + ?Indexed {nth ([this i] (with-form this (nth form i)))} + ?Lookup {get (([this k] (with-form this (get form k))) + #_([this k else] (with-form this (get form k else))))} ; TODO make it work ?Meta {meta ([this] (meta form)) with-meta ([this meta'] (Expression. (with-meta form meta') evaled))} ?Reversible {rseq ([this] (with-form this (rseq form)))} diff --git a/src/quantum/core/refs.cljc b/src/quantum/core/refs.cljc index 3b00f3cb..0317ac98 100644 --- a/src/quantum/core/refs.cljc +++ b/src/quantum/core/refs.cljc @@ -37,7 +37,8 @@ the case of an exception). - Here transactionality says nothing whatsoever about referential integrity or durability; and whether the operation is `Serializable`, `Linearizable`, or both is up to the implementation - and is marked as such. For example, targets intended only for single-threaded use do not satisfy linearizability ('thread-safety') by definition in multi-threaded contexts, but may + and is marked as such. For example, targets intended only for single-threaded use do not + satisfy linearizability ('thread-safety') by definition in multi-threaded contexts, but may yet be atomic and thus satisfy this narrow definition of transactionality. - Some implementations may run `f` multiple times in an effort to transactionally apply it, so in those cases `f` must be free of side-effects not applied to the `target`. diff --git a/test/quantum/test/core/defnt.cljc b/test/quantum/test/core/defnt.cljc index 443e7664..8cf85ba3 100644 --- a/test/quantum/test/core/defnt.cljc +++ b/test/quantum/test/core/defnt.cljc @@ -62,97 +62,6 @@ ;; ============== OLD TESTS ============== ;; -(deftest test|methods->spec - (testing "Class hierarchy" - (is= - (self/methods->spec - [{:rtype Object :argtypes [int? char?]} - {:rtype Object :argtypes [String]} - {:rtype Object :argtypes [CharSequence]} - {:rtype Object :argtypes [Object]} - {:rtype Object :argtypes [Comparable]}]) - (xp/casef count - 1 (xp/condpf-> t/<= (xp/get 0) - (t/? string?) (t/? t/object?) - (t/? t/char-seq?) (t/? t/object?) - (t/? t/comparable?) (t/? t/object?) - (t/? t/object?) (t/? t/object?)) - 2 (xp/condpf-> t/<= (xp/get 0) - t/int? (xp/condpf-> t/<= (xp/get 1) - t/char? (t/? t/object?)))))) - (testing "Complex dispatch based off of `Numeric/bitAnd`" - (is= - (self/methods->spec - [{:rtype t/int? :argtypes [t/int? t/char?]} - {:rtype t/int? :argtypes [t/int? t/byte?]} - {:rtype t/int? :argtypes [t/int? t/short?]} - {:rtype t/int? :argtypes [t/int? t/int?]} - {:rtype t/long? :argtypes [t/short? t/long?]} - {:rtype t/int? :argtypes [t/short? t/int?]} - {:rtype t/short? :argtypes [t/short? t/short?]} - {:rtype t/long? :argtypes [t/long? t/long?]} - {:rtype t/long? :argtypes [t/long? t/int?]} - {:rtype t/long? :argtypes [t/long? t/short?]} - {:rtype t/long? :argtypes [t/long? t/char?]} - {:rtype t/long? :argtypes [t/long? t/byte?]} - {:rtype t/long? :argtypes [t/int? t/long?]} - {:rtype t/char? :argtypes [t/char? t/byte?]} - {:rtype t/long? :argtypes [t/byte? t/long?]} - {:rtype t/int? :argtypes [t/byte? t/int?]} - {:rtype t/short? :argtypes [t/byte? t/short?]} - {:rtype t/char? :argtypes [t/byte? t/char?]} - {:rtype t/byte? :argtypes [t/byte? t/byte?]} - {:rtype t/short? :argtypes [t/short? t/char?]} - {:rtype t/short? :argtypes [t/short? t/byte?]} - {:rtype t/long? :argtypes [t/char? t/long?]} - {:rtype t/long? :argtypes [t/char? t/long? t/long?]} - {:rtype t/char? :argtypes [t/char? t/char?]} - {:rtype t/short? :argtypes [t/char? t/short?]} - {:rtype t/int? :argtypes [t/char? t/int?]}]) - (xp/casef count - 2 (xp/condpf-> t/<= (xp/get 0) - t/int? - (xp/condpf-> t/<= (xp/get 1) - t/char? t/int? - t/byte? t/int? - t/short? t/int? - t/int? t/int? - t/long? t/long?) - t/short? - (xp/condpf-> t/<= (xp/get 1) - t/long? t/long? - t/int? t/int? - t/short? t/short? - t/char? t/short? - t/byte? t/short?) - t/long? - (xp/condpf-> t/<= (xp/get 1) - t/long? t/long? - t/int? t/long? - t/short? t/long? - t/char? t/long? - t/byte? t/long?) - t/char? - (xp/condpf-> t/<= (xp/get 1) - t/byte? t/char? - t/long? t/long? - t/char? t/char? - t/short? t/short? - t/int? t/int?) - t/byte? - (xp/condpf-> t/<= (xp/get 1) - t/long? t/long? - t/int? t/int? - t/short? t/short? - t/char? t/char? - t/byte? t/byte?)) - 3 (xp/condpf-> t/<= (xp/get 0) - t/char? - (xp/condpf-> t/<= (xp/get 1) - t/long? - (xp/condpf-> t/<= (xp/get 2) - t/long? t/long?))))))) - (def truthy-objects [1 1.0 1N 1M "abc" :abc]) (def falsey-objects [nil]) (def objects {true truthy-objects false falsey-objects}) diff --git a/test/quantum/test/untyped/core/analyze/expr.cljc b/test/quantum/test/untyped/core/analyze/expr.cljc index afe099f8..f40a711a 100644 --- a/test/quantum/test/untyped/core/analyze/expr.cljc +++ b/test/quantum/test/untyped/core/analyze/expr.cljc @@ -5,73 +5,3 @@ [quantum.core.untyped.analyze.ast :as ast] [quantum.core.untyped.analyze.expr :as self] [quantum.core.untyped.type :as t])) - -(deftest test|casef - (testing "equality" - (testing "self-equality" - (is= (self/casef count 1 nil 2 nil) - (self/casef count 1 nil 2 nil))) - (testing "different case orders are equal" - (is= (self/casef count 1 nil 2 nil) - (self/casef count 2 nil 1 nil)) - (is= (self/casef count "1" nil "2" nil) - (self/casef count "2" nil "1" nil)))) - (testing "inequality" - (testing "inequality of different cases" - (is (not= (self/casef count 1 nil 2 nil) - (self/casef count "1" nil 2 nil))))) - (testing "function call" - (let [dispatch - (self/casef count - 2 (self/condpf-> t/>= (self/get 0) - t/int - (self/condpf-> t/>= (self/get 1) - t/char? t/int? - t/byte? t/int? - t/short? t/int? - t/int? t/int? - t/long? t/long?) - t/short - (self/condpf-> t/>= (self/get 1) - t/long? t/long? - t/int? t/int? - t/short? t/short? - t/char? t/short? - t/byte? t/short?) - t/long - (self/condpf-> t/>= (self/get 1) - t/long? t/long? - t/int? t/long? - t/short? t/long? - t/char? t/long? - t/byte? t/long?) - t/char - (self/condpf-> t/>= (self/get 1) - t/byte? t/char? - t/long? t/long? - t/char? t/char? - t/short? t/short? - t/int? t/int?) - t/byte - (self/condpf-> t/>= (self/get 1) - t/long? t/long? - t/int? t/int? - t/short? t/short? - t/char? t/char? - t/byte? t/byte?)) - 3 (self/condpf-> t/>= (self/get 0) - t/char? - (self/condpf-> t/>= (self/get 1) - t/long? - (self/condpf-> t/>= (self/get 2) - t/long? t/long?))))] - (testing "Success" - (is= (dispatch [t/long? t/long?]) - t/long?) - (is= (dispatch [t/char? t/long? t/long?]) - t/long?) - (is= (dispatch [t/char? t/char?]) - t/char?)) - #_(testing "Failure" - (throws ? (dispatch [t/char]))) - ))) From cf7e9a0821dd26297a5360cacf31909bcbb96b22 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 2 Oct 2018 21:56:50 -0600 Subject: [PATCH 389/810] Add unanalyzed and analyzed forms to all AST nodes --- src-untyped/quantum/untyped/core/analyze.cljc | 150 +++++++++++------- .../quantum/untyped/core/analyze/ast.cljc | 93 ++++++----- 2 files changed, 143 insertions(+), 100 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 7c53e67c..97c33ddb 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -18,6 +18,7 @@ :refer [TODO err!]] [quantum.untyped.core.fn :refer [<- fn-> fn->>]] + [quantum.untyped.core.form :as uform] [quantum.untyped.core.form.evaluate :as ufeval] [quantum.untyped.core.form.type-hint :as ufth] [quantum.untyped.core.identifiers :as uident @@ -229,11 +230,11 @@ (defns- analyze-seq|do [opts ::opts, env ::env, [_ _ & body|form _ :as form] _ > uast/do?] (if (empty? body|form) (uast/do {:env env - :unexpanded-form form + :unanalyzed-form form :form form :body [] :type t/nil?}) - (let [{expanded-form :form body :body} + (let [{analyzed-form :form body :body} (analyze-non-map-seqable opts env body|form [] (fn [accum ast-data _] ;; The env should be the same as whatever it was originally because no new scopes @@ -242,8 +243,8 @@ (update :form conj! (:form ast-data)) (update :body conj! ast-data))))] (uast/do {:env env - :unexpanded-form form - :form (with-meta (list* 'do expanded-form) (meta expanded-form)) + :unanalyzed-form form + :form (with-meta (list* 'do analyzed-form) (meta analyzed-form)) :body body ;; To types, only the last sub-AST-node ever matters, as each is independent from ;; the others @@ -267,7 +268,7 @@ {body|form' :form body|type :type body :body} (analyze-seq|do opts env' (list* 'do body|form))] (uast/let* {:env env - :unexpanded-form form + :unanalyzed-form form :form (list* 'let* bindings|form' (rest body|form')) :bindings bindings-map :body body @@ -361,12 +362,13 @@ "Not yet able to statically validate whether primitive cast will succeed at runtime" {:form form}))] (uast/method-call - {:env env - :form form - :target target - :method method-form - :args args|analyzed - :type (-> call-sites first :out-class (maybe-with-assume-val form))}))) + {:env env + :unanalyzed-form form + :form (list* '. (:form target) method-form (map :form args|analyzed)) + :target target + :method method-form + :args args|analyzed + :type (-> call-sites first :out-class (maybe-with-assume-val form))}))) (defns- analyze-seq|dot|method-call "A note will be made of what methods match the argument types. @@ -459,11 +461,12 @@ (analyze-seq|method-or-constructor-call|incrementally-analyze opts env form c args|form constructors-for-ct "constructors")] (uast/new-node - {:env env - :form (list* 'new c|form (map :form args|analyzed)) - :class c - :args args|analyzed - :type (t/isa? c)}))))))) + {:env env + :unanalyzed-form form + :form (list* 'new c|form (map :form args|analyzed)) + :class c + :args args|analyzed + :type (t/isa? c)}))))))) ;; TODO move this (defns truthy-node? [{:as ast t [:type _]} _ > (t/? t/boolean?)] @@ -484,13 +487,14 @@ whole-node (delay (uast/if-node - {:env env - :form (list 'if (:form pred-node) (:form @true-node) (:form @false-node)) - :pred-node pred-node - :true-node @true-node - :false-node @false-node - :type (apply t/or (->> [(:type @true-node) (:type @false-node)] - (remove nil?)))}))] + {:env env + :unanalyzed-form form + :form (list 'if (:form pred-node) (:form @true-node) (:form @false-node)) + :pred-node pred-node + :true-node @true-node + :false-node @false-node + :type (apply t/or (->> [(:type @true-node) (:type @false-node)] + (remove nil?)))}))] (case (truthy-node? pred-node) true (do (log/ppr :warn "Predicate in `if` node is always true" {:pred pred-form}) (assoc @true-node :env env)) @@ -509,11 +513,12 @@ (if-not (-> arg|analyzed :type (t/<= t/throwable?)) (err! "`throw` requires a throwable; received" {:arg arg :type (:type arg|analyzed)}) (uast/throw-node - {:env env - :form (list 'throw (:form arg|analyzed)) - :arg arg|analyzed - ;; `t/none?` because nothing is actually returned - :type t/none?}))))) + {:env env + :unanalyzed-form form + :form (list 'throw (:form arg|analyzed)) + :arg arg|analyzed + ;; `t/none?` because nothing is actually returned + :type t/none?}))))) (defn- filter-dynamic-dispatchable-overloads "An example of dynamic dispatch: @@ -611,6 +616,22 @@ (get inputs-ct)))}))) :dispatchable-overloads-seq)) +(defns- analyze-dependent-type-call + [opts ::opts, env ::env, [caller|form _, arg-form _ & extra-args-form _ :as form] _ > uast/node?] + (if (not (empty? extra-args-form)) + (err! "Incorrect number of args passed to dependent type call" + {:form form :args-ct (-> extra-args-form count inc)}) + (let [node (analyze* opts env arg-form) + caller|node (analyze* opts env caller|form)] + (uast/call-node + {:env env + ;; We replace the `form` with the form of the arg type + :unanalyzed-form form + :form (-> node :type uform/>form) + :caller caller|node + :args [arg-form] + :type (:type node)})))) + ;; TODO break this fn up. It's "clean" but just not broken up (defns- analyze-seq* "Analyze a seq after it has been macro-expanded. @@ -631,7 +652,7 @@ (and (:arglist-context? opts) (case caller|form (quantum.core.type/type - quantum.core.untyped.type/type) true + quantum.untyped.core.type/type) true false))] (analyze-dependent-type-call opts env form) (let [caller|node (analyze* opts env caller|form) @@ -681,15 +702,14 @@ :fn nil) {:keys [input-nodes out-type]} (call>input-nodes+out-type - opts env caller|node caller|type caller-kind inputs-ct body) - call-node - (uast/call-node - {:env env - :form form - :caller caller|node - :args input-nodes - :type out-type})] - call-node))))) + opts env caller|node caller|type caller-kind inputs-ct body)] + (uast/call-node + {:env env + :unanalyzed-form form + :form (list* (:form caller|node) (map :form input-nodes)) + :caller caller|node + :args input-nodes + :type out-type}))))))) (defns- analyze-seq [opts ::opts, env ::env, form _] (let [expanded-form (ufeval/macroexpand form)] @@ -700,6 +720,7 @@ (uast/macro-call {:env env :unexpanded-form form + :unanalyzed-form expanded-form' :form (:form expanded) :expanded expanded :type (:type expanded)}))))) @@ -777,24 +798,39 @@ (reset! *analyze-depth 0) (analyze* opts env form))) -(s/def ::arg-sym->arg-type-form (s/map-of uid/simple-symbol? t/any?)) +(s/def ::arg-sym->arg-type-form (s/map-of simple-symbol? t/any?)) + +(def analyze-arg-syms|max-iter 100) (defns analyze-arg-syms - ([arg-sym->arg-type-form ::arg-sym->arg-type-form] (analyze-arg-syms {} {})) - ([opts ::opts, env ::env arg-sym->arg-type-form ::arg-sym->arg-type-form] - (loop [env env - arglist-syms|queue #{} - arglist-syms|unanalyzed (-> arg-sym->arg-type-form keys set)] - (if (empty? arglist-syms|unanalyzed) - env ; TODO maybe `(select-keys env (keys arg-sym->arg-type-form))` ? - (let [arg-sym (first arglist-syms|unanalyzed) - arg-type-form (arg-sym->arg-type-form arg-sym) - analyzed (analyze (assoc opts :arglist-context? true - :arg-sym->arg-type-form arg-sym->arg-type-form - :arglist-syms|queue arglist-syms|queue - :arglist-syms|unanalyzed arglist-syms|unanalyzed) - env arg-type-form)] - (recur (:env analyzed) - (:arglist-syms|queue analyzed) - (:arglist-syms|unanalyzed analyzed))))) - ))) + ([arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _] + (analyze-arg-syms {} {} arg-sym->arg-type-form out-type-form)) + ([opts ::opts, env ::env arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _ + > (s/kv {:env ::env :out-type-node uast/node?})] + (let [opts' (assoc opts :arglist-context? true + :arg-sym->arg-type-form arg-sym->arg-type-form)] + (loop [env env + arglist-syms|queue #{} + arglist-syms|unanalyzed (-> arg-sym->arg-type-form keys set) + n|iter 0] + (println "env" env + "arglist-syms|queue" arglist-syms|queue + "arglist-syms|unanalyzed" arglist-syms|unanalyzed + "n|iter" n|iter) + (ifs (empty? arglist-syms|unanalyzed) + (let [out-type-analyzed (analyze opts' env out-type-form)] + {:env env :out-type-node out-type-analyzed}) + (>= n|iter analyze-arg-syms|max-iter) + (err! "Max number of iterations reached for `analyze-arg-syms" {:n n|iter}) + (let [arg-sym (first arglist-syms|unanalyzed) + arg-type-form (arg-sym->arg-type-form arg-sym) + analyzed (analyze (assoc opts' + :arglist-syms|queue arglist-syms|queue + :arglist-syms|unanalyzed arglist-syms|unanalyzed) + env arg-type-form) + env' (assoc (:env analyzed) arg-sym analyzed)] + (quantum.untyped.core.print/ppr analyzed) + (recur env' + (:arglist-syms|queue analyzed) + (:arglist-syms|unanalyzed analyzed) + (inc n|iter)))))))) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index c75a32a2..71922682 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -112,11 +112,12 @@ (defn quoted? [x] (instance? Quoted x)) (defrecord Let* - [env #_::env - form #_::t/body - bindings #_::env - body #_(t/and t/sequential? t/indexed? (t/every? ::node)) - type #_t/type?] + [env #_::env + unanalyzed-form #_::t/form + form #_::t/body + bindings #_::env + body #_(t/and t/sequential? t/indexed? (t/every? ::node)) + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -127,11 +128,11 @@ (defn let*? [x] (instance? Let* x)) (defrecord Do - [env #_::env - form #_::t/form - unexpanded-form #_::t/form - body #_(t/and t/sequential? t/indexed? (t/every? ::node)) - type #_t/type?] + [env #_::env + unanalyzed-form #_::t/form + form #_::t/form + body #_(t/and t/sequential? t/indexed? (t/every? ::node)) + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -143,8 +144,9 @@ (defrecord MacroCall [env #_::env - unexpanded-form #_::t/form - form #_::t/form ; the *fully* expanded form + unexpanded-form #_::t/form ; the original form + unanalyzed-form #_::t/form ; the expanded-once form, pre-analysis + form #_::t/form ; the *fully* expanded form, post-analysis expanded #_::node type #_t/type?] INode @@ -157,12 +159,13 @@ (defn macro-call? [x] (instance? MacroCall x)) (defrecord IfNode - [env #_::env - form #_::t/form - pred-node #_::node - true-node #_::node - false-node #_::node - type #_t/type?] + [env #_::env + unanalyzed-form #_::t/form + form #_::t/form + pred-node #_::node + true-node #_::node + false-node #_::node + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -175,11 +178,11 @@ ;; ===== RUNTIME CALLS ===== ;; (defrecord FieldAccess - [env #_::env - form #_::t/form - target #_::node - field #_unqualified-symbol? - type #_t/type?] + [env #_::env + form #_::t/form + target #_::node + field #_unqualified-symbol? + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -191,12 +194,13 @@ (defn field-access? [x] (instance? FieldAccess x)) (defrecord MethodCall - [env #_::env - form #_::t/form - target #_::node - method #_::unqualified-symbol? - args #_(t/and t/sequential? t/indexed? (t/seq-and ::node)) - type #_t/type?] + [env #_::env + unanalyzed-form #_::t/form + form #_::t/form + target #_::node + method #_::unqualified-symbol? + args #_(t/and t/sequential? t/indexed? (t/seq-and ::node)) + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -208,11 +212,12 @@ (defn method-call? [x] (instance? MethodCall x)) (defrecord CallNode ; by a `t/callable?` - [env #_::env - form #_::t/form - caller #_::node - args #_(t/and t/sequential? t/indexed? (t/seq-and ::node)) - type #_t/type?] + [env #_::env + unanalyzed-form #_::t/form + form #_::t/form + caller #_::node + args #_(t/and t/sequential? t/indexed? (t/seq-and ::node)) + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -223,11 +228,12 @@ (defn call-node? [x] (instance? CallNode x)) (defrecord NewNode - [env #_::env - form #_::t/form - class #_t/class? - args #_(t/and t/sequential? t/indexed? (t/seq-and ::node)) - type #_t/type?] + [env #_::env + unanalyzed-form #_::t/form + form #_::t/form + class #_t/class? + args #_(t/and t/sequential? t/indexed? (t/seq-and ::node)) + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -239,10 +245,11 @@ (defn new-node? [x] (instance? NewNode x)) (defrecord ThrowNode - [env #_::env - form #_::t/form - arg #_::node - type #_t/nil?] + [env #_::env + unanalyzed-form #_::t/form + form #_::t/form + arg #_::node + type #_t/nil?] INode fipp.ednize/IOverride fipp.ednize/IEdn From 76d3539da9ef3a4c5892a764d38f5d2a94cf5b2b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 2 Oct 2018 21:57:03 -0600 Subject: [PATCH 390/810] `om` -> `hash-map` so we can compile correctly --- src-untyped/quantum/untyped/core/defnt.cljc | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index d31d753f..8f5edeb5 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -9,8 +9,6 @@ :refer [any?]] [quantum.untyped.core.data :refer [seqable?]] - [quantum.untyped.core.data.map - :refer [om]] [quantum.untyped.core.form.evaluate :as ufeval] [quantum.untyped.core.identifiers :refer [>keyword ident? qualified-keyword? simple-symbol?]] @@ -220,9 +218,9 @@ (apply concat)) ~@(when varargs [:varargs most-complex-positional-destructurer-sym])) kv-spec# - (us/kv (om ~@(apply concat - (cond-> (->> args (map (fn [{:keys [k spec]}] [k spec]))) - varargs (concat [[(:k varargs) (:spec varargs)]]))))) + (us/kv (hash-map ~@(apply concat + (cond-> (->> args (map (fn [{:keys [k spec]}] [k spec]))) + varargs (concat [[(:k varargs) (:spec varargs)]]))))) or|conformer# (us/conformer (fn or|conformer# [m#] @@ -350,7 +348,7 @@ (-> ret (cond-> varargs? (update :fn-arglist conj '&)) (update :fn-arglist conj binding-) (update :kw-args assoc binding- arg-ident)))) - {:fn-arglist [] :kw-args (om)} + {:fn-arglist [] :kw-args (hash-map)} (cond-> args varargs (conj (assoc varargs :varargs? true)))) overload-form (list* fn-arglist body) arity-ident (keyword (str "arity-" (if varargs "varargs" (count args)))) From d007d9d9b981ac66c144eb3caaa0d6c17803ab26 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 2 Oct 2018 23:49:30 -0600 Subject: [PATCH 391/810] type -> t/type --- .../quantum/test/untyped/core/type/defnt.cljc | 162 +++++++++--------- 1 file changed, 82 insertions(+), 80 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 116a7530..aec0b150 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1118,7 +1118,7 @@ (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] (let* [~(tag "clojure.lang.Ratio" 'x) ~'x] ;; Resolved from `(>long (.bigIntegerValue x))` - ;; In this case, `(t/compare (type-of '(.bigIntegerValue x)) overload-type)`: + ;; In this case, `(t/compare (t/type-of '(.bigIntegerValue x)) overload-type)`: ;; - `(t/- tt/boolean? tt/boolean? float? double?)` -> t/<> ;; - `(t/and (t/or double? float?) ...)` -> t/<> ;; - `(t/and (t/isa? clojure.lang.BigInt) ...)` -> t/<> @@ -1348,9 +1348,11 @@ (let [actual (macroexpand ' (self/defn dependent-type - ;; 1. Expand/analyze `tt/boolean?` -> `(t/isa? Boolean)` - ;; 2. Expand/analyze `(type x)` -> `(t/isa? Boolean)` - ([x tt/boolean? > (type x)] x)) + #_"1. Analyze `x` = `tt/boolean?` + -> Put `x` in env as `(t/isa? Boolean)` + 2. Analyze out-type = `(t/type x)` + -> `(t/isa? Boolean)`" + ([x tt/boolean? > (t/type x)] x)) expected (case (env-lang) :clj @@ -1366,11 +1368,11 @@ (self/defn dependent-type-nest #_"1. Analyze `x` = `tt/boolean?` -> Put `x` in env as `(t/isa? Boolean)` - 2. Analyze out-type = `(t/or t/number? (type x))` - 1. Analyze `(type x)` + 2. Analyze out-type = `(t/or t/number? (t/type x))` + 1. Analyze `(t/type x)` -> `(t/isa? Boolean)` -> `(t/or (t/isa? Number) (t/isa? Boolean))`" - ([x tt/boolean? > (t/or t/number? (type x))] (if x x 1))) + ([x tt/boolean? > (t/or t/number? (t/type x))] (if x x 1))) expected (case (env-lang) :clj @@ -1386,15 +1388,15 @@ #_"1. Analyze `x` = `tt/boolean?` -> Put `x` in env as `(t/isa? Boolean)` 2. Analyze out-type = `(let [x (>long-checked \"123\")] - (t/or t/number? (type x)))` + (t/or t/number? (t/type x)))` 1. Analyze `(>long-checked \"123\")` -> Put `x` in env as `(t/isa? Long)` - 2. Analyze `(t/or t/number? (type x))` - 1. Analyze `(type x)` + 2. Analyze `(t/or t/number? (t/type x))` + 1. Analyze `(t/type x)` -> `(t/isa? Long)` -> `(t/or (t/isa? Number) (t/isa? Long))`" ([x tt/boolean? > (let [x (>long-checked "123")] - (t/or t/number? (type x)))] (if x x 1))) + (t/or t/number? (t/type x)))] (if x x 1))) expected (case (env-lang) :clj @@ -1409,19 +1411,19 @@ (self/defn dependent-type-split #_"1. Analyze `x` = `(t/or tt/boolean? tt/string?)`. Splittable. 2. Split `(t/or tt/boolean? tt/string?)`: - [[x tt/boolean? > (type x)] - [x tt/string? > (type x)]] + [[x tt/boolean? > (t/type x)] + [x tt/string? > (t/type x)]] 3. Analyze split 0. 1. Analyze `x` = `tt/boolean?` -> Put `x` in env as `(t/isa? Boolean)` - 2. Analyze out-type = `(type x)` + 2. Analyze out-type = `(t/type x)` -> `(t/isa? Boolean)` 4. Analyze split 1. 1. Analyze `x` = `tt/string?` -> Put `x` in env as `(t/isa? String)` - 2. Analyze out-type = `(type x)` + 2. Analyze out-type = `(t/type x)` -> `(t/isa? String)`" - ([x (t/or tt/boolean? tt/string?) > (type x)] x)) + ([x (t/or tt/boolean? tt/string?) > (t/type x)] x)) expected (case (env-lang) :clj @@ -1436,15 +1438,15 @@ (self/defn dependent-type-psplit #_"1. Analyze `x` = `t/any?`. Primitive-splittable. 2. Split `t/any?`: - [[x tt/boolean? > (type x)] - [x ... > (type x)]] + [[x tt/boolean? > (t/type x)] + [x ... > (t/type x)]] 3. Analyze split 0. 1. Analyze `x` = `tt/boolean?` -> Put `x` in env as `(t/isa? Boolean)` - 2. Analyze out-type = `(type x)` + 2. Analyze out-type = `(t/type x)` -> `(t/isa? Boolean)` 4. Analyze rest of splits in the same way." - ([x t/any? > (type x)] x))) + ([x t/any? > (t/type x)] x))) expected (case (env-lang) :clj @@ -1460,9 +1462,9 @@ (self/defn dependent-type-input #_"1. Analyze `a` = `tt/byte?` -> Put `a` in env as `(t/isa? Byte)` - 2. Analyze `b` = `(type a)` + 2. Analyze `b` = `(t/type a)` -> Put `b` in env as `(t/isa? Byte)`" - ([a tt/byte?, b (type a)] a))) + ([a tt/byte?, b (t/type a)] a))) expected (case (env-lang) :clj @@ -1475,11 +1477,11 @@ (let [actual (macroexpand ' (self/defn dependent-type-input-first - #_"1. Analyze `a` = `(type b)`. + #_"1. Analyze `a` = `(t/type b)`. 2. Analyze `b` = `tt/byte?` -> Put `b` in env as `(t/isa? Byte)` -> Put `a` in env as `(t/isa? Byte)`" - ([a (type b), b tt/byte?] a))) + ([a (t/type b), b tt/byte?] a))) expected (case (env-lang) :clj @@ -1495,11 +1497,11 @@ (self/defn dependent-type-2input #_"1. Analyze `a` = `tt/byte?` -> Put `a` in env as `(t/isa? Byte)` - 2. Analyze `b` = `(type a)` + 2. Analyze `b` = `(t/type a)` -> Put `b` in env as `(t/isa? Byte)` - 3. Analyze out-type = `(type b)` + 3. Analyze out-type = `(t/type b)` -> `(t/isa? Byte)`" - ([a tt/byte?, b (type a) > (type b)] b))) + ([a tt/byte?, b (t/type a) > (t/type b)] b))) expected (case (env-lang) :clj @@ -1514,17 +1516,17 @@ (self/defn dependent-type-2input-0split #_"1. Analyze `a` = `(t/or tt/boolean? tt/byte?)`. Splittable. 2. Split: - [[a tt/boolean?, b (type a) > (type b)] - [a tt/byte? , b (type a) > (type b)]] + [[a tt/boolean?, b (t/type a) > (t/type b)] + [a tt/byte? , b (t/type a) > (t/type b)]] 3. Analyze split 0. 1. Analyze `a` = `tt/boolean?` -> Put `a` in env as `(t/isa? Boolean)` - 2. Analyze `b` = `(type a)` + 2. Analyze `b` = `(t/type a)` -> Put `b` in env as `(t/isa? Boolean)` - 3. Analyze out-type = `(type b)` + 3. Analyze out-type = `(t/type b)` -> `(t/isa? Boolean)` 4. Analyze split 1 in the same way." - ([a (t/or tt/boolean? tt/byte?), b (type a) > (type b)] b))) + ([a (t/or tt/boolean? tt/byte?), b (t/type a) > (t/type b)] b))) expected (case (env-lang) :clj @@ -1537,38 +1539,38 @@ (let [actual (macroexpand ' (self/defn dependent-type-combo - #_"1. Analyze `a` = `(type (>long-checked \"23\"))` + #_"1. Analyze `a` = `(t/type (>long-checked \"23\"))` 1. Analyze `(>long-checked \"23\")` -> `(t/value 23)` -> Put `out` in env as `(t/value 23)`" - [out (type (>long-checked "23"))] + [out (t/type (>long-checked "23"))] (self/fn dependent-type-combo-inner ;; This test overview was put up in ~30 minutes during a seemingly random walk of ;; thoughts without any testing or research whatsoever that happened to actually ;; coalesce into a working, clear, simple algorithm for handling dependent types. ;; Not sure if listening to Bach Passacaglia & Fugue In C Minor for organ and ;; then orchestra helped, but there you go :) - #_"1. Analyze `a` = `(t/or tt/boolean? (type b))` + #_"1. Analyze `a` = `(t/or tt/boolean? (t/type b))` - Put `a` on queue 1. Analyze `tt/boolean?` -> `(t/isa? Boolean)` - 2. Analyze `(type b)` - 1. Analyze `b` = `(t/or tt/byte? (type d))` + 2. Analyze `(t/type b)` + 1. Analyze `b` = `(t/or tt/byte? (t/type d))` - Put `b` on queue 1. Analyze `tt/byte?` -> `(t/isa? Byte)` - 2. Analyze `(type d)` + 2. Analyze `(t/type d)` 1. Analyze `d` = `(let [b (t/- tt/char? tt/long?)] - (t/or tt/char? (type b) (type c)))` + (t/or tt/char? (t/type b) (t/type c)))` - Put `d` on queue 1. Analyze `b` = `(t/- tt/char? tt/long?)` -> Put `b` in env as `t/none?` - 2. Analyze `(t/or tt/char? (type b) (type c))` + 2. Analyze `(t/or tt/char? (t/type b) (t/type c))` 1. Analyze `tt/char?` -> `(t/isa? Character)` - 2. Analyze `(type b)` + 2. Analyze `(t/type b)` -> `t/none-type?` <-- be careful of this - 3. Analyze `(type c)` + 3. Analyze `(t/type c)` 1. Analyze `c` = `(t/or tt/short? tt/char?)` 1. Analyze `tt/short?` -> `(t/isa? Short)` @@ -1578,18 +1580,18 @@ `(t/or (t/isa? Short) (t/isa? Character))` Splittable. - Split: - [[a (t/or tt/boolean? (type b)) - b (t/or tt/byte? (type d)) + [[a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) c (t/isa? Short) d (let [b (t/- tt/char? tt/long?)] - (t/or tt/char? (type b) (type c))) - > (t/or (type b) (type d))] - [a (t/or tt/boolean? (type b)) - b (t/or tt/byte? (type d)) + (t/or tt/char? (t/type b) (t/type c))) + > (t/or (t/type b) (t/type d))] + [a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) c (t/isa? Character) d (let [b (t/- tt/char? tt/long?)] - (t/or tt/char? (type b) (type c))) - > (t/or (type b) (type d))]] + (t/or tt/char? (t/type b) (t/type c))) + > (t/or (t/type b) (t/type d))]] - We continue with only Split 0 for brevity. Other splits should be handled the same. -> Put `c` in env as `(t/isa? Short)` @@ -1605,21 +1607,21 @@ (t/isa? Short))`. Splittable. - Split: - [[a (t/or tt/boolean? (type b)) - b (t/or tt/byte? (type d)) + [[a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) c (t/isa? Short) d (t/isa? Character) - > (t/or (type b) (type d))] - [a (t/or tt/boolean? (type b)) - b (t/or tt/byte? (type d)) + > (t/or (t/type b) (t/type d))] + [a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) c (t/isa? Short) d t/none-type? - > (t/or (type b) (type d))] - [a (t/or tt/boolean? (type b)) - b (t/or tt/byte? (type d)) + > (t/or (t/type b) (t/type d))] + [a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) c (t/isa? Short) d (t/isa? Short) - > (t/or (type b) (type d))]] + > (t/or (t/type b) (t/type d))]] - We continue with only Split 0 for brevity. Other splits should be handled the same. -> Put `d` in env as `(t/isa? Character)` @@ -1630,16 +1632,16 @@ `(t/or (t/isa? Byte) (t/isa? Character))` Splittable. - Split: - [[a (t/or tt/boolean? (type b)) + [[a (t/or tt/boolean? (t/type b)) b (t/isa? Byte) c (t/isa? Short) d (t/isa? Character) - > (t/or (type b) (type d))] - [a (t/or tt/boolean? (type b)) + > (t/or (t/type b) (t/type d))] + [a (t/or tt/boolean? (t/type b)) b (t/isa? Character) c (t/isa? Short) d (t/isa? Character) - > (t/or (type b) (type d))]] + > (t/or (t/type b) (t/type d))]] - We continue with only Split 0 for brevity. Other splits should be handled the same. -> Put `b` in env as `(t/isa? Byte)` @@ -1653,25 +1655,25 @@ b (t/isa? Byte) c (t/isa? Short) d (t/isa? Character) - > (t/or (type b) (type d))] + > (t/or (t/type b) (t/type d))] [a (t/isa? Byte) b (t/isa? Character) c (t/isa? Short) d (t/isa? Character) - > (t/or (type b) (type d))]] + > (t/or (t/type b) (t/type d))]] - We continue with only Split 0 for brevity. Other splits should be handled the same. -> Put `a` in env as `(t/isa? Boolean)` - 2. Analyze out-type = `(t/or (type b) (type d))` + 2. Analyze out-type = `(t/or (t/type b) (t/type d))` -> (Cutting obvious corners) `(t/or (t/isa? Byte) (t/isa? Character))` - No splitting necessary because out-type - All input types are in env and output-type was analyzed. DONE" - ([a (t/or tt/boolean? (type b)) - b (t/or tt/byte? (type d)) + ([a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) c (t/or tt/short? tt/char?) d (let [b (t/- tt/char? tt/long?)] - (t/or tt/char? (type b) (type c))) - > (t/or (type b) (type d))] b))) + (t/or tt/char? (t/type b) (t/type c))) + > (t/or (t/type b) (t/type d))] b))) expected (case (env-lang) :clj @@ -1685,40 +1687,40 @@ (let [actual (macroexpand ' (self/defn dependent-type-directin - #_"1. Analyze `a` = `(type b)` + #_"1. Analyze `a` = `(t/type b)` - Put `a` on queue - 1. Analyze `b` = `(type a)` + 1. Analyze `b` = `(t/type a)` - Put `b` on queue -> ERROR: `a` not in environment and `a` already on queue; circular dependency detected" - ([a (type b), b (type a)] b)))] + ([a (t/type b), b (t/type a)] b)))] (testing "functionality" (throws? (eval actual))))) (testing "Non-symbolically" (let [actual (macroexpand ' (self/defn dependent-type-directin - #_"1. Analyze `a` = `(type b)` + #_"1. Analyze `a` = `(t/type b)` - Put `a` on queue - 1. Analyze `b` = `(type [a])` + 1. Analyze `b` = `(t/type [a])` - Put `b` on queue 1. Analyze `[a]` 1. Analyze `a` -> ERROR: `a` not in environment and `a` already on queue; circular dependency detected" - ([a (type b), b (type [a])] b)))] + ([a (t/type b), b (t/type [a])] b)))] (testing "functionality" (throws? (eval actual)))))) (testing "Two input types indirectly depend on each other" (let [actual (macroexpand ' (self/defn dependent-type-indirectin - #_"1. Analyze `a` = `(type b)` - 1. Analyze `b` = `(type c)` - 1. Analyze `c` = `(type a)` + #_"1. Analyze `a` = `(t/type b)` + 1. Analyze `b` = `(t/type c)` + 1. Analyze `c` = `(t/type a)` -> ERROR `a` not in environment and `a` already in queue; circular dependency detected" - ([a (type b), b (type c), c (type a)] b)))] + ([a (t/type b), b (t/type c), c (t/type a)] b)))] (testing "functionality" (throws? (eval actual)))))) From 1344194c4cf1f4cf74517f2d7817205d6f7fbba9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 2 Oct 2018 23:49:39 -0600 Subject: [PATCH 392/810] Add `uvar/dynamic?` --- src/quantum/core/vars.cljc | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/quantum/core/vars.cljc b/src/quantum/core/vars.cljc index 94abd061..b8c9d4b9 100644 --- a/src/quantum/core/vars.cljc +++ b/src/quantum/core/vars.cljc @@ -108,6 +108,12 @@ (def var? (t/isa? #?(:clj clojure.lang.Var :cljs cljs.core/Var))) +;; TODO maybe extend to CLJS? +#?(:clj (t/defn var-defined? [x var?] (.hasRoot x))) + +;; TODO maybe extend to CLJS? +#?(:clj (t/defn dynamic? [x var?] (.isDynamic x))) + #?(:clj (t/extend-defn! id/>name (^:inline [x var?] (-> x >meta :name id/>name)))) #?(:clj (t/extend-defn! id/>namespace (^:inline [x var?] (-> x >meta :ns id/>name)))) #?(:clj (t/extend-defn! id/>symbol (^:inline [x var?] @@ -137,8 +143,6 @@ ;; TODO TYPED #?(:clj (uvar/defaliases uvar defalias defaliases defaliases')) -#?(:clj (t/defn var-defined? [x var?] (.hasRoot x))) - ;; TODO TYPED — need to do `apply`, and `apply` with t/defn; also `merge`, `str`, `deref` #_(:clj (t/defn alias-var From 944cc418305356a02382dddd072a073dc939d093 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 2 Oct 2018 23:50:01 -0600 Subject: [PATCH 393/810] Add beginnings of `dependent-type-test` --- test/quantum/test/untyped/core/analyze.cljc | 25 +++++++++++++++++++++ 1 file changed, 25 insertions(+) create mode 100644 test/quantum/test/untyped/core/analyze.cljc diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc new file mode 100644 index 00000000..50565537 --- /dev/null +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -0,0 +1,25 @@ +(ns quantum.test.untyped.core.analyze + (:require + [quantum.test.untyped.core.type :as tt] + [quantum.untyped.core.analyze :as self] + [quantum.untyped.core.test + :refer [deftest is is= testing]] + [quantum.untyped.core.type :as t])) + +;; More dependent type tests in `quantum.test.untyped.core.type.defnt` but those are more like +;; integration tests +(deftest dependent-type-test + (testing "Output type dependent on non-splittable input" + (testing "Not nested within another type" + (let [ana (self/analyze-arg-syms {} {} {'x `tt/boolean?} `(t/type ~'x))] + (is= t/boolean? + (get-in ana [:env 'x :type])))) + (testing "Nested within another type" + (testing "Without arg shadowing" + (let [ana (self/analyze-arg-syms {'x `tt/boolean?} `(t/or t/number? (t/type ~x)))] + (is= t/boolean? + (get-in ana [:env 'x :type]))))))) + + +(quantum.untyped.core.print/ppr + ) From dcc5f5d43cd6e562b2b999ee94d85d8bce6ad0fe Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 2 Oct 2018 23:50:09 -0600 Subject: [PATCH 394/810] Add `uvar/dynamic?` --- src-untyped/quantum/untyped/core/vars.cljc | 1 + 1 file changed, 1 insertion(+) diff --git a/src-untyped/quantum/untyped/core/vars.cljc b/src-untyped/quantum/untyped/core/vars.cljc index f9421e31..0423e4a5 100644 --- a/src-untyped/quantum/untyped/core/vars.cljc +++ b/src-untyped/quantum/untyped/core/vars.cljc @@ -12,6 +12,7 @@ (ucore/log-this-ns) #?(:clj (defn unbound? [x] (instance? clojure.lang.Var$Unbound x))) +#?(:clj (defn dynamic? [x] (.isDynamic ^clojure.lang.Var x))) #?(:cljs (defn defined? [x] (not (undefined? x)))) ;; ===== Metadata ===== ;; From efc3e31c9e2c8e2f912dc4ab85059750144f8f49 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 2 Oct 2018 23:50:36 -0600 Subject: [PATCH 395/810] Add ast/Var, ast/VarValue; enhance some other records --- .../quantum/untyped/core/analyze/ast.cljc | 62 ++++++++++++++++--- 1 file changed, 53 insertions(+), 9 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 71922682..839a3247 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -2,9 +2,7 @@ "Facilities for creating AST nodes (for now, just for Clojure). No actual analysis is done here." (:refer-clojure :exclude - [symbol Symbol #?(:cljs ->Symbol) symbol? - == - unbound?]) + [== symbol Symbol #?(:cljs ->Symbol) symbol? unbound? var var?]) (:require [quantum.untyped.core.analyze.expr :as uxp] [quantum.untyped.core.compare :as comp @@ -55,7 +53,12 @@ ;; ===== Nodes ===== ;; -(defrecord Unbound [env #_::env, form #_symbol?, minimum-type #_t/type?, type #_t/type?] ;; TODO `type` should be `t/deducible-type?` +;; Does not include unbound vars; this is specifically for arguments +(defrecord Unbound + [env #_::env + form #_symbol? + minimum-type #_t/type? + type #_t/type?] ;; TODO should be `t/deducible-type?` INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -68,7 +71,9 @@ (defn unbound? [x] (instance? Unbound x)) -(defrecord Literal [env #_::env, form #_::t/literal, type #_t/type?] +(defrecord + ^{:doc "AST node whose `type` is `(t/value form)`."} + Literal [env #_::env, form #_t/literal?, type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -80,19 +85,58 @@ (defn literal? [x] (instance? Literal x)) -(defrecord Symbol +(defrecord + ^{:doc "AST node generated from the value of a non-dynamic var. + The `type` may not always be `(t/value value)` because in the case of e.g. `t/defn`s, + their corresponding var value may just be a `core/defn`, but the type of the `t/defn` is + annotated in the var's metadata."} + VarValue [env #_::env - form #_symbol? + form #_qualified-symbol? value #_t/any? type #_t/type?] INode fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (list `var-value form type))) + +(defn var-value + ([form v t] (var-value nil form v t)) + ([env form v t] (VarValue. env (ufth/with-type-hint form (>type-hint form t)) v t))) + +(defn var-value? [x] (instance? VarValue x)) + +(defrecord + ^{:doc "AST node reserved only for dynamic vars."} + Var + [env #_::env + form ; (list 'var ) + value #_core/var? + type #_t/type?] + INode + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (list `var* form type))) + +(defn var* + ([form value t] (var* nil form value t)) + ([env form value t] (Var. env form value t))) + +(defn var? [x] (instance? Var x)) + +(defrecord Symbol + [env #_::env + form #_id/symbol? + node #_t/any? + type #_t/type?] + INode + fipp.ednize/IOverride fipp.ednize/IEdn (-edn [this] (list `symbol (into (array-map) this)))) (defn symbol - ([form value t] (symbol nil form value t)) - ([env form value t] (Symbol. env (ufth/with-type-hint form (>type-hint form t)) value t))) + ([form node t] (symbol nil form node t)) + ([env form node t] (Symbol. env (ufth/with-type-hint form (>type-hint form t)) node t))) (defn symbol? [x] (instance? Symbol x)) From 1302034eeb869b0a6034409f123aef5bfeb2826d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 2 Oct 2018 23:50:58 -0600 Subject: [PATCH 396/810] Overhaul symbol analysis and add var special sym handling --- src-untyped/quantum/untyped/core/analyze.cljc | 79 +++++++++++-------- 1 file changed, 47 insertions(+), 32 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 97c33ddb..98534dd5 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -21,8 +21,7 @@ [quantum.untyped.core.form :as uform] [quantum.untyped.core.form.evaluate :as ufeval] [quantum.untyped.core.form.type-hint :as ufth] - [quantum.untyped.core.identifiers :as uident - :refer [>symbol]] + [quantum.untyped.core.identifiers :as uid] [quantum.untyped.core.log :as log :refer [prl!]] [quantum.untyped.core.logic :as l @@ -502,16 +501,19 @@ (assoc @false-node :env env)) nil @whole-node)))) -(defns- analyze-seq|quote [opts ::opts, env ::env, [_ _ & body _ :as form] _ > uast/quoted?] - (uast/quoted env form (t/value (list* body)))) +(defns- analyze-seq|quote [opts ::opts, env ::env, [_ _, arg-form _ :as form] _ > uast/quoted?] + (if (-> form count (not= 2)) + (err! "Must supply exactly one input to `quote`" {:form form}) + (uast/quoted env form (t/value arg-form)))) -(defns- analyze-seq|throw [opts ::opts, env ::env, form _ [arg _ :as body] _ > uast/throw-node?] - (if (-> body count (not= 1)) - (err! "Must supply exactly one input to `throw`; supplied" {:body body}) - (let [arg|analyzed (analyze* opts env arg)] +(defns- analyze-seq|throw [opts ::opts, env ::env, [_ _, arg-form _ :as form] _ > uast/throw-node?] + (if (-> form count (not= 2)) + (err! "Must supply exactly one input to `throw`" {:form form}) + (let [arg|analyzed (analyze* opts env arg-form)] ;; TODO this is not quite true for CLJS but it's good practice at least (if-not (-> arg|analyzed :type (t/<= t/throwable?)) - (err! "`throw` requires a throwable; received" {:arg arg :type (:type arg|analyzed)}) + (err! "`throw` requires a throwable; received" + {:arg-form arg-form :type (:type arg|analyzed)}) (uast/throw-node {:env env :unanalyzed-form form @@ -520,6 +522,15 @@ ;; `t/none?` because nothing is actually returned :type t/none?}))))) +(defns- analyze-seq|var [opts ::opts, env ::env, [_ _, arg-form _ :as form] _ > uast/var?] + (ifs (-> form count (not= 2)) + (err! "Must supply exactly one input to `var`" {:form form}) + (not (symbol? arg-form)) + (err! "`var` accepts a symbol argument" {:form form}) + (if-let [resolved (ns-resolve *ns* arg-form)] + (uast/var* env (list 'var (uid/>symbol resolved)) resolved (t/value resolved)) + (err! "Could not resolve var from symbol" {:symbol arg-form})))) + (defn- filter-dynamic-dispatchable-overloads "An example of dynamic dispatch: - When we call `seq` on an input of type `(t/? (t/isa? java.util.Set))`, direct dispatch will @@ -621,16 +632,16 @@ (if (not (empty? extra-args-form)) (err! "Incorrect number of args passed to dependent type call" {:form form :args-ct (-> extra-args-form count inc)}) - (let [node (analyze* opts env arg-form) + (let [arg-node (analyze* opts env arg-form) caller|node (analyze* opts env caller|form)] (uast/call-node {:env env ;; We replace the `form` with the form of the arg type :unanalyzed-form form - :form (-> node :type uform/>form) + :form (-> arg-node :type uform/>form) :caller caller|node - :args [arg-form] - :type (:type node)})))) + :args [arg-node] + :type (:type arg-node)})))) ;; TODO break this fn up. It's "clean" but just not broken up (defns- analyze-seq* @@ -648,6 +659,7 @@ quote (analyze-seq|quote opts env form) new (analyze-seq|new opts env form) throw (analyze-seq|throw opts env form) + var (analyze-seq|var opts env form) (if-let [caller-form-dependent-type-call? (and (:arglist-context? opts) (case caller|form @@ -725,31 +737,34 @@ :expanded expanded :type (:type expanded)}))))) -(defns ?resolve-with-env [opts ::opts, env ::env, sym symbol?] +(defns- ?resolve [opts ::opts, env ::env, sym symbol?] (if-let [[_ local] (find env sym)] - {:value local} + {:resolved local :resolved-via :env} (let [resolved (ns-resolve *ns* sym)] (ifs resolved - {:value resolved} - (some-> sym namespace symbol resolve class?) - {:value (analyze-seq|dot - opts env (list '. (-> sym namespace symbol) (-> sym name symbol)))} + {:resolved resolved :resolved-via :var} + (some->> sym namespace symbol (ns-resolve *ns*) class?) + {:resolved (analyze-seq|dot + opts env (list '. (-> sym namespace symbol) (-> sym name symbol))) + :resolved-via :dot} nil)))) -(defns- analyze-symbol [opts ::opts, env ::env, form symbol? > uast/symbol?] - (if-not-let [{resolved :value} (?resolve-with-env opts env form)] +(defns- analyze-symbol + "Analyzes vars as if their value is constant, unless they're marked as dynamic." + [opts ::opts, env ::env, form symbol? > uast/symbol?] + (if-not-let [{:keys [resolved resolved-via]} (?resolve opts env form)] (err! "Could not resolve symbol" {:sym form}) - (uast/symbol env form resolved - (ifs (uast/node? resolved) - (:type resolved) - (or (t/literal? resolved) (class? resolved)) - (t/value resolved) - (var? resolved) - (or (-> resolved meta :quantum.core.type/type) (t/value @resolved)) - (uvar/unbound? resolved) - ;; Because the var could be anything and cannot have metadata (type or otherwise) - t/any? - (TODO "Unsure of what to do in this case" (kw-map env form resolved)))))) + (let [node (case resolved-via + (:env :dot) resolved + :var (let [form (list 'var (uid/>symbol resolved))] + (if (uvar/dynamic? resolved) + (uast/var* env form resolved (t/value resolved)) + (let [v (var-get resolved)] + (uast/var-value env form v + (or (-> resolved meta :quantum.core.type/type) (t/value v)))))))] + (if (uast/symbol? node) + (assoc node :env env) + (uast/symbol env form node (:type node)))))) (defns- analyze* [opts ::opts, env ::env, form _ > uast/node?] (when (> (swap! *analyze-depth inc) 200) (throw (ex-info "Stack too deep" {:form form}))) From 228f3605911608ca47023e1a256ba458972747d5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 3 Oct 2018 00:38:39 -0600 Subject: [PATCH 397/810] Add `ast/std-print-structure` --- .../quantum/untyped/core/analyze/ast.cljc | 35 +++++++++++-------- 1 file changed, 20 insertions(+), 15 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 839a3247..06e7d61a 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -14,6 +14,11 @@ (ucore/log-this-ns) +(def ^:dynamic *print-env?* true) + +(defn std-print-structure [record] + (cond-> (into (array-map) record) (not *print-env?*) (dissoc :env))) + (defn >type-hint "Applied on every `form` of every AST node created in order to avoid reflection wherever possible." @@ -62,7 +67,7 @@ INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `unbound form {:minimum minimum-type :deduced type}))) + (-edn [this] (list `unbound (std-print-structure this)))) (defn unbound ([form t] (unbound nil form t)) @@ -77,7 +82,7 @@ INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `literal form type))) + (-edn [this] (list `literal (std-print-structure this)))) (defn literal ([form t] (literal nil form t)) @@ -98,7 +103,7 @@ INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `var-value form type))) + (-edn [this] (list `var-value (std-print-structure this)))) (defn var-value ([form v t] (var-value nil form v t)) @@ -116,7 +121,7 @@ INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `var* form type))) + (-edn [this] (list `var* (std-print-structure this)))) (defn var* ([form value t] (var* nil form value t)) @@ -132,7 +137,7 @@ INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `symbol (into (array-map) this)))) + (-edn [this] (list `symbol (std-print-structure this)))) (defn symbol ([form node t] (symbol nil form node t)) @@ -147,7 +152,7 @@ INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `quoted form type))) + (-edn [this] (list `quoted (std-print-structure this)))) (defn quoted ([form t] (quoted nil form t)) @@ -165,7 +170,7 @@ INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `let* (into (array-map) this)))) + (-edn [this] (list `let* (std-print-structure this)))) (defn let* [m] (-> m map->Let* with-type-hint)) @@ -180,7 +185,7 @@ INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `do (into (array-map) this)))) + (-edn [this] (list `do (std-print-structure this)))) (defn do [m] (-> m map->Do with-type-hint)) @@ -196,7 +201,7 @@ INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `macro-call (into (array-map) this)))) + (-edn [this] (list `macro-call (std-print-structure this)))) (defn macro-call [m] (-> m map->MacroCall with-type-hint)) @@ -213,7 +218,7 @@ INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `if-node (into (array-map) this)))) + (-edn [this] (list `if-node (std-print-structure this)))) (defn if-node [m] (-> m map->IfNode with-type-hint)) @@ -230,7 +235,7 @@ INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `field-access (into (array-map) this)))) + (-edn [this] (list `field-access (std-print-structure this)))) ;; Not type hinted because it's inferred (defn field-access [m] (map->FieldAccess m)) @@ -248,7 +253,7 @@ INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `method-call (into (array-map) this)))) + (-edn [this] (list `method-call (std-print-structure this)))) ;; Not type hinted because it's inferred (defn method-call [m] (map->MethodCall m)) @@ -265,7 +270,7 @@ INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `call-node (into (array-map) this)))) + (-edn [this] (list `call-node (std-print-structure this)))) (defn call-node [m] (-> m map->CallNode with-type-hint)) @@ -281,7 +286,7 @@ INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `new-node (into (array-map) this)))) + (-edn [this] (list `new-node (std-print-structure this)))) ;; Not type hinted because it's inferred (defn new-node [m] (map->NewNode m)) @@ -297,7 +302,7 @@ INode fipp.ednize/IOverride fipp.ednize/IEdn - (-edn [this] (list `throw-node (into (array-map) this)))) + (-edn [this] (list `throw-node (std-print-structure this)))) ;; Not type hinted because there's no point (defn throw-node [m] (map->ThrowNode m)) From a71871c81b4b352e57c19f5462eadaac2dd22a42 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 3 Oct 2018 00:38:56 -0600 Subject: [PATCH 398/810] Create and use `uvar/resolve` --- src-untyped/quantum/untyped/core/analyze.cljc | 13 +++--- src-untyped/quantum/untyped/core/vars.cljc | 44 ++++++++++++++++++- src/quantum/core/vars.cljc | 2 +- 3 files changed, 51 insertions(+), 8 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 98534dd5..ecdd6783 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -527,9 +527,12 @@ (err! "Must supply exactly one input to `var`" {:form form}) (not (symbol? arg-form)) (err! "`var` accepts a symbol argument" {:form form}) - (if-let [resolved (ns-resolve *ns* arg-form)] - (uast/var* env (list 'var (uid/>symbol resolved)) resolved (t/value resolved)) - (err! "Could not resolve var from symbol" {:symbol arg-form})))) + (let [resolved (uvar/resolve *ns* arg-form)] + (ifs (nil? resolved) + (err! "Could not resolve var from symbol" {:symbol arg-form}) + (not (var? resolved)) + (err! "Expected var, but found" {:form form :resolved resolved}) + (uast/var* env (list 'var (uid/>symbol resolved)) resolved (t/value resolved)))))) (defn- filter-dynamic-dispatchable-overloads "An example of dynamic dispatch: @@ -740,10 +743,10 @@ (defns- ?resolve [opts ::opts, env ::env, sym symbol?] (if-let [[_ local] (find env sym)] {:resolved local :resolved-via :env} - (let [resolved (ns-resolve *ns* sym)] + (let [resolved (uvar/resolve *ns* sym)] (ifs resolved {:resolved resolved :resolved-via :var} - (some->> sym namespace symbol (ns-resolve *ns*) class?) + (some->> sym namespace symbol (uvar/resolve *ns*) class?) {:resolved (analyze-seq|dot opts env (list '. (-> sym namespace symbol) (-> sym name symbol))) :resolved-via :dot} diff --git a/src-untyped/quantum/untyped/core/vars.cljc b/src-untyped/quantum/untyped/core/vars.cljc index 0423e4a5..37fa2b52 100644 --- a/src-untyped/quantum/untyped/core/vars.cljc +++ b/src-untyped/quantum/untyped/core/vars.cljc @@ -1,8 +1,11 @@ (ns quantum.untyped.core.vars - (:refer-clojure :exclude [defonce]) + (:refer-clojure :exclude + [defonce resolve]) (:require [clojure.core :as core] [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.logic + :refer [ifs]] [quantum.untyped.core.form.evaluate :refer [case-env case-env*]] [quantum.untyped.core.form.generate :as ufgen]) @@ -82,7 +85,6 @@ (throw (IllegalArgumentException. (str "Macro '" '~name "' not defined."))))] (cons ~orig-sym-f ~args-sym))))))) - #?(:clj (defmacro def "Like `clojure.core/def`, but allows for docstring and metadata placement @@ -94,3 +96,41 @@ `(quantum.untyped.core.vars/def ~sym ~doc-or-meta nil ~v) `(quantum.untyped.core.vars/def ~sym nil ~doc-or-meta ~v))) ([sym -doc -meta v] `(~'def ~(with-meta sym (assoc -meta :doc -doc)) ~v)))) + +;; ===== Symbol Resolution ===== ;; + +(defn resolve-ns + "Resolves the namespace of a symbol, checking in aliases first. + Totally distinct from `core/ns-resolve`." + {:incorporated {'clojure.lang.Compiler/namespaceFor "10/3/2018"}} + ([sym] (resolve-ns *ns* sym)) + ([ns-val #_namespace?, sym] + (let [ns-sym (-> sym namespace symbol)] + (or (.lookupAlias ^clojure.lang.Namespace ns-val ns-sym) + (find-ns ns-sym))))) + +(defn resolve + "Combines `core/resolve` with `core/ns-resolve` and does not throw an exception when a class can't + be resolved." + {:incorporated {'clojure.core/resolve "10/3/2018" + 'clojure.core/ns-resolve "10/3/2018" + 'clojure.lang.Compiler/maybeResolveIn "10/3/2018"}} + ([sym] (resolve *ns* sym)) + ([ns-val #_namespace?, sym] (resolve ns-val nil sym)) + ([ns-val #_namespace?, env #_map?, sym] + (if (contains? env sym) + (get env sym) + (if (some? (namespace sym)) + (when-let [sym-ns-val (resolve-ns sym)] + (.findInternedVar ^clojure.lang.Namespace sym-ns-val (-> sym name symbol))) + (let [^String sym-name (name sym)] + (ifs (or (and (pos? (.indexOf sym-name ".")) + (not (.endsWith sym-name "."))) + (= (.charAt sym-name 0) \[)) + (try (clojure.lang.RT/classForName sym-name) + (catch ClassNotFoundException _ nil)) + (= sym 'ns) + #'core/ns + (= sym 'in-ns) + #'core/in-ns + (.getMapping ^clojure.lang.Namespace ns-val sym))))))) diff --git a/src/quantum/core/vars.cljc b/src/quantum/core/vars.cljc index b8c9d4b9..c4f1b313 100644 --- a/src/quantum/core/vars.cljc +++ b/src/quantum/core/vars.cljc @@ -282,4 +282,4 @@ #?(:clj (defaliases uns ns>alias ns-name>alias clear-ns-interns! search-var ns-exclude with-ns with-temp-ns import-static - load-ns load-nss loaded-libs load-lib! load-package! load-dep! assert-ns-aliased)) + load-ns load-nss loaded-libs load-lib! load-package! load-dep! assert-ns-aliased ?resolve)) From 66b58c40abb17598b6937a4b68ad058a4e2ab29f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 3 Oct 2018 00:39:17 -0600 Subject: [PATCH 399/810] Update test --- test/quantum/test/untyped/core/analyze.cljc | 7 ++----- test/quantum/test/untyped/core/type/defnt.cljc | 6 +++--- 2 files changed, 5 insertions(+), 8 deletions(-) diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index 50565537..1019225f 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -16,10 +16,7 @@ (get-in ana [:env 'x :type])))) (testing "Nested within another type" (testing "Without arg shadowing" - (let [ana (self/analyze-arg-syms {'x `tt/boolean?} `(t/or t/number? (t/type ~x)))] + (let [ana (quantum.untyped.core.print/ppr + (self/analyze-arg-syms {'x `tt/boolean?} `(t/or tt/byte? (t/type ~'x))))] (is= t/boolean? (get-in ana [:env 'x :type]))))))) - - -(quantum.untyped.core.print/ppr - ) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index aec0b150..6d25ccda 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1368,11 +1368,11 @@ (self/defn dependent-type-nest #_"1. Analyze `x` = `tt/boolean?` -> Put `x` in env as `(t/isa? Boolean)` - 2. Analyze out-type = `(t/or t/number? (t/type x))` + 2. Analyze out-type = `(t/or t/byte? (t/type x))` 1. Analyze `(t/type x)` -> `(t/isa? Boolean)` - -> `(t/or (t/isa? Number) (t/isa? Boolean))`" - ([x tt/boolean? > (t/or t/number? (t/type x))] (if x x 1))) + -> `(t/or (t/isa? Byte) (t/isa? Boolean))`" + ([x tt/boolean? > (t/or t/byte? (t/type x))] (if x x 1))) expected (case (env-lang) :clj From b50ec2584b78a628abbcd3eb806949e13c0cce19 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 3 Oct 2018 01:05:25 -0600 Subject: [PATCH 400/810] Dep type tests are actually beginning to almost work! --- resources-dev/defnt.cljc | 7 ++++++- .../quantum/untyped/core/analyze/ast.cljc | 2 +- test/quantum/test/untyped/core/analyze.cljc | 18 +++++++++++------- 3 files changed, 18 insertions(+), 9 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 7998dff3..23c9fed2 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -60,7 +60,12 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: [1 .] t/type - - dependent types: `[x arr/array? > (t/type x)]` + - [ ] Make sure that (t/type t/boolean?) is not (t/value t/boolean?) but rather t/boolean?. + We need to 'un-`t/value`' it somehow? + - [ ] We need to ensure that operators are recognized as such. `t/or` should not return + `t/any?` but rather the `t/or` of its arguments. In fact maybe we should add the + `::t/type` metadata to it after the fact? Somehow it needs to be recognized that it's + not a `t/defn` despite this though. [2] t/value-of - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` [3] - t/input-type diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 06e7d61a..1616abb9 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -14,7 +14,7 @@ (ucore/log-this-ns) -(def ^:dynamic *print-env?* true) +(def ^:dynamic ^{:doc "Controls whether `:env` is printed on AST nodes."} *print-env?* true) (defn std-print-structure [record] (cond-> (into (array-map) record) (not *print-env?*) (dissoc :env))) diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index 1019225f..cf6de2a9 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -1,10 +1,11 @@ (ns quantum.test.untyped.core.analyze (:require - [quantum.test.untyped.core.type :as tt] - [quantum.untyped.core.analyze :as self] + [quantum.test.untyped.core.type :as tt] + [quantum.untyped.core.analyze :as self] + [quantum.untyped.core.analyze.ast :as uast] [quantum.untyped.core.test :refer [deftest is is= testing]] - [quantum.untyped.core.type :as t])) + [quantum.untyped.core.type :as t])) ;; More dependent type tests in `quantum.test.untyped.core.type.defnt` but those are more like ;; integration tests @@ -13,10 +14,13 @@ (testing "Not nested within another type" (let [ana (self/analyze-arg-syms {} {} {'x `tt/boolean?} `(t/type ~'x))] (is= t/boolean? - (get-in ana [:env 'x :type])))) + (get-in ana [:env 'x :type])) + (is= t/boolean? + (get-in ana [:out-type-node :type])))) (testing "Nested within another type" (testing "Without arg shadowing" - (let [ana (quantum.untyped.core.print/ppr - (self/analyze-arg-syms {'x `tt/boolean?} `(t/or tt/byte? (t/type ~'x))))] + (let [ana (self/analyze-arg-syms {'x `tt/boolean?} `(t/or tt/byte? (t/type ~'x)))] (is= t/boolean? - (get-in ana [:env 'x :type]))))))) + (get-in ana [:env 'x :type])) + (is= (t/or tt/byte? tt/boolean?) + (get-in ana [:out-type-node :type]))))))) From a64e1e26516026db640f925e27a3b5cff6d7d7b0 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 3 Oct 2018 02:20:55 -0600 Subject: [PATCH 401/810] Updated todo --- resources-dev/defnt.cljc | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 23c9fed2..dfe6f607 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -60,12 +60,11 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: [1 .] t/type - - [ ] Make sure that (t/type t/boolean?) is not (t/value t/boolean?) but rather t/boolean?. + - [x] Make sure that (t/type t/boolean?) is not (t/value t/boolean?) but rather t/boolean?. We need to 'un-`t/value`' it somehow? - - [ ] We need to ensure that operators are recognized as such. `t/or` should not return - `t/any?` but rather the `t/or` of its arguments. In fact maybe we should add the - `::t/type` metadata to it after the fact? Somehow it needs to be recognized that it's - not a `t/defn` despite this though. + - [.] We need to ensure that operators are recognized as such. `t/or` should not return + `t/any?` but rather the `t/or` of its arguments. In fact maybe it would work if we + added the `::t/type` metadata to it after the fact. [2] t/value-of - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` [3] - t/input-type From f1430da0f421a880ad91bf41866cd378949fb7eb Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 3 Oct 2018 02:21:24 -0600 Subject: [PATCH 402/810] Add `ast/class-value` --- src-untyped/quantum/untyped/core/analyze.cljc | 57 +++++++++++++------ .../quantum/untyped/core/analyze/ast.cljc | 16 ++++++ 2 files changed, 55 insertions(+), 18 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index ecdd6783..9b77fab9 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -630,6 +630,12 @@ (get inputs-ct)))}))) :dispatchable-overloads-seq)) +(defn- dependent-type-call-node? [x] + (and (uast/call-node? x) + (case (-> x :unanalyzed-form first) + (quantum.core.type/type quantum.untyped.core.type/type) true + false))) + (defns- analyze-dependent-type-call [opts ::opts, env ::env, [caller|form _, arg-form _ & extra-args-form _ :as form] _ > uast/node?] (if (not (empty? extra-args-form)) @@ -745,7 +751,7 @@ {:resolved local :resolved-via :env} (let [resolved (uvar/resolve *ns* sym)] (ifs resolved - {:resolved resolved :resolved-via :var} + {:resolved resolved :resolved-via :resolve} (some->> sym namespace symbol (uvar/resolve *ns*) class?) {:resolved (analyze-seq|dot opts env (list '. (-> sym namespace symbol) (-> sym name symbol))) @@ -759,12 +765,15 @@ (err! "Could not resolve symbol" {:sym form}) (let [node (case resolved-via (:env :dot) resolved - :var (let [form (list 'var (uid/>symbol resolved))] - (if (uvar/dynamic? resolved) - (uast/var* env form resolved (t/value resolved)) - (let [v (var-get resolved)] - (uast/var-value env form v - (or (-> resolved meta :quantum.core.type/type) (t/value v)))))))] + :resolve + (if (var? resolved) + (let [form (list 'var (uid/>symbol resolved))] + (if (uvar/dynamic? resolved) + (uast/var* env form resolved (t/value resolved)) + (let [v (var-get resolved)] + (uast/var-value env form v + (or (-> resolved meta :quantum.core.type/type) (t/value v)))))) + (uast/class-value env (uid/>symbol resolved) resolved)))] (if (uast/symbol? node) (assoc node :env env) (uast/symbol env form node (:type node)))))) @@ -820,6 +829,9 @@ (def analyze-arg-syms|max-iter 100) +(defns- unvalue-node [node uast/node? > uast/node?] + (cond-> node (not (dependent-type-call-node? node)) (update :type t/unvalue))) + (defns analyze-arg-syms ([arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _] (analyze-arg-syms {} {} arg-sym->arg-type-form out-type-form)) @@ -831,23 +843,32 @@ arglist-syms|queue #{} arglist-syms|unanalyzed (-> arg-sym->arg-type-form keys set) n|iter 0] - (println "env" env - "arglist-syms|queue" arglist-syms|queue - "arglist-syms|unanalyzed" arglist-syms|unanalyzed - "n|iter" n|iter) + (binding [quantum.untyped.core.analyze.ast/*print-env?* false + quantum.untyped.core.print/*collapse-symbols?* true] + (quantum.untyped.core.print/ppr + (kw-map env arglist-syms|queue arglist-syms|unanalyzed n|iter))) (ifs (empty? arglist-syms|unanalyzed) - (let [out-type-analyzed (analyze opts' env out-type-form)] - {:env env :out-type-node out-type-analyzed}) + (let [out-type-node (unvalue-node (analyze opts' env out-type-form)) + ret {:env env :out-type-node out-type-node}] + (binding [quantum.untyped.core.analyze.ast/*print-env?* false + quantum.untyped.core.print/*collapse-symbols?* true] + (quantum.untyped.core.print/ppr ret)) + (assoc ret + :arg-sym->arg-type (->> env (c/map-vals' :type)) + :out-type (:type out-type-node))) (>= n|iter analyze-arg-syms|max-iter) (err! "Max number of iterations reached for `analyze-arg-syms" {:n n|iter}) (let [arg-sym (first arglist-syms|unanalyzed) arg-type-form (arg-sym->arg-type-form arg-sym) - analyzed (analyze (assoc opts' - :arglist-syms|queue arglist-syms|queue - :arglist-syms|unanalyzed arglist-syms|unanalyzed) - env arg-type-form) + analyzed (-> (analyze (assoc opts' + :arglist-syms|queue arglist-syms|queue + :arglist-syms|unanalyzed arglist-syms|unanalyzed) + env arg-type-form) + unvalue-node) env' (assoc (:env analyzed) arg-sym analyzed)] - (quantum.untyped.core.print/ppr analyzed) + (binding [quantum.untyped.core.analyze.ast/*print-env?* false + quantum.untyped.core.print/*collapse-symbols?* true] + (quantum.untyped.core.print/ppr {:analyzed analyzed})) (recur env' (:arglist-syms|queue analyzed) (:arglist-syms|unanalyzed analyzed) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 1616abb9..f35e0c56 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -90,6 +90,22 @@ (defn literal? [x] (instance? Literal x)) +(defrecord ClassValue + [env #_::env + form #_simple-symbol? + value #_t/class? + type #_(t/value value)] + INode + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (list `class-value (std-print-structure this)))) + +(defn class-value + ([form v] (class-value nil form v)) + ([env form v] (ClassValue. env form v (t/value v)))) + +(defn class-value? [x] (instance? ClassValue x)) + (defrecord ^{:doc "AST node generated from the value of a non-dynamic var. The `type` may not always be `(t/value value)` because in the case of e.g. `t/defn`s, From ffa84db2e7e93ff0d7bb2fd29020d1f9ecdb8bd3 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 3 Oct 2018 02:22:07 -0600 Subject: [PATCH 403/810] `t/unvalue` makes dep types work; also `t/fnt?` enhancement --- src-untyped/quantum/untyped/core/type.cljc | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index de234094..98da6ae6 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -167,6 +167,12 @@ "Creates a type whose extension is the singleton set containing only the value `v`." [v _] (ValueType. uhash/default uhash/default nil v)) +(defns unvalue + [t utr/type?] + (ifs (utr/value-type? t) (utr/value-type>value t) + (c/= t universal-set) t + (err! "Don't know how to handle `unvalue` for type" {:t t}))) + ;; ----- `isa?` / Class-Inheritance ----- ;; (defn isa? [x] @@ -458,8 +464,8 @@ ;; ===== Dependent types ===== ;; (defns type - "Treated specially by the type analyzer when used within the type declaration of a function input. - For runtime use, just defaults to `(t/value x)`." + "When used within the type declaration of a function input, returns the compile-time type of `x`. + For all other cases, returns `(t/value x)` at runtime." [x _ > type?] (value x)) ;; TODO figure this out @@ -653,7 +659,7 @@ (isa?|direct #?(:clj clojure.lang.IFn :cljs cljs.core/IFn))) ;; Used by `quantum.untyped.core.analyze` via `t/callable?` -(def fnt? (and fn? (>expr (fn-> c/meta ::type)))) +(def fnt? (and fn? (>expr (fn-> c/meta ::type utr/fn-type?)))) ;; TODO should we allow java.lang.Runnable, java.util.concurrent.Callable, and other ;; functional interfaces to be `callable?`? From 00b02dfe0bd22bdd2e095b1e26c71892c315b811 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 3 Oct 2018 02:22:19 -0600 Subject: [PATCH 404/810] Continue in tests --- test/quantum/test/untyped/core/analyze.cljc | 49 +++++++++++++++++-- .../quantum/test/untyped/core/type/defnt.cljc | 20 -------- 2 files changed, 44 insertions(+), 25 deletions(-) diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index cf6de2a9..fe17a492 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -7,20 +7,59 @@ :refer [deftest is is= testing]] [quantum.untyped.core.type :as t])) +(self/analyze-arg-syms {'x `tt/boolean?} `(t/type ~'x)) +(self/analyze-arg-syms {'x `tt/boolean?} `tt/byte) +(self/analyze-arg-syms {'x `tt/boolean?} `(tt/value tt/byte)) +(self/analyze-arg-syms {'x `tt/boolean?} `(t/isa? Byte)) + +(defn fake-typed-defn + {:quantum.core.type/type (t/ftype nil [t/string? :> tt/long?])} + []) + ;; More dependent type tests in `quantum.test.untyped.core.type.defnt` but those are more like ;; integration tests (deftest dependent-type-test (testing "Output type dependent on non-splittable input" (testing "Not nested within another type" - (let [ana (self/analyze-arg-syms {} {} {'x `tt/boolean?} `(t/type ~'x))] + #_"1. Analyze `x` = `tt/boolean?` + -> Put `x` in env as `(t/isa? Boolean)` + 2. Analyze out-type = `(t/type x)` + -> `(t/isa? Boolean)`" + (let [ana (self/analyze-arg-syms {'x `tt/boolean?} `(t/type ~'x))] (is= t/boolean? - (get-in ana [:env 'x :type])) + (get-in ana [:arg-sym->arg-type 'x])) (is= t/boolean? - (get-in ana [:out-type-node :type])))) + (get-in ana [:out-type])))) (testing "Nested within another type" (testing "Without arg shadowing" + #_"1. Analyze `x` = `tt/boolean?` + -> Put `x` in env as `(t/isa? Boolean)` + 2. Analyze out-type = `(t/or t/byte? (t/type x))` + 1. Analyze `(t/type x)` + -> `(t/isa? Boolean)` + -> `(t/or (t/isa? Byte) (t/isa? Boolean))`" (let [ana (self/analyze-arg-syms {'x `tt/boolean?} `(t/or tt/byte? (t/type ~'x)))] (is= t/boolean? - (get-in ana [:env 'x :type])) + (get-in ana [:arg-sym->arg-type 'x])) + (is= (t/or tt/byte? tt/boolean?) + (get-in ana [:out-type])))) + (testing "With arg shadowing" + #_"1. Analyze `x` = `tt/boolean?` + -> Put `x` in env as `(t/isa? Boolean)` + 2. Analyze out-type = `(let [x (>long-checked \"123\")] + (t/or t/number? (t/type x)))` + 1. Analyze `(>long-checked \"123\")` + -> Put `x` in env as `(t/isa? Long)` + 2. Analyze `(t/or t/number? (t/type x))` + 1. Analyze `(t/type x)` + -> `(t/isa? Long)` + -> `(t/or (t/isa? Number) (t/isa? Long)) + -> (t/isa? Number)`" + (let [ana (self/analyze-arg-syms + {'x `tt/boolean?} + `(let [~'x (fake-typed-defn "123")] + (t/or (t/isa? Number) (t/type ~'x))))] + (is= t/boolean? + (get-in ana [:arg-sym->arg-type 'x])) (is= (t/or tt/byte? tt/boolean?) - (get-in ana [:out-type-node :type]))))))) + (get-in ana [:out-type]))))))) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 6d25ccda..d5f2c6a4 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1348,10 +1348,6 @@ (let [actual (macroexpand ' (self/defn dependent-type - #_"1. Analyze `x` = `tt/boolean?` - -> Put `x` in env as `(t/isa? Boolean)` - 2. Analyze out-type = `(t/type x)` - -> `(t/isa? Boolean)`" ([x tt/boolean? > (t/type x)] x)) expected (case (env-lang) @@ -1366,12 +1362,6 @@ (let [actual (macroexpand ' (self/defn dependent-type-nest - #_"1. Analyze `x` = `tt/boolean?` - -> Put `x` in env as `(t/isa? Boolean)` - 2. Analyze out-type = `(t/or t/byte? (t/type x))` - 1. Analyze `(t/type x)` - -> `(t/isa? Boolean)` - -> `(t/or (t/isa? Byte) (t/isa? Boolean))`" ([x tt/boolean? > (t/or t/byte? (t/type x))] (if x x 1))) expected (case (env-lang) @@ -1385,16 +1375,6 @@ (let [actual (macroexpand ' (self/defn dependent-type-nest-shadow - #_"1. Analyze `x` = `tt/boolean?` - -> Put `x` in env as `(t/isa? Boolean)` - 2. Analyze out-type = `(let [x (>long-checked \"123\")] - (t/or t/number? (t/type x)))` - 1. Analyze `(>long-checked \"123\")` - -> Put `x` in env as `(t/isa? Long)` - 2. Analyze `(t/or t/number? (t/type x))` - 1. Analyze `(t/type x)` - -> `(t/isa? Long)` - -> `(t/or (t/isa? Number) (t/isa? Long))`" ([x tt/boolean? > (let [x (>long-checked "123")] (t/or t/number? (t/type x)))] (if x x 1))) expected From 71a15d0631a456b4a365ede55bfcfdd40975ac7f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 00:30:05 -0600 Subject: [PATCH 405/810] Add in off-heap and int map benchmarks --- benchmarks/jvm.clj | 389 +++++++++++++++++-------------- doc/cljc/quantum/_performance.md | 1 + 2 files changed, 213 insertions(+), 177 deletions(-) diff --git a/benchmarks/jvm.clj b/benchmarks/jvm.clj index 3e598e4d..55006db5 100644 --- a/benchmarks/jvm.clj +++ b/benchmarks/jvm.clj @@ -1,20 +1,20 @@ (ns quantum.test.benchmarks.jvm (:require - [quantum.core.macros.defnt + [criterium.core + :refer [bench quick-bench]] + #_[quantum.core.macros.defnt :refer [defnt defnt' defntp]] - [quantum.core.collections :as coll - :refer [reduce-pair]] - [quantum.core.meta.bench - :refer [bench complete-bench]] [quantum.untyped.core.form.type-hint - :refer [static-cast]]) + :refer [static-cast]] + [quantum.untyped.core.reducers + :refer [reduce-pair]]) (:import [quantum.core Numeric Fn] [quantum.core.data Array] [clojure.lang BigInt] + [it.unimi.dsi.fastutil.ints Int2ObjectOpenHashMap] [java.util Map HashMap IdentityHashMap] - [java.lang.invoke MethodHandle MethodHandles MethodType] - #_[cern.colt.map OpenIntObjectHashMap])) + [java.lang.invoke MethodHandle MethodHandles MethodType])) ; TODO try to use static methods instead of `invokevirtual` on the `reify`? @@ -283,123 +283,66 @@ ~(compile-hash Double) (+*-static (double x#) (double y#)))))) ; ===== LOOKUP MAP, IMMUTABLE ===== ; +;; Could have done something like `(reify Primitive (invoke [^whatever0 x ^whatever1 y] ...))` but +;; then when we went to call the retrieved fn we wouldn't know what input classes to call it with (defn gen-dispatch-map [create-map] (create-map Byte (create-map - Byte (fn [x y] (+*-static (byte x) (byte y))) - Character (fn [x y] (+*-static (byte x) (char y))) - Short (fn [x y] (+*-static (byte x) (short y))) - Integer (fn [x y] (+*-static (byte x) (int y))) - Long (fn [x y] (+*-static (byte x) (long y))) - Float (fn [x y] (+*-static (byte x) (float y))) - Double (fn [x y] (+*-static (byte x) (double y)))) + Byte (fn [x y] (Numeric/add (unchecked-byte x) (unchecked-byte y))) + Character (fn [x y] (Numeric/add (unchecked-byte x) (unchecked-char y))) + Short (fn [x y] (Numeric/add (unchecked-byte x) (unchecked-short y))) + Integer (fn [x y] (Numeric/add (unchecked-byte x) (unchecked-int y))) + Long (fn [x y] (Numeric/add (unchecked-byte x) (unchecked-long y))) + Float (fn [x y] (Numeric/add (unchecked-byte x) (unchecked-float y))) + Double (fn [x y] (Numeric/add (unchecked-byte x) (unchecked-double y)))) Character (create-map - Byte (fn [x y] (+*-static (char x) (byte y))) - Character (fn [x y] (+*-static (char x) (char y))) - Short (fn [x y] (+*-static (char x) (short y))) - Integer (fn [x y] (+*-static (char x) (int y))) - Long (fn [x y] (+*-static (char x) (long y))) - Float (fn [x y] (+*-static (char x) (float y))) - Double (fn [x y] (+*-static (char x) (double y)))) + Byte (fn [x y] (Numeric/add (unchecked-char x) (unchecked-byte y))) + Character (fn [x y] (Numeric/add (unchecked-char x) (unchecked-char y))) + Short (fn [x y] (Numeric/add (unchecked-char x) (unchecked-short y))) + Integer (fn [x y] (Numeric/add (unchecked-char x) (unchecked-int y))) + Long (fn [x y] (Numeric/add (unchecked-char x) (unchecked-long y))) + Float (fn [x y] (Numeric/add (unchecked-char x) (unchecked-float y))) + Double (fn [x y] (Numeric/add (unchecked-char x) (unchecked-double y)))) Short (create-map - Byte (fn [x y] (+*-static (short x) (byte y))) - Character (fn [x y] (+*-static (short x) (char y))) - Short (fn [x y] (+*-static (short x) (short y))) - Integer (fn [x y] (+*-static (short x) (int y))) - Long (fn [x y] (+*-static (short x) (long y))) - Float (fn [x y] (+*-static (short x) (float y))) - Double (fn [x y] (+*-static (short x) (double y)))) + Byte (fn [x y] (Numeric/add (unchecked-short x) (unchecked-byte y))) + Character (fn [x y] (Numeric/add (unchecked-short x) (unchecked-char y))) + Short (fn [x y] (Numeric/add (unchecked-short x) (unchecked-short y))) + Integer (fn [x y] (Numeric/add (unchecked-short x) (unchecked-int y))) + Long (fn [x y] (Numeric/add (unchecked-short x) (unchecked-long y))) + Float (fn [x y] (Numeric/add (unchecked-short x) (unchecked-float y))) + Double (fn [x y] (Numeric/add (unchecked-short x) (unchecked-double y)))) Integer (create-map - Byte (fn [x y] (+*-static (int x) (byte y))) - Character (fn [x y] (+*-static (int x) (char y))) - Short (fn [x y] (+*-static (int x) (short y))) - Integer (fn [x y] (+*-static (int x) (int y))) - Long (fn [x y] (+*-static (int x) (long y))) - Float (fn [x y] (+*-static (int x) (float y))) - Double (fn [x y] (+*-static (int x) (double y)))) + Byte (fn [x y] (Numeric/add (unchecked-int x) (unchecked-byte y))) + Character (fn [x y] (Numeric/add (unchecked-int x) (unchecked-char y))) + Short (fn [x y] (Numeric/add (unchecked-int x) (unchecked-short y))) + Integer (fn [x y] (Numeric/add (unchecked-int x) (unchecked-int y))) + Long (fn [x y] (Numeric/add (unchecked-int x) (unchecked-long y))) + Float (fn [x y] (Numeric/add (unchecked-int x) (unchecked-float y))) + Double (fn [x y] (Numeric/add (unchecked-int x) (unchecked-double y)))) Long (create-map - Byte (fn [x y] (+*-static (long x) (byte y))) - Character (fn [x y] (+*-static (long x) (char y))) - Short (fn [x y] (+*-static (long x) (short y))) - Integer (fn [x y] (+*-static (long x) (int y))) - Long (fn [x y] (+*-static (long x) (long y))) - Float (fn [x y] (+*-static (long x) (float y))) - Double (fn [x y] (+*-static (long x) (double y)))) + Byte (fn [x y] (Numeric/add (unchecked-long x) (unchecked-byte y))) + Character (fn [x y] (Numeric/add (unchecked-long x) (unchecked-char y))) + Short (fn [x y] (Numeric/add (unchecked-long x) (unchecked-short y))) + Integer (fn [x y] (Numeric/add (unchecked-long x) (unchecked-int y))) + Long (fn [x y] (Numeric/add (unchecked-long x) (unchecked-long y))) + Float (fn [x y] (Numeric/add (unchecked-long x) (unchecked-float y))) + Double (fn [x y] (Numeric/add (unchecked-long x) (unchecked-double y)))) Float (create-map - Byte (fn [x y] (+*-static (float x) (byte y))) - Character (fn [x y] (+*-static (float x) (char y))) - Short (fn [x y] (+*-static (float x) (short y))) - Integer (fn [x y] (+*-static (float x) (int y))) - Long (fn [x y] (+*-static (float x) (long y))) - Float (fn [x y] (+*-static (float x) (float y))) - Double (fn [x y] (+*-static (float x) (double y)))) + Byte (fn [x y] (Numeric/add (unchecked-float x) (unchecked-byte y))) + Character (fn [x y] (Numeric/add (unchecked-float x) (unchecked-char y))) + Short (fn [x y] (Numeric/add (unchecked-float x) (unchecked-short y))) + Integer (fn [x y] (Numeric/add (unchecked-float x) (unchecked-int y))) + Long (fn [x y] (Numeric/add (unchecked-float x) (unchecked-long y))) + Float (fn [x y] (Numeric/add (unchecked-float x) (unchecked-float y))) + Double (fn [x y] (Numeric/add (unchecked-float x) (unchecked-double y)))) Double (create-map - Byte (fn [x y] (+*-static (double x) (byte y))) - Character (fn [x y] (+*-static (double x) (char y))) - Short (fn [x y] (+*-static (double x) (short y))) - Integer (fn [x y] (+*-static (double x) (int y))) - Long (fn [x y] (+*-static (double x) (long y))) - Float (fn [x y] (+*-static (double x) (float y))) - Double (fn [x y] (+*-static (double x) (double y)))))) - -(defn gen-inlined-dispatch-map [create-map] - (create-map - Byte (create-map - Byte (fn [x y] (Numeric/add (byte x) (byte y))) - Character (fn [x y] (Numeric/add (byte x) (char y))) - Short (fn [x y] (Numeric/add (byte x) (short y))) - Integer (fn [x y] (Numeric/add (byte x) (int y))) - Long (fn [x y] (Numeric/add (byte x) (long y))) - Float (fn [x y] (Numeric/add (byte x) (float y))) - Double (fn [x y] (Numeric/add (byte x) (double y)))) - Character (create-map - Byte (fn [x y] (Numeric/add (char x) (byte y))) - Character (fn [x y] (Numeric/add (char x) (char y))) - Short (fn [x y] (Numeric/add (char x) (short y))) - Integer (fn [x y] (Numeric/add (char x) (int y))) - Long (fn [x y] (Numeric/add (char x) (long y))) - Float (fn [x y] (Numeric/add (char x) (float y))) - Double (fn [x y] (Numeric/add (char x) (double y)))) - Short (create-map - Byte (fn [x y] (Numeric/add (short x) (byte y))) - Character (fn [x y] (Numeric/add (short x) (char y))) - Short (fn [x y] (Numeric/add (short x) (short y))) - Integer (fn [x y] (Numeric/add (short x) (int y))) - Long (fn [x y] (Numeric/add (short x) (long y))) - Float (fn [x y] (Numeric/add (short x) (float y))) - Double (fn [x y] (Numeric/add (short x) (double y)))) - Integer (create-map - Byte (fn [x y] (Numeric/add (int x) (byte y))) - Character (fn [x y] (Numeric/add (int x) (char y))) - Short (fn [x y] (Numeric/add (int x) (short y))) - Integer (fn [x y] (Numeric/add (int x) (int y))) - Long (fn [x y] (Numeric/add (int x) (long y))) - Float (fn [x y] (Numeric/add (int x) (float y))) - Double (fn [x y] (Numeric/add (int x) (double y)))) - Long (create-map - Byte (fn [x y] (Numeric/add (long x) (byte y))) - Character (fn [x y] (Numeric/add (long x) (char y))) - Short (fn [x y] (Numeric/add (long x) (short y))) - Integer (fn [x y] (Numeric/add (long x) (int y))) - Long (fn [x y] (Numeric/add (long x) (long y))) - Float (fn [x y] (Numeric/add (long x) (float y))) - Double (fn [x y] (Numeric/add (long x) (double y)))) - Float (create-map - Byte (fn [x y] (Numeric/add (float x) (byte y))) - Character (fn [x y] (Numeric/add (float x) (char y))) - Short (fn [x y] (Numeric/add (float x) (short y))) - Integer (fn [x y] (Numeric/add (float x) (int y))) - Long (fn [x y] (Numeric/add (float x) (long y))) - Float (fn [x y] (Numeric/add (float x) (float y))) - Double (fn [x y] (Numeric/add (float x) (double y)))) - Double (create-map - Byte (fn [x y] (Numeric/add (double x) (byte y))) - Character (fn [x y] (Numeric/add (double x) (char y))) - Short (fn [x y] (Numeric/add (double x) (short y))) - Integer (fn [x y] (Numeric/add (double x) (int y))) - Long (fn [x y] (Numeric/add (double x) (long y))) - Float (fn [x y] (Numeric/add (double x) (float y))) - Double (fn [x y] (Numeric/add (double x) (double y)))))) + Byte (fn [x y] (Numeric/add (unchecked-double x) (unchecked-byte y))) + Character (fn [x y] (Numeric/add (unchecked-double x) (unchecked-char y))) + Short (fn [x y] (Numeric/add (unchecked-double x) (unchecked-short y))) + Integer (fn [x y] (Numeric/add (unchecked-double x) (unchecked-int y))) + Long (fn [x y] (Numeric/add (unchecked-double x) (unchecked-long y))) + Float (fn [x y] (Numeric/add (unchecked-double x) (unchecked-float y))) + Double (fn [x y] (Numeric/add (unchecked-double x) (unchecked-double y)))))) (def dispatch-map (gen-dispatch-map hash-map)) @@ -410,35 +353,53 @@ ; ===== LOOKUP MAP, MUTABLE ===== ; -(defn map!* [constructor & args] - (assert (-> args count even?)) - (reduce-pair (fn [ret k v] (.put ^Map ret k v) ret) (constructor) args)) +(defn map!* [constructor & kvs] + (assert (-> kvs count even?)) + (reduce-pair (fn [ret k v] (.put ^Map ret k v) ret) (constructor) kvs)) (def hash-map! (partial map!* #(HashMap.))) -(def ^HashMap dispatch-map-mutable (gen-dispatch-map hash-map!)) +(def ^HashMap !dispatch-map (gen-dispatch-map hash-map!)) -(defn dispatch-with-map-mutable [x y] - (let [f (some-> dispatch-map-mutable ^HashMap (.get (class x)) (.get (class y)))] - (assert (some? f)) - (f x y))) +(defn dispatch-with-!map [x y] + (if-some [a0 (.get !dispatch-map (clojure.lang.Util/classOf x))] + (if-some [a1 (.get ^HashMap a0 (clojure.lang.Util/classOf y))] + (.invoke ^clojure.lang.IFn a1 x y) + (throw (Exception. "Method not found"))) + (throw (Exception. "Method not found")))) ; ===== LOOKUP MAP, IDENTITY MUTABLE ===== ; (def identity-hash-map! (partial map!* #(IdentityHashMap.))) -(def ^IdentityHashMap dispatch-identity-map-mutable (gen-dispatch-map identity-hash-map!)) +(def ^IdentityHashMap !dispatch-identity-map (gen-dispatch-map identity-hash-map!)) -(defn dispatch-with-identity-map-mutable [x y] - (if-let [a0 (.get dispatch-identity-map-mutable (clojure.lang.Util/classOf x))] - (if-let [a1 (.get ^IdentityHashMap a0 (clojure.lang.Util/classOf y))] - (a1 x y) +(defn dispatch-with-!identity-map [x y] + (if-some [a0 (.get !dispatch-identity-map (clojure.lang.Util/classOf x))] + (if-some [a1 (.get ^IdentityHashMap a0 (clojure.lang.Util/classOf y))] + (.invoke ^clojure.lang.IFn a1 x y) (throw (Exception. "Method not found"))) (throw (Exception. "Method not found")))) ; ===== LOOKUP MAP, INT->OBJECT MUTABLE ===== ; -; Colt's OpenIntObjectHashMap doesn't help here +(defn >!int-map [& kvs] + (assert (-> kvs count even?)) + (reduce-pair + (fn [ret k v] (.put ^Int2ObjectOpenHashMap ret (System/identityHashCode k) v) ret) + (Int2ObjectOpenHashMap.) + kvs)) + +(def ^Int2ObjectOpenHashMap !dispatch-int-map (gen-dispatch-map >!int-map)) + +(defn dispatch-with-!int-map [x y] + (if-some [a0 (.get !dispatch-int-map + (-> x clojure.lang.Util/classOf System/identityHashCode))] + (if-some [a1 (.get ^Int2ObjectOpenHashMap a0 + (-> y clojure.lang.Util/classOf System/identityHashCode))] + (.invoke ^clojure.lang.IFn a1 x y) + (throw (Exception. "Method not found"))) + (throw (Exception. "Method not found")))) ; ===== CUSTOMIZED (CLOJURE NUMERICS) ===== ; @@ -456,11 +417,11 @@ (.unreflect Fn/fnLookup (.getMethod (class +*-static-reified) "_PLUS__STAR_Static"))) ; 13.650164 ns -(complete-bench (do (Fn/invoke method-double-double +*-static-reified 1.0 3.0) - #_(Fn/invoke method +*-static-reified 1 3 ))) +(bench (do (Fn/invoke method-double-double +*-static-reified 1.0 3.0) + #_(Fn/invoke method +*-static-reified 1 3 ))) -(complete-bench (do (Fn/invoke method +*-static-reified 1.0 3.0) - #_(Fn/invoke method +*-static-reified 1 3 ))) +(bench (do (Fn/invoke method +*-static-reified 1.0 3.0) + #_(Fn/invoke method +*-static-reified 1 3 ))) ; ===== BENCHMARKS ===== ; @@ -468,74 +429,78 @@ ; It's more fair to benchmark this way. ; Also, all benchmarks were run multiple times to ensure complete and utter JVM warmup. -; 4.911254 ns -(complete-bench (do (+ 1.0 3.0) - (+ 1 3 ))) +; 4.911254 ns (2.983740 ns new computer) +(bench (do (+ 1.0 3.0) + (+ 1 3 ))) ; Same time -(complete-bench (do (Numeric/add 1.0 3.0) - (Numeric/add 1 3 ))) +(bench (do (Numeric/add 1.0 3.0) + (Numeric/add 1 3 ))) ; 5.970614 ns ; May currently have slightly worse performance since it isn't inlined, and is an instance instead of a static method (let [^quantum.test.benchmarks.jvm._PLUS__STAR_StaticInterface +*-static-reified-direct @#'+*-static-reified] ; to get rid of var indirection, which can't be optimized away by the JVM because is marked as `volatile` - (complete-bench (do (. +*-static-reified-direct _PLUS__STAR_Static 1.0 3.0) + (bench (do (. +*-static-reified-direct _PLUS__STAR_Static 1.0 3.0) (. +*-static-reified-direct _PLUS__STAR_Static 1 3 )))) ; 6.361026 ns ; May currently have slightly worse performance since it isn't inlined, and is an instance instead of a static method -(complete-bench (do (+*-static 1.0 3.0) - (+*-static 1 3 ))) +(bench (do (+*-static 1.0 3.0) + (+*-static 1 3 ))) + +; 14.300336 ns new computer, 4.79x +(bench (do (dispatch-with-!int-map 1.0 3.0) + (dispatch-with-!int-map 1 3 ))) -; 22.369795 ns (4.55x) -(complete-bench (do (argtypes-unknown 1.0 3.0) - (argtypes-unknown 1 3 ))) +; 22.369795 ns (4.55x) (18.556532 ns new computer) +(bench (do (argtypes-unknown 1.0 3.0) + (argtypes-unknown 1 3 ))) ; 30.778042 ns (6.27x) (on first run is 23.467812 ns, 4.78x) -(complete-bench (do (Fn/dispatch2 dispatch-identity-map-mutable 1.0 3.0) - (Fn/dispatch2 dispatch-identity-map-mutable 1 3 ))) +(bench (do (Fn/dispatch2 !dispatch-identity-map 1.0 3.0) + (Fn/dispatch2 !dispatch-identity-map 1 3 ))) ; 34.343497 ns -#_(complete-bench (do (Fn/dispatch2 dispatch-map-mutable 1.0 3.0) - (Fn/dispatch2 dispatch-map-mutable 1 3 ))) +#_(bench (do (Fn/dispatch2 !dispatch-map 1.0 3.0) + (Fn/dispatch2 !dispatch-map 1 3 ))) ; 37.636059 ns (7.66x) -(complete-bench (do (case-hash-dispatch 1.0 3.0) - (case-hash-dispatch 1 3 ))) +(bench (do (case-hash-dispatch 1.0 3.0) + (case-hash-dispatch 1 3 ))) ; 38.843166 ns -(complete-bench (do (case-string-dispatch 1.0 3.0) - (case-string-dispatch 1 3 ))) +(bench (do (case-string-dispatch 1.0 3.0) + (case-string-dispatch 1 3 ))) ; 51.184897 ns (10.42x) (on first run is 33.707466 ns, 6.86x) -(complete-bench (do (+*-protocol-0 1.0 3.0) - (+*-protocol-0 1 3 ))) +(bench (do (+*-protocol-0 1.0 3.0) + (+*-protocol-0 1 3 ))) -; 40.611242 ns -(complete-bench (do (dispatch-with-identity-map-mutable 1.0 3.0) - (dispatch-with-identity-map-mutable 1 3 ))) +; 40.611242 ns (15.944187 ns new computer) +(bench (do (dispatch-with-!identity-map 1.0 3.0) + (dispatch-with-!identity-map 1 3 ))) -; 42.714549 ns -(complete-bench (do (dispatch-with-map-mutable 1.0 3.0) - (dispatch-with-map-mutable 1 3 ))) +; 42.714549 ns (19.076145 ns new computer) +(bench (do (dispatch-with-!map 1.0 3.0) + (dispatch-with-!map 1 3 ))) ; 48.844710 ns -(complete-bench (do (dispatch 1.0 3.0) - (dispatch 1 3 ))) +(bench (do (dispatch 1.0 3.0) + (dispatch 1 3 ))) ; 79.343540 ns -#_(complete-bench (do (dispatch-with-int->object-map-mutable 1.0 3.0) +#_(bench (do (dispatch-with-int->object-map-mutable 1.0 3.0) (dispatch-with-int->object-map-mutable 1 3 ))) ; 188.686935 ns -(complete-bench (.invokeWithArguments method (Array/newObjectArray +*-static-reified 1.0 3.0))) +(bench (.invokeWithArguments method (Array/newObjectArray +*-static-reified 1.0 3.0))) ; 212.066270 ns -(complete-bench (do (dispatch-with-map 1.0 3.0) - (dispatch-with-map 1 3 ))) +(bench (do (dispatch-with-map 1.0 3.0) + (dispatch-with-map 1 3 ))) ; Didn't even complete -(complete-bench +(bench (Fn/invoke (.findVirtual Fn/fnLookup (compile-time-class +*-static-boxed-reified) "_PLUS__STAR_StaticBoxed" @@ -564,37 +529,107 @@ ; 5.580126 ns (let [v [1 2 3 4 5]] - (complete-bench (.get v 3))) + (bench (.get v 3))) ; 7.644827 ns ; will be same as direct dispatch when inlined (let [v [1 2 3 4 5]] - (complete-bench (quantum.core.collections.core/get v 3))) + (bench (quantum.core.collections.core/get v 3))) ; 10.542661 ns (let [v [1 2 3 4 5]] - (complete-bench (clojure.core/get v 3))) + (bench (clojure.core/get v 3))) ; 10.686585 ns ; because it's on the fast track (let [v [1 2 3 4 5]] - (complete-bench (quantum.core.collections.core/get-protocol v 3))) + (bench (quantum.core.collections.core/get-protocol v 3))) ; 7.438636 ns (let [v (long-array [1 2 3 4 5])] - (complete-bench (clojure.core/aget v 3))) + (bench (clojure.core/aget v 3))) ; 7.649213 ns — statistically equivalent (let [v (long-array [1 2 3 4 5])] - (complete-bench (quantum.core.data.Array/get v 3))) + (bench (quantum.core.data.Array/get v 3))) ; 8.691139 ns (let [v (long-array [1 2 3 4 5])] - (complete-bench (quantum.core.collections.core/get v 3))) + (bench (quantum.core.collections.core/get v 3))) ; 15.832480 ns ; good performance, but not on the fast track (let [v (long-array [1 2 3 4 5])] - (complete-bench (quantum.core.collections.core/get-protocol v 3))) + (bench (quantum.core.collections.core/get-protocol v 3))) ; 53.855997 ns ; semi-reflection going on here (let [v (long-array [1 2 3 4 5])] - (complete-bench (clojure.core/get v 3))) + (bench (clojure.core/get v 3))) + +;; ================================================================================================= +;; Memory strategies: off-heap vs. on-heap +;; +;; Key takeaways: +;; - Perhaps in the small, there isn't much difference +;; - That said, off-heap allocation is an order of magnitude more expensive than on-heap +;; - The real advantages of off-heap are: +;; - Cache locality / memory contiguity +;; - GC-lessness and thus GC-pauselessness + +(def ^sun.misc.Unsafe unsafe + (-> (.getDeclaredField sun.misc.Unsafe "theUnsafe") + (doto (.setAccessible true)) + (.get nil))) + +;; allocating one byte of off-heap memory: avg 90.23 ns +;; NOTE: This benchmark will allocate a lot of memory that won't be reclaimed till process killed +;; In one case with 161031248 calls it allocated 161031248/1024/1024 -> 154 MB +(let [^sun.misc.Unsafe u unsafe] + (bench (do (.allocateMemory u 1) + (.allocateMemory u 1) + (.allocateMemory u 1) + (.allocateMemory u 1) + (.allocateMemory u 1)))) + +;; allocating one byte of heap memory: avg 0.698 ns (or less depending on bench overhead) +(bench (do (Array/newUninitialized1dByteArray 1) + (Array/newUninitialized1dByteArray 1) + (Array/newUninitialized1dByteArray 1) + (Array/newUninitialized1dByteArray 1) + (Array/newUninitialized1dByteArray 1))) + +;; writing one byte of off-heap memory: avg 0.636 ns (or less depending on bench overhead) +(let [^sun.misc.Unsafe u unsafe + pointer (.allocateMemory u 1) + b (byte 1)] + (bench (.putByte u pointer b) + (.putByte u pointer b) + (.putByte u pointer b) + (.putByte u pointer b) + (.putByte u pointer b))) + +;; writing one byte of on-heap memory: avg 0.6698 ns (or less depending on bench overhead) +(let [bs (Array/newUninitialized1dByteArray 1) + b (byte 1) + i (int 0)] + (bench (Array/set bs b i) + (Array/set bs b i) + (Array/set bs b i) + (Array/set bs b i) + (Array/set bs b i))) + +;; accessing one byte of off-heap memory: 0.7052 ns (or less depending on bench overhead) +(let [^sun.misc.Unsafe u unsafe + pointer (.allocateMemory u 1)] + (bench (do (.getByte u pointer) + (.getByte u pointer) + (.getByte u pointer) + (.getByte u pointer) + (.getByte u pointer)))) + +;; accessing one byte of on-heap memory: 0.7302 ns (or less depending on bench overhead) +(let [bs (Array/newUninitialized1dByteArray 1) + i (int 0)] + (bench (do (Array/get bs i) + (Array/get bs i) + (Array/get bs i) + (Array/get bs i) + (Array/get bs i)))) diff --git a/doc/cljc/quantum/_performance.md b/doc/cljc/quantum/_performance.md index 61929757..6250157b 100644 --- a/doc/cljc/quantum/_performance.md +++ b/doc/cljc/quantum/_performance.md @@ -2,6 +2,7 @@ https://github.com/druid-io/druid/issues/3892 (Move from `ByteBuffer` to `Memory`) - Yahoo's `Memory` submodule of `DataSketches` is faster than `ByteBuffer` (!) + - https://github.com/DataSketches/memory/tree/master/src/main/java/com/yahoo/memory ## quantum.net.http From 8ff7414b9566053a7c4eb2c22d5a7c51cca00efb Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 00:30:14 -0600 Subject: [PATCH 406/810] Update some todos --- resources-dev/defnt.cljc | 29 ++++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index dfe6f607..f98461a8 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -81,6 +81,19 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative ([n dnum/std-integer?, xs ?] ...) - (comp/t== x) - dependent type such that the passed input must be identical to x + - Type Logic and Predicates + - We should probably have a 'normal form' so we can correctly hash if we do spec lookup + - t/- : fix + - (t/- (t/isa? java.util.Queue) (t/or ?!+queue? !!queue?)) + - t/numerically : e.g. a double representing exactly what a float is able to represent + - and variants thereof: `numerically-long?` etc. + - t/numerically-integer? + - dc/of + - (dc/of number?) ; implicitly the container is a `reducible?` + - (dc/of map/+map? symbol? dstr/string?) + - (dc/of t/seq? namespace?) + - dc/map-of + - dc/seq-of - Analysis - Better analysis of compound literals - Literal vectors need to be analyzed — (t/finite-of t/built-in-vector? a-type b-type ...) @@ -113,21 +126,11 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative (#?(:clj clojure.core.protocols/coll-reduce :cljs cljs.core/-reduce) xs rf init)) - (if (A) ...) should be (if ^boolean (A) ...) if A returns a `p/boolean?` - - t/- : fix - - (t/- (t/isa? java.util.Queue) (t/or ?!+queue? !!queue?)) - - t/numerically : e.g. a double representing exactly what a float is able to represent - - and variants thereof: `numerically-long?` etc. - - t/numerically-integer? - We should not rely on the value of dynamic vars e.g. `*math-context*` unless specifically typed - We'll have to make a special class or *something* like that to ensure that typed bindings are only bound within typed contexts. + - `t/defn` declaration: `(t/defn >std-fixint > std-fixint?)` - t/extend-defn! - - dc/of - - (dc/of number?) ; implicitly the container is a `reducible?` - - (dc/of map/+map? symbol? dstr/string?) - - (dc/of t/seq? namespace?) - - dc/map-of - - dc/seq-of - t/defrecord - t/def-concrete-type (i.e. `t/deftype`) - expressions (`quantum.untyped.core.analyze.expr`) @@ -181,8 +184,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [xs (t/fn [x (t/isa? clojure.lang.Range)] ...)] - No return value means that it should infer - NOTE on namespace organization: - - Conversion functions belong in the namespace that their destination types belong in, not in one - giant namespace of all conversion + - The initial definition of conversion functions belongs in the namespace that their destination + type belongs in, and it may be extended in every namespace in which there is a source type. - TODO transition the quantum.core.* namespaces: ->>>>>> TODO need to add *all* quantum namespaces in here - Legend: From d26cf230ac5c166d3c6d47737e5abf2355559ef6 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 00:30:33 -0600 Subject: [PATCH 407/810] Move numeric ns and add `std-fixint?` --- .../untyped => src/quantum}/core/data/numeric.cljc | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) rename {src-untyped/quantum/untyped => src/quantum}/core/data/numeric.cljc (96%) diff --git a/src-untyped/quantum/untyped/core/data/numeric.cljc b/src/quantum/core/data/numeric.cljc similarity index 96% rename from src-untyped/quantum/untyped/core/data/numeric.cljc rename to src/quantum/core/data/numeric.cljc index 98b7c0b5..1d321234 100644 --- a/src-untyped/quantum/untyped/core/data/numeric.cljc +++ b/src/quantum/core/data/numeric.cljc @@ -34,7 +34,7 @@ ;; Incorporated `clojure.core/int?` ;; Incorporated `cljs.core/int?` -(var/def fixint? "The set of all fixed-precision integers." +(var/def fixint? "The set of all fixed-precision (though not necessarily primitive) integers." (t/or #?@(:clj [p/byte? p/short?]) p/int? p/long?)) #?(:clj (def java-bigint? (t/isa? java.math.BigInteger))) @@ -233,8 +233,16 @@ (def numerically-integer-primitive? (t/and p/primitive? numerically-integer?)) +;; TODO excise? (def std-integer? (t/or integer? #?(:cljs numerically-integer-double?))) +(def std-fixint? #?(:clj long? :cljs numerically-integer-double?)) + +(t/defn >std-fixint + "Converts input to a `std-fixint?` in a way that may involve truncation or rounding." + > std-fixint? +#?(:cljs ([x double? > (t/assume std-fixint?)] (js/Math.round x)))) + ;; TODO TYPED (t/defn read-rational "Create cross-platform literal rational numbers from decimal, without intermediate inexact From 5c4b98530c8d23b0b2cea34da3a5248d6e7efad1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 00:30:53 -0600 Subject: [PATCH 408/810] Add radix sort reference --- src/quantum/core/collections.cljc | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/quantum/core/collections.cljc b/src/quantum/core/collections.cljc index 5c6d50db..c56d50d6 100644 --- a/src/quantum/core/collections.cljc +++ b/src/quantum/core/collections.cljc @@ -1219,11 +1219,7 @@ (loop [[part & parts] work] (if-let [[pivot & xs] (seq part)] (let [smaller? #(< % pivot)] - (recur (list* - (lfilter smaller? xs) - pivot - (lremove smaller? xs) - parts))) + (recur (list* (lfilter smaller? xs) pivot (lremove smaller? xs) parts))) (when-let [[x & parts] parts] (cons x (sort-parts parts))))))) @@ -1235,6 +1231,10 @@ ; TODO subarray-only sort +;; TODO incorporate highly tuned radix sort with better performance than quicksort on n < 10000 +;; - http://fastutil.di.unimi.it/docs/it/unimi/dsi/fastutil/ints/IntArrays.html#radixSort-int:A-int-int- +;; - http://fastutil.di.unimi.it/docs/overview-summary.html + #?(:clj (defnt heap-sort! [#{ints? floats? doubles? "[Ljava.lang.Comparable;"} arr] From 8774483f01422cdd4c757d10afd815be5856bf7a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 00:31:09 -0600 Subject: [PATCH 409/810] Move numeric parsing to string namespace --- src/quantum/core/data/primitive.cljc | 141 +++++++++------------------ src/quantum/core/data/string.cljc | 72 ++++++++++++++ 2 files changed, 118 insertions(+), 95 deletions(-) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index abd60bba..7f60c9ab 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -166,57 +166,16 @@ ;; ===== Conversion ===== ;; -;; TODO TYPED add t/fn -(def radix? integer? - #_(t/fn [x integer?] - (<= #?(:clj Character/MIN_RADIX :cljs 2) x #?(:clj Character/MAX_RADIX :cljs 36)))) - ;; ----- Boolean ----- ;; (t/defn ^:inline >boolean "Converts input to a boolean. Differs from asking whether something is truthy/falsey." > boolean? - ([x boolean?] x) - ([x (t/value "true")] true) - ([x (t/value "false")] false) ;; For purposes of intrinsics + ([x boolean?] x) ;; For purposes of Clojure intrinsics ([x (t/or long? double?)] (-> x clojure.lang.Numbers/isZero Numeric/not)) ([x (t/- primitive? boolean? long? double?)] (-> x Numeric/isZero Numeric/not))) -;; ----- Int ----- ;; -;; Forward-declared so `radix?` coercion to `int` works - -;; TODO figure out how to use with goog.math.Integer/Long -#?(:clj -(t/defn ^:inline >int* - "May involve non-out-of-range truncation." - > int? - ([x int?] x) ;; For purposes of intrinsics - ([x (t/- primitive? int? boolean?)] (clojure.lang.RT/uncheckedIntCast x)))) - -;; TODO TYPED `numerically` -;; TODO figure out how to use with goog.math.Integer/Long -#_(t/defn ^:inline >int - "May involve non-out-of-range truncation" - > #?(:clj int? :cljs numerically-int?) - ([x #?(:clj int? :cljs numerically-int?)] x) -#?(:clj ([x (t/and (t/- primitive? int? boolean?) numerically-int?)] (>int* x)) - :cljs ([x (t/and double? numerically-int?) > (t/assume numerically-int?)] (js/Math.round x))) - ([x boolean?] (if x #?(:clj (int 1) :cljs 1) #?(:clj (int 0) :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-int?)] (>int* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-int?)] (.intValue x))) -#?(:clj ([x (t/and dnum/ratio? numerically-int?)] (-> x .bigIntegerValue .intValue))) - ([x string?] - #?(:clj (Integer/parseInteger x) - ;; NOTE could use `js/parseInt` but it's very 'unsafe' - :cljs (throw (ex-info "Parsing not implemented" {:string x})))) - ([x string?, radix radix?] - #?(:clj (Integer/parseInteger x (>int radix)) - ;; NOTE could use `js/parseInt` but it's very 'unsafe' - :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) - -; js/Math.trunc for CLJS - ;; ----- Byte ----- ;; ;; TODO figure out how to use with CLJS @@ -230,22 +189,14 @@ ;; TODO TYPED `numerically` ;; TODO figure out how to use with goog.math.Integer/Long #_(defnt ^:inline >byte > #?(:clj byte? :cljs numerically-byte?) - "May involve non-out-of-range truncation." + "Does not involve truncation or rounding." ([x #?(:clj byte? :cljs numerically-byte?)] x) #?(:clj ([x (t/and (t/- primitive? byte? boolean?) numerically-byte?)] (>byte* x)) - :cljs ([x (t/and double? numerically-byte?)] (js/Math.round x))) + :cljs ([x (t/and double? numerically-byte?)] x)) ([x boolean?] (if x #?(:clj (byte 1) :cljs 1) #?(:clj (byte 0) :cljs 0))) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-byte?)] (>byte* (.lpart x)))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-byte?)] (.byteValue x))) -#?(:clj ([x (t/and dnum/ratio? numerically-byte?)] (-> x .bigIntegerValue .byteValue))) - ([x string?] - #?(:clj (Byte/parseByte x) - ;; NOTE could use `js/parseInt` but it's very 'unsafe' - :cljs (throw (ex-info "Parsing not implemented" {:string x})))) - ([x string?, radix radix?] - #?(:clj (Byte/parseByte x (>int radix)) - ;; NOTE could use `js/parseInt` but it's very 'unsafe' - :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) +#?(:clj ([x (t/and dnum/ratio? numerically-byte?)] (-> x .bigIntegerValue .byteValue)))) ;; ----- Short ----- ;; @@ -260,22 +211,14 @@ ;; TODO TYPED `numerically` ;; TODO figure out how to use with goog.math.Integer/Long #_(t/defn ^:inline >short > #?(:clj short? :cljs numerically-short?) - "May involve non-out-of-range truncation." + "Does not involve truncation or rounding." ([x #?(:clj short? :cljs numerically-short?)] x) #?(:clj ([x (t/and (t/- primitive? short? boolean?) numerically-short?)] (>short* x)) - :cljs ([x (t/and double? numerically-short?)] (js/Math.round x))) + :cljs ([x (t/and double? numerically-short?)] x)) ([x boolean?] (if x #?(:clj (short 1) :cljs 1) #?(:clj (short 0) :cljs 0))) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-short?)] (>short* (.lpart x)))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-short?)] (.shortValue x))) -#?(:clj ([x (t/and dnum/ratio? numerically-short?)] (-> x .bigIntegerValue .shortValue))) - ([x string?] - #?(:clj (Short/parseShort x) - ;; NOTE could use `js/parseInt` but it's very 'unsafe' - :cljs (throw (ex-info "Parsing not implemented" {:string x})))) - ([x string?, radix radix?] - #?(:clj (Short/parseShort x (>int radix)) - ;; NOTE could use `js/parseInt` but it's very 'unsafe' - :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) +#?(:clj ([x (t/and dnum/ratio? numerically-short?)] (-> x .bigIntegerValue .shortValue)))) ;; ----- Char ----- ;; @@ -290,16 +233,39 @@ ;; TODO TYPED `numerically` ;; TODO figure out how to use with goog.math.Integer/Long #_(t/defn ^:inline >char > #?(:clj char? :cljs numerically-char?) - "May involve non-out-of-range truncation. + "Does not involve truncation or rounding. For CLJS, returns not a String of length 1 but a numerically-char Number." ([x #?(:clj char? :cljs numerically-char?)] x) #?(:clj ([x (t/and (t/- primitive? char? boolean?) numerically-char?)] (>char* x)) - :cljs ([x (t/and double? numerically-char?)] (js/Math.round x))) + :cljs ([x (t/and double? numerically-char?)] x)) ([x boolean?] (if x #?(:clj (char 1) :cljs 1) #?(:clj (char 0) :cljs 0))) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-char?)] (>char* (.lpart x)))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-char?)] (.charValue x))) #?(:clj ([x (t/and dnum/ratio? numerically-char?)] (-> x .bigIntegerValue .charValue)))) +;; ----- Int ----- ;; + +;; TODO figure out how to use with goog.math.Integer/Long +#?(:clj +(t/defn ^:inline >int* + "May involve non-out-of-range truncation." + > int? + ([x int?] x) ;; For purposes of Clojure intrinsics + ([x (t/- primitive? int? boolean?)] (clojure.lang.RT/uncheckedIntCast x)))) + +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +#_(t/defn ^:inline >int + "Does not involve truncation or rounding." + > int? + ([x int?] x) +#?(:clj ([x (t/and (t/- primitive? int? boolean?) numerically-int?)] (>int* x)) + :cljs ([x (t/and double? numerically-int?)] x)) + ([x boolean?] (if x #?(:clj (int 1) :cljs 1) #?(:clj (int 0) :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-int?)] (>int* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-int?)] (.intValue x))) +#?(:clj ([x (t/and dnum/ratio? numerically-int?)] (-> x .bigIntegerValue .intValue)))) + ;; ----- Long ----- ;; ;; TODO figure out how to use with CLJS, including goog.math.Integer/Long @@ -308,34 +274,27 @@ "May involve non-out-of-range truncation." > long? ([x long?] x) - ([x char?] (Primitive/uncheckedLongCast x)) ;; For purposes of intrinsics + ([x char?] (Primitive/uncheckedLongCast x)) ;; For purposes of Clojure intrinsics ([x (t/- primitive? long? boolean? char?)] (clojure.lang.RT/uncheckedLongCast x)))) ;; TODO TYPED `numerically` ;; TODO figure out how to use with goog.math.Integer/Long -#_(t/defn ^:inline >long > #?(:clj long? :cljs numerically-long?) - "May involve non-out-of-range truncation." +#_(t/defn ^:inline >long + "Does not involve truncation or rounding." + > #?(:clj long? :cljs numerically-long?) ([x #?(:clj long? :cljs numerically-long?)] x) #?(:clj ([x (t/and (t/- primitive? long? boolean?) numerically-long?)] (>long* x)) - :cljs ([x double?] (js/Math.round x))) + :cljs ([x (t/and double? numerically-long?)] x)) ([x boolean?] (if x 1 0)) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-long? - ;; This might be faster than `numerically-long?` + ;; TODO This might be faster than `numerically-long?` #_(fnt [x ?] (nil? (.bipart x))))] (.lpart x))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-long? - ;; This might be faster than `numerically-long?` + ;; TODO This might be faster than `numerically-long?` #_(fnt [x ?] (< (.bitLength x) 64)))] (.longValue x))) -#?(:clj ([x (t/and dnum/ratio? numerically-long?)] (-> x .bigIntegerValue .longValue))) - ([x string?] - #?(:clj (Long/parseLong x) - ;; NOTE could use `js/parseInt` but it's very 'unsafe' - :cljs (throw (ex-info "Parsing not implemented" {:string x})))) - ([x string?, radix radix?] - #?(:clj (Long/parseLong x (>int radix)) - ;; NOTE could use `js/parseInt` but it's very 'unsafe' - :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) +#?(:clj ([x (t/and dnum/ratio? numerically-long?)] (-> x .bigIntegerValue .longValue)))) ;; ----- Float ----- ;; @@ -350,18 +309,14 @@ ;; TODO TYPED `numerically` ;; TODO figure out how to use with goog.math.Integer/Long #_(t/defn ^:inline >float > #?(:clj float? :cljs numerically-float?) - "May involve non-out-of-range truncation." + "Does not involve truncation or rounding." ([x #?(:clj float? :cljs numerically-float?)] x) #?(:clj ([x (t/and (t/- primitive? float? boolean?) numerically-float?)] (>float* x)) - :cljs ([x (t/and double? numerically-float?) > (t/assume numerically-float?)] (js.Math/fround x))) + :cljs ([x (t/and double? numerically-float?)] x)) ([x boolean?] (if x #?(:clj (float 1) :cljs 1) #?(:clj (float 0) :cljs 0))) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-float?)] (>float* (.lpart x)))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-float?)] (.floatValue x))) -#?(:clj ([x (t/and dnum/ratio? numerically-float?)] (-> x .bigIntegerValue .floatValue))) - ([x string?] - #?(:clj (Float/parseFloat x) - ;; NOTE could use `js/parseFloat` but it's very 'unsafe' - :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) +#?(:clj ([x (t/and dnum/ratio? numerically-float?)] (-> x .bigIntegerValue .floatValue)))) ;; ----- Double ----- ;; @@ -370,23 +325,19 @@ "May involve non-out-of-range truncation." > double? ([x double?] x) - ([x char?] (Primitive/uncheckedDoubleCast x)) ;; For purposes of intrinsics + ([x char?] (Primitive/uncheckedDoubleCast x)) ;; For purposes of Clojure intrinsics #?(:clj ([x (t/- primitive? double? boolean? char?)] (clojure.lang.RT/uncheckedDoubleCast x)))) ;; TODO TYPED `numerically` ;; TODO figure out how to use with goog.math.Integer/Long #_(t/defn ^:inline >double > double? - "May involve non-out-of-range truncation." + "Does not involve truncation or rounding." ([x double?] x) #?(:clj ([x (t/and (t/- primitive? double? boolean?) numerically-double?)] (>double* x))) ([x boolean?] (if x #?(:clj 1.0 :cljs 1) #?(:clj 1.0 :cljs 0))) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-double?)] (>double* (.lpart x)))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-double?)] (.doubleValue x))) -#?(:clj ([x (t/and dnum/ratio? numerically-double?)] (-> x .bigIntegerValue .doubleValue))) - ([x string?] - #?(:clj (Double/parseDouble x) - ;; NOTE could use `js/parseFloat` but it's very 'unsafe' - :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) +#?(:clj ([x (t/and dnum/ratio? numerically-double?)] (-> x .bigIntegerValue .doubleValue)))) ;; ===== Unsigned ===== ;; diff --git a/src/quantum/core/data/string.cljc b/src/quantum/core/data/string.cljc index 3d1b1b72..65ad42df 100644 --- a/src/quantum/core/data/string.cljc +++ b/src/quantum/core/data/string.cljc @@ -4,6 +4,7 @@ [string?]) (:require [quantum.core.data.meta :as meta] + [quantum.core.data.numeric :as num] [quantum.core.data.primitive :as p] [quantum.core.type :as t] ;; TODO TYPED excise @@ -142,6 +143,77 @@ (recur (.append sb (str (first more))) (next more)) (>string sb))))) +;; TODO TYPED add t/fn +(def radix? + (t/fn [x integer?] + (comp/<= #?(:clj Character/MIN_RADIX :cljs 2) x #?(:clj Character/MAX_RADIX :cljs 36)))) + +(t/extend-defn! p/>boolean + ([x (t/value "true")] true) + ([x (t/value "false")] false)) + +(t/extend-defn! p/>byte + ([x string?] + #?(:clj (Byte/parseByte x) + ;; NOTE could use `js/parseInt` but it's very 'unsafe' + ;; TODO implement based on `Byte/parseByte` + :cljs (throw (ex-info "Parsing not implemented" {:string x})))) + ([x string?, radix radix?] + #?(:clj (Byte/parseByte x (>int radix)) + ;; NOTE could use `js/parseInt` but it's very 'unsafe' + ;; TODO implement based on `Byte/parseByte` + :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) + +(t/extend-defn! p/>short + ([x string?] + #?(:clj (Short/parseShort x) + ;; NOTE could use `js/parseInt` but it's very 'unsafe' + ;; TODO implement based on `Short/parseShort` + :cljs (throw (ex-info "Parsing not implemented" {:string x})))) + ([x string?, radix radix?] + #?(:clj (Short/parseShort x (>int radix)) + ;; NOTE could use `js/parseInt` but it's very 'unsafe' + ;; TODO implement based on `Short/parseShort` + :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) + +(t/extend-defn! p/>int + ([x string?] + #?(:clj (Integer/parseInteger x) + ;; NOTE could use `js/parseInt` but it's very 'unsafe' + ;; TODO implement based on `Integer/parseInteger` + :cljs (throw (ex-info "Parsing not implemented" {:string x})))) + ([x string?, radix radix?] + #?(:clj (Integer/parseInteger x (p/>int radix)) + ;; NOTE could use `js/parseInt` but it's very 'unsafe' + ;; TODO implement based on `Integer/parseInteger` + :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) + +(t/extend-defn! p/>long + ([x string?] + #?(:clj (Long/parseLong x) + ;; NOTE could use `js/parseInt` but it's very 'unsafe' + ;; TODO implement based on `Long/parseLong` + :cljs (throw (ex-info "Parsing not implemented" {:string x})))) + ([x string?, radix radix?] + #?(:clj (Long/parseLong x (>int radix)) + ;; NOTE could use `js/parseInt` but it's very 'unsafe' + ;; TODO implement based on `Long/parseLong` + :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) + +(t/extend-defn! p/>float + ([x string?] + #?(:clj (Float/parseFloat x) + ;; NOTE could use `js/parseFloat` but it's very 'unsafe' + ;; TODO implement based on `Float/parseFloat` + :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) + +(t/extend-defn! p/>double + ([x string?] + #?(:clj (Double/parseDouble x) + ;; NOTE could use `js/parseFloat` but it's very 'unsafe' + ;; TODO implement based on `Double/parseDouble` + :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) + ;; ----- Metable immutable strings ----- ;; ;; TODO TYPED `t/deftype` From 26b80de78ad9746c6c6286235e5f2e07a53b7ebc Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 00:31:22 -0600 Subject: [PATCH 410/810] Some todos --- src/quantum/core/numeric/truncate.cljc | 5 +++++ src/quantum/ui/style/color.cljc | 2 ++ 2 files changed, 7 insertions(+) diff --git a/src/quantum/core/numeric/truncate.cljc b/src/quantum/core/numeric/truncate.cljc index 2411d409..f4d943f2 100644 --- a/src/quantum/core/numeric/truncate.cljc +++ b/src/quantum/core/numeric/truncate.cljc @@ -17,6 +17,11 @@ :refer [pos?]]) #?(:clj (:import java.math.BigDecimal clojure.lang.Ratio))) +;; TODO js/Math.trunc for CLJS +;; TODO js/Math.round for CLJS +;; TODO js/Math.fround for CLJS +;; TODO js/Math.rint for CLJS + #?(:clj (defnt' rint "The double value that is closest in value to ->`x` and is equal to a mathematical integer." diff --git a/src/quantum/ui/style/color.cljc b/src/quantum/ui/style/color.cljc index db738559..69f4c3ae 100644 --- a/src/quantum/ui/style/color.cljc +++ b/src/quantum/ui/style/color.cljc @@ -1,4 +1,6 @@ (ns quantum.ui.style.color + "TODO import: + - https://github.com/thi-ng/color" (:require [quantum.core.vars :as var :refer [defaliases]] From fe8432262cfae03d98f2460d4552af443fc268fb Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 09:45:00 -0600 Subject: [PATCH 411/810] Admit other `adapted-from` values --- resources-dev/defnt.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index f98461a8..70d7cc9a 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -1354,7 +1354,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - uncheckedDoubleCast - Standard metadata - e.g. `{:alternate-implementations #{'cljs.tools.reader/merge-meta}}` - - :adapted-from + - :adapted-from (t/or namespace-symbol? class-symbol? url-string?) - :source - :todo #{} - :attribution From 187935b331205319a58b14a5e05f04d02bcbf698 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 09:45:11 -0600 Subject: [PATCH 412/810] `mobile-user-agent?`, `websocket-enabled?` --- src/quantum/ui/features.cljc | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/quantum/ui/features.cljc b/src/quantum/ui/features.cljc index 4a2f2435..9dbde635 100644 --- a/src/quantum/ui/features.cljc +++ b/src/quantum/ui/features.cljc @@ -2,12 +2,20 @@ :todo ["Possibly rename 'quantum.ui.platform'?"]} quantum.ui.features (:require - [quantum.core.vars + [quantum.core.vars :as var :refer [defaliases]] [quantum.untyped.ui.features :as u])) #?(:cljs (defaliases u flex-test feature-test)) +#?(:cljs +(var/def mobile-user-agent? + "From https://github.com/thi-ng/domus/blob/master/src/detect.org" + (and (re-find #"(?i)mobile|tablet|ip(ad|hone|od)|android|silk" (.-userAgent js/navigator)) + (not (re-find #"(?i)crios" (.-userAgent js/navigator)))))) + +#?(:cljs (def websocket-enabled? (some? (aget js/window "WebSocket")))) + #?(:cljs (def touch-events (delay (let [events (cond From d14e8263d857749335f58417c0f68cb2133a5105 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 09:45:17 -0600 Subject: [PATCH 413/810] `quantum.ui.navigation` --- src/quantum/ui/navigation.cljc | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 src/quantum/ui/navigation.cljc diff --git a/src/quantum/ui/navigation.cljc b/src/quantum/ui/navigation.cljc new file mode 100644 index 00000000..6db7d3e9 --- /dev/null +++ b/src/quantum/ui/navigation.cljc @@ -0,0 +1,5 @@ +(ns quantum.ui.navigation + "Implements, for instance, HTML5 history / navigation / page routing. + + TODO incorporate: + - https://github.com/thi-ng/domus/blob/master/src/router.org") From 2dce67c97219588f1115372f2051aa0692bf4a11 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 09:45:28 -0600 Subject: [PATCH 414/810] Clean up `quantum.ui.view` --- src/quantum/ui/view.cljc | 68 ++++++++++++++++++++++------------------ 1 file changed, 37 insertions(+), 31 deletions(-) diff --git a/src/quantum/ui/view.cljc b/src/quantum/ui/view.cljc index 283ef5b5..9afd33d9 100644 --- a/src/quantum/ui/view.cljc +++ b/src/quantum/ui/view.cljc @@ -1,35 +1,41 @@ -(ns quantum.ui.view) +(ns quantum.ui.view + (:require + [quantum.core.vars + :refer [def-]])) + +#?(:cljs +(defn full-screen? [] + (or (.-fullscreenElement js/document) + (.-mozFullScreenElement js/document) + (.-webkitFullscreenElement js/document) + (.-msFullscreenElement js/document)))) + +#?(:cljs +(def- *enable-full-screen! + (delay + (let [de (.-documentElement js/document)] + (or (.-requestFullscreen de) + (.-msRequestFullscreen de) + (.-mozRequestFullscreen de) + (.-webkitRequestFullscreen de)))))) + +#?(:cljs +(defn enable-full-screen! [] (@*enable-full-screen!))) + +#?(:cljs +(def- *disable-full-screen! + (delay + (or (.-exitFullscreen js/document) + (.-msExitFullscreen js/document) + (.-mozCancelFullScreen js/document) + (.-webkitExitFullscreen js/document))))) + +#?(:cljs (defn disable-full-screen! [] (@*disable-full-screen!))) #?(:cljs (defn toggle-full-screen! - {:from "https://developer.mozilla.org/en-US/docs/Web/API/Fullscreen_API" - :todo ["More elegant way to do this"]} + {:adapted-from "https://developer.mozilla.org/en-US/docs/Web/API/Fullscreen_API"} [] - (if (and (not (.-fullscreenElement js/document)) - (not (.-mozFullScreenElement js/document)) - (not (.-webkitFullscreenElement js/document)) - (not (.-msFullscreenElement js/document))) - (cond - (-> js/document .-documentElement .-requestFullscreen) - (-> js/document .-documentElement .requestFullscreen ) - - (-> js/document .-documentElement .-msRequestFullscreen) - (-> js/document .-documentElement .msRequestFullscreen ) - - (-> js/document .-documentElement .-mozRequestFullscreen) - (-> js/document .-documentElement .mozRequestFullscreen ) - - (-> js/document .-documentElement .-webkitRequestFullscreen) - (-> js/document .-documentElement (.webkitRequestFullscreen js/Element.ALLOW_KEYBOARD_INPUT))) - (cond - (-> js/document (.-exitFullscreen)) - (-> js/document (.-exitFullscreen)) - - (-> js/document (.-msExitFullscreen)) - (-> js/document (.-msExitFullscreen)) - - (-> js/document (.-mozCancelFullScreen)) - (-> js/document (.-mozCancelFullScreen)) - - (-> js/document (.-webkitExitFullscreen)) - (-> js/document (.-webkitExitFullscreen)))))) \ No newline at end of file + (if (full-screen?) + (disable-full-screen!) + (enable-full-screen!)))) From cbcce037cd48adcc4250ecb31ce40fb6bf177eac Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 09:45:53 -0600 Subject: [PATCH 415/810] ni-double > std-fixint --- src/quantum/core/data/time.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/quantum/core/data/time.cljc b/src/quantum/core/data/time.cljc index 1a19fdff..cc5c603b 100644 --- a/src/quantum/core/data/time.cljc +++ b/src/quantum/core/data/time.cljc @@ -4,4 +4,4 @@ [quantum.core.type :as t])) ;; TODO is this the right place to put this? -#?(:cljs (t/defn date>millis [x js/Date > (t/assume dnum/ni-double?)] (.valueOf x))) +#?(:cljs (t/defn date>millis [x js/Date > (t/assume dnum/std-fixint?)] (.valueOf x))) From 01e738bbee9f7114cf004a8e1db515c0386ea84a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 09:46:03 -0600 Subject: [PATCH 416/810] Begin work on `abs` --- src/quantum/core/numeric/operators.cljc | 30 ++++++++++++++++--------- 1 file changed, 20 insertions(+), 10 deletions(-) diff --git a/src/quantum/core/numeric/operators.cljc b/src/quantum/core/numeric/operators.cljc index 2affc0ac..f1d6aae3 100644 --- a/src/quantum/core/numeric/operators.cljc +++ b/src/quantum/core/numeric/operators.cljc @@ -5,10 +5,12 @@ numerator denominator]) (:require [clojure.core :as core] + ;; TODO TYPED remove #?(:cljs [com.gfredericks.goog.math.Integer :as int]) - ;; TODO TYPED re-enable - #_[quantum.core.data.numeric :as dnum - :refer [bigdec? clj-bigint? numerator numeric? denominator]] + [quantum.core.data.bits :as bit + :refer [<< >> >>>]] + [quantum.core.data.numeric :as dnum + :refer [bigdec? clj-bigint? denominator numerator numeric? numerically-int?]] [quantum.core.data.primitive :as p] [quantum.core.data.refs :as ref] ;; TODO TYPED re-enable @@ -271,12 +273,22 @@ (+* x 1)))) :cljs (defalias inc' inc )) +(t/defn abs > nneg? +#?(:clj (^:inline [x char?] x)) + (^{:adapted-from 'thi.ng.math.bits + :doc "Faster than using conditionals to determine the absolute value"} + [x #?(:clj (t/or p/byte? p/short? p/int? p/long?) :cljs ni-double?) + > (t/and (t/type x) (t/assume nneg?))] + (let [mask (>> x (bit/dec-bits-of x))] + (- (bit/xor x mask) mask))) +#?(:clj (^:intrinsic ^:inline [x p/float? > (t/and p/float? (t/assume nneg?))] (Math/abs x))) +#?(:clj (^:inline [x p/double? ...]) + :cljs (^:inline [x p/double? > (t/assume (t/and p/double? nneg?))] (js/Math.abs x))) +#?(:clj (^:inline [x bigdec? > (t/and bigdec? (t/assume nneg?))] (.abs x))) +) + +;; TODO TYPED incorporate #?(:clj (defnt abs' - ([#{int long double} x] (Math/abs x)) - (^float ^:intrinsic [^float x] (Math/abs x)) - ([#{byte char short} x] (if (Numeric/isNeg x) (-' x) x)) ; TODO abstract this - (^BigDecimal [^BigDecimal x] - (.abs x)) (^BigDecimal [^BigDecimal x math-context] (.abs x math-context)) (^BigInteger [^BigInteger x] @@ -290,8 +302,6 @@ (abs' (denominator x))))) :cljs (defnt abs' ([x] (TODO "incomplete") (js/Math.abs x)))) -#?(:clj (defalias abs abs')) - #?(:clj (defmacro int-nil [x] `(let [x# ~x] (if (nil? x#) 0 x#)))) #?(:clj From 9e763dbe1888a3f227bfb1a91b82e1f38608d822 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 09:46:47 -0600 Subject: [PATCH 417/810] Add bit lengths and do correct CLJS bit ops --- src/quantum/core/data/bits.cljc | 159 ++++++++++++++++----------- src/quantum/core/data/primitive.cljc | 10 ++ 2 files changed, 107 insertions(+), 62 deletions(-) diff --git a/src/quantum/core/data/bits.cljc b/src/quantum/core/data/bits.cljc index 28f9454e..79ca1d9b 100644 --- a/src/quantum/core/data/bits.cljc +++ b/src/quantum/core/data/bits.cljc @@ -1,5 +1,11 @@ (ns quantum.core.data.bits - "Useful bit/binary operations." + "Useful bit/binary operations. + + Note that bitwise operators on CLJS doubles behave differently than on CLJ doubles: the bitwise + operators `<<`, `>>`, `&`, `|` and `~` are defined in terms of operations on 32-bit integers. + Doing a bitwise operation converts the number to a 32-bit signed int, losing any fractions and + higher-place bits than 32, before doing the calculation and then converting back to Number." + {:todo #{"Port http://graphics.stanford.edu/~seander/bithacks.html"}} (:refer-clojure :exclude [and conj contains? empty not or]) (:require @@ -13,9 +19,33 @@ #?(:clj (:import [quantum.core Numeric]))) +;; TODO make sure that for all bit ops here, there's a checked and unchecked version Because +;; currently the CLJS version just truncates the input without warning + (def bit-false 0) (def bit-true 1) +;; ===== Decremented bit sizes of types ===== ;; +;; For bit-manipulation purposes + +(var/def dec-boolean-bits (core/dec p/boolean-bits)) +(var/def dec-byte-bits (core/dec p/byte-bits))) +(var/def dec-short-bits (core/dec p/short-bits))) +(var/def dec-int-bits (core/dec p/int-bits))) +(var/def dec-long-bits (core/dec p/long-bits))) +(var/def dec-float-bits (core/dec p/float-bits))) +(var/def dec-double-bits (core/dec p/double-bits))) + +(t/defn ^:inline dec-bits-of + "For bit manipulation purposes" + ([x p/boolean?] dec-boolean-bits) +#?(:clj ([x p/byte?] dec-byte-bits)) +#?(:clj ([x p/short?] dec-short-bits)) +#?(:clj ([x p/int?] dec-int-bits)) +#?(:clj ([x p/long?] dec-long-bits)) +#?(:clj ([x p/float?] dec-float-bits)) + ([x p/double?] dec-double-bits)) + ;; ===== Logical bit-operations ===== ;; ;; NOTE: we won't be supporting `and-not` @@ -32,7 +62,7 @@ ([x p/float? > p/float?] (Numeric/bitNot x)) ([x p/double? > p/double?] (Numeric/bitNot x))] :cljs [([x p/boolean? > p/boolean?] (if x false true)) - ([x p/double? > p/double?] (core/bit-not x))])) + ([x p/double? > (t/assume numerically-int?)] (core/bit-not x))])) ;; TODO make variadic ;; TODO TYPED we can shorten this by having dependent types @@ -72,7 +102,8 @@ ([a p/float? , b (t/or p/long? p/double?) > p/double?] (Numeric/bitAnd a b)) ([a p/double? , b (t/- p/primitive? p/boolean?) > p/double?] (Numeric/bitAnd a b))] :cljs [([a p/boolean?, b p/boolean? > p/boolean?] (core/and a b)) - ([a p/double? , b p/double? > p/double?] (core/bit-and a b))])) + ([a p/double? , b p/double? > (t/assume numerically-int?)] + (core/bit-and a b))])) ;; TODO make variadic ;; TODO TYPED we can shorten this by having dependent types @@ -112,7 +143,8 @@ ([a p/float? , b (t/or p/long? p/double?) > p/double?] (Numeric/bitOr a b)) ([a p/double? , b (t/- p/primitive? p/boolean?) > p/double?] (Numeric/bitOr a b))] :cljs [([a p/boolean?, b p/boolean? > p/boolean?] (core/or a b)) - ([a p/double? , b p/double? > p/double?] (core/bit-or a b))])) + ([a p/double? , b p/double? > (t/assume numerically-int?)] + (core/bit-or a b))])) ;; TODO make variadic ;; TODO TYPED we can shorten this by having dependent types @@ -152,7 +184,8 @@ ([a p/float? , b (t/or p/long? p/double?) > p/double?] (Numeric/bitXOr a b)) ([a p/double? , b (t/- p/primitive? p/boolean?) > p/double?] (Numeric/bitXOr a b))] :cljs [([a p/boolean?, b p/boolean? > p/boolean?] (js* "(~{} !=== ~{})" a b)) - ([a p/double? , b p/double? > p/double?] (core/bit-xor a b))])) + ([a p/double? , b p/double? > (t/assume numerically-int?)] + (core/bit-xor a b))])) ;; ===== Bit-shifts ===== ;; @@ -164,29 +197,29 @@ "Unsigned (logical) bitwise shift left" #?@(:clj [#_([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] (Numeric/bitOr x n)) - ([x p/byte? , n p/integral? > p/byte?] (Numeric/shiftLeft x n)) - ([x p/short? , n p/integral? > p/short?] (Numeric/shiftLeft x n)) + ([x p/byte? , n p/integral? > p/byte?] (Numeric/shiftLeft x n)) + ([x p/short? , n p/integral? > p/short?] (Numeric/shiftLeft x n)) ;; TODO implement this correctly because it likely isn't correct just to do `<<` in Java #_([x p/char? , n p/integral? > p/char?] (Numeric/shiftLeft x n)) - ([x p/int? , n p/integral? > p/int?] (Numeric/shiftLeft x n)) - ([x p/long? , n p/integral? > p/long?] (Numeric/shiftLeft x n)) - ([x p/float? , n p/integral? > p/float?] (Numeric/shiftLeft x n)) - ([x p/double?, n p/integral? > p/double?] (Numeric/shiftLeft x n))] - :cljs [([x p/double?, n t/numerically-integer? > p/double?] (core/bit-shift-left x n))])) + ([x p/int? , n p/integral? > p/int?] (Numeric/shiftLeft x n)) + ([x p/long? , n p/integral? > p/long?] (Numeric/shiftLeft x n)) + ([x p/float? , n p/integral? > p/float?] (Numeric/shiftLeft x n)) + ([x p/double?, n p/integral? > p/double?] (Numeric/shiftLeft x n))] + :cljs [([x p/double?, n std-fixint? > (t/assume numerically-int?)] (core/bit-shift-left x n))])) ;; TODO TYPED we can shorten this by having dependent types (defnt ^:inline >>> "Unsigned (logical) bitwise shift right" #?@(:clj [#_([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] (Numeric/bitOr a b)) - ([x p/byte? , n p/integral? > p/byte?] (Numeric/uShiftRight x n)) - ([x p/short? , n p/integral? > p/short?] (Numeric/uShiftRight x n)) - ([x p/char? , n p/integral? > p/char?] (Numeric/uShiftRight x n)) - ([x p/int? , n p/integral? > p/int?] (Numeric/uShiftRight x n)) - ([x p/long? , n p/integral? > p/long?] (Numeric/uShiftRight x n)) - ([x p/float? , n p/integral? > p/float?] (Numeric/uShiftRight x n)) - ([x p/double?, n p/integral? > p/double?] (Numeric/uShiftRight x n))] - :cljs [([x p/double?, n t/numerically-integer? > p/double?] + ([x p/byte? , n p/integral? > p/byte?] (Numeric/uShiftRight x n)) + ([x p/short? , n p/integral? > p/short?] (Numeric/uShiftRight x n)) + ([x p/char? , n p/integral? > p/char?] (Numeric/uShiftRight x n)) + ([x p/int? , n p/integral? > p/int?] (Numeric/uShiftRight x n)) + ([x p/long? , n p/integral? > p/long?] (Numeric/uShiftRight x n)) + ([x p/float? , n p/integral? > p/float?] (Numeric/uShiftRight x n)) + ([x p/double?, n p/integral? > p/double?] (Numeric/uShiftRight x n))] + :cljs [([x p/double?, n std-fixint? > (t/assume numerically-int?)] (core/unsigned-bit-shift-right x n))])) ;; ----- Arithmetic bit-shifts ----- ;; @@ -196,28 +229,29 @@ "Arithmetic bitwise shift left" #?@(:clj [#_([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] (Numeric/bitOr a b)) - ([x p/byte? , n p/integral? > p/byte?] (Numeric/shiftLeft x n)) - ([x p/short? , n p/integral? > p/short?] (Numeric/shiftLeft x n)) - ([x p/char? , n p/integral? > p/char?] (Numeric/shiftLeft x n)) - ([x p/int? , n p/integral? > p/int?] (Numeric/shiftLeft x n)) - ([x p/long? , n p/integral? > p/long?] (Numeric/shiftLeft x n)) - ([x p/float? , n p/integral? > p/float?] (Numeric/shiftLeft x n)) - ([x p/double?, n p/integral? > p/double?] (Numeric/shiftLeft x n))] - :cljs [([x p/double?, n t/numerically-integer? > p/double?] (core/bit-shift-left x n))])) + ([x p/byte? , n p/integral? > p/byte?] (Numeric/shiftLeft x n)) + ([x p/short? , n p/integral? > p/short?] (Numeric/shiftLeft x n)) + ([x p/char? , n p/integral? > p/char?] (Numeric/shiftLeft x n)) + ([x p/int? , n p/integral? > p/int?] (Numeric/shiftLeft x n)) + ([x p/long? , n p/integral? > p/long?] (Numeric/shiftLeft x n)) + ([x p/float? , n p/integral? > p/float?] (Numeric/shiftLeft x n)) + ([x p/double?, n p/integral? > p/double?] (Numeric/shiftLeft x n))] + :cljs [([x p/double?, n std-fixint? > (t/assume numerically-int?)] (core/bit-shift-left x n))])) ;; TODO TYPED we can shorten this by having dependent types (defnt ^:inline >> "Arithmetic bitwise shift right" #?@(:clj [#_([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] (Numeric/bitOr a b)) - ([x p/byte? , n p/integral? > p/byte?] (Numeric/shiftRight x n)) - ([x p/short? , n p/integral? > p/short?] (Numeric/shiftRight x n)) - ([x p/char? , n p/integral? > p/char?] (Numeric/shiftRight x n)) - ([x p/int? , n p/integral? > p/int?] (Numeric/shiftRight x n)) - ([x p/long? , n p/integral? > p/long?] (Numeric/shiftRight x n)) - ([x p/float? , n p/integral? > p/float?] (Numeric/shiftRight x n)) - ([x p/double?, n p/integral? > p/double?] (Numeric/shiftRight x n))] - :cljs [([x p/double?, n t/numerically-integer? > p/double?] (core/bit-shift-right x n))])) + ([x p/byte? , n p/integral? > p/byte?] (Numeric/shiftRight x n)) + ([x p/short? , n p/integral? > p/short?] (Numeric/shiftRight x n)) + ([x p/char? , n p/integral? > p/char?] (Numeric/shiftRight x n)) + ([x p/int? , n p/integral? > p/int?] (Numeric/shiftRight x n)) + ([x p/long? , n p/integral? > p/long?] (Numeric/shiftRight x n)) + ([x p/float? , n p/integral? > p/float?] (Numeric/shiftRight x n)) + ([x p/double?, n p/integral? > p/double?] (Numeric/shiftRight x n))] + :cljs [([x p/double?, n std-fixint? > (t/assume numerically-int?)] + (core/bit-shift-right x n))])) ;; ===== Single-bit operations ===== ;; @@ -230,14 +264,14 @@ Equivalent to `clojure.core/bit-clear`." {:todo #{"Extend index to non-longs"}} #?@(:clj [#_([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitClear x i)) - ([x p/byte? , i p/long? > p/byte?] (Numeric/bitClear x i)) - ([x p/short? , i p/long? > p/short?] (Numeric/bitClear x i)) - ([x p/char? , i p/long? > p/char?] (Numeric/bitClear x i)) - ([x p/int? , i p/long? > p/int?] (Numeric/bitClear x i)) - ([x p/long? , i p/long? > p/long?] (Numeric/bitClear x i)) - ([x p/float? , i p/long? > p/float?] (Numeric/bitClear x i)) - ([x p/double?, i p/long? > p/double?] (Numeric/bitClear x i))] - :cljs [([x p/double?, i t/numerically-integer? > p/double?] (core/bit-clear x i))])) + ([x p/byte? , i p/long? > p/byte?] (Numeric/bitClear x i)) + ([x p/short? , i p/long? > p/short?] (Numeric/bitClear x i)) + ([x p/char? , i p/long? > p/char?] (Numeric/bitClear x i)) + ([x p/int? , i p/long? > p/int?] (Numeric/bitClear x i)) + ([x p/long? , i p/long? > p/long?] (Numeric/bitClear x i)) + ([x p/float? , i p/long? > p/float?] (Numeric/bitClear x i)) + ([x p/double?, i p/long? > p/double?] (Numeric/bitClear x i))] + :cljs [([x p/double?, i std-fixint? > (t/assume numerically-int?)] (core/bit-clear x i))])) ;; TODO TYPED we can shorten this by having dependent types (defnt ^:inline bit-set-true* @@ -246,14 +280,14 @@ Equivalent to `clojure.core/bit-set`." {:todo #{"Extend index to non-longs"}} #?@(:clj [#_([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitSet x i)) - ([x p/byte? , i p/long? > p/byte?] (Numeric/bitSet x i)) - ([x p/short? , i p/long? > p/short?] (Numeric/bitSet x i)) - ([x p/char? , i p/long? > p/char?] (Numeric/bitSet x i)) - ([x p/int? , i p/long? > p/int?] (Numeric/bitSet x i)) - ([x p/long? , i p/long? > p/long?] (Numeric/bitSet x i)) - ([x p/float? , i p/long? > p/float?] (Numeric/bitSet x i)) - ([x p/double?, i p/long? > p/double?] (Numeric/bitSet x i))] - :cljs [([x p/double?, i t/numerically-integer? > p/double?] (core/bit-set x i))])) + ([x p/byte? , i p/long? > p/byte?] (Numeric/bitSet x i)) + ([x p/short? , i p/long? > p/short?] (Numeric/bitSet x i)) + ([x p/char? , i p/long? > p/char?] (Numeric/bitSet x i)) + ([x p/int? , i p/long? > p/int?] (Numeric/bitSet x i)) + ([x p/long? , i p/long? > p/long?] (Numeric/bitSet x i)) + ([x p/float? , i p/long? > p/float?] (Numeric/bitSet x i)) + ([x p/double?, i p/long? > p/double?] (Numeric/bitSet x i))] + :cljs [([x p/double?, i std/fixint? > (t/assume numerically-int?)] (core/bit-set x i))])) ;; TODO TYPED we can shorten this by having dependent types (defnt ^:inline bit-not* @@ -262,22 +296,23 @@ Equivalent to `clojure.core/bit-flip`." {:todo #{"Extend index to non-longs"}} #?@(:clj [#_([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitFlip x i)) - ([x p/byte? , i p/long? > p/byte?] (Numeric/bitFlip x i)) - ([x p/short? , i p/long? > p/short?] (Numeric/bitFlip x i)) - ([x p/char? , i p/long? > p/char?] (Numeric/bitFlip x i)) - ([x p/int? , i p/long? > p/int?] (Numeric/bitFlip x i)) - ([x p/long? , i p/long? > p/long?] (Numeric/bitFlip x i)) - ([x p/float? , i p/long? > p/float?] (Numeric/bitFlip x i)) - ([x p/double?, i p/long? > p/double?] (Numeric/bitFlip x i))] - :cljs [([x p/double?, i t/numerically-integer? > p/double?] (core/bit-flip x i))])) + ([x p/byte? , i p/long? > p/byte?] (Numeric/bitFlip x i)) + ([x p/short? , i p/long? > p/short?] (Numeric/bitFlip x i)) + ([x p/char? , i p/long? > p/char?] (Numeric/bitFlip x i)) + ([x p/int? , i p/long? > p/int?] (Numeric/bitFlip x i)) + ([x p/long? , i p/long? > p/long?] (Numeric/bitFlip x i)) + ([x p/float? , i p/long? > p/float?] (Numeric/bitFlip x i)) + ([x p/double?, i p/long? > p/double?] (Numeric/bitFlip x i))] + :cljs [([x p/double?, i std-fixint? > (t/assume numerically-int?)] + (core/bit-flip x i))])) (defnt ^:inline bit-true?* "Outputs whether the bit at the provided index ->`i` is `bit-true`. Unchecked w.r.t. the bit index. Equivalent to `clojure.core/bit-test`." {:todo #{"Extend index to non-longs"}} -#?(:clj ([x (t/- p/primitive? p/boolean?), i p/long? > p/boolean?] (Numeric/bitTest x i)) - :cljs ([x p/double?, i t/numerically-integer? > p/boolean?] (core/bit-test x i)))) +#?(:clj ([x (t/- p/primitive? p/boolean?), i p/long? > p/boolean?] (Numeric/bitTest x i)) + :cljs ([x p/double? , i std-fixint? > p/boolean?] (core/bit-test x i)))) (defalias ? test*) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 7f60c9ab..ee6a4246 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -108,6 +108,16 @@ ([x (t/ref float?) > float?] (.floatValue x)) ([x (t/ref double?) > double?] (.doubleValue x)))) +;; ===== Bit lengths ===== ;; + +(var/def boolean-bits "Implementationally might not be bit-manipulable but logically 1 bit" 1) +(def byte-bits 8) +(def short-bits 16) +(def int-bits 32) +(def long-bits 64) +(def float-bits 32) +(def double-bits 64) + ;; ===== Extreme magnitudes and values ===== ;; (t/defn ^:inline >min-magnitude From f9dfab2175f54a7f1972e5f298d8badb58bbe5aa Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 09:46:57 -0600 Subject: [PATCH 418/810] ni-double? = numerically-int-double? --- src/quantum/core/data/numeric.cljc | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/quantum/core/data/numeric.cljc b/src/quantum/core/data/numeric.cljc index 1d321234..64a401cd 100644 --- a/src/quantum/core/data/numeric.cljc +++ b/src/quantum/core/data/numeric.cljc @@ -229,10 +229,12 @@ (def numeric-primitive? p/numeric?) (def numerically-integer-double? (t/and p/double? numerically-integer?)) -(def ni-double? numerically-integer-double?) (def numerically-integer-primitive? (t/and p/primitive? numerically-integer?)) +(def numerically-int-double? (t/and p/double? numerically-int?)) +(def ni-double? numerically-int-double?) + ;; TODO excise? (def std-integer? (t/or integer? #?(:cljs numerically-integer-double?))) From b5ae6ab5837d92f3b633991b41a72ecd1f084b6e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 09:47:07 -0600 Subject: [PATCH 419/810] Refine browser check --- src-untyped/quantum/untyped/core/system.cljc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src-untyped/quantum/untyped/core/system.cljc b/src-untyped/quantum/untyped/core/system.cljc index 32c85e7e..29cdef42 100644 --- a/src-untyped/quantum/untyped/core/system.cljc +++ b/src-untyped/quantum/untyped/core/system.cljc @@ -55,13 +55,13 @@ (.-chrome global) :chrome ; Firefox 1.0+ - (.-InstallTrigger global) + (aget global "InstallTrigger") :firefox ; At least Safari 3+: "[object HTMLElementConstructor]" (-> js/Object .-prototype .-toString (.call (.-HTMLElement global)) (.indexOf "Constructor") - (> 0)) + pos?) :safari ; At least IE6 (-> global .-document .-documentMode) From 6769afa531d3fa2e536a4d7f705579818886e77c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 13:31:29 -0600 Subject: [PATCH 420/810] Add all Java 8 (and many Java 9) intrinsics to todo --- resources-dev/defnt.cljc | 237 ++++++++++++++++++++++++++++++++++++++- 1 file changed, 234 insertions(+), 3 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 70d7cc9a..f45bf93c 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -77,8 +77,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - ? : type inference - use logic programming and variable unification e.g. `?1` `?2` ? - For this situation: `?` is `(t/- dc/counted?)` - ([n dnum/std-integer?, xs dc/counted?] (count xs)) - ([n dnum/std-integer?, xs ?] ...) + ([n dn/std-integer?, xs dc/counted?] (count xs)) + ([n dn/std-integer?, xs ?] ...) - (comp/t== x) - dependent type such that the passed input must be identical to x - Type Logic and Predicates @@ -1010,6 +1010,237 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] Util.equiv(boolean,boolean) - [ ] Util.equiv(double,double) - [ ] Java intrinsics + http://hg.openjdk.java.net/jdk8/jdk8/hotspot/file/87ee5ee27509/src/share/vm/classfile/vmSymbols.hpp + http://hg.openjdk.java.net/jdk9/jdk9/hotspot/file/b756e7a2ec33/src/share/vm/classfile/vmSymbols.hpp + http://hg.openjdk.java.net/jdk10/jdk10/hotspot/file/5ab7a67bc155/src/share/vm/classfile/vmSymbols.hpp + Those marked with a number or numbers mean they are specific to only those JDK versions. + - [ ] .hashCode() > int + - [ ] System.identityHashCode(Object) > int + - [ ] .getClass() > Class + - [ ] .clone() + - [ ] >=9 : .notify() + - [ ] >=9 : .notifyAll() + - [ ] System.currentTimeMillis() > int + - [ ] System.nanoTime() > int + - [ ] Math.abs(double) > double + - [ ] Math.sin(double) > double + - [ ] Math.cos(double) > double + - [ ] Math.tan(double) > double + - [ ] Math.atan2(double, double) > double + - [ ] Math.sqrt(double) > double + - [ ] Math.log(double) > double + - [ ] Math.log10(double) > double + - [ ] Math.pow(double, double) > double + - [ ] Math.exp(double) > double + - [ ] Math.min(int, int) > int + - [ ] Math.max(int, int) > int + - [ ] Math.addExact(int, int) > int + - [ ] Math.addExact(long, long) > long + - [ ] Math.decrementExact(int) > int + - [ ] Math.decrementExact(long, long) > long + - [ ] Math.incrementExact(int) > int + - [ ] Math.incrementExact(long, long) > long + - [ ] Math.multiplyExact(int, int) > int + - [ ] Math.multiplyExact(long, long) > long + - [ ] Math.negateExact(int) > int + - [ ] Math.negateExact(long) > long + - [ ] Math.subtractExact(int, int) > int + - [ ] Math.subtractExact(long, long) > long + - [ ] >=9 : Math.fma(float, float, float) > float + - [ ] >=9 : Math.fma(double, double, double) > double + - [ ] Float.floatToRawIntBits(float) > int + - [ ] Float.floatToIntBits(float) > int + - [ ] Float.intBitsToFloat(int) > float + - [ ] Double.doubleToRawLongBits(double) > long + - [ ] Double.doubleToLongBits(double) > long + - [ ] Double.longBitsToDouble(long) > double + - [ ] Integer.numberOfLeadingZeros(int) > int + - [ ] Long.numberOfLeadingZeros(long) > long + - [ ] Integer.numberOfTrailingZeros(int) > int + - [ ] Long.numberOfTrailingZeros(long) > long + - [ ] Integer.bitCount(int) > int + - [ ] Long.bitCount(long) > int + - [ ] Short.reverseBytes(short) > short + - [ ] Character.reverseBytes(char) > char + - [ ] Integer.reverseBytes(int) > int + - [ ] Long.reverseBytes(long) > long + - [ ] System.arrayCopy(objects, int, objects, int, int) + - [ ] .getComponentType() > Class + - [ ] .getModifiers() > int + - [ ] .getSuperclass() > Class + - [ ] .isArray() > boolean + - [ ] .isAssignableFrom(Class) > boolean + - [ ] .isInstance(Class) > boolean + - [ ] .isInterface() > boolean + - [ ] .isPrimitive() > boolean + - [ ] >=9 : .cast(Object) > Object + - [ ] java.lang.reflect.Array.getLength(Object) > int + - [ ] java.lang.reflect.Array.newArray(Class, int) > Object + - [ ] .checkIndex(int) > int + - [ ] >=9 : jdk.internal.util.Preconditions.checkIndex(int, int, java.util.function.BiFunction) > int + - [ ] java.util.Arrays.copyOf(objects, int, Class) > objects + - [ ] java.util.Arrays.copyOfRange(objects, int, int, Class) > objects + - [ ] java.util.Arrays.equals(chars, chars) > boolean + - [ ] .compareTo(String) > int + - [ ] .equals(Object) > boolean + - [ ] .indexOf(String) > int + - [ ] sun.nio.cs.ISO_8859_1$Encoder.encodeISOArray(chars, int, bytes, int, int) > int + - [ ] sun.reflect.Reflection.getCallerClass() > Class + - [ ] sun.reflect.Reflection.getClassAccessFlags(Class) > int + - [ ] Thread.currentThread() > Thread + - [ ] Thread.isInterrupted(boolean) > boolean + - [ ] >=9 : Thread.onSpinWait() + + - [ ] .get() > Object + - [ ] .decryptBlock(bytes, int, bytes, int) + - [ ] .encryptBlock(bytes, int, bytes, int) + - [ ] .decrypt(bytes, int, int, bytes, int) + - [ ] .encrypt(bytes, int, int, bytes, int) + - [ ] .update(int, int) > int + - [ ] .updateByteBuffer(int, long, int, int) > int + - [ ] .updateBytes(int, bytes, int, int) > int + - [ ] .allocateInstance(Class) > Object + - [ ] .copyMemory(Object, long, Object, long, long) + - [ ] .park(boolean, long) + - [ ] .unpark(Object) + - [ ] .loadFence() + - [ ] .storeFence() + - [ ] .fullFence() + - [ ] .getObject (Object, long ) > Object + - [ ] .putObject (Object, long, Object ) + - [ ] .getBoolean(Object, long ) > boolean + - [ ] .putBoolean(Object, long, boolean) + - [ ] .getByte (Object, long ) > byte + - [ ] .putByte (Object, long, byte ) + - [ ] .getShort (Object, long ) > short + - [ ] .putShort (Object, long, short ) + - [ ] .getChar (Object, long ) > char + - [ ] .putChar (Object, long, char ) + - [ ] .getInt (Object, long ) > int + - [ ] .putInt (Object, long, int ) + - [ ] .getLong (Object, long ) > long + - [ ] .putLong (Object, long, long ) + - [ ] .getFloat (Object, long ) > float + - [ ] .putFloat (Object, long, float ) + - [ ] .getDouble (Object, long ) > double + - [ ] .putDouble (Object, long, double ) + - [ ] .getObjectVolatile (Object, long ) > Object + - [ ] .putObjectVolatile (Object, long, Object ) + - [ ] .getBooleanVolatile(Object, long ) > boolean + - [ ] .putBooleanVolatile(Object, long, boolean) + - [ ] .getByteVolatile (Object, long ) > byte + - [ ] .putByteVolatile (Object, long, byte ) + - [ ] .getShortVolatile (Object, long ) > short + - [ ] .putShortVolatile (Object, long, short ) + - [ ] .getCharVolatile (Object, long ) > char + - [ ] .putCharVolatile (Object, long, char ) + - [ ] .getIntVolatile (Object, long ) > int + - [ ] .putIntVolatile (Object, long, int ) + - [ ] .getLongVolatile (Object, long ) > long + - [ ] .putLongVolatile (Object, long, long ) + - [ ] .getFloatVolatile (Object, long ) > float + - [ ] .putFloatVolatile (Object, long, float ) + - [ ] .getDoubleVolatile (Object, long ) > double + - [ ] .putDoubleVolatile (Object, long, double ) + - [ ] .getObject (long ) > Object + - [ ] .putObject (long, Object ) + - [ ] .getBoolean(long ) > boolean + - [ ] .putBoolean(long, boolean) + - [ ] .getByte (long ) > byte + - [ ] .putByte (long, byte ) + - [ ] .getShort (long ) > short + - [ ] .putShort (long, short ) + - [ ] .getChar (long ) > char + - [ ] .putChar (long, char ) + - [ ] .getInt (long ) > int + - [ ] .putInt (long, int ) + - [ ] .getLong (long ) > long + - [ ] .putLong (long, long ) + - [ ] .getFloat (long ) > float + - [ ] .putFloat (long, float ) + - [ ] .getDouble (long ) > double + - [ ] .putDouble (long, double ) + - [ ] .getAddress(long ) > long + - [ ] .putAddress(long, long ) + - [ ] .compareAndSwapInt (Object, long, int , int ) > boolean + - [ ] .compareAndSwapLong (Object, long, long , long ) > boolean + - [ ] .compareAndSwapObject(Object, long, Object, Object) > boolean + - [ ] .putOrderedInt (Object, long, int) + - [ ] .putOrderedLong (Object, long, long) + - [ ] .putOrderedObject (Object, long, Object) + - [ ] .getAndAddInt (Object, long, int ) > int + - [ ] .getAndAddLong (Object, long, long ) > long + - [ ] .getAndSetInt (Object, long, int ) > int + - [ ] .getAndSetLong (Object, long, long ) > long + - [ ] .getAndSetObject (Object, long, Object) > Object + - [ ] .prefetchRead (Object, long) + - [ ] .prefetchWrite (Object, long) + - [ ] .prefetchReadStatic (Object, long) + - [ ] .prefetchWriteStatic (Object, long) + - [ ] .fillInStackTrace() > Throwable + - [ ] >=9 : StringUTF16.compress(chars, int, bytes, int, int) > int + - [ ] >=9 : StringUTF16.compress(bytes, int, bytes, int, int) > int + - [ ] >=9 : StringLatin1.inflate(bytes, int, chars, int, int) + - [ ] >=9 : StringLatin1.inflate(bytes, int, bytes, int, int) + - [ ] >=9 : StringUTF16.toBytes(chars, int, int) > bytes + - [ ] >=9 : StringUTF16.getChars(bytes, int, int, chars, int) + - [ ] >=9 : StringUTF16.getChar(bytes, int) > char + - [ ] >=9 : StringUTF16.putChar(bytes, int, int) + - [ ] >=9 : StringLatin1.compareTo(bytes, bytes) > int + - [ ] >=9 : StringUTF16.compareTo(bytes, bytes) > int + - [ ] >=9 : StringLatin1.compareToUTF16(bytes, bytes) > int + - [ ] >=9 : StringUTF16.compareToLatin1(bytes, bytes) > int + - [ ] >=9 : StringLatin1.indexOf(bytes, bytes) > int + - [ ] >=9 : StringUTF16.indexOf(bytes, bytes) > int + - [ ] >=9 : StringUTF16.indexOfLatin1(bytes, bytes) > int + - [ ] >=9 : StringLatin1.indexOf(bytes, int, bytes, int, int) > int + - [ ] >=9 : StringUTF16.indexOf(bytes, int, bytes, int, int) > int + - [ ] >=9 : StringUTF16.indexOfLatin1(bytes, int, bytes, int, int) > int + - [ ] >=9 : StringUTF16.indexOfChar(bytes, int, int, int) > int + - [ ] >=9 : StringLatin1.equals(bytes, bytes) > boolean + - [ ] >=9 : StringUTF16.equals(bytes, bytes) > boolean + - [ ] new StringBuilder() + - [ ] new StringBuilder(int) + - [ ] new StringBuilder(String) + - [ ] .append(char) > StringBuilder + - [ ] .append(int) > StringBuilder + - [ ] .append(String) > StringBuilder + - [ ] .toString() > String + - [ ] new StringBuffer() + - [ ] new StringBuffer(int) + - [ ] new StringBuffer(String) + - [ ] .append(char) > StringBuffer + - [ ] .append(int) > StringBuffer + - [ ] .append(String) > StringBuffer + - [ ] .toString() > String + - [ ] Integer.toString(int) > String + - [ ] new String(String) + - [ ] new Object() + - [ ] .invoke(Object, objects) > Object + - [ ] .invoke(*) + - [ ] .invokeBasic(*) + - [ ] java.lang.invoke.MethodHandle.invokeVirtual(*) + - [ ] java.lang.invoke.MethodHandle.linkToVirtual(*) + - [ ] java.lang.invoke.MethodHandle.linkToStatic(*) + - [ ] java.lang.invoke.MethodHandle.linkToSpecial(*) + - [ ] java.lang.invoke.MethodHandle.linkToInterface(*) + - [x] .booleanValue() > boolean + - [x] .byteValue () > byte + - [x] .shortValue () > short + - [x] .charValue () > char + - [x] .intValue () > int + - [x] .longValue () > long + - [x] .floatValue () > float + - [x] .doubleValue () > double + - [x] Boolean .valueOf(boolean) > Boolean + - [x] Byte .valueOf(byte ) > Byte + - [x] Short .valueOf(short ) > Short + - [x] Character.valueOf(char ) > Character + - [x] Integer .valueOf(int ) > Integer + - [x] Long .valueOf(long ) > Long + - [x] Float .valueOf(float ) > Float + - [x] Double .valueOf(double ) > Double + - [ ] >=9 : .forEachRemaining(java.util.function.IntConsumer) - [.] clojure.lang.RT https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/RT.java - [ ] aclone @@ -1233,7 +1464,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [.] quantum.core.refs -> quantum.core.data.refs ? - [ ] quantum.core.logic - (def nneg? (l/fn-not neg?)) - - (def pos-int? (l/fn-and dnum/integer? pos?)) + - (def pos-int? (l/fn-and dn/integer? pos?)) - [.] quantum.core.fn - [ ] `apply` - especially with `t/defn` as the caller From 525c309111a5c85663a6a94ed22fd387cfa8fa16 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 14:10:11 -0600 Subject: [PATCH 421/810] Add JDK intrinsics todos for all JDK 9 --- resources-dev/defnt.cljc | 306 ++++++++++++++++++++++++++++----------- 1 file changed, 219 insertions(+), 87 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index f45bf93c..a0029a18 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -1014,6 +1014,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative http://hg.openjdk.java.net/jdk9/jdk9/hotspot/file/b756e7a2ec33/src/share/vm/classfile/vmSymbols.hpp http://hg.openjdk.java.net/jdk10/jdk10/hotspot/file/5ab7a67bc155/src/share/vm/classfile/vmSymbols.hpp Those marked with a number or numbers mean they are specific to only those JDK versions. + Only starts at Java 8. + Unsafe = sun.misc.Unsafe for Java 8 + Unsafe = jdk.internal.misc.Unsafe for Java >= 9 - [ ] .hashCode() > int - [ ] System.identityHashCode(Object) > int - [ ] .getClass() > Class @@ -1048,6 +1051,11 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] Math.subtractExact(long, long) > long - [ ] >=9 : Math.fma(float, float, float) > float - [ ] >=9 : Math.fma(double, double, double) > double + - [ ] >=9 : BigInteger.implMultiplyToLen(ints, int, ints, int, ints) > ints + - [ ] >=9 : BigInteger.implSquareToLen(ints, int, ints, int) > ints + - [ ] >=9 : BigInteger.implMulAdd(ints, ints, int, int, int) > int + - [ ] >=9 : BigInteger.implMontgomeryMultiply(ints, ints, ints, int, long, ints) > ints + - [ ] >=9 : BigInteger.implMontgomerySquare(ints, ints, int, long, ints) > ints - [ ] Float.floatToRawIntBits(float) > int - [ ] Float.floatToIntBits(float) > int - [ ] Float.intBitsToFloat(int) > float @@ -1081,103 +1089,222 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] java.util.Arrays.copyOf(objects, int, Class) > objects - [ ] java.util.Arrays.copyOfRange(objects, int, int, Class) > objects - [ ] java.util.Arrays.equals(chars, chars) > boolean + - [ ] java.util.ArraysSupport.vectorizedMismatch(Object, long, Object, long, int, int) > int - [ ] .compareTo(String) > int - [ ] .equals(Object) > boolean - [ ] .indexOf(String) > int - - [ ] sun.nio.cs.ISO_8859_1$Encoder.encodeISOArray(chars, int, bytes, int, int) > int - [ ] sun.reflect.Reflection.getCallerClass() > Class - [ ] sun.reflect.Reflection.getClassAccessFlags(Class) > int - [ ] Thread.currentThread() > Thread - [ ] Thread.isInterrupted(boolean) > boolean - [ ] >=9 : Thread.onSpinWait() - - [ ] .get() > Object - - [ ] .decryptBlock(bytes, int, bytes, int) - - [ ] .encryptBlock(bytes, int, bytes, int) - - [ ] .decrypt(bytes, int, int, bytes, int) - - [ ] .encrypt(bytes, int, int, bytes, int) + - [ ] 8 : .decryptBlock(bytes, int, bytes, int) + - [ ] 8 : .encryptBlock(bytes, int, bytes, int) + - [ ] >=9 : .implDecryptBlock(bytes, int, bytes, int) + - [ ] >=9 : .implEncryptBlock(bytes, int, bytes, int) + - [ ] 8 : .decrypt(bytes, int, int, bytes, int) + - [ ] 8 : .encrypt(bytes, int, int, bytes, int) + - [ ] >=9 : .implDecrypt(bytes, int, int, bytes, int) + - [ ] >=9 : .implEncrypt(bytes, int, int, bytes, int) + - [ ] >=9 : .implCrypt(bytes, int, int, bytes, int) > int + - [ ] >=9 : .implCompress0(bytes, int) + - [ ] >=9 : .implCompress0(bytes, int) + - [ ] >=9 : .implCompress0(bytes, int) + - [ ] >=9 : .implCompressMultiBlock0(bytes, int, int) > int + - [ ] >=9 : com.sun.crypto.provider.GHASH.processBlocks(bytes, int, int, longs, longs) - [ ] .update(int, int) > int - - [ ] .updateByteBuffer(int, long, int, int) > int - - [ ] .updateBytes(int, bytes, int, int) > int - - [ ] .allocateInstance(Class) > Object - - [ ] .copyMemory(Object, long, Object, long, long) - - [ ] .park(boolean, long) - - [ ] .unpark(Object) - - [ ] .loadFence() - - [ ] .storeFence() - - [ ] .fullFence() - - [ ] .getObject (Object, long ) > Object - - [ ] .putObject (Object, long, Object ) - - [ ] .getBoolean(Object, long ) > boolean - - [ ] .putBoolean(Object, long, boolean) - - [ ] .getByte (Object, long ) > byte - - [ ] .putByte (Object, long, byte ) - - [ ] .getShort (Object, long ) > short - - [ ] .putShort (Object, long, short ) - - [ ] .getChar (Object, long ) > char - - [ ] .putChar (Object, long, char ) - - [ ] .getInt (Object, long ) > int - - [ ] .putInt (Object, long, int ) - - [ ] .getLong (Object, long ) > long - - [ ] .putLong (Object, long, long ) - - [ ] .getFloat (Object, long ) > float - - [ ] .putFloat (Object, long, float ) - - [ ] .getDouble (Object, long ) > double - - [ ] .putDouble (Object, long, double ) - - [ ] .getObjectVolatile (Object, long ) > Object - - [ ] .putObjectVolatile (Object, long, Object ) - - [ ] .getBooleanVolatile(Object, long ) > boolean - - [ ] .putBooleanVolatile(Object, long, boolean) - - [ ] .getByteVolatile (Object, long ) > byte - - [ ] .putByteVolatile (Object, long, byte ) - - [ ] .getShortVolatile (Object, long ) > short - - [ ] .putShortVolatile (Object, long, short ) - - [ ] .getCharVolatile (Object, long ) > char - - [ ] .putCharVolatile (Object, long, char ) - - [ ] .getIntVolatile (Object, long ) > int - - [ ] .putIntVolatile (Object, long, int ) - - [ ] .getLongVolatile (Object, long ) > long - - [ ] .putLongVolatile (Object, long, long ) - - [ ] .getFloatVolatile (Object, long ) > float - - [ ] .putFloatVolatile (Object, long, float ) - - [ ] .getDoubleVolatile (Object, long ) > double - - [ ] .putDoubleVolatile (Object, long, double ) - - [ ] .getObject (long ) > Object - - [ ] .putObject (long, Object ) - - [ ] .getBoolean(long ) > boolean - - [ ] .putBoolean(long, boolean) - - [ ] .getByte (long ) > byte - - [ ] .putByte (long, byte ) - - [ ] .getShort (long ) > short - - [ ] .putShort (long, short ) - - [ ] .getChar (long ) > char - - [ ] .putChar (long, char ) - - [ ] .getInt (long ) > int - - [ ] .putInt (long, int ) - - [ ] .getLong (long ) > long - - [ ] .putLong (long, long ) - - [ ] .getFloat (long ) > float - - [ ] .putFloat (long, float ) - - [ ] .getDouble (long ) > double - - [ ] .putDouble (long, double ) - - [ ] .getAddress(long ) > long - - [ ] .putAddress(long, long ) - - [ ] .compareAndSwapInt (Object, long, int , int ) > boolean - - [ ] .compareAndSwapLong (Object, long, long , long ) > boolean - - [ ] .compareAndSwapObject(Object, long, Object, Object) > boolean - - [ ] .putOrderedInt (Object, long, int) - - [ ] .putOrderedLong (Object, long, long) - - [ ] .putOrderedObject (Object, long, Object) - - [ ] .getAndAddInt (Object, long, int ) > int - - [ ] .getAndAddLong (Object, long, long ) > long - - [ ] .getAndSetInt (Object, long, int ) > int - - [ ] .getAndSetLong (Object, long, long ) > long - - [ ] .getAndSetObject (Object, long, Object) > Object - - [ ] .prefetchRead (Object, long) - - [ ] .prefetchWrite (Object, long) - - [ ] .prefetchReadStatic (Object, long) - - [ ] .prefetchWriteStatic (Object, long) - - [ ] .fillInStackTrace() > Throwable + - [ ] 8 : java.util.zip.CRC32.updateByteBuffer(int, long, int, int) > int + - [ ] >=9 : java.util.zip.CRC32.updateByteBuffer0(int, long, int, int) > int + - [ ] 8 : java.util.zip.CRC32.updateBytes(int, bytes, int, int) > int + - [ ] >=9 : java.util.zip.CRC32.updateBytes0(int, bytes, int, int) > int + - [ ] >=9 : java.util.zip.CRC32C.updateBytes(int, bytes, int, int) > int + - [ ] >=9 : java.util.zip.CRC32C.updateDirectByteBuffer(int, long, int, int) > int + - [ ] >=9 : java.util.zip.Adler32.updateBytes(int, bytes, int, int) > int + - [ ] >=9 : java.util.zip.Adler32.updateByteBuffer(int, long, int, int) > int + - [ ] .allocateInstance(Class) > Object + - [ ] >=9 : .allocateUninitializedArray0(Class, int) > Object + - [ ] 8 : .copyMemory(Object, long, Object, long, long) + - [ ] >=9 : .copyMemory0(Object, long, Object, long, long) + - [ ] .park(boolean, long) + - [ ] .unpark(Object) + - [ ] .loadFence() + - [ ] .storeFence() + - [ ] .fullFence() + - [ ] .getObject (Object, long ) > Object + - [ ] .putObject (Object, long, Object ) + - [ ] .getBoolean(Object, long ) > boolean + - [ ] .putBoolean(Object, long, boolean) + - [ ] .getByte (Object, long ) > byte + - [ ] .putByte (Object, long, byte ) + - [ ] .getShort (Object, long ) > short + - [ ] .putShort (Object, long, short ) + - [ ] .getChar (Object, long ) > char + - [ ] .putChar (Object, long, char ) + - [ ] .getInt (Object, long ) > int + - [ ] .putInt (Object, long, int ) + - [ ] .getLong (Object, long ) > long + - [ ] .putLong (Object, long, long ) + - [ ] .getFloat (Object, long ) > float + - [ ] .putFloat (Object, long, float ) + - [ ] .getDouble (Object, long ) > double + - [ ] .putDouble (Object, long, double ) + - [ ] .getObjectVolatile (Object, long ) > Object + - [ ] .putObjectVolatile (Object, long, Object ) + - [ ] .getBooleanVolatile(Object, long ) > boolean + - [ ] .putBooleanVolatile(Object, long, boolean) + - [ ] .getByteVolatile (Object, long ) > byte + - [ ] .putByteVolatile (Object, long, byte ) + - [ ] .getShortVolatile (Object, long ) > short + - [ ] .putShortVolatile (Object, long, short ) + - [ ] .getCharVolatile (Object, long ) > char + - [ ] .putCharVolatile (Object, long, char ) + - [ ] .getIntVolatile (Object, long ) > int + - [ ] .putIntVolatile (Object, long, int ) + - [ ] .getLongVolatile (Object, long ) > long + - [ ] .putLongVolatile (Object, long, long ) + - [ ] .getFloatVolatile (Object, long ) > float + - [ ] .putFloatVolatile (Object, long, float ) + - [ ] .getDoubleVolatile (Object, long ) > double + - [ ] .putDoubleVolatile (Object, long, double ) + - [ ] .getObjectVolatile (Object, long ) > Object + - [ ] .putObjectVolatile (Object, long, Object ) + - [ ] >=9 : .getBooleanOpaque (Object, long ) > boolean + - [ ] >=9 : .putBooleanOpaque (Object, long, boolean) + - [ ] >=9 : .getByteOpaque (Object, long ) > byte + - [ ] >=9 : .putByteOpaque (Object, long, byte ) + - [ ] >=9 : .getShortOpaque (Object, long ) > short + - [ ] >=9 : .putShortOpaque (Object, long, short ) + - [ ] >=9 : .getCharOpaque (Object, long ) > char + - [ ] >=9 : .putCharOpaque (Object, long, char ) + - [ ] >=9 : .getIntOpaque (Object, long ) > int + - [ ] >=9 : .putIntOpaque (Object, long, int ) + - [ ] >=9 : .getLongOpaque (Object, long ) > long + - [ ] >=9 : .putLongOpaque (Object, long, long ) + - [ ] >=9 : .getFloatOpaque (Object, long ) > float + - [ ] >=9 : .putFloatOpaque (Object, long, float ) + - [ ] >=9 : .getDoubleOpaque (Object, long ) > double + - [ ] >=9 : .putDoubleOpaque (Object, long, double ) + - [ ] >=9 : .getBooleanRelease(Object, long ) > boolean + - [ ] >=9 : .putBooleanRelease(Object, long, boolean) + - [ ] >=9 : .getByteRelease (Object, long ) > byte + - [ ] >=9 : .putByteRelease (Object, long, byte ) + - [ ] >=9 : .getShortRelease (Object, long ) > short + - [ ] >=9 : .putShortRelease (Object, long, short ) + - [ ] >=9 : .getCharRelease (Object, long ) > char + - [ ] >=9 : .putCharRelease (Object, long, char ) + - [ ] >=9 : .getIntRelease (Object, long ) > int + - [ ] >=9 : .putIntRelease (Object, long, int ) + - [ ] >=9 : .getLongRelease (Object, long ) > long + - [ ] >=9 : .putLongRelease (Object, long, long ) + - [ ] >=9 : .getFloatRelease (Object, long ) > float + - [ ] >=9 : .putFloatRelease (Object, long, float ) + - [ ] >=9 : .getDoubleRelease (Object, long ) > double + - [ ] >=9 : .putDoubleRelease (Object, long, double ) + - [ ] >=9 : .getBooleanAcquire(Object, long ) > boolean + - [ ] >=9 : .putBooleanAcquire(Object, long, boolean) + - [ ] >=9 : .getByteAcquire (Object, long ) > byte + - [ ] >=9 : .putByteAcquire (Object, long, byte ) + - [ ] >=9 : .getShortAcquire (Object, long ) > short + - [ ] >=9 : .putShortAcquire (Object, long, short ) + - [ ] >=9 : .getCharAcquire (Object, long ) > char + - [ ] >=9 : .putCharAcquire (Object, long, char ) + - [ ] >=9 : .getIntAcquire (Object, long ) > int + - [ ] >=9 : .putIntAcquire (Object, long, int ) + - [ ] >=9 : .getLongAcquire (Object, long ) > long + - [ ] >=9 : .putLongAcquire (Object, long, long ) + - [ ] >=9 : .getFloatAcquire (Object, long ) > float + - [ ] >=9 : .putFloatAcquire (Object, long, float ) + - [ ] >=9 : .getDoubleAcquire (Object, long ) > double + - [ ] >=9 : .putDoubleAcquire (Object, long, double ) + - [ ] >=9 : .getShortUnaligned(Object, long ) > short + - [ ] >=9 : .putShortUnaligned(Object, long, short ) + - [ ] >=9 : .getCharUnaligned (Object, long ) > char + - [ ] >=9 : .putCharUnaligned (Object, long, char ) + - [ ] >=9 : .getIntUnaligned (Object, long ) > int + - [ ] >=9 : .putIntUnaligned (Object, long, int ) + - [ ] >=9 : .getLongUnaligned (Object, long ) > long + - [ ] >=9 : .putLongUnaligned (Object, long, long ) + - [ ] 8 : .getObject (long ) > Object + - [ ] 8 : .putObject (long, Object ) + - [ ] 8 : .getBoolean(long ) > boolean + - [ ] 8 : .putBoolean(long, boolean) + - [ ] 8 : .getByte (long ) > byte + - [ ] 8 : .putByte (long, byte ) + - [ ] 8 : .getShort (long ) > short + - [ ] 8 : .putShort (long, short ) + - [ ] 8 : .getChar (long ) > char + - [ ] 8 : .putChar (long, char ) + - [ ] 8 : .getInt (long ) > int + - [ ] 8 : .putInt (long, int ) + - [ ] 8 : .getLong (long ) > long + - [ ] 8 : .putLong (long, long ) + - [ ] 8 : .getFloat (long ) > float + - [ ] 8 : .putFloat (long, float ) + - [ ] 8 : .getDouble (long ) > double + - [ ] 8 : .putDouble (long, double ) + - [ ] 8 : .getAddress(long ) > long + - [ ] 8 : .putAddress(long, long ) + - [ ] 8 : .compareAndSwapInt (Object, long, int , int ) > boolean + - [ ] 8 : .compareAndSwapLong (Object, long, long , long ) > boolean + - [ ] 8 : .compareAndSwapObject(Object, long, Object, Object) > boolean + - [ ] 8 : .putOrderedInt (Object, long, int) + - [ ] 8 : .putOrderedLong (Object, long, long) + - [ ] 8 : .putOrderedObject (Object, long, Object) + - [ ] >=9 : .compareAndSetByte (Object, long, byte , byte ) > boolean + - [ ] >=9 : .weakCompareAndSetByte (Object, long, byte , byte ) > boolean + - [ ] >=9 : .weakCompareAndSetBytePlain (Object, long, byte , byte ) > boolean + - [ ] >=9 : .weakCompareAndSetByteAcquire (Object, long, byte , byte ) > boolean + - [ ] >=9 : .weakCompareAndSetByteRelease (Object, long, byte , byte ) > boolean + - [ ] >=9 : .compareAndExchangeByte (Object, long, byte , byte ) > byte + - [ ] >=9 : .compareAndExchangeByteAcquire (Object, long, byte , byte ) > byte + - [ ] >=9 : .compareAndExchangeByteRelease (Object, long, byte , byte ) > byte + - [ ] >=9 : .compareAndSetShort (Object, long, short , short ) > boolean + - [ ] >=9 : .weakCompareAndSetShort (Object, long, short , short ) > boolean + - [ ] >=9 : .weakCompareAndSetShortPlain (Object, long, short , short ) > boolean + - [ ] >=9 : .weakCompareAndSetShortAcquire (Object, long, short , short ) > boolean + - [ ] >=9 : .weakCompareAndSetShortRelease (Object, long, short , short ) > boolean + - [ ] >=9 : .compareAndExchangeShort (Object, long, short , short ) > short + - [ ] >=9 : .compareAndExchangeShortAcquire (Object, long, short , short ) > short + - [ ] >=9 : .compareAndExchangeShortRelease (Object, long, short , short ) > short + - [ ] >=9 : .compareAndSetInt (Object, long, int , int ) > boolean + - [ ] >=9 : .weakCompareAndSetInt (Object, long, int , int ) > boolean + - [ ] >=9 : .weakCompareAndSetIntPlain (Object, long, int , int ) > boolean + - [ ] >=9 : .weakCompareAndSetIntAcquire (Object, long, int , int ) > boolean + - [ ] >=9 : .weakCompareAndSetIntRelease (Object, long, int , int ) > boolean + - [ ] >=9 : .compareAndExchangeInt (Object, long, int , int ) > int + - [ ] >=9 : .compareAndExchangeIntAcquire (Object, long, int , int ) > int + - [ ] >=9 : .compareAndExchangeIntRelease (Object, long, int , int ) > int + - [ ] >=9 : .compareAndSetLong (Object, long, long , long ) > boolean + - [ ] >=9 : .weakCompareAndSetLong (Object, long, long , long ) > boolean + - [ ] >=9 : .weakCompareAndSetLongPlain (Object, long, long , long ) > boolean + - [ ] >=9 : .weakCompareAndSetLongAcquire (Object, long, long , long ) > boolean + - [ ] >=9 : .weakCompareAndSetLongRelease (Object, long, long , long ) > boolean + - [ ] >=9 : .compareAndExchangeLong (Object, long, long , long ) > long + - [ ] >=9 : .compareAndExchangeLongAcquire (Object, long, long , long ) > long + - [ ] >=9 : .compareAndExchangeLongRelease (Object, long, long , long ) > long + - [ ] >=9 : .compareAndSetObject (Object, long, Object, Object) > boolean + - [ ] >=9 : .weakCompareAndSetObject (Object, long, Object, Object) > boolean + - [ ] >=9 : .weakCompareAndSetObjectPlain (Object, long, Object, Object) > boolean + - [ ] >=9 : .weakCompareAndSetObjectAcquire (Object, long, Object, Object) > boolean + - [ ] >=9 : .weakCompareAndSetObjectRelease (Object, long, Object, Object) > boolean + - [ ] >=9 : .compareAndExchangeObject (Object, long, Object, Object) > Object + - [ ] >=9 : .compareAndExchangeObjectAcquire(Object, long, Object, Object) > Object + - [ ] >=9 : .compareAndExchangeObjectRelease(Object, long, Object, Object) > Object + - [ ] >=9 : .getAndAddByte (Object, long, byte ) > byte + - [ ] >=9 : .getAndAddShort (Object, long, short ) > short + - [ ] .getAndAddInt (Object, long, int ) > int + - [ ] .getAndAddLong (Object, long, long ) > long + - [ ] >=9 : .getAndSetByte (Object, long, byte ) > byte + - [ ] >=9 : .getAndSetShort (Object, long, short ) > short + - [ ] .getAndSetInt (Object, long, int ) > int + - [ ] .getAndSetLong (Object, long, long ) > long + - [ ] .getAndSetObject(Object, long, Object) > Object + - [ ] 8 : .prefetchRead (Object, long) + - [ ] 8 : .prefetchWrite (Object, long) + - [ ] 8 : .prefetchReadStatic (Object, long) + - [ ] 8 : .prefetchWriteStatic(Object, long) + - [ ] 8 : .fillInStackTrace() > Throwable - [ ] >=9 : StringUTF16.compress(chars, int, bytes, int, int) > int - [ ] >=9 : StringUTF16.compress(bytes, int, bytes, int, int) > int - [ ] >=9 : StringLatin1.inflate(bytes, int, chars, int, int) @@ -1199,6 +1326,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] >=9 : StringUTF16.indexOfChar(bytes, int, int, int) > int - [ ] >=9 : StringLatin1.equals(bytes, bytes) > boolean - [ ] >=9 : StringUTF16.equals(bytes, bytes) > boolean + - [ ] >=9 : StringCoding.hasNegatives(bytes, int, int) > boolean + - [ ] sun.nio.cs.ISO_8859_1$Encoder.encodeISOArray(chars, int, bytes, int, int) > int + - [ ] >=9 : StringCoding.encodeISOArray(bytes, int, bytes, int, int) > int - [ ] new StringBuilder() - [ ] new StringBuilder(int) - [ ] new StringBuilder(String) @@ -1224,6 +1354,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] java.lang.invoke.MethodHandle.linkToStatic(*) - [ ] java.lang.invoke.MethodHandle.linkToSpecial(*) - [ ] java.lang.invoke.MethodHandle.linkToInterface(*) + - [ ] >=9 : java.lang.invoke.MethodHandleImpl.profileBoolean(boolean, ints) > boolean + - [ ] >=9 : java.lang.invoke.MethodHandleImpl.isCompileConstant(object) > boolean - [x] .booleanValue() > boolean - [x] .byteValue () > byte - [x] .shortValue () > short From 9cb9bcf3863cb930d4e831927fcf459da7d91c0c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 14:13:06 -0600 Subject: [PATCH 422/810] Add note about Java 10 intrinsics --- resources-dev/defnt.cljc | 1 + 1 file changed, 1 insertion(+) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index a0029a18..b50705cf 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -1015,6 +1015,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative http://hg.openjdk.java.net/jdk10/jdk10/hotspot/file/5ab7a67bc155/src/share/vm/classfile/vmSymbols.hpp Those marked with a number or numbers mean they are specific to only those JDK versions. Only starts at Java 8. + Note that Java 10 didn't add any intrinsics. Unsafe = sun.misc.Unsafe for Java 8 Unsafe = jdk.internal.misc.Unsafe for Java >= 9 - [ ] .hashCode() > int From 4e5220eee2273236f80e4ce4ba6f6b69bf93484e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:12:04 -0600 Subject: [PATCH 423/810] Add test for `abs` --- benchmarks/jvm.clj | 88 ++++++++++++++++++++++++++-------------------- 1 file changed, 49 insertions(+), 39 deletions(-) diff --git a/benchmarks/jvm.clj b/benchmarks/jvm.clj index 55006db5..abe8d80a 100644 --- a/benchmarks/jvm.clj +++ b/benchmarks/jvm.clj @@ -16,6 +16,10 @@ [java.util Map HashMap IdentityHashMap] [java.lang.invoke MethodHandle MethodHandles MethodType])) +;; To avoid extraneous overhead from a loop +(defmacro repeat-test [n expr] + `(do ~@(for [i (range n)] expr))) + ; TODO try to use static methods instead of `invokevirtual` on the `reify`? ; ===== STATIC ===== ; @@ -579,57 +583,63 @@ (doto (.setAccessible true)) (.get nil))) -;; allocating one byte of off-heap memory: avg 90.23 ns +;; Allocating one byte of off-heap memory: avg 91.902 ns ;; NOTE: This benchmark will allocate a lot of memory that won't be reclaimed till process killed ;; In one case with 161031248 calls it allocated 161031248/1024/1024 -> 154 MB (let [^sun.misc.Unsafe u unsafe] - (bench (do (.allocateMemory u 1) - (.allocateMemory u 1) - (.allocateMemory u 1) - (.allocateMemory u 1) - (.allocateMemory u 1)))) - -;; allocating one byte of heap memory: avg 0.698 ns (or less depending on bench overhead) -(bench (do (Array/newUninitialized1dByteArray 1) - (Array/newUninitialized1dByteArray 1) - (Array/newUninitialized1dByteArray 1) - (Array/newUninitialized1dByteArray 1) - (Array/newUninitialized1dByteArray 1))) - -;; writing one byte of off-heap memory: avg 0.636 ns (or less depending on bench overhead) + (bench (repeat-test 100 (.allocateMemory u 1)))) + +;; Allocating one byte of heap memory: avg 0.0384 ns (or less depending on bench overhead) +;; My guess is that it's being optimized and it knows that it's just being thrown away +(bench (repeat-test 100 (Array/newUninitialized1dByteArray 1))) + +(defmacro gen-off-heap-set-test [n] + `(do ~@(for [i (range n)] + (let [x (byte (rand-int Byte/MAX_VALUE))] `(.putByte ~'u ~'pointer ~x))))) + +;; Writing one byte of off-heap memory: avg 0.0318 ns (or less depending on bench overhead) +;; My guess is that somehow it knows where it's being set and/or knows it's already set? (let [^sun.misc.Unsafe u unsafe pointer (.allocateMemory u 1) b (byte 1)] - (bench (.putByte u pointer b) - (.putByte u pointer b) - (.putByte u pointer b) - (.putByte u pointer b) - (.putByte u pointer b))) + (bench (gen-off-heap-set-test 100))) + +(defmacro gen-heap-set-test [n] + `(do ~@(for [i (range n)] + (let [x (byte (rand-int Byte/MAX_VALUE))] `(Array/set ~'bs ~x ~'i))))) -;; writing one byte of on-heap memory: avg 0.6698 ns (or less depending on bench overhead) +;; Writing one byte of on-heap memory: avg 0.0329 ns (or less depending on bench overhead) +;; My guess is that somehow it knows where it's being set and/or knows it's already set? (let [bs (Array/newUninitialized1dByteArray 1) - b (byte 1) i (int 0)] - (bench (Array/set bs b i) - (Array/set bs b i) - (Array/set bs b i) - (Array/set bs b i) - (Array/set bs b i))) + (bench (gen-heap-set-test 100))) -;; accessing one byte of off-heap memory: 0.7052 ns (or less depending on bench overhead) +;; Accessing one byte of off-heap memory: avg 0.0367 ns (or less depending on bench overhead) +;; My guess is that once it's in the register then it only reads from L1 cache at that point (let [^sun.misc.Unsafe u unsafe + n 100 pointer (.allocateMemory u 1)] - (bench (do (.getByte u pointer) - (.getByte u pointer) - (.getByte u pointer) - (.getByte u pointer) - (.getByte u pointer)))) + (bench (repeat-test 100 (.getByte u pointer)))) -;; accessing one byte of on-heap memory: 0.7302 ns (or less depending on bench overhead) +;; Accessing one byte of on-heap memory: 0.0371 ns (or less depending on bench overhead) +;; My guess is that once it's in the register then it only reads from L1 cache at that point (let [bs (Array/newUninitialized1dByteArray 1) i (int 0)] - (bench (do (Array/get bs i) - (Array/get bs i) - (Array/get bs i) - (Array/get bs i) - (Array/get bs i)))) + (bench (repeat-test 100 (Array/get bs i)))) + +;; ===== Miscellaneous + +(defmacro gen-incrementing-test [f x n] + `(do ~@(for [i (range n)] `(~f ~(+ x i))))) + +(defmacro abs-bit-shift-test [x] + `(let [mask# (bit-shift-right ~x 32)] + (- (bit-xor ~x mask#) mask#))) + +(defmacro abs-simple-test [x] `(if (< ~x 0) (- ~x) ~x)) + +;; 0.0374 ns avg +(bench (gen-incrementing-test abs-bit-shift-test -100203 100)) + +;; 0.0378 ns avg +(bench (gen-incrementing-test abs-simple-test -100203 100)) From aceba3a9bffb7915809f53ba133e9ed520dec6a7 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:12:24 -0600 Subject: [PATCH 424/810] Add todos --- resources-dev/defnt.cljc | 2 ++ src-untyped/quantum/untyped/core/analyze.cljc | 1 + src/quantum/convert/core.cljc | 2 +- 3 files changed, 4 insertions(+), 1 deletion(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index b50705cf..ff3abcc5 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -1009,6 +1009,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] Util.equiv(long,long) - [ ] Util.equiv(boolean,boolean) - [ ] Util.equiv(double,double) + - [ ] JS built-in functions (the most common/relevant ones) + - ... - [ ] Java intrinsics http://hg.openjdk.java.net/jdk8/jdk8/hotspot/file/87ee5ee27509/src/share/vm/classfile/vmSymbols.hpp http://hg.openjdk.java.net/jdk9/jdk9/hotspot/file/b756e7a2ec33/src/share/vm/classfile/vmSymbols.hpp diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 9b77fab9..315454e0 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -473,6 +473,7 @@ (or (t/> t t/nil?) (t/> t t/false?)) nil ; representing "unknown" true)) +;; TODO this should be adding analysis information on every predicate it finds to be true or not true (defns- analyze-seq|if "Performs conditional branch pruning." [opts ::opts, env ::env, [_ _ & [pred-form _, true-form _, false-form _ :as body] _ :as form] _ diff --git a/src/quantum/convert/core.cljc b/src/quantum/convert/core.cljc index d52eed51..044331a0 100644 --- a/src/quantum/convert/core.cljc +++ b/src/quantum/convert/core.cljc @@ -9,6 +9,7 @@ (:import [javax.imageio.metadata IIOAttr IIOMetadataNode])) +;; TODO MOVE (defnt ->hiccup [^IIOMetadataNode x] ; .getPrefix ; .getLocalName @@ -29,4 +30,3 @@ (conj! !children (->hiccup child)) (reduced !children)))) (range)))) - From 35de90055f51c50ae2270c415b33eb0c1db2fac9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:12:45 -0600 Subject: [PATCH 425/810] Clean up `request-animation-frame` logic --- src/quantum/core/async.cljc | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/src/quantum/core/async.cljc b/src/quantum/core/async.cljc index 2f422b1b..1c809e8e 100644 --- a/src/quantum/core/async.cljc +++ b/src/quantum/core/async.cljc @@ -821,14 +821,13 @@ #?(:cljs (def request-animation-frame - (or - (.-requestAnimationFrame sys/global) - (.-webkitRequestAnimationFrame sys/global) - (.-mozRequestAnimationFrame sys/global) - (.-msRequestAnimationFrame sys/global) - (.-oRequestAnimationFrame sys/global) - (let [t0 (.getTime (js/Date.))] - (fn [f] - (js/setTimeout - #(f (- (.getTime (js/Date.)) t0)) - 16.66666)))))) + (or (.-requestAnimationFrame sys/global) + (.-webkitRequestAnimationFrame sys/global) + (.-mozRequestAnimationFrame sys/global) + (.-msRequestAnimationFrame sys/global) + (.-oRequestAnimationFrame sys/global) + (let [t0 (.getTime (js/Date.))] + (fn [f] + (js/setTimeout + #(f (- (.getTime (js/Date.)) t0)) + 16.66666)))))) From 8aa4de2e6424db193830d7cc038abc86683ccf1b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:12:52 -0600 Subject: [PATCH 426/810] Add todos --- src/quantum/core/collections.cljc | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/quantum/core/collections.cljc b/src/quantum/core/collections.cljc index c56d50d6..612c015c 100644 --- a/src/quantum/core/collections.cljc +++ b/src/quantum/core/collections.cljc @@ -11,6 +11,9 @@ Many of them are aliased from other namespaces like quantum.core.collections.core, or quantum.core.reducers." + {:todo #{"Incorporate System.arrayCopy" + "Incorporate java.util.Arrays" + "Incorporate java.util.ArraysSupport"}} (:refer-clojure :exclude [for doseq reduce transduce dotimes contains? From aca62d74dd7ec565dae660b687b776ae859bb6f4 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:13:05 -0600 Subject: [PATCH 427/810] dnum/nip? -> dn/std-fixint? --- src/quantum/core/collections_typed.cljc | 28 ++++++++++++------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index d96131a9..c2407dd0 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -8,7 +8,7 @@ [quantum.core.data.compare :as dcomp] [quantum.core.data.identifiers :as id] [quantum.core.data.map :as map] - [quantum.core.data.numeric :as dnum] + [quantum.core.data.numeric :as dn] [quantum.core.data.primitive :as p] [quantum.core.data.string :as dstr] [quantum.core.data.vector :as vec] @@ -266,7 +266,7 @@ #?(:clj (^:inline [rf rf?, init t/any? xs (t/or (t/isa? clojure.lang.PersistentVector) chunked-seq?)] (reduce-chunked rf init xs))) - ([rf rf?, init t/any?, n dnum/numerically-integer?] + ([rf rf?, init t/any?, n dn/numerically-integer?] (loop [i 0, ret init] (if (comp/< i n) (let [ret' (rf ret i)] @@ -378,25 +378,25 @@ ([ct ?, _ ?] (num/inc ct)))) ;; TODO make sure !+vector is handled for CLJS -(t/defn ^:inline count > dnum/std-integer? +(t/defn ^:inline count > dn/std-integer? {:todo #{"handle persistent maps"} :incorporated '{clojure.lang.RT/count "9/2018" clojure.lang.RT/countFrom "9/2018" clojure.core/count "9/2018" cljs.core/count "9/26/2018"}} ;; Counted - ([x p/nil? > #?(:clj p/long? :cljs dnum/nip?)] 0) -#?(:cljs ([xs dstr/string? > (t/assume dnum/nip?)] (.-length xs))) -#?(:cljs ([xs dstr/!string? > (t/assume dnum/nip?)] (.getLength xs))) - ([xs dc/icounted? > #?(:clj p/int? :cljs (t/* dnum/nip?))] + ([x p/nil? > #?(:clj p/long? :cljs dn/std-fixint?)] 0) +#?(:cljs ([xs dstr/string? > (t/assume dn/std-fixint?)] (.-length xs))) +#?(:cljs ([xs dstr/!string? > (t/assume dn/std-fixint?)] (.getLength xs))) + ([xs dc/icounted? > #?(:clj p/int? :cljs (t/* dn/std-fixint?))] (#?(:clj .count :cljs cljs.core/-count) xs)) #?(:clj ([xs dstr/char-seq? > p/int?] (.length xs))) - ([xs tup/tuple? > #?(:clj p/int? :cljs (t/assume dnum/nip?))] + ([xs tup/tuple? > #?(:clj p/int? :cljs (t/assume dn/std-fixint?))] (-> xs .-vs count)) - ([xs dasync/m2m-chan? > #?(:clj p/int? :cljs dnum/nip?)] + ([xs dasync/m2m-chan? > #?(:clj p/int? :cljs dn/std-fixint?)] (-> xs #?(:clj .buf :cljs .-buf) count)) #?(:clj ([xs tup/map-entry? > p/long?] 2)) - ([xs arr/std-array? > #?(:clj p/int? :cljs (t/assume dnum/nip?))] + ([xs arr/std-array? > #?(:clj p/int? :cljs (t/assume dn/std-fixint?))] (#?(:clj Array/count :cljs .-length) xs)) #?(:clj ([xs arr/array? > p/int?] (java.lang.reflect.Array/getLength xs))) ;; Possibly counted @@ -407,15 +407,15 @@ ;; Not counted ([xs (t/input-type educe :_ :_ :?)] (educe count|rf xs))) -(t/defn ^:inline gen-bounded-count|rf [n dnum/std-integer?] +(t/defn ^:inline gen-bounded-count|rf [n dn/std-integer?] (t/fn {:inline true} ([] 0) ([ct ?] ct) ([ct ?, _ ?] (if (dcomp/< ct n) (num/inc ct) (?/reduced ct))))) -(t/defn ^:inline bounded-count > dnum/std-integer? - ([n dnum/std-integer?, xs dc/counted?] (count xs)) - ([n dnum/std-integer?, xs (t/input-type educe :_ :_ :?)] (educe (gen-bounded-count|rf n) xs))) +(t/defn ^:inline bounded-count > dn/std-integer? + ([n dn/std-integer?, xs dc/counted?] (count xs)) + ([n dn/std-integer?, xs (t/input-type educe :_ :_ :?)] (educe (gen-bounded-count|rf n) xs))) (t/def ^:inline empty?|rf (fn/aritoid From ed878f0b405c4c4a5f19e219d8f8af858038333a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:13:23 -0600 Subject: [PATCH 428/810] dnum -> dn --- src/quantum/core/compare.cljc | 2 +- src/quantum/core/compare/core.cljc | 2 +- src/quantum/core/data/collections.cljc | 2 +- src/quantum/core/data/time.cljc | 4 ++-- 4 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/quantum/core/compare.cljc b/src/quantum/core/compare.cljc index 1043cf96..657cbec7 100644 --- a/src/quantum/core/compare.cljc +++ b/src/quantum/core/compare.cljc @@ -25,7 +25,7 @@ :refer [- -' + abs inc div:natural]] [quantum.core.numeric.predicates :as pred :refer [neg? pos? zero?]] - [quantum.core.data.numeric :as dnum] + [quantum.core.data.numeric :as dn] [quantum.core.data.time :as dtime] [quantum.core.reducers :as red :refer [reduce, transduce]] diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index e26f8f74..f6654b6b 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -21,7 +21,7 @@ #_[quantum.core.numeric.convert :refer [->num ->num&]] ;; TODO TYPED excise - #_[quantum.core.data.numeric :as dnum] + #_[quantum.core.data.numeric :as dn] [quantum.core.data.primitive :as p] [quantum.core.type :as t] ;; TODO TYPED excise diff --git a/src/quantum/core/data/collections.cljc b/src/quantum/core/data/collections.cljc index acdde912..99b35a97 100644 --- a/src/quantum/core/data/collections.cljc +++ b/src/quantum/core/data/collections.cljc @@ -170,7 +170,7 @@ [x t/ref?] (#?(:clj clojure.lang.Reduced. :cljs cljs.core/Reduced.) x)) (def reducible? - (t/or p/nil? dstr/string? vec/!+vector? arr/array? dnum/numerically-integer? + (t/or p/nil? dstr/string? vec/!+vector? arr/array? dn/numerically-integer? ;; TODO what about `transformer?` dasync/read-chan? (t/isa? fast_zip.core.ZipperLocation) diff --git a/src/quantum/core/data/time.cljc b/src/quantum/core/data/time.cljc index cc5c603b..0c74560d 100644 --- a/src/quantum/core/data/time.cljc +++ b/src/quantum/core/data/time.cljc @@ -1,7 +1,7 @@ (ns quantum.core.data.time (:require - [quantum.core.data.numeric :as dnum] + [quantum.core.data.numeric :as dn] [quantum.core.type :as t])) ;; TODO is this the right place to put this? -#?(:cljs (t/defn date>millis [x js/Date > (t/assume dnum/std-fixint?)] (.valueOf x))) +#?(:cljs (t/defn date>millis [x js/Date > (t/assume dn/std-fixint?)] (.valueOf x))) From a67761cd49a47858b5c32766ec4646fb84944ec9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:13:40 -0600 Subject: [PATCH 429/810] `and*`, `or*` --- src/quantum/core/logic.cljc | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/quantum/core/logic.cljc b/src/quantum/core/logic.cljc index f7d7e054..e5e8eea5 100644 --- a/src/quantum/core/logic.cljc +++ b/src/quantum/core/logic.cljc @@ -46,6 +46,20 @@ xor xnor implies?])) +#?(:clj +(defmacro and* + "Like `clojure.core/and`, but avoids intermediate let bindings and only ever returns a boolean." + ([] true) + ([x] `(if ~x true false)) + ([x & xs] `(if ~x (and* ~@xs) false)))) + +#?(:clj +(defmacro or* + "Like `clojure.core/or`, but avoids intermediate let bindings and only ever returns a boolean." + ([] false) + ([x] `(if ~x true false)) + ([x & xs] `(if ~x true (or* ~@xs))))) + ;; ===== Function-logical operators ===== ;; #?(:clj From 1f751f03cbb6b4733345178748519660d29ed89b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:14:04 -0600 Subject: [PATCH 430/810] ui.plots -> ui.visualization --- src/quantum/ui/{plots.cljc => visualization.cljc} | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) rename src/quantum/ui/{plots.cljc => visualization.cljc} (93%) diff --git a/src/quantum/ui/plots.cljc b/src/quantum/ui/visualization.cljc similarity index 93% rename from src/quantum/ui/plots.cljc rename to src/quantum/ui/visualization.cljc index c1627125..dd427211 100644 --- a/src/quantum/ui/plots.cljc +++ b/src/quantum/ui/visualization.cljc @@ -1,7 +1,9 @@ -(ns quantum.ui.plots) +(ns quantum.ui.visualization) ; TO EXPLORE +; https://github.com/thi-ng/geom/blob/master/geom-viz/src/core.org + ; Mathematica ; - 2D and 3D data, function and geo visualization and animation tools From 5e82636985b944305e3f127ea79be0cfc4a5fc8e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:14:19 -0600 Subject: [PATCH 431/810] Add to todos for numeric.tensors --- src/quantum/numeric/tensors.cljc | 36 ++++++++++++++++---------------- 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/src/quantum/numeric/tensors.cljc b/src/quantum/numeric/tensors.cljc index 37e071bd..4b6d310c 100644 --- a/src/quantum/numeric/tensors.cljc +++ b/src/quantum/numeric/tensors.cljc @@ -1,8 +1,24 @@ (ns quantum.numeric.tensors "1D array: vector 2D array: matrix - 3D array: (no special name) - ND array: tensor" + ND array: tensor + + Note: (Java-only) Colt performs atrociously." + {:todo #{"Incorporate https://github.com/thi-ng/geom/blob/master/geom-core/src/vector.org" + "Incorporate https://github.com/thi-ng/geom/blob/master/geom-core/src/matrix.org" + "Incorporate https://github.com/thi-ng/geom/blob/master/geom-core/src/quaternion.org" + "Probably use core.matrix API" + "Incorporate core.matrix" + "EJML if performance on small matrices is more important than features" + "Neanderthal if performance on large (n >= 50) matrices is needed. + Even for very small matrices (except for matrices smaller than 5x5), Neanderthal is + faster than the pure Java library Vectorz. + - http://blog.mikiobraun.de/2009/04/some-benchmark-numbers-for-jblas.html" + "MTJ=" + "spark.mllib -> breeze -> netlib-java -> BLAS/LAPACK + matrix-toolkits-java (MTJ) -> netlib-java -> BLAS/LAPACK" + "Mathematica + - Matrix and data manipulation tools including support for sparse arrays"}} (:refer-clojure :exclude [max count get subvec swap! first last empty contains? for dotimes, reduce]) @@ -45,22 +61,6 @@ [org.apache.spark.mllib.linalg BLAS DenseVector] [uncomplicate.neanderthal.protocols Vector RealVector RealMatrix RealChangeable]))) -; TODO probably use core.matrix API - -; TO EXPLORE -; - core.matrix — incorporate! -; - EJML if performance on small matrices is more important than features -; - Neanderthal if performance on large (n >= 50) matrices is needed -; http://blog.mikiobraun.de/2009/04/some-benchmark-numbers-for-jblas.html -; - (Java-only) Colt performs atrociously -; Even for very small matrices (except for matrices smaller than 5x5), -; Neanderthal is faster than pure Java library Vectorz. -; MTJ=matrix-toolkits-java -; spark.mllib -> breeze -> netlib-java -> BLAS/LAPACK -; MTJ -> netlib-java -> BLAS/LAPACK -; - Mathematica -; - Matrix and data manipulation tools including support for sparse arrays - ; ================================= ; ================= From acfdf210eccf65ed21f2cb04030d557714f60490 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:14:30 -0600 Subject: [PATCH 432/810] `quantum.numeric.subdivision` --- src/quantum/numeric/subdivision.cljc | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 src/quantum/numeric/subdivision.cljc diff --git a/src/quantum/numeric/subdivision.cljc b/src/quantum/numeric/subdivision.cljc new file mode 100644 index 00000000..8434d1bd --- /dev/null +++ b/src/quantum/numeric/subdivision.cljc @@ -0,0 +1,3 @@ +(ns quantum.numeric.subdivision + "Functionality relating to the subdivision of geometric spaces — lines, planes, and volumes." + {:todo #{"Incorporate https://github.com/thi-ng/geom/blob/master/geom-core/src/subdiv.org"}}) From 5e596efe4eddd8f6031b9f9cf7ef2200fb5c03cc Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:14:36 -0600 Subject: [PATCH 433/810] `quantum.numeric.noise` --- src/quantum/numeric/noise.cljc | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 src/quantum/numeric/noise.cljc diff --git a/src/quantum/numeric/noise.cljc b/src/quantum/numeric/noise.cljc new file mode 100644 index 00000000..83f41cf0 --- /dev/null +++ b/src/quantum/numeric/noise.cljc @@ -0,0 +1,2 @@ +(ns quantum.numeric.noise + {:todo #{"Import https://github.com/thi-ng/math/blob/master/src/noise.org"}}) From fa47ae7857a5aede40b60d17d854d5372e15f06a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:14:45 -0600 Subject: [PATCH 434/810] Add to todos of `quantum.numeric.geometry` --- src/quantum/numeric/geometry.cljc | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/src/quantum/numeric/geometry.cljc b/src/quantum/numeric/geometry.cljc index d868e8ff..901b8a43 100644 --- a/src/quantum/numeric/geometry.cljc +++ b/src/quantum/numeric/geometry.cljc @@ -1,11 +1,16 @@ (ns quantum.numeric.geometry + {:todo #{"Incorporate https://github.com/thi-ng/geom/blob/master/geom-core/src/intersect.org" + "Incorporate https://github.com/thi-ng/geom/blob/master/geom-core/src/utils.org" + "Incorporate https://github.com/thi-ng/geom/blob/master/geom-core/src/core.org" + "Incorporate https://github.com/thi-ng/ndarray/blob/master/src/contours.org" + "Incorporate https://github.com/thi-ng/geom/tree/master/geom-types/src" + "Incorporate https://github.com/thi-ng/geom/tree/master/geom-meshops/src"}} (:require [quantum.core.error :as err :refer [TODO]])) (defn smallest-enclosing-ball - "Uses the Emo Welzl algorithm to find the smallest - enclosing ball in linear time." + "Uses the Emo Welzl algorithm to find the smallest enclosing ball in linear time." {:implemented-by '#{org.apache.commons.math3.geometry.enclosing.*}} [pts] (TODO)) From c6cdf8652c43cd965e707fc63eb828ffdb1ac492 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:18:46 -0600 Subject: [PATCH 435/810] Add interesting idea about performance analysis --- resources-dev/defnt.cljc | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index ff3abcc5..5ade3a29 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -100,6 +100,10 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - Literal sets need to be analyzed — (t/finite-of t/built-in-set? a-type b-type ...) - Literal maps need to be better analyzed — (t/finite-of t/built-in-map? [ak-type av-type] ...) - Literal seqs need to be better analyzed — (t/finite-of t/built-in-list? [ak-type av-type] ...) + - Peformance analysis (this comes very much later) + - We should be able to do complexity analysis. Similarly to how we can combine and manipulate + types, we could do like `(cplex/assume (cplex/o :n))` or `(cplex/assume (cplex/o :n2))` etc. + - Record performance for each relevant part and cache? - (if (dcoll/reduced? ret) ;; TODO TYPED `(ref/deref ret)` should realize it's dealing with a `reduced?` (ref/deref ret) From 08fc473f09b4ef4b0afdc1eaff7926210adb2066 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:18:58 -0600 Subject: [PATCH 436/810] Add note about `gamma` --- src/quantum/numeric/functions.cljc | 1 + 1 file changed, 1 insertion(+) diff --git a/src/quantum/numeric/functions.cljc b/src/quantum/numeric/functions.cljc index cf22864c..c89fe29a 100644 --- a/src/quantum/numeric/functions.cljc +++ b/src/quantum/numeric/functions.cljc @@ -11,6 +11,7 @@ ; ===== GAMMA ===== ; +;; TODO incorporate https://github.com/thi-ng/math/blob/master/src/gamma.org (defn ^double gamma "Gamma function. The extension of the factorial function to the reals. Breeze: exp(lgamma(a)) From 2c751f396368c9d6887a5b2ac319063f64a11cbe Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:19:31 -0600 Subject: [PATCH 437/810] imaging.convert -> graphics.convert --- .../{media/imaging => graphics}/convert.cljc | 25 ++++++++++++------- 1 file changed, 16 insertions(+), 9 deletions(-) rename src/quantum/{media/imaging => graphics}/convert.cljc (72%) diff --git a/src/quantum/media/imaging/convert.cljc b/src/quantum/graphics/convert.cljc similarity index 72% rename from src/quantum/media/imaging/convert.cljc rename to src/quantum/graphics/convert.cljc index 8b651597..9ee72f22 100644 --- a/src/quantum/media/imaging/convert.cljc +++ b/src/quantum/graphics/convert.cljc @@ -1,16 +1,12 @@ -(ns - ^{:doc "Image library. Conversion." - :attribution "alexandergunnarson"} - quantum.media.imaging.convert +(ns quantum.graphics.convert (:refer-clojure :exclude [contains?]) (:require [quantum.core.process :as proc - :refer [proc!] ] - [quantum.core.io :as io ] - [quantum.core.paths :as path - :include-macros true ] + :refer [proc!]] + [quantum.core.io :as io] + [quantum.core.paths :as path] [quantum.core.collections - :refer [contains? in?] ])) + :refer [contains? in?]])) (def supported-types #{:jpg :png :tiff :jpeg :gif :pdf}) @@ -22,6 +18,7 @@ (str #_[to-type ":"] (-> to path/file-str))] {:dir (path/file-str [:resources "Images"])})) +;; TODO extend `quantum.core.convert/convert" instead of doing this (defn convert! "DOC http://libjpeg-turbo.virtualgl.org" {:usage @@ -41,3 +38,13 @@ (assert (in? from-type supported-types)) (assert (in? to-type supported-types)) (convert!* from-type from to-type to))))) + + +(defn ocr + "Uses the open-source tool `tesseract` to perform OCR on a document. + Refer to the Tesseract GitHub for help and setup. + + To OCR a PDF: + `gs -o -sDEVICE=tiffg4 && tesseract stdout pdf > `" + [in out opts] + (TODO)) From 71de8c7c43aa00ea5920a5b72a11cb2f5a45f15f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:19:40 -0600 Subject: [PATCH 438/810] Add `quantum.graphics.voxel` --- src/quantum/graphics/voxel.cljc | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 src/quantum/graphics/voxel.cljc diff --git a/src/quantum/graphics/voxel.cljc b/src/quantum/graphics/voxel.cljc new file mode 100644 index 00000000..bc8a9074 --- /dev/null +++ b/src/quantum/graphics/voxel.cljc @@ -0,0 +1,3 @@ +(ns quantum.graphics.voxel + "A voxel is the smallest unit in a 3-dimensional graphics space." + {:todo #{"Incorporate https://github.com/thi-ng/geom/blob/master/geom-voxel/src/index.org"}}) From 5e9c0cfcaebeadf3a84e78847c77257eb8bad072 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:20:02 -0600 Subject: [PATCH 439/810] Add `quantum.graphics.svg` --- src/quantum/graphics/svg.cljc | 4 ++++ 1 file changed, 4 insertions(+) create mode 100644 src/quantum/graphics/svg.cljc diff --git a/src/quantum/graphics/svg.cljc b/src/quantum/graphics/svg.cljc new file mode 100644 index 00000000..4ac8f8cf --- /dev/null +++ b/src/quantum/graphics/svg.cljc @@ -0,0 +1,4 @@ +(ns quantum.graphics.svg + {:todo #{"Incorporate https://github.com/thi-ng/geom/blob/master/geom-svg/src/renderer.org" + "Incorporate https://github.com/thi-ng/geom/blob/master/geom-svg/src/shaders.org" + "Incorporate https://github.com/thi-ng/geom/blob/master/geom-svg/src/core.org"}}) From 88ce8cd33b636c5d27ba3ad38a8e21a38925b900 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:20:08 -0600 Subject: [PATCH 440/810] Add `quantum.graphics.physics` --- src/quantum/graphics/physics.cljc | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 src/quantum/graphics/physics.cljc diff --git a/src/quantum/graphics/physics.cljc b/src/quantum/graphics/physics.cljc new file mode 100644 index 00000000..7edc04ec --- /dev/null +++ b/src/quantum/graphics/physics.cljc @@ -0,0 +1,2 @@ +(ns quantum.graphics.physics + {:todo #{"Incorporate https://github.com/thi-ng/geom/blob/master/geom-physics/src/core.org"}}) From f9024e308165025fa8db872d82b944a0e3ef7511 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:20:15 -0600 Subject: [PATCH 441/810] Add `quantum.graphics.gl` --- src/quantum/graphics/gl.cljc | 6 ++++++ 1 file changed, 6 insertions(+) create mode 100644 src/quantum/graphics/gl.cljc diff --git a/src/quantum/graphics/gl.cljc b/src/quantum/graphics/gl.cljc new file mode 100644 index 00000000..05e26b31 --- /dev/null +++ b/src/quantum/graphics/gl.cljc @@ -0,0 +1,6 @@ +(ns quantum.graphics.gl + "Functionality relating to WebGL/GLSL shaders." + {:todo #{"Incorporate https://github.com/thi-ng/shadergraph" + "Incorporate https://github.com/thi-ng/geom/blob/master/geom-webgl/src/shaders.org" + "Incorporate https://github.com/thi-ng/geom/blob/master/geom-webgl/src/core.org" + "Incorporate https://github.com/thi-ng/geom/blob/master/geom-webgl/src/buffers.org"}}) From 35e242dae671415b52f878610aa4fbdf5a0741af Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:51:12 -0600 Subject: [PATCH 442/810] Typed array `.slice` polyfill --- src/quantum/core/data/array.cljc | 95 +++++++++++++++++++------------- 1 file changed, 58 insertions(+), 37 deletions(-) diff --git a/src/quantum/core/data/array.cljc b/src/quantum/core/data/array.cljc index 80fe591a..91f28115 100644 --- a/src/quantum/core/data/array.cljc +++ b/src/quantum/core/data/array.cljc @@ -1,42 +1,63 @@ -(ns - ^{:doc "Useful array functions. Array creation, joining, reversal, etc. - Arrays are Sequential, Associative (specifically, whose keys are sequential, dense integer - values), and not extensible." - :attribution 'alexandergunnarson - :todo ["Incorporate amap, areduce, etc."]} - quantum.core.data.array +(ns quantum.core.data.array + "Useful array functions. Array creation, joining, reversal, etc. + Arrays are Sequential, Associative (specifically, whose keys are sequential, dense integer + values), and not extensible." (:refer-clojure :exclude - [== reverse boolean-array byte-array char-array short-array - int-array long-array float-array double-array]) + [== reverse boolean-array byte-array char-array short-array int-array long-array float-array + double-array]) (:require - [clojure.core :as core] -#_(:clj - [loom.alg-generic :as alg]) ; temporarily - #_[quantum.core.type.core :as tcore] - #_[quantum.core.fn :as fn - :refer [fn->]] - #_[quantum.core.log :as log] - #_[quantum.core.macros.type-hint :as th] - #_[quantum.core.compare :as comp] - #_[quantum.core.numeric :as num] - [quantum.core.data.identifiers :as id] - [quantum.core.type :as t - :refer [defnt]] - [quantum.core.vars :as var - :refer [defalias]] - ;; TODO TYPED (?) - [quantum.untyped.core.form.generate :as ufgen]) -#?(:cljs - (:require-macros - [quantum.core.data.array :as self])) -#?(:clj - (:import - [quantum.core.data Array] - [java.io File FileInputStream BufferedInputStream InputStream ByteArrayOutputStream] - [java.nio ByteBuffer] - [java.util ArrayList]))) - -(log/this-ns) + [clojure.core :as core] + #_(:clj [loom.alg-generic :as alg]) ; temporarily + #_[quantum.core.type.core :as tcore] + #_[quantum.core.macros.type-hint :as th] + #_[quantum.core.compare :as comp] + #_[quantum.core.numeric :as num] + [quantum.core.data.identifiers :as id] + [quantum.core.type :as t + :refer [defnt]] + [quantum.core.vars :as var + :refer [defalias]] + ;; TODO TYPED (?) + [quantum.untyped.core.form.generate :as ufgen] + [quantum.untyped.core.log :as ulog] + [quantum.untyped.core.system :as usys]) +#?(:clj (:import + [quantum.core.data Array] + [java.io File FileInputStream BufferedInputStream InputStream ByteArrayOutputStream] + [java.nio ByteBuffer] + [java.util ArrayList]))) + +(ulog/this-ns) + +(def typed-arrays-supported? (p/val? (aget usys/global "ArrayBuffer"))) + +;; A polyfill for the `.slice` prototype method missing in Safari and some mobile browser versions +;; Adapted from `thi.ng.typedarrays.core` +(when typed-arrays-supported? + (->> ["Int8Array" "Uint8Array" "Uint8ClampedArray" "Int16Array" "Uint16Array" + "Int32Array" "Uint32Array" "Float32Array" "Float64Array"] + (run! + (fn [type-str] + (when-not (-> usys/global (aget type-str) .-prototype .-slice) + (set! (-> usys/global (aget type-str) .-prototype .-slice) + (fn [from to] + (this-as this + (let [from (if (neg? from) + (int (unchecked-add (.-length this) from)) + (int from)) + to (if (goog/isNumber to) + (if (neg? to) + (int (unchecked-add (.-length this) to)) + (js/Math.min to (.-length this))) + (.-length this)) + len (js/Math.max (unchecked-subtract to from) 0) + ctor (.-constructor this) + dest (js* "new ~{}(~{})" ctor len)] + (loop [i 0] + (when (< i len) + (aset dest i (aget this (unchecked-add from i))) + (recur (unchecked-inc i)))) + dest))))))))) #?(:clj (defnt >array-nd-type [kind id/symbol?, n num/pos-int? > t/class-type?] From 09de30780f12618625c88b969cab54841eedfc49 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:51:16 -0600 Subject: [PATCH 443/810] `quantum.core.data.heap` --- src/quantum/core/data/heap.cljc | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 src/quantum/core/data/heap.cljc diff --git a/src/quantum/core/data/heap.cljc b/src/quantum/core/data/heap.cljc new file mode 100644 index 00000000..0225502c --- /dev/null +++ b/src/quantum/core/data/heap.cljc @@ -0,0 +1,2 @@ +(ns quantum.core.data.heap + {:todo "Incorporate https://github.com/thi-ng/dstruct/blob/master/src/heap.org"}) From 6b66ec8bb8cb0d5c1c89c12840dfc355f563bd7b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:51:22 -0600 Subject: [PATCH 444/810] Add todo --- src/quantum/core/data/map.cljc | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/quantum/core/data/map.cljc b/src/quantum/core/data/map.cljc index 10505595..d31b49b5 100644 --- a/src/quantum/core/data/map.cljc +++ b/src/quantum/core/data/map.cljc @@ -26,6 +26,9 @@ [it.unimi.dsi.fastutil.objects Reference2LongOpenHashMap]] :cljs [[goog.structs AvlTree LinkedMap]]))) +;; TODO make a wrapper fn/type for associative data structures such that it maintains a +;; bidirectional mapping/index between keys and values + ;; TO EXPLORE ;; - Optimizing Hash-Array Mapped Tries for Fast and Lean Immutable JVM Collections ;; - Actual usable implementation: https://github.com/usethesource/capsule From 643feb8ac8938815423503441b6fe823d3ff6ba1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:51:31 -0600 Subject: [PATCH 445/810] Label intrinsic --- src/quantum/core/data/primitive.cljc | 48 ++++++++++++++-------------- 1 file changed, 24 insertions(+), 24 deletions(-) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index ee6a4246..fb23be39 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -87,26 +87,26 @@ #?(:clj (t/defn ^:inline box - ([x boolean? > (t/assume (t/ref boolean?))] (Boolean/valueOf x)) - ([x byte? > (t/assume (t/ref byte?))] (Byte/valueOf x)) - ([x char? > (t/assume (t/ref char?))] (Character/valueOf x)) - ([x short? > (t/assume (t/ref short?))] (Short/valueOf x)) - ([x int? > (t/assume (t/ref int?))] (Integer/valueOf x)) - ([x long? > (t/assume (t/ref long?))] (Long/valueOf x)) - ([x float? > (t/assume (t/ref float?))] (Float/valueOf x)) - ([x double? > (t/assume (t/ref double?))] (Double/valueOf x)) - ([x t/ref?] x))) + (^:intrinsic [x boolean? > (t/assume (t/ref boolean?))] (Boolean/valueOf x)) + (^:intrinsic [x byte? > (t/assume (t/ref byte?))] (Byte/valueOf x)) + (^:intrinsic [x char? > (t/assume (t/ref char?))] (Character/valueOf x)) + (^:intrinsic [x short? > (t/assume (t/ref short?))] (Short/valueOf x)) + (^:intrinsic [x int? > (t/assume (t/ref int?))] (Integer/valueOf x)) + (^:intrinsic [x long? > (t/assume (t/ref long?))] (Long/valueOf x)) + (^:intrinsic [x float? > (t/assume (t/ref float?))] (Float/valueOf x)) + (^:intrinsic [x double? > (t/assume (t/ref double?))] (Double/valueOf x)) + ( [x t/ref?] x))) #?(:clj (t/defn ^:inline unbox - ([x (t/ref boolean?) > boolean?] (.booleanValue x)) - ([x (t/ref byte?) > byte?] (.byteValue x)) - ([x (t/ref char?) > char?] (.charValue x)) - ([x (t/ref short?) > short?] (.shortValue x)) - ([x (t/ref int?) > int?] (.intValue x)) - ([x (t/ref long?) > long?] (.longValue x)) - ([x (t/ref float?) > float?] (.floatValue x)) - ([x (t/ref double?) > double?] (.doubleValue x)))) + (^:intrinsic [x (t/ref boolean?) > boolean?] (.booleanValue x)) + (^:intrinsic [x (t/ref byte?) > byte?] (.byteValue x)) + (^:intrinsic [x (t/ref char?) > char?] (.charValue x)) + (^:intrinsic [x (t/ref short?) > short?] (.shortValue x)) + (^:intrinsic [x (t/ref int?) > int?] (.intValue x)) + (^:intrinsic [x (t/ref long?) > long?] (.longValue x)) + (^:intrinsic [x (t/ref float?) > float?] (.floatValue x)) + (^:intrinsic [x (t/ref double?) > double?] (.doubleValue x)))) ;; ===== Bit lengths ===== ;; @@ -206,7 +206,7 @@ ([x boolean?] (if x #?(:clj (byte 1) :cljs 1) #?(:clj (byte 0) :cljs 0))) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-byte?)] (>byte* (.lpart x)))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-byte?)] (.byteValue x))) -#?(:clj ([x (t/and dnum/ratio? numerically-byte?)] (-> x .bigIntegerValue .byteValue)))) +#?(:clj ([x (t/and dn/ratio? numerically-byte?)] (-> x .bigIntegerValue .byteValue)))) ;; ----- Short ----- ;; @@ -228,7 +228,7 @@ ([x boolean?] (if x #?(:clj (short 1) :cljs 1) #?(:clj (short 0) :cljs 0))) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-short?)] (>short* (.lpart x)))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-short?)] (.shortValue x))) -#?(:clj ([x (t/and dnum/ratio? numerically-short?)] (-> x .bigIntegerValue .shortValue)))) +#?(:clj ([x (t/and dn/ratio? numerically-short?)] (-> x .bigIntegerValue .shortValue)))) ;; ----- Char ----- ;; @@ -251,7 +251,7 @@ ([x boolean?] (if x #?(:clj (char 1) :cljs 1) #?(:clj (char 0) :cljs 0))) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-char?)] (>char* (.lpart x)))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-char?)] (.charValue x))) -#?(:clj ([x (t/and dnum/ratio? numerically-char?)] (-> x .bigIntegerValue .charValue)))) +#?(:clj ([x (t/and dn/ratio? numerically-char?)] (-> x .bigIntegerValue .charValue)))) ;; ----- Int ----- ;; @@ -274,7 +274,7 @@ ([x boolean?] (if x #?(:clj (int 1) :cljs 1) #?(:clj (int 0) :cljs 0))) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-int?)] (>int* (.lpart x)))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-int?)] (.intValue x))) -#?(:clj ([x (t/and dnum/ratio? numerically-int?)] (-> x .bigIntegerValue .intValue)))) +#?(:clj ([x (t/and dn/ratio? numerically-int?)] (-> x .bigIntegerValue .intValue)))) ;; ----- Long ----- ;; @@ -304,7 +304,7 @@ numerically-long? ;; TODO This might be faster than `numerically-long?` #_(fnt [x ?] (< (.bitLength x) 64)))] (.longValue x))) -#?(:clj ([x (t/and dnum/ratio? numerically-long?)] (-> x .bigIntegerValue .longValue)))) +#?(:clj ([x (t/and dn/ratio? numerically-long?)] (-> x .bigIntegerValue .longValue)))) ;; ----- Float ----- ;; @@ -326,7 +326,7 @@ ([x boolean?] (if x #?(:clj (float 1) :cljs 1) #?(:clj (float 0) :cljs 0))) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-float?)] (>float* (.lpart x)))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-float?)] (.floatValue x))) -#?(:clj ([x (t/and dnum/ratio? numerically-float?)] (-> x .bigIntegerValue .floatValue)))) +#?(:clj ([x (t/and dn/ratio? numerically-float?)] (-> x .bigIntegerValue .floatValue)))) ;; ----- Double ----- ;; @@ -347,7 +347,7 @@ ([x boolean?] (if x #?(:clj 1.0 :cljs 1) #?(:clj 1.0 :cljs 0))) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-double?)] (>double* (.lpart x)))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-double?)] (.doubleValue x))) -#?(:clj ([x (t/and dnum/ratio? numerically-double?)] (-> x .bigIntegerValue .doubleValue)))) +#?(:clj ([x (t/and dn/ratio? numerically-double?)] (-> x .bigIntegerValue .doubleValue)))) ;; ===== Unsigned ===== ;; From 3af0b4c076c9d505902d2a715dbac4546cecb65b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:51:40 -0600 Subject: [PATCH 446/810] Add todos to `quantum.core.numeric` --- src/quantum/core/numeric.cljc | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/quantum/core/numeric.cljc b/src/quantum/core/numeric.cljc index b62d11c6..26e8d426 100644 --- a/src/quantum/core/numeric.cljc +++ b/src/quantum/core/numeric.cljc @@ -1,6 +1,9 @@ (ns quantum.core.numeric "Numeric functions. Aliases all subnamespaces." + {:todo #{"Incorporate https://github.com/thi-ng/math/blob/master/src/bits.org" + "Incorporate https://github.com/thi-ng/math/blob/master/src/core.org" + "Add mutable numeric operations like `+!` or `-!` etc."}} (:refer-clojure :exclude [* *' + +' - -' / < > <= >= == rem inc dec zero? neg? pos? pos-int? min max quot mod format @@ -9,7 +12,7 @@ [clojure.core :as c] #?@(:cljs [[com.gfredericks.goog.math.Integer :as int]]) - [quantum.core.data.numeric :as dnum] + [quantum.core.data.numeric :as dn] [quantum.core.data.primitive :refer [#?(:clj >long)]] [quantum.core.log :as log] @@ -180,8 +183,8 @@ ; ===== NON-TRANSFORMATIVE OPERATIONS ===== ; -(defalias numerator dnum/numerator) -(defalias denominator dnum/denominator) +(defalias numerator dn/numerator) +(defalias denominator dn/denominator) ;_____________________________________________________________________ ;==================={ CONVERT }====================== ;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° From 02effcd012565206966fcc694e8c7eaea6969b71 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:52:01 -0600 Subject: [PATCH 447/810] dnum -> dn --- src/quantum/core/numeric/convert.cljc | 10 +++++----- src/quantum/core/numeric/operators.cljc | 22 +++++++++++----------- src/quantum/core/numeric/predicates.cljc | 16 ++++++++-------- src/quantum/core/numeric/strict_args.cljc | 2 +- 4 files changed, 25 insertions(+), 25 deletions(-) diff --git a/src/quantum/core/numeric/convert.cljc b/src/quantum/core/numeric/convert.cljc index f1d64837..374f7de0 100644 --- a/src/quantum/core/numeric/convert.cljc +++ b/src/quantum/core/numeric/convert.cljc @@ -2,7 +2,7 @@ (:refer-clojure :exclude [bigdec]) (:require [clojure.core :as core] - [quantum.core.data.numeric :as dnum] + [quantum.core.data.numeric :as dn] [quantum.core.error :as err :refer [TODO]] [quantum.core.macros @@ -23,7 +23,7 @@ (defn ->boolean-num [x] (if x 1 0)) -#?(:clj (defalias ->big-integer dnum/->big-integer)) +#?(:clj (defalias ->big-integer dn/->big-integer)) #?(:clj (defnt' ^BigInt ->bigint ([^BigInt x] x) @@ -31,7 +31,7 @@ ([^long x] (-> x BigInt/fromLong)) ([^string? x radix] (->bigint (BigInteger. x (int radix)))) ([#{double? Number} x] (-> x BigInteger/valueOf ->bigint))) - :cljs (defalias ->bigint dnum/->bigint)) + :cljs (defalias ->bigint dn/->bigint)) #?(:clj (doto (defalias ->bigdec core/bigdec) (alter-meta! assoc :tag BigDecimal)) #_(defnt' ^BigDecimal ->bigdec @@ -46,7 +46,7 @@ ([#{(- number? :curr)} x] (BigDecimal/valueOf x))) :cljs (defn ->bigdec [x] (TODO))) -#?(:clj (defalias ->ratio dnum/->ratio) +#?(:clj (defalias ->ratio dn/->ratio) #_(defnt ^clojure.lang.Ratio ->ratio ([^clojure.lang.Ratio x] x) ([^java.math.BigDecimal x] @@ -59,7 +59,7 @@ BigInteger/ONE) (Ratio. bv (-> BigInteger/TEN (.pow scale)))))) ([^Object x] (-> x ->big-integer (Ratio. BigInteger/ONE)))) - :cljs (defalias ->ratio dnum/->ratio)) + :cljs (defalias ->ratio dn/->ratio)) #?(:clj (defnt exactly diff --git a/src/quantum/core/numeric/operators.cljc b/src/quantum/core/numeric/operators.cljc index f1d6aae3..1038a889 100644 --- a/src/quantum/core/numeric/operators.cljc +++ b/src/quantum/core/numeric/operators.cljc @@ -9,7 +9,7 @@ #?(:cljs [com.gfredericks.goog.math.Integer :as int]) [quantum.core.data.bits :as bit :refer [<< >> >>>]] - [quantum.core.data.numeric :as dnum + [quantum.core.data.numeric :as dn :refer [bigdec? clj-bigint? denominator numerator numeric? numerically-int?]] [quantum.core.data.primitive :as p] [quantum.core.data.refs :as ref] @@ -40,7 +40,7 @@ ;; ----- Addition ----- ;; - ;; TODO we're missing CLJS bigdec/bigint (`dnum/-add`) as well as other type combos + ;; TODO we're missing CLJS bigdec/bigint (`dn/-add`) as well as other type combos (t/defn ^:inline +* "Lax `+`. Continues on overflow/underflow." > numeric? @@ -54,7 +54,7 @@ (.add x y) (.add x y *math-context*))))) - ;; TODO we're missing CLJS bigdec/bigint (`dnum/-add`) as well as other type combos + ;; TODO we're missing CLJS bigdec/bigint (`dn/-add`) as well as other type combos (t/defn ^:inline +' "Strict `+`. Throws exception on overflow/underflow." > numeric? @@ -65,7 +65,7 @@ ;; A Java intrinsic, so we keep this arity #?(:clj ([x p/long?, y p/long? > p/long?] (Math/addExact x y)))) - ;; TODO we're missing CLJS bigdec/bigint (`dnum/-add`) as well as other type combos + ;; TODO we're missing CLJS bigdec/bigint (`dn/-add`) as well as other type combos (t/defn ^:inline + "Natural `+`. Promotes on overflow/underflow." > numeric? @@ -74,7 +74,7 @@ ;; ----- Subtraction ----- ;; - ;; TODO we're missing CLJS bigdec/bigint (`dnum/-subtract`, `dnum/-negate`) as well as other + ;; TODO we're missing CLJS bigdec/bigint (`dn/-subtract`, `dn/-negate`) as well as other ;; type combos (t/defn ^:inline -* "Lax `-`. Continues on overflow/underflow." @@ -86,7 +86,7 @@ ([x numeric-primitive?, y numeric-primitive? > ?] (#?(:clj Numeric/subtract :cljs cljs.core/-) x y)))) - ;; TODO we're missing CLJS bigdec/bigint (`dnum/-subtract`, `dnum/-negate`) as well as other + ;; TODO we're missing CLJS bigdec/bigint (`dn/-subtract`, `dn/-negate`) as well as other ;; type combos (t/defn ^:inline -' "Strict `-`. Throws exception on overflow/underflow." @@ -108,7 +108,7 @@ (^long [^long x] (if (Numeric/eq x Long/MIN_VALUE ) (num-ex) (-* x)))) :cljs (defalias -'-bin core/-)) - ;; TODO we're missing CLJS bigdec/bigint (`dnum/-subtract`, `dnum/-negate`) as well as other + ;; TODO we're missing CLJS bigdec/bigint (`dn/-subtract`, `dn/-negate`) as well as other ;; type combos (t/defn ^:inline - "Natural `-`. Promotes on overflow/underflow." @@ -132,7 +132,7 @@ :cljs (defn **-bin "Lax `*`. Continues on overflow/underflow." ([] 0) ([x] x) - ([x y] (TODO "fix") (dnum/-multiply x y)))) + ([x y] (TODO "fix") (dn/-multiply x y)))) #?(:cljs (defn *'-bin- [x y] (TODO))) ; TODO only to fix CLJS arithmetic warning here @@ -179,11 +179,11 @@ (.divide n d) (.divide n d *math-context*)))) :cljs (defnt div*-bin "Lax `/`. Continues on overflow/underflow." - ([^ratio? x ] (TODO "fix") (dnum/-invert x)) + ([^ratio? x ] (TODO "fix") (dn/-invert x)) ([^ratio? x y] (TODO "fix") ;(* x (-invert (apply * y more))) - (* x (dnum/-invert y))) + (* x (dn/-invert y))) ([^double? x ] (core// x)) ([^double? x y] (div*-bin- x y)))) @@ -275,7 +275,7 @@ (t/defn abs > nneg? #?(:clj (^:inline [x char?] x)) - (^{:adapted-from 'thi.ng.math.bits + (^{:adapted-from 'thi.ng.math.bits/abs :doc "Faster than using conditionals to determine the absolute value"} [x #?(:clj (t/or p/byte? p/short? p/int? p/long?) :cljs ni-double?) > (t/and (t/type x) (t/assume nneg?))] diff --git a/src/quantum/core/numeric/predicates.cljc b/src/quantum/core/numeric/predicates.cljc index 452dd15b..4663cbd4 100644 --- a/src/quantum/core/numeric/predicates.cljc +++ b/src/quantum/core/numeric/predicates.cljc @@ -4,7 +4,7 @@ (:require #?(:cljs [com.gfredericks.goog.math.Integer :as int]) [quantum.core.compare.core :as comp] - [quantum.core.data.numeric :as dnum + [quantum.core.data.numeric :as dn :refer [bigdec? bigint? clj-bigint? java-bigint? numeric-primitive?]] [quantum.core.data.primitive :as p] [quantum.core.logic :as l] @@ -23,7 +23,7 @@ (-> x .lpart neg?) (-> x .bipart .signum neg?)))) #?(:cljs ([x bigint?] (.isNegative x))) -#?(:clj ([x dnum/ratio?] (-> x .numerator .signum neg?)))) +#?(:clj ([x dn/ratio?] (-> x .numerator .signum neg?)))) ;; TODO TYPED (t/defn ^:inline pos? > p/boolean? @@ -33,7 +33,7 @@ (-> x .lpart pos?) (-> x .bipart .signum pos?)))) #?(:cljs ([x bigint?] (l/not (.isNegative x)))) -#?(:clj ([x dnum/ratio?] (-> x .numerator .signum pos?)))) +#?(:clj ([x dn/ratio?] (-> x .numerator .signum pos?)))) ;; TODO TYPED (t/defn ^:inline zero? > p/boolean? @@ -43,7 +43,7 @@ (-> x .lpart zero?) (-> x .bipart .signum zero?)))) #?(:cljs ([x bigint?] (.isZero x))) -#?(:clj ([x dnum/ratio?] (-> x .numerator .signum zero?)))) +#?(:clj ([x dn/ratio?] (-> x .numerator .signum zero?)))) (t/defnt ^:inline nan? > p/boolean? #?(:clj ([x p/float?] (Float/isNaN x))) @@ -52,9 +52,9 @@ (def npos? (l/fn-not pos?)) (def nneg? (l/fn-not neg?)) -(def pos-int? (l/fn-and dnum/integer? pos?)) -(def neg-int? (l/fn-and dnum/integer? neg?)) -(def npos-int? (l/fn-and dnum/integer? npos?)) -(def nneg-int? (l/fn-and dnum/integer? nneg?)) +(def pos-int? (l/fn-and dn/integer? pos?)) +(def neg-int? (l/fn-and dn/integer? neg?)) +(def npos-int? (l/fn-and dn/integer? npos?)) +(def nneg-int? (l/fn-and dn/integer? nneg?)) (t/defn exact? > p/boolean? [x p/numeric?] (TODO)) diff --git a/src/quantum/core/numeric/strict_args.cljc b/src/quantum/core/numeric/strict_args.cljc index 244de5a9..b3024491 100644 --- a/src/quantum/core/numeric/strict_args.cljc +++ b/src/quantum/core/numeric/strict_args.cljc @@ -10,7 +10,7 @@ #?@(:clj [bigint biginteger bigdec numerator denominator inc' dec'])]) (:require [clojure.core :as c] - [quantum.core.data.numeric :as dnum] + [quantum.core.data.numeric :as dn] [quantum.core.vars :as var :refer [defalias defaliases]] [quantum.core.numeric.convert ] From 76f47cffd1f08fd1e884b6d170b4b561df470f38 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:52:13 -0600 Subject: [PATCH 448/810] Combine nss into `quantum.graphics.core` --- .../{media/imaging => graphics}/core.cljc | 5 +--- src/quantum/media/imaging/ocr.cljc | 26 ------------------- 2 files changed, 1 insertion(+), 30 deletions(-) rename src/quantum/{media/imaging => graphics}/core.cljc (86%) delete mode 100644 src/quantum/media/imaging/ocr.cljc diff --git a/src/quantum/media/imaging/core.cljc b/src/quantum/graphics/core.cljc similarity index 86% rename from src/quantum/media/imaging/core.cljc rename to src/quantum/graphics/core.cljc index e608d935..cc64807e 100644 --- a/src/quantum/media/imaging/core.cljc +++ b/src/quantum/graphics/core.cljc @@ -1,7 +1,4 @@ -(ns - ^{:doc "Image library. Conversion, compression, etc." - :attribution "alexandergunnarson"} - quantum.media.imaging.core +(ns quantum.graphics.core #?(:clj (:import javax.imageio.ImageIO java.awt.image.BufferedImage))) diff --git a/src/quantum/media/imaging/ocr.cljc b/src/quantum/media/imaging/ocr.cljc deleted file mode 100644 index 109570f1..00000000 --- a/src/quantum/media/imaging/ocr.cljc +++ /dev/null @@ -1,26 +0,0 @@ -(ns quantum.media.imaging.ocr - (:require - [quantum.core.error :as err - :refer [TODO]] - [quantum.core.paths :as path] - [quantum.core.system :as sys ] - [quantum.core.io :as io ] - [quantum.core.process - :refer [proc!]] - [quantum.core.fn - :refer [fn-> fn']] - [quantum.core.logic - :refer [ifn1]] - [quantum.core.collections :as coll - :refer [join map+ filter+ flatten+]])) - -(defn ocr - "Uses the open-source tool `tesseract` to perform OCR on a document. - Refer to the Tesseract GitHub for help and setup. - - To OCR a PDF: - `gs -o -sDEVICE=tiffg4 && tesseract stdout pdf > `" - [in out opts] - (TODO)) - - From 441bdda73bd13a4d58697e13491b3c1a8beda4d0 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:52:20 -0600 Subject: [PATCH 449/810] Add todos to `quantum.core.streams` --- src/quantum/core/streams.cljc | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/src/quantum/core/streams.cljc b/src/quantum/core/streams.cljc index d88433cc..bb1af71d 100644 --- a/src/quantum/core/streams.cljc +++ b/src/quantum/core/streams.cljc @@ -1,10 +1,11 @@ -(ns quantum.core.streams) - -; pingles/zilch — ZeroMQ Clojure Library -#_"mpenet/grease — Provides faster non thread-safe alternatives to common Classes: - ByteArrayInputStream ByteArrayOuputStream - BufferedInputStream BufferedOutputStream - CharArrayReader CharArrayWriter - StringReader - Code taken from various repositories such as Apache Cassandra and ElasticSearch. - TODO provide bindings for e.g. Cassandra and ElasticSearch to update with bugfixes" +(ns quantum.core.streams + {:todo #{"Maybe move to `quantum.core.data.streams`?" + "Incorporate https://github.com/thi-ng/dstruct/blob/master/src/streams.org" + "pingles/zilch — ZeroMQ Clojure Library" + "mpenet/grease — Provides faster non thread-safe alternatives to common Classes: + ByteArrayInputStream ByteArrayOuputStream + BufferedInputStream BufferedOutputStream + CharArrayReader CharArrayWriter + StringReader + Code taken from various repositories such as Apache Cassandra and ElasticSearch. + TODO provide bindings for e.g. Cassandra and ElasticSearch to update with bugfixes"}}) From d343a60b03f16560195abb5950c22304c7c171b6 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:52:48 -0600 Subject: [PATCH 450/810] `time/now-nanos` --- src/quantum/core/time/core.cljc | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/quantum/core/time/core.cljc b/src/quantum/core/time/core.cljc index dd6c4045..682e8436 100644 --- a/src/quantum/core/time/core.cljc +++ b/src/quantum/core/time/core.cljc @@ -27,7 +27,7 @@ [quantum.core.numeric :as num] [quantum.core.spec :as s] [quantum.core.vars :as var - :refer [defalias]] + :refer [def- defalias]] [quantum.measure.convert :as uconv :refer [convert]]) #?(:cljs @@ -43,6 +43,17 @@ [java.time.format DateTimeFormatter] [java.time.temporal Temporal TemporalAccessor ChronoField]))) +#?(:cljs +(def- now-nanos* + (or (.-now js/performance) + (.-webkitNow js/performance) + (.-mozNow js/performance) + (.-msNow js/performance) + (.-oNow js/performance)))) + +(t/defn ^:inline now-nanos > #?(:clj long? :cljs (t/assume std-fixint?)) [] + #?(:clj (System/nanoTime) :cljs (now-nanos*))) + ; ===== ABOUT ===== ; https://www.npmjs.com/package/js-joda ; js-joda is fast. It is about 2 to 10 times faster than other javascript date libraries. From fae3b0d9b76452dc1f728d6165cec01502217e64 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 18:53:18 -0600 Subject: [PATCH 451/810] `log-2?` --- src/quantum/core/numeric/exponents.cljc | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/quantum/core/numeric/exponents.cljc b/src/quantum/core/numeric/exponents.cljc index 848e6aa0..895425cc 100644 --- a/src/quantum/core/numeric/exponents.cljc +++ b/src/quantum/core/numeric/exponents.cljc @@ -1,6 +1,7 @@ (ns quantum.core.numeric.exponents (:require [clojure.core :as core] + [quantum.core.data.bits :as bit] [quantum.core.numeric.operators :as no] [quantum.core.type :as t] [quantum.core.vars @@ -106,6 +107,11 @@ #?(:clj (def ^:const ^double ln-2 (ln 2))) +(t/defn log-2? + {:adapted-from 'thi.ng.math.bits/log2?} + ( [x dn/integer?] (and (no/zero? (bit/and x (no/dec x))) (??/not (no/zero? x)))) + (^:intrinsic [x dn/number?] false)) + #?(:clj (defnt log-2 [^double x] (/ (ln x) ln-2)) :cljs (defnt log-2 [^number? x] (js/Math.log2 x))) From b2b59bb8aa22efd7dd30c1b4de2bbd22517eeb3c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 21:01:58 -0600 Subject: [PATCH 452/810] Ensure `fnt?` checks correct keyword --- resources-dev/defnt.cljc | 5 ++--- src-untyped/quantum/untyped/core/analyze.cljc | 3 ++- src-untyped/quantum/untyped/core/type.cljc | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 5ade3a29..fa1f5b59 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -130,9 +130,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative (#?(:clj clojure.core.protocols/coll-reduce :cljs cljs.core/-reduce) xs rf init)) - (if (A) ...) should be (if ^boolean (A) ...) if A returns a `p/boolean?` - - We should not rely on the value of dynamic vars e.g. `*math-context*` unless specifically typed - - We'll have to make a special class or *something* like that to ensure that typed bindings are only - bound within typed contexts. + - We'll should make a special class or *something* like that to ensure that typed bindings are only + bound within typed contexts. - `t/defn` declaration: `(t/defn >std-fixint > std-fixint?)` - t/extend-defn! - t/defrecord diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 315454e0..7bc51f67 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -523,7 +523,8 @@ ;; `t/none?` because nothing is actually returned :type t/none?}))))) -(defns- analyze-seq|var [opts ::opts, env ::env, [_ _, arg-form _ :as form] _ > uast/var?] +(defns- analyze-seq|var + [opts ::opts, env ::env, [_ _, arg-form _ :as form] _ > uast/var?] (ifs (-> form count (not= 2)) (err! "Must supply exactly one input to `var`" {:form form}) (not (symbol? arg-form)) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 98da6ae6..234361fd 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -659,7 +659,7 @@ (isa?|direct #?(:clj clojure.lang.IFn :cljs cljs.core/IFn))) ;; Used by `quantum.untyped.core.analyze` via `t/callable?` -(def fnt? (and fn? (>expr (fn-> c/meta ::type utr/fn-type?)))) +(def fnt? (and fn? (>expr (fn-> c/meta :quantum.core.type/type utr/fn-type?)))) ;; TODO should we allow java.lang.Runnable, java.util.concurrent.Callable, and other ;; functional interfaces to be `callable?`? From 7bbce938af39eac3f32d1c05632d6ffabeff8975 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 21:51:08 -0600 Subject: [PATCH 453/810] More dependent type tests pass :D --- resources-dev/defnt.cljc | 2 +- src-untyped/quantum/untyped/core/analyze.cljc | 146 ++++++++++-------- src-untyped/quantum/untyped/core/type.cljc | 3 +- test/quantum/test/untyped/core/analyze.cljc | 9 +- 4 files changed, 92 insertions(+), 68 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index fa1f5b59..2abd93aa 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -66,7 +66,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative `t/any?` but rather the `t/or` of its arguments. In fact maybe it would work if we added the `::t/type` metadata to it after the fact. [2] t/value-of - - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` + - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` [3] - t/input-type - `(t/input-type >namespace :?)` meaning the possible input types to the first input to `>namespace` - `(t/input-type reduce :_ :_ :?)` diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 7bc51f67..ef8b9eb0 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -638,7 +638,7 @@ (quantum.core.type/type quantum.untyped.core.type/type) true false))) -(defns- analyze-dependent-type-call +(defns- analyze-seq|dependent-type-call [opts ::opts, env ::env, [caller|form _, arg-form _ & extra-args-form _ :as form] _ > uast/node?] (if (not (empty? extra-args-form)) (err! "Incorrect number of args passed to dependent type call" @@ -652,7 +652,82 @@ :form (-> arg-node :type uform/>form) :caller caller|node :args [arg-node] - :type (:type arg-node)})))) + :type (t/value (:type arg-node))})))) + +(defns- analyze-seq|call + [opts ::opts, env ::env, [caller|form _ & args-form _ :as form] _ > uast/call-node?] + (let [caller|node (analyze* opts env caller|form) + caller|type (:type caller|node) + inputs-ct (count args-form)] + ;; TODO fix this line of code and extend t/compare so the comparison checks below + ;; will work with t/fn + (case (if (utr/fn-type? caller|type) + -1 + (t/compare caller|type t/callable?)) + (1 2) (err! "It is not known whether form can be called" {:node caller|node}) + 3 (err! "Form cannot be called" {:node caller|node}) + (-1 0) (let [caller-kind + (ifs (utr/fn-type? caller|type) :fnt + (t/<= caller|type t/keyword?) :keyword + (t/<= caller|type t/+map|built-in?) :map + (t/<= caller|type t/+vector|built-in?) :vector + (t/<= caller|type t/+set|built-in?) :set + (t/<= caller|type t/fn?) :fn + ;; If it's callable but not fn, we might have missed something in + ;; this dispatch so for now we throw + (err! "Don't know how how to handle non-fn callable" + {:caller caller|node})) + assert-valid-inputs-ct + (case caller-kind + (:keyword :map) + (when-not (or (= inputs-ct 1) (= inputs-ct 2)) + (err! (str "Keywords and `clojure.core` persistent maps must be " + "provided with exactly one or two inputs when calling " + "them") + {:inputs-ct inputs-ct :caller caller|node})) + + (:vector :set) + (when-not (= inputs-ct 1) + (err! (str "`clojure.core` persistent vectors and `clojure.core` " + "persistent sets must be provided with exactly one " + "input when calling them") + {:inputs-ct inputs-ct :caller caller|node})) + + :fnt + (when-not (-> caller|type utr/fn-type>arities (contains? inputs-ct)) + (err! "Unhandled number of inputs for fnt" + {:inputs-ct inputs-ct :caller caller|node})) + ;; For non-typed fns, unknown; we will have to risk runtime exception + ;; because we can't necessarily rely on metadata to tell us the + ;; whole truth + :fn nil) + {:keys [input-nodes out-type]} + (call>input-nodes+out-type + opts env caller|node caller|type caller-kind inputs-ct args-form) + apply-arg-type-combine + (fn [combinef] + (->> input-nodes + (c/map+ :type) + (c/map+ t/unvalue) + r/join + (apply t/or) + t/value)) + out-type' + (if (:arglist-context? opts) + ;; TODO this is probably not a great way to do this; rethink this + (condp = (:type caller|node) + (t/value t/isa?) (apply-arg-type-combine t/isa?) + (t/value t/or) (apply-arg-type-combine t/or) + (t/value t/and) (apply-arg-type-combine t/and) + out-type) + out-type)] + (uast/call-node + {:env env + :unanalyzed-form form + :form (list* (:form caller|node) (map :form input-nodes)) + :caller caller|node + :args input-nodes + :type out-type'}))))) ;; TODO break this fn up. It's "clean" but just not broken up (defns- analyze-seq* @@ -671,68 +746,15 @@ new (analyze-seq|new opts env form) throw (analyze-seq|throw opts env form) var (analyze-seq|var opts env form) - (if-let [caller-form-dependent-type-call? - (and (:arglist-context? opts) + (if (:arglist-context? opts) + (if-let [caller-form-dependent-type-call? (case caller|form (quantum.core.type/type quantum.untyped.core.type/type) true - false))] - (analyze-dependent-type-call opts env form) - (let [caller|node (analyze* opts env caller|form) - caller|type (:type caller|node) - inputs-ct (count body)] - ;; TODO fix this line of code and extend t/compare so the comparison checks below - ;; will work with t/fn - (case (if (utr/fn-type? caller|type) - -1 - (t/compare caller|type t/callable?)) - (1 2) (err! "It is not known whether form can be called" {:node caller|node}) - 3 (err! "Form cannot be called" {:node caller|node}) - (-1 0) (let [caller-kind - (ifs (utr/fn-type? caller|type) :fnt - (t/<= caller|type t/keyword?) :keyword - (t/<= caller|type t/+map|built-in?) :map - (t/<= caller|type t/+vector|built-in?) :vector - (t/<= caller|type t/+set|built-in?) :set - (t/<= caller|type t/fn?) :fn - ;; If it's callable but not fn, we might have missed something in - ;; this dispatch so for now we throw - (err! "Don't know how how to handle non-fn callable" - {:caller caller|node})) - assert-valid-inputs-ct - (case caller-kind - (:keyword :map) - (when-not (or (= inputs-ct 1) (= inputs-ct 2)) - (err! (str "Keywords and `clojure.core` persistent maps must be " - "provided with exactly one or two inputs when calling " - "them") - {:inputs-ct inputs-ct :caller caller|node})) - - (:vector :set) - (when-not (= inputs-ct 1) - (err! (str "`clojure.core` persistent vectors and `clojure.core` " - "persistent sets must be provided with exactly one " - "input when calling them") - {:inputs-ct inputs-ct :caller caller|node})) - - :fnt - (when-not (-> caller|type utr/fn-type>arities (contains? inputs-ct)) - (err! "Unhandled number of inputs for fnt" - {:inputs-ct inputs-ct :caller caller|node})) - ;; For non-typed fns, unknown; we will have to risk runtime exception - ;; because we can't necessarily rely on metadata to tell us the - ;; whole truth - :fn nil) - {:keys [input-nodes out-type]} - (call>input-nodes+out-type - opts env caller|node caller|type caller-kind inputs-ct body)] - (uast/call-node - {:env env - :unanalyzed-form form - :form (list* (:form caller|node) (map :form input-nodes)) - :caller caller|node - :args input-nodes - :type out-type}))))))) + false)] + (analyze-seq|dependent-type-call opts env form) + (analyze-seq|call opts env form)) + (analyze-seq|call opts env form)))) (defns- analyze-seq [opts ::opts, env ::env, form _] (let [expanded-form (ufeval/macroexpand form)] @@ -832,7 +854,7 @@ (def analyze-arg-syms|max-iter 100) (defns- unvalue-node [node uast/node? > uast/node?] - (cond-> node (not (dependent-type-call-node? node)) (update :type t/unvalue))) + (cond-> node true (update :type t/unvalue))) (defns analyze-arg-syms ([arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _] diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 234361fd..5b69e75a 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -698,7 +698,8 @@ ;; Used by `quantum.untyped.core.analyze` (def literal? - (or nil? boolean? symbol? keyword? string? #?(:clj long?) double? regex? #?(:clj tagged-literal?))) + (or nil? boolean? symbol? keyword? string? #?(:clj long?) double? regex? + #?(:clj tagged-literal?))) ;; TODO this might not be right — quite possibly any seq is a valid form ;; TODO this has to be recursively true for seq, vector, map, and set diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index fe17a492..b2329ccc 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -12,7 +12,8 @@ (self/analyze-arg-syms {'x `tt/boolean?} `(tt/value tt/byte)) (self/analyze-arg-syms {'x `tt/boolean?} `(t/isa? Byte)) -(defn fake-typed-defn +;; Simulates a typed fn +(defn >long-checked {:quantum.core.type/type (t/ftype nil [t/string? :> tt/long?])} []) @@ -57,9 +58,9 @@ -> (t/isa? Number)`" (let [ana (self/analyze-arg-syms {'x `tt/boolean?} - `(let [~'x (fake-typed-defn "123")] - (t/or (t/isa? Number) (t/type ~'x))))] + `(let [~'x (>long-checked "123")] + (t/or (t/isa? Byte) (t/type ~'x))))] (is= t/boolean? (get-in ana [:arg-sym->arg-type 'x])) - (is= (t/or tt/byte? tt/boolean?) + (is= (t/or tt/byte? tt/long?) (get-in ana [:out-type]))))))) From 43887b7382d9af32c1ca7d496a81e1d4ae8a279e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 21:59:22 -0600 Subject: [PATCH 454/810] Fulfill a todo! --- resources-dev/defnt.cljc | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 2abd93aa..064c4510 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -62,9 +62,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative [1 .] t/type - [x] Make sure that (t/type t/boolean?) is not (t/value t/boolean?) but rather t/boolean?. We need to 'un-`t/value`' it somehow? - - [.] We need to ensure that operators are recognized as such. `t/or` should not return - `t/any?` but rather the `t/or` of its arguments. In fact maybe it would work if we - added the `::t/type` metadata to it after the fact. + - [x] We need to ensure that operators are recognized as such. `t/or` should not return + `t/any?` but rather the `t/or` of its arguments. [2] t/value-of - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` [3] - t/input-type From ff06b4f05ae636bfa80c946c44cd3e28f155a8ce Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 21:59:33 -0600 Subject: [PATCH 455/810] Reorganize the ` handle-type-combinators` --- src-untyped/quantum/untyped/core/analyze.cljc | 34 +++++++++++-------- 1 file changed, 20 insertions(+), 14 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index ef8b9eb0..d57c55d1 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -654,6 +654,25 @@ :args [arg-node] :type (t/value (:type arg-node))})))) +(defns- apply-arg-type-combine [combinef fn?, input-nodes _ > t/value-type?] + (->> input-nodes + (c/map+ :type) + (c/map+ t/unvalue) + r/join + (apply combinef) + t/value)) + +;; TODO this is probably not a great way to do this; rethink this +;; Maybe it would work more cleanly if we added the `::t/type` metadata to each `t/` operator after +;; the fact? +(defns- handle-type-combinators + [caller|node uast/node?, input-nodes _, out-type t/type? > t/type?] + (condp = (:type caller|node) + (t/value t/isa?) (apply-arg-type-combine t/isa? input-nodes) + (t/value t/or) (apply-arg-type-combine t/or input-nodes) + (t/value t/and) (apply-arg-type-combine t/and input-nodes) + out-type)) + (defns- analyze-seq|call [opts ::opts, env ::env, [caller|form _ & args-form _ :as form] _ > uast/call-node?] (let [caller|node (analyze* opts env caller|form) @@ -704,22 +723,9 @@ {:keys [input-nodes out-type]} (call>input-nodes+out-type opts env caller|node caller|type caller-kind inputs-ct args-form) - apply-arg-type-combine - (fn [combinef] - (->> input-nodes - (c/map+ :type) - (c/map+ t/unvalue) - r/join - (apply t/or) - t/value)) out-type' (if (:arglist-context? opts) - ;; TODO this is probably not a great way to do this; rethink this - (condp = (:type caller|node) - (t/value t/isa?) (apply-arg-type-combine t/isa?) - (t/value t/or) (apply-arg-type-combine t/or) - (t/value t/and) (apply-arg-type-combine t/and) - out-type) + (handle-type-combinators caller|node input-nodes out-type) out-type)] (uast/call-node {:env env From dc8295f108bf3eb0356d0b4966e33d8d9f898cf5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 21:59:39 -0600 Subject: [PATCH 456/810] Test parity --- test/quantum/test/untyped/core/analyze.cljc | 3 +-- test/quantum/test/untyped/core/type/defnt.cljc | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index b2329ccc..3cffa95a 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -54,8 +54,7 @@ 2. Analyze `(t/or t/number? (t/type x))` 1. Analyze `(t/type x)` -> `(t/isa? Long)` - -> `(t/or (t/isa? Number) (t/isa? Long)) - -> (t/isa? Number)`" + -> `(t/or (t/isa? Byte) (t/isa? Long))" (let [ana (self/analyze-arg-syms {'x `tt/boolean?} `(let [~'x (>long-checked "123")] diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index d5f2c6a4..98eb9134 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1376,7 +1376,7 @@ (macroexpand ' (self/defn dependent-type-nest-shadow ([x tt/boolean? > (let [x (>long-checked "123")] - (t/or t/number? (t/type x)))] (if x x 1))) + (t/or (t/isa? Byte) (t/type x)))] (if x x 1))) expected (case (env-lang) :clj From 695ad5e65581316ce71478ffb1c364478622f6b8 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 22:24:37 -0600 Subject: [PATCH 457/810] Add complexity analysis note --- resources-dev/defnt.cljc | 1 + 1 file changed, 1 insertion(+) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 064c4510..cb3ff790 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -102,6 +102,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - Peformance analysis (this comes very much later) - We should be able to do complexity analysis. Similarly to how we can combine and manipulate types, we could do like `(cplex/assume (cplex/o :n))` or `(cplex/assume (cplex/o :n2))` etc. + - For `reduce` we'd always know it's up to N operations, so O(n * ) - Record performance for each relevant part and cache? - (if (dcoll/reduced? ret) ;; TODO TYPED `(ref/deref ret)` should realize it's dealing with a `reduced?` From 6fc002937c54a73c3dedd0ecf96aa3bd83664536 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 22:24:50 -0600 Subject: [PATCH 458/810] Change alias --- src-untyped/quantum/untyped/core/analyze.cljc | 80 +++++++++---------- 1 file changed, 39 insertions(+), 41 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index d57c55d1..ef74dabd 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -4,7 +4,7 @@ [quantum.core.type.core :as tcore] [quantum.untyped.core.analyze.ast :as uast] [quantum.untyped.core.analyze.expr :as uxp] - [quantum.untyped.core.collections :as c + [quantum.untyped.core.collections :as uc :refer [>vec]] [quantum.untyped.core.collections.logic :as clogic] [quantum.untyped.core.compare :as ucomp] @@ -92,21 +92,21 @@ ;; (http://docs.oracle.com/javase/specs/jls/se8/html/jls-8.html#jls-8.4.2) and that the bug ;; only exists in Java 6 or 7 on Oracle's JDK, OpenJDK, and IBM's JDK: https://stackoverflow.com/questions/5561436/can-two-java-methods-have-same-name-with-different-return-types with-distinct-arg-class-seqs - (fn->> (c/group-by (fn-> :arg-classes vec)) + (fn->> (uc/group-by (fn-> :arg-classes vec)) vals - (c/map with-most-specific-out-class))] + (uc/map with-most-specific-out-class))] (->> (.getMethods c) - (c/map+ (fn [^java.lang.reflect.Method x] - (Method. (.getName x) (.getReturnType x) (.getParameterTypes x) - (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) - :static - :instance)))) - (c/group-by (fn [^Method x] (:name x))) ; TODO all of these need to be into !vector and !hash-map - (c/map-vals+ - (fn->> (c/group-by (fn [^Method x] (count (:arg-classes x)))) - (c/map-vals+ - (fn->> (c/group-by (fn [^Method x] (:kind x))) - (c/map-vals+ with-distinct-arg-class-seqs) + (uc/map+ (fn [^java.lang.reflect.Method x] + (Method. (.getName x) (.getReturnType x) (.getParameterTypes x) + (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) + :static + :instance)))) + (uc/group-by (fn [^Method x] (:name x))) ; TODO all of these need to be into !vector and !hash-map + (uc/map-vals+ + (fn->> (uc/group-by (fn [^Method x] (count (:arg-classes x)))) + (uc/map-vals+ + (fn->> (uc/group-by (fn [^Method x] (:kind x))) + (uc/map-vals+ with-distinct-arg-class-seqs) (r/join {}))) (r/join {}))) (r/join {}))))) @@ -127,7 +127,7 @@ "Returns all the public constructors associated with a class, as a vector." [^Class c class? > vector?] (->> (.getConstructors c) - (c/map (fn [^java.lang.reflect.Constructor x] (Constructor. (.getParameterTypes x))))))) + (uc/map (fn [^java.lang.reflect.Constructor x] (Constructor. (.getParameterTypes x))))))) (defonce class>constructors|with-cache (memoize (fn [c] (class>constructors c)))) @@ -142,12 +142,12 @@ "Returns all the public fields associated with a class, as a map from field name to field." [^Class c class? > map?] (->> (.getFields c) - (c/map+ (fn [^java.lang.reflect.Field x] - [(.getName x) - (Field. (.getName x) (.getType x) - (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) - :static - :instance))])) + (uc/map+ (fn [^java.lang.reflect.Field x] + [(.getName x) + (Field. (.getName x) (.getType x) + (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) + :static + :instance))])) (r/join {})))) ; TODO !hash-map #?(:clj @@ -247,11 +247,11 @@ :body body ;; To types, only the last sub-AST-node ever matters, as each is independent from ;; the others - :type (-> body c/last :type)})))) + :type (-> body uc/last :type)})))) (defns analyze-seq|let*|bindings [opts ::opts, env ::env, bindings|form _] (->> bindings|form - (c/partition-all+ 2) + (uc/partition-all+ 2) (reduce (fn [{env' :env !bindings :form :keys [bindings-map]} [sym form :as binding|form]] (let [node (analyze* opts env' form)] ; environment is additive with each binding {:env (assoc env' sym node) @@ -302,7 +302,7 @@ (reduce (fn [call-sites' i] (->> call-sites' - (c/map+ (fn [{:keys [^"[Ljava.lang.Object;" arg-classes]}] (aget arg-classes i))) + (uc/map+ (fn [{:keys [^"[Ljava.lang.Object;" arg-classes]}] (aget arg-classes i))) (ucomp/comp-mins-of compare-class-specificity))) call-sites)))) @@ -317,7 +317,7 @@ arg|analyzed|type (:type arg|analyzed) call-sites' (->> call-sites - (c/filter + (uc/filter (fn [{:keys [^"[Ljava.lang.Object;" arg-classes]}] (t/<= arg|analyzed|type (class>type (aget arg-classes i|arg))))))] @@ -377,17 +377,17 @@ method-form simple-symbol?, args|form _ #_(seq-of form?) > uast/method-call?] ;; TODO cache type by method (if-not-let [methods-for-name (-> target-class class>methods|with-cache - (c/get (name method-form)))] + (uc/get (name method-form)))] (if (empty? args|form) (err! "No such method or field in class" {:class target-class :method-or-field method-form}) (err! "No such method in class" {:class target-class :methods method-form})) - (if-not-let [methods-for-ct (c/get methods-for-name (c/count args|form))] + (if-not-let [methods-for-ct (uc/get methods-for-name (uc/count args|form))] (err! "Incorrect number of arguments for method" {:class target-class :method method-form :possible-counts (->> methods-for-name keys (apply sorted-set))}) (let [[kind non-kind] (if static? [:static :instance] [:instance :static])] - (if-not-let [methods-for-ct-and-kind (c/get methods-for-ct kind)] + (if-not-let [methods-for-ct-and-kind (uc/get methods-for-ct kind)] (err! (istr "Method found for arg-count, but was ~non-kind, not ~kind") {:class target-class :method method-form :args args|form}) (analyze-seq|dot|method-call|incrementally-analyze opts env form target target-class @@ -436,7 +436,7 @@ {:form form :target-type (:type target)}) (if-let [field (and (empty? args-forms) (-> target-class class>fields|with-cache - (c/get (name method-or-field))))] + (uc/get (name method-or-field))))] (analyze-seq|dot|field-access opts env form target method-or-field field) (analyze-seq|dot|method-call opts env form target target-class (boolean ?target-static-class-map) method-or-field args-forms))))))) @@ -452,8 +452,8 @@ constructors (-> c class>constructors|with-cache) args-ct (count args|form) constructors-for-ct (->> constructors - (c/filter (fn [{:keys [^"[Ljava.lang.Object;" arg-classes]}] - (= (alength arg-classes) args-ct))))] + (uc/filter (fn [{:keys [^"[Ljava.lang.Object;" arg-classes]}] + (= (alength arg-classes) args-ct))))] (if (empty? constructors-for-ct) (err! "No constructors for class match the arg ct" {:class c :args|form args|form}) (let [{:keys [args|analyzed call-sites]} @@ -551,7 +551,7 @@ (reduce (fn [ret {:as overload :keys [input-types]}] (if-let [or-types-that-match - (->> or-types (c/lfilter #(t/<= % (get input-types i))) seq)] + (->> or-types (uc/lfilter #(t/<= % (get input-types i))) seq)] (-> ret (update :dispatchable-overloads-seq' conj overload) (update :non-dispatchable-or-types @@ -560,7 +560,7 @@ {:dispatchable-overloads-seq' [] :non-dispatchable-or-types (set or-types)}))] (if (or (empty? dispatchable-overloads-seq') - (c/contains? non-dispatchable-or-types)) + (uc/contains? non-dispatchable-or-types)) (err! "No overloads satisfy the inputs, whether direct or dynamic" {:caller caller|node :inputs body @@ -575,7 +575,7 @@ [{:as ret :keys [dispatchable-overloads-seq]} input|analyzed i caller|node body] (if-let [dispatchable-overloads-seq' (->> dispatchable-overloads-seq - (c/lfilter + (uc/lfilter (fn [{:keys [input-types]}] (t/<= (:type input|analyzed) (get input-types i)))) seq)] @@ -586,7 +586,7 @@ (case dispatch-type :direct (-> dispatchable-overloads-seq first :output-type) :dynamic (->> dispatchable-overloads-seq - (c/lmap :output-type) + (uc/lmap :output-type) ;; Technically we could do a complex conditional instead of a simple `t/or` but ;; no need (apply t/or)))) @@ -604,7 +604,7 @@ ;; We could do a little smarter analysis here but we'll keep it simple for now t/any?)} (->> body - (c/map+ #(analyze* opts env %)) + (uc/map+ #(analyze* opts env %)) (reducei (fn [{:as ret :keys [dispatch-type]} input|analyzed i] (if (= :fnt caller-kind) @@ -656,8 +656,8 @@ (defns- apply-arg-type-combine [combinef fn?, input-nodes _ > t/value-type?] (->> input-nodes - (c/map+ :type) - (c/map+ t/unvalue) + (uc/map+ :type) + (uc/map+ t/unvalue) r/join (apply combinef) t/value)) @@ -883,9 +883,7 @@ (binding [quantum.untyped.core.analyze.ast/*print-env?* false quantum.untyped.core.print/*collapse-symbols?* true] (quantum.untyped.core.print/ppr ret)) - (assoc ret - :arg-sym->arg-type (->> env (c/map-vals' :type)) - :out-type (:type out-type-node))) + [ret]) (>= n|iter analyze-arg-syms|max-iter) (err! "Max number of iterations reached for `analyze-arg-syms" {:n n|iter}) (let [arg-sym (first arglist-syms|unanalyzed) From 2e9efa53e1b847775c4f16a09939b5e6d7bda9ca Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 22:24:58 -0600 Subject: [PATCH 459/810] Cosmetic change --- src-untyped/quantum/untyped/core/data/map.cljc | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/map.cljc b/src-untyped/quantum/untyped/core/data/map.cljc index 411aacd2..fbef046f 100644 --- a/src-untyped/quantum/untyped/core/data/map.cljc +++ b/src-untyped/quantum/untyped/core/data/map.cljc @@ -1,6 +1,4 @@ -(ns - ^{:doc "Useful map functions. |map-entry|, a better merge, sorted-maps, etc." - :attribution "alexandergunnarson"} +(ns "Map functions. |map-entry|, a better merge, sorted-maps, etc." quantum.untyped.core.data.map (:refer-clojure :exclude [split-at, merge, sorted-map sorted-map-by, array-map, hash-map]) From 57181325b8cba9de421fc6073a2015885484eb0b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 4 Oct 2018 22:25:11 -0600 Subject: [PATCH 460/810] Flesh out next test --- test/quantum/test/untyped/core/analyze.cljc | 52 +++++++++++++------ .../quantum/test/untyped/core/type/defnt.cljc | 14 ----- 2 files changed, 37 insertions(+), 29 deletions(-) diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index 3cffa95a..c5416fa2 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -3,6 +3,8 @@ [quantum.test.untyped.core.type :as tt] [quantum.untyped.core.analyze :as self] [quantum.untyped.core.analyze.ast :as uast] + [quantum.untyped.core.collections :as uc] + [quantum.untyped.core.data.map :as umap] [quantum.untyped.core.test :refer [deftest is is= testing]] [quantum.untyped.core.type :as t])) @@ -13,10 +15,15 @@ (self/analyze-arg-syms {'x `tt/boolean?} `(t/isa? Byte)) ;; Simulates a typed fn -(defn >long-checked +(defn- >long-checked {:quantum.core.type/type (t/ftype nil [t/string? :> tt/long?])} []) +(defn- transform-ana [ana] + (->> ana + (mapv #(do [(->> % :env (uc/map-vals' :type)) + (-> % :out-type-node :type)])))) + ;; More dependent type tests in `quantum.test.untyped.core.type.defnt` but those are more like ;; integration tests (deftest dependent-type-test @@ -27,10 +34,8 @@ 2. Analyze out-type = `(t/type x)` -> `(t/isa? Boolean)`" (let [ana (self/analyze-arg-syms {'x `tt/boolean?} `(t/type ~'x))] - (is= t/boolean? - (get-in ana [:arg-sym->arg-type 'x])) - (is= t/boolean? - (get-in ana [:out-type])))) + (is= [[{'x tt/boolean?} tt/boolean?]] + (transform-ana ana)))) (testing "Nested within another type" (testing "Without arg shadowing" #_"1. Analyze `x` = `tt/boolean?` @@ -39,11 +44,9 @@ 1. Analyze `(t/type x)` -> `(t/isa? Boolean)` -> `(t/or (t/isa? Byte) (t/isa? Boolean))`" - (let [ana (self/analyze-arg-syms {'x `tt/boolean?} `(t/or tt/byte? (t/type ~'x)))] - (is= t/boolean? - (get-in ana [:arg-sym->arg-type 'x])) - (is= (t/or tt/byte? tt/boolean?) - (get-in ana [:out-type])))) + (let [ana (self/analyze-arg-syms {'x 'tt/boolean?} `(t/or tt/byte? (t/type ~'x)))] + (is= [[{'x tt/boolean?} (t/or tt/byte? tt/boolean?)]] + (transform-ana ana)))) (testing "With arg shadowing" #_"1. Analyze `x` = `tt/boolean?` -> Put `x` in env as `(t/isa? Boolean)` @@ -56,10 +59,29 @@ -> `(t/isa? Long)` -> `(t/or (t/isa? Byte) (t/isa? Long))" (let [ana (self/analyze-arg-syms - {'x `tt/boolean?} + {'x 'tt/boolean?} `(let [~'x (>long-checked "123")] (t/or (t/isa? Byte) (t/type ~'x))))] - (is= t/boolean? - (get-in ana [:arg-sym->arg-type 'x])) - (is= (t/or tt/byte? tt/long?) - (get-in ana [:out-type]))))))) + (is= [[{'x tt/boolean?} (t/or (t/isa? Byte) tt/long?)]] + (transform-ana ana)))))) + (testing "Output type dependent on splittable but non-primitive-splittable input" + #_"1. Analyze `x` = `(t/or tt/boolean? tt/string?)`. Splittable. + 2. Split `(t/or tt/boolean? tt/string?)`: + [[x tt/boolean? > (t/type x)] + [x tt/string? > (t/type x)]] + 3. Analyze split 0. + 1. Analyze `x` = `tt/boolean?` + -> Put `x` in env as `(t/isa? Boolean)` + 2. Analyze out-type = `(t/type x)` + -> `(t/isa? Boolean)` + 4. Analyze split 1. + 1. Analyze `x` = `tt/string?` + -> Put `x` in env as `(t/isa? String)` + 2. Analyze out-type = `(t/type x)` + -> `(t/isa? String)`" + (let [ana (self/analyze-arg-syms + {'x '(t/or tt/boolean? tt/string?)} + `(t/type ~'x))] + (is= [[{'x tt/boolean?} tt/boolean?] + [{'x tt/string?} tt/string?]] + (transform-ana ana))))) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 98eb9134..62ae5ad7 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1389,20 +1389,6 @@ (let [actual (macroexpand ' (self/defn dependent-type-split - #_"1. Analyze `x` = `(t/or tt/boolean? tt/string?)`. Splittable. - 2. Split `(t/or tt/boolean? tt/string?)`: - [[x tt/boolean? > (t/type x)] - [x tt/string? > (t/type x)]] - 3. Analyze split 0. - 1. Analyze `x` = `tt/boolean?` - -> Put `x` in env as `(t/isa? Boolean)` - 2. Analyze out-type = `(t/type x)` - -> `(t/isa? Boolean)` - 4. Analyze split 1. - 1. Analyze `x` = `tt/string?` - -> Put `x` in env as `(t/isa? String)` - 2. Analyze out-type = `(t/type x)` - -> `(t/isa? String)`" ([x (t/or tt/boolean? tt/string?) > (t/type x)] x)) expected (case (env-lang) From d497db98fbe7fb6de1c32a9684b3ff5912462f87 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 5 Oct 2018 01:07:39 -0600 Subject: [PATCH 461/810] Attach opts to env; another dep type test case passes :D --- src-untyped/quantum/untyped/core/analyze.cljc | 283 +++++++++++------- .../quantum/untyped/core/type/defnt.cljc | 4 +- test/quantum/test/untyped/core/analyze.cljc | 4 +- 3 files changed, 175 insertions(+), 116 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index ef74dabd..e6671187 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -189,10 +189,10 @@ ([v] (->WatchableMutable v nil)) ([v watch] (->WatchableMutable v watch))) -(s/def ::env (s/map-of symbol? t/any?)) - (s/def ::opts (s/map-of keyword? t/any?)) +(s/def ::env (s/map-of (s/or* symbol? #(= % :opts)) t/any?)) + (declare analyze*) (defns- analyze-non-map-seqable @@ -202,9 +202,9 @@ The first argument is the current deduced type of the overall AST node; the second is the deduced type of the current sub-AST-node."}} - [opts ::opts, env ::env, form _, empty-form _, rf _] + [env ::env, form _, empty-form _, rf _] (-> (reducei - (fn [accum form' i] (rf accum (analyze* opts (:env accum) form') i)) + (fn [accum form' i] (rf accum (analyze* (:env accum) form') i)) {:env env :form (transient empty-form) :body (transient [])} form) (update :form (fn-> persistent! (add-file-context-from form))) @@ -213,12 +213,12 @@ (defns- analyze-map {:todo #{"If the map is bound to a variable, preserve type info for it such that lookups can start out with a guarantee of a certain type."}} - [opts ::opts, env ::env, form _] + [env ::env, form _] (TODO "analyze-map") #_(->> form (reduce-kv (fn [{env' :env forms :form} form'k form'v] - (let [ast-node-k (analyze* opts env' form'k) - ast-node-v (analyze* opts env' form'v)] + (let [ast-node-k (analyze* env' form'k) + ast-node-v (analyze* env' form'v)] (->expr-info {:env env' :form (assoc! forms (:form ast-node-k) (:form ast-node-v)) ;; TODO fix; we want the types of the keys and vals to be deduced @@ -226,7 +226,7 @@ (->expr-info {:env env :form (transient {})})) (persistent!-and-add-file-context-from form))) -(defns- analyze-seq|do [opts ::opts, env ::env, [_ _ & body|form _ :as form] _ > uast/do?] +(defns- analyze-seq|do [env ::env, [_ _ & body|form _ :as form] _ > uast/do?] (if (empty? body|form) (uast/do {:env env :unanalyzed-form form @@ -234,7 +234,7 @@ :body [] :type t/nil?}) (let [{analyzed-form :form body :body} - (analyze-non-map-seqable opts env body|form [] + (analyze-non-map-seqable env body|form [] (fn [accum ast-data _] ;; The env should be the same as whatever it was originally because no new scopes ;; are created @@ -249,11 +249,11 @@ ;; the others :type (-> body uc/last :type)})))) -(defns analyze-seq|let*|bindings [opts ::opts, env ::env, bindings|form _] +(defns analyze-seq|let*|bindings [env ::env, bindings|form _] (->> bindings|form (uc/partition-all+ 2) (reduce (fn [{env' :env !bindings :form :keys [bindings-map]} [sym form :as binding|form]] - (let [node (analyze* opts env' form)] ; environment is additive with each binding + (let [node (analyze* env' form)] ; environment is additive with each binding {:env (assoc env' sym node) :form (conj! (conj! !bindings sym) (:form node)) :bindings-map (assoc bindings-map sym node)})) @@ -261,11 +261,11 @@ (<- (update :form (fn-> persistent! (add-file-context-from bindings|form)))))) (defns analyze-seq|let* - [opts ::opts, env ::env, [_ _, bindings|form _ & body|form _ :as form] _ > uast/let*?] + [env ::env, [_ _, bindings|form _ & body|form _ :as form] _ > uast/let*?] (let [{env' :env bindings|form' :form :keys [bindings-map]} - (analyze-seq|let*|bindings opts env bindings|form) + (analyze-seq|let*|bindings env bindings|form) {body|form' :form body|type :type body :body} - (analyze-seq|do opts env' (list* 'do body|form))] + (analyze-seq|do env' (list* 'do body|form))] (uast/let* {:env env :unanalyzed-form form :form (list* 'let* bindings|form' (rest body|form')) @@ -307,13 +307,13 @@ call-sites)))) (defns- analyze-seq|method-or-constructor-call|incrementally-analyze - [opts ::opts, env ::env, form _, target-class class?, args|form _, call-sites-for-ct _ + [env ::env, form _, target-class class?, args|form _, call-sites-for-ct _ kinds-str string? > (s/kv {:args|analyzed vector?})] (let [{:as ret :keys [call-sites args|analyzed]} (->> args|form (reducei (fn [{:as ret :keys [args|analyzed call-sites]} arg|form i|arg] - (let [arg|analyzed (analyze* opts env arg|form) + (let [arg|analyzed (analyze* env arg|form) arg|analyzed|type (:type arg|analyzed) call-sites' (->> call-sites @@ -348,10 +348,10 @@ ret))) (defns- analyze-seq|dot|method-call|incrementally-analyze - [opts ::opts, env ::env, form _, target uast/node?, target-class class?, method-form _ + [env ::env, form _, target uast/node?, target-class class?, method-form _ args|form _ methods-for-ct-and-kind (s/seq-of t/any?) > uast/method-call?] (let [{:keys [args|analyzed call-sites]} - (analyze-seq|method-or-constructor-call|incrementally-analyze opts env form target-class + (analyze-seq|method-or-constructor-call|incrementally-analyze env form target-class args|form methods-for-ct-and-kind "methods") ?cast-type (?cast-call->type target-class method-form) ;; TODO enable the below: @@ -373,7 +373,7 @@ "A note will be made of what methods match the argument types. If only one method is found, that is noted too. If no matching method is found, an exception is thrown." - [opts ::opts, env ::env, form _, target uast/node?, target-class class?, static? t/boolean? + [env ::env, form _, target uast/node?, target-class class?, static? t/boolean? method-form simple-symbol?, args|form _ #_(seq-of form?) > uast/method-call?] ;; TODO cache type by method (if-not-let [methods-for-name (-> target-class class>methods|with-cache @@ -390,11 +390,11 @@ (if-not-let [methods-for-ct-and-kind (uc/get methods-for-ct kind)] (err! (istr "Method found for arg-count, but was ~non-kind, not ~kind") {:class target-class :method method-form :args args|form}) - (analyze-seq|dot|method-call|incrementally-analyze opts env form target target-class + (analyze-seq|dot|method-call|incrementally-analyze env form target target-class method-form args|form methods-for-ct-and-kind)))))) (defns- analyze-seq|dot|field-access - [opts ::opts, env ::env, form _, target _, field-form simple-symbol?, field (t/isa? Field) + [env ::env, form _, target _, field-form simple-symbol?, field (t/isa? Field) > uast/field-access?] (uast/field-access {:env env @@ -414,8 +414,8 @@ ;; TODO type these arguments; e.g. check that ?method||field, if present, is an unqualified symbol (defns- analyze-seq|dot - [opts ::opts, env ::env, [_ _, target-form _, ?method-or-field _ & ?args _ :as form] _] - (let [target (analyze* opts env target-form) + [env ::env, [_ _, target-form _, ?method-or-field _ & ?args _ :as form] _] + (let [target (analyze* env target-form) method-or-field (if (symbol? ?method-or-field) ?method-or-field (first ?method-or-field)) args-forms (if (symbol? ?method-or-field) ?args (rest ?method-or-field))] (if (t/= (:type target) t/nil?) @@ -437,14 +437,14 @@ (if-let [field (and (empty? args-forms) (-> target-class class>fields|with-cache (uc/get (name method-or-field))))] - (analyze-seq|dot|field-access opts env form target method-or-field field) - (analyze-seq|dot|method-call opts env form target target-class + (analyze-seq|dot|field-access env form target method-or-field field) + (analyze-seq|dot|method-call env form target target-class (boolean ?target-static-class-map) method-or-field args-forms))))))) ;; TODO this is not the right approach for CLJS (defns- analyze-seq|new - [opts ::opts, env ::env, [_ _ & [c|form _ & args|form _ :as body] _ :as form] _ > uast/new-node?] - (let [c|analyzed (analyze* opts env c|form)] + [env ::env, [_ _ & [c|form _ & args|form _ :as body] _ :as form] _ > uast/new-node?] + (let [c|analyzed (analyze* env c|form)] (if-not (and (-> c|analyzed :type t/value-type?) (-> c|analyzed :type utr/value-type>value class?)) (err! "Supplied non-class to `new` form" {:form form}) @@ -457,7 +457,7 @@ (if (empty? constructors-for-ct) (err! "No constructors for class match the arg ct" {:class c :args|form args|form}) (let [{:keys [args|analyzed call-sites]} - (analyze-seq|method-or-constructor-call|incrementally-analyze opts env form c + (analyze-seq|method-or-constructor-call|incrementally-analyze env form c args|form constructors-for-ct "constructors")] (uast/new-node {:env env @@ -476,14 +476,14 @@ ;; TODO this should be adding analysis information on every predicate it finds to be true or not true (defns- analyze-seq|if "Performs conditional branch pruning." - [opts ::opts, env ::env, [_ _ & [pred-form _, true-form _, false-form _ :as body] _ :as form] _ + [env ::env, [_ _ & [pred-form _, true-form _, false-form _ :as body] _ :as form] _ > uast/node?] (if-not (<= 2 (count body) 3) (err! "`if` accepts exactly 3 arguments: one predicate test and two branches; received" {:body body}) - (let [pred-node (analyze* opts env pred-form) - true-node (delay (analyze* opts env true-form)) - false-node (delay (analyze* opts env false-form)) + (let [pred-node (analyze* env pred-form) + true-node (delay (analyze* env true-form)) + false-node (delay (analyze* env false-form)) whole-node (delay (uast/if-node @@ -502,15 +502,15 @@ (assoc @false-node :env env)) nil @whole-node)))) -(defns- analyze-seq|quote [opts ::opts, env ::env, [_ _, arg-form _ :as form] _ > uast/quoted?] +(defns- analyze-seq|quote [env ::env, [_ _, arg-form _ :as form] _ > uast/quoted?] (if (-> form count (not= 2)) (err! "Must supply exactly one input to `quote`" {:form form}) (uast/quoted env form (t/value arg-form)))) -(defns- analyze-seq|throw [opts ::opts, env ::env, [_ _, arg-form _ :as form] _ > uast/throw-node?] +(defns- analyze-seq|throw [env ::env, [_ _, arg-form _ :as form] _ > uast/throw-node?] (if (-> form count (not= 2)) (err! "Must supply exactly one input to `throw`" {:form form}) - (let [arg|analyzed (analyze* opts env arg-form)] + (let [arg|analyzed (analyze* env arg-form)] ;; TODO this is not quite true for CLJS but it's good practice at least (if-not (-> arg|analyzed :type (t/<= t/throwable?)) (err! "`throw` requires a throwable; received" @@ -524,7 +524,7 @@ :type t/none?}))))) (defns- analyze-seq|var - [opts ::opts, env ::env, [_ _, arg-form _ :as form] _ > uast/var?] + [env ::env, [_ _, arg-form _ :as form] _ > uast/var?] (ifs (-> form count (not= 2)) (err! "Must supply exactly one input to `var`" {:form form}) (not (symbol? arg-form)) @@ -592,7 +592,7 @@ (apply t/or)))) (defns- call>input-nodes+out-type - [opts ::opts, env ::env, caller|node _, caller|type _, caller-kind _, inputs-ct _, body _ + [env ::env, caller|node _, caller|type _, caller-kind _, inputs-ct _, body _ > (s/kv {:input-nodes t/any? #_(s/seq-of ast/node?) :out-type t/type?})] (dissoc @@ -604,7 +604,7 @@ ;; We could do a little smarter analysis here but we'll keep it simple for now t/any?)} (->> body - (uc/map+ #(analyze* opts env %)) + (uc/map+ #(analyze* env %)) (reducei (fn [{:as ret :keys [dispatch-type]} input|analyzed i] (if (= :fnt caller-kind) @@ -639,12 +639,12 @@ false))) (defns- analyze-seq|dependent-type-call - [opts ::opts, env ::env, [caller|form _, arg-form _ & extra-args-form _ :as form] _ > uast/node?] + [env ::env, [caller|form _, arg-form _ & extra-args-form _ :as form] _ > uast/node?] (if (not (empty? extra-args-form)) (err! "Incorrect number of args passed to dependent type call" {:form form :args-ct (-> extra-args-form count inc)}) - (let [arg-node (analyze* opts env arg-form) - caller|node (analyze* opts env caller|form)] + (let [arg-node (analyze* env arg-form) + caller|node (analyze* env caller|form)] (uast/call-node {:env env ;; We replace the `form` with the form of the arg type @@ -674,8 +674,8 @@ out-type)) (defns- analyze-seq|call - [opts ::opts, env ::env, [caller|form _ & args-form _ :as form] _ > uast/call-node?] - (let [caller|node (analyze* opts env caller|form) + [env ::env, [caller|form _ & args-form _ :as form] _ > uast/call-node?] + (let [caller|node (analyze* env caller|form) caller|type (:type caller|node) inputs-ct (count args-form)] ;; TODO fix this line of code and extend t/compare so the comparison checks below @@ -722,9 +722,9 @@ :fn nil) {:keys [input-nodes out-type]} (call>input-nodes+out-type - opts env caller|node caller|type caller-kind inputs-ct args-form) + env caller|node caller|type caller-kind inputs-ct args-form) out-type' - (if (:arglist-context? opts) + (if (-> env :opts :arglist-context?) (handle-type-combinators caller|node input-nodes out-type) out-type)] (uast/call-node @@ -739,35 +739,35 @@ (defns- analyze-seq* "Analyze a seq after it has been macro-expanded. The ->`form` is post- incremental macroexpansion." - [opts ::opts, env ::env, [caller|form _ & body _ :as form] _ > uast/node?] + [env ::env, [caller|form _ & body _ :as form] _ > uast/node?] (case caller|form - do (analyze-seq|do opts env form) - let* (analyze-seq|let* opts env form) + do (analyze-seq|do env form) + let* (analyze-seq|let* env form) deftype* (TODO "deftype*") fn* (TODO "fn*") def (TODO "def") - . (analyze-seq|dot opts env form) - if (analyze-seq|if opts env form) - quote (analyze-seq|quote opts env form) - new (analyze-seq|new opts env form) - throw (analyze-seq|throw opts env form) - var (analyze-seq|var opts env form) - (if (:arglist-context? opts) + . (analyze-seq|dot env form) + if (analyze-seq|if env form) + quote (analyze-seq|quote env form) + new (analyze-seq|new env form) + throw (analyze-seq|throw env form) + var (analyze-seq|var env form) + (if (-> env :opts :arglist-context?) (if-let [caller-form-dependent-type-call? (case caller|form (quantum.core.type/type quantum.untyped.core.type/type) true false)] - (analyze-seq|dependent-type-call opts env form) - (analyze-seq|call opts env form)) - (analyze-seq|call opts env form)))) + (analyze-seq|dependent-type-call env form) + (analyze-seq|call env form)) + (analyze-seq|call env form)))) -(defns- analyze-seq [opts ::opts, env ::env, form _] +(defns- analyze-seq [env ::env, form _] (let [expanded-form (ufeval/macroexpand form)] (if-let [no-expansion? (ucomp/== form expanded-form)] - (analyze-seq* opts env expanded-form) + (analyze-seq* env expanded-form) (let [expanded-form' (-> expanded-form (update-meta merge (meta form))) - expanded (analyze* opts env expanded-form')] + expanded (analyze* env expanded-form')] (uast/macro-call {:env env :unexpanded-form form @@ -776,7 +776,7 @@ :expanded expanded :type (:type expanded)}))))) -(defns- ?resolve [opts ::opts, env ::env, sym symbol?] +(defns- ?resolve [env ::env, sym symbol?] (if-let [[_ local] (find env sym)] {:resolved local :resolved-via :env} (let [resolved (uvar/resolve *ns* sym)] @@ -784,14 +784,14 @@ {:resolved resolved :resolved-via :resolve} (some->> sym namespace symbol (uvar/resolve *ns*) class?) {:resolved (analyze-seq|dot - opts env (list '. (-> sym namespace symbol) (-> sym name symbol))) + env (list '. (-> sym namespace symbol) (-> sym name symbol))) :resolved-via :dot} nil)))) (defns- analyze-symbol "Analyzes vars as if their value is constant, unless they're marked as dynamic." - [opts ::opts, env ::env, form symbol? > uast/symbol?] - (if-not-let [{:keys [resolved resolved-via]} (?resolve opts env form)] + [env ::env, form symbol? > uast/symbol?] + (if-not-let [{:keys [resolved resolved-via]} (?resolve env form)] (err! "Could not resolve symbol" {:sym form}) (let [node (case resolved-via (:env :dot) resolved @@ -808,19 +808,19 @@ (assoc node :env env) (uast/symbol env form node (:type node)))))) -(defns- analyze* [opts ::opts, env ::env, form _ > uast/node?] +(defns- analyze* [env ::env, form _ > uast/node?] (when (> (swap! *analyze-depth inc) 200) (throw (ex-info "Stack too deep" {:form form}))) (ifs (symbol? form) - (analyze-symbol opts env form) + (analyze-symbol env form) (t/literal? form) (uast/literal env form (t/>type form)) (or (vector? form) (set? form)) - (analyze-non-map-seqable opts env form (empty form) (fn stop [& [a b :as args]] (prl! args) (err! "STOP"))) + (analyze-non-map-seqable env form (empty form) (fn stop [& [a b :as args]] (prl! args) (err! "STOP"))) (map? form) - (analyze-map opts env form) + (analyze-map env form) (seq? form) - (analyze-seq opts env form) + (analyze-seq env form) (throw (ex-info "Unrecognized form" {:form form})))) ;; ===== Dependent types functionality ===== ;; @@ -830,7 +830,12 @@ ;; ===== End dependent types functionality ===== ;; (defns analyze - "Opts may include: + "`env` consists of a map from simple symbol to `uast/node?`, with one exception: `env` admits one + optional key that is not a symbol: `:opts`. The reason `:opts` exists on the `env` map is that + analyzer functions may need to return updated opts or metadata and it is cleaner to put it on the + env map rather than on the AST nodes themselves. + + The `:opts` map may include: - :arglist-context? : p/boolean? : If you use `analyze-arg-syms` you won't have to set this yourself. : When this is enabled, each AST node is tagged with additional @@ -850,54 +855,108 @@ non-primitives." > uast/node? ([form _] (analyze {} form)) - ([env ::env, form _] (analyze {} env form)) - ([opts ::opts, env ::env, form _] + ([env ::env, form _] (reset! *analyze-depth 0) - (analyze* opts env form))) + (analyze* env form))) (s/def ::arg-sym->arg-type-form (s/map-of simple-symbol? t/any?)) (def analyze-arg-syms|max-iter 100) -(defns- unvalue-node [node uast/node? > uast/node?] - (cond-> node true (update :type t/unvalue))) +;; TODO excise +(defn pr! [x] + (binding [quantum.untyped.core.analyze.ast/*print-env?* false + quantum.untyped.core.print/*collapse-symbols?* true] + (quantum.untyped.core.print/ppr x))) -(defns analyze-arg-syms - ([arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _] - (analyze-arg-syms {} {} arg-sym->arg-type-form out-type-form)) - ([opts ::opts, env ::env arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _ - > (s/kv {:env ::env :out-type-node uast/node?})] - (let [opts' (assoc opts :arglist-context? true - :arg-sym->arg-type-form arg-sym->arg-type-form)] - (loop [env env - arglist-syms|queue #{} - arglist-syms|unanalyzed (-> arg-sym->arg-type-form keys set) - n|iter 0] - (binding [quantum.untyped.core.analyze.ast/*print-env?* false - quantum.untyped.core.print/*collapse-symbols?* true] - (quantum.untyped.core.print/ppr - (kw-map env arglist-syms|queue arglist-syms|unanalyzed n|iter))) - (ifs (empty? arglist-syms|unanalyzed) - (let [out-type-node (unvalue-node (analyze opts' env out-type-form)) - ret {:env env :out-type-node out-type-node}] - (binding [quantum.untyped.core.analyze.ast/*print-env?* false - quantum.untyped.core.print/*collapse-symbols?* true] - (quantum.untyped.core.print/ppr ret)) - [ret]) - (>= n|iter analyze-arg-syms|max-iter) - (err! "Max number of iterations reached for `analyze-arg-syms" {:n n|iter}) - (let [arg-sym (first arglist-syms|unanalyzed) - arg-type-form (arg-sym->arg-type-form arg-sym) - analyzed (-> (analyze (assoc opts' - :arglist-syms|queue arglist-syms|queue - :arglist-syms|unanalyzed arglist-syms|unanalyzed) - env arg-type-form) - unvalue-node) - env' (assoc (:env analyzed) arg-sym analyzed)] - (binding [quantum.untyped.core.analyze.ast/*print-env?* false - quantum.untyped.core.print/*collapse-symbols?* true] - (quantum.untyped.core.print/ppr {:analyzed analyzed})) +;; TODO move? +(defns split-type + "Only `t/or`s are splittable for now" + [t t/type? > (s/vec-of t/type?)] + (if (utr/or-type? t) + (utr/or-type>args t) + [t])) + +(defn- analyze-arg-syms* + [env #_::env + arg-sym->arg-type-form #_::arg-sym->arg-type-form + out-type-form + arglist-syms|queue #_(dc/set-of id/symbol?) + arglist-syms|unanalyzed #_(dc/set-of id/symbol?) + n|iter #_nneg-fixint?] + (pr! (kw-map #_env arglist-syms|queue arglist-syms|unanalyzed n|iter)) + (ifs (empty? arglist-syms|unanalyzed) + [{:env env + :out-type-node (-> (analyze env out-type-form) (update :type t/unvalue))}] + (>= n|iter analyze-arg-syms|max-iter) + (err! "Max number of iterations reached for `analyze-arg-syms" {:n n|iter}) + ;; TODO if it finds a symbol it doesn't recognize then it should end up in the + ;; env via not this loop + (let [arg-sym (first arglist-syms|unanalyzed) + arg-type-form (arg-sym->arg-type-form arg-sym) + env' (update env :opts + #(assoc % :arglist-syms|queue (conj arglist-syms|queue arg-sym) + :arglist-syms|unanalyzed arglist-syms|unanalyzed)) + _ (println "About to analyze") + analyzed (-> (analyze env' arg-type-form) (update :type t/unvalue)) + ;; If a deduced argtype needs to be split, we don't put it in the env yet + t-split (-> analyzed :type split-type)] + (pr! {:t (:type analyzed) :t-split t-split} #_{:analyzed analyzed}) + (if (-> t-split count (= 1)) + (let [env' (assoc (:env analyzed) arg-sym analyzed)] (recur env' + arg-sym->arg-type-form + out-type-form (:arglist-syms|queue analyzed) (:arglist-syms|unanalyzed analyzed) - (inc n|iter)))))))) + (inc n|iter))) + (->> t-split + (c/mapcat+ (fn [t] + (analyze-arg-syms* + (assoc (:env analyzed) arg-sym (assoc analyzed :type t)) + arg-sym->arg-type-form + out-type-form + (:arglist-syms|queue analyzed) + (:arglist-syms|unanalyzed analyzed) + (inc n|iter)))) + r/join))))) + +(defns analyze-arg-syms + "Performance characteristics: + - While an internally recursive function, the maximum stack depth is the number of arguments in + the provided arglist. + - The maximum number of generated arglists is equal to the product of the cardinalities of the + deduced types of the inputs. In other words, in the worst case scenario each of the arg types + would be a 'splittable' type like `t/or` (whose cardinality is the number of arguments to it + when simplified) which would require a Cartesian product of the splits of the arg types." + > vector? ; one level deep + ([arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _] + (analyze-arg-syms {} arg-sym->arg-type-form out-type-form)) + ([env ::env arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _ + > (s/kv {:env ::env :out-type-node uast/node?})] + (analyze-arg-syms* + (update env :opts + #(assoc % :arglist-context? true + :arg-sym->arg-type-form arg-sym->arg-type-form + :out-type-form out-type-form)) + arg-sym->arg-type-form out-type-form #{} (-> arg-sym->arg-type-form keys set) 0))) + +#_" +[a b c > out] + split?=true +-> [a0 b c > out] + -> [a0 b0 c > out] + -> [a0 b0 c0 > out] done! + [a0 b0 c1 > out] + [a0 b1 c > out] + -> [a0 b1 c0 > out] + [a0 b1 c1 > out] + [a1 b c > out] + -> [a1 b0 c > out] + -> [a1 b0 c0 > out] + [a1 b0 c1 > out] + [a1 b1 c > out] + -> [a1 b1 c0 > out] + [a1 b1 c1 > out] +We want all the leaves to make it in but not the rest +" diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index dbf6457a..47ac5067 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -340,9 +340,7 @@ (assert kind :sym) binding-))) arg-types|split - ;; NOTE Only `t/or`s are splittable for now - (->> arg-types - (c/map (fn [t] (if (utr/or-type? t) (utr/or-type>args t) [t])))) + (->> arg-types (c/map uana/split-type)) arg-types|expanded-seq (->> arg-types|split (apply ucombo/cartesian-product) (c/map vec)) diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index c5416fa2..1477c9c7 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -5,6 +5,8 @@ [quantum.untyped.core.analyze.ast :as uast] [quantum.untyped.core.collections :as uc] [quantum.untyped.core.data.map :as umap] + [quantum.untyped.core.fn + :refer [<-]] [quantum.untyped.core.test :refer [deftest is is= testing]] [quantum.untyped.core.type :as t])) @@ -21,7 +23,7 @@ (defn- transform-ana [ana] (->> ana - (mapv #(do [(->> % :env (uc/map-vals' :type)) + (mapv #(do [(->> % :env (<- (dissoc :opts)) (uc/map-vals' :type)) (-> % :out-type-node :type)])))) ;; More dependent type tests in `quantum.test.untyped.core.type.defnt` but those are more like From 10c8edca64539fe7cafdcefb1fc026b9cfc26bfa Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 5 Oct 2018 02:29:35 -0600 Subject: [PATCH 462/810] Another test passes :D --- src-untyped/quantum/untyped/core/analyze.cljc | 62 +++++++++---------- .../quantum/untyped/core/collections.cljc | 2 + src-untyped/quantum/untyped/core/type.cljc | 38 +++++++++++- .../quantum/untyped/core/type/defnt.cljc | 46 ++------------ test/quantum/test/untyped/core/analyze.cljc | 22 +++++++ .../quantum/test/untyped/core/type/defnt.cljc | 12 +--- 6 files changed, 95 insertions(+), 87 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index e6671187..71e579f7 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -29,7 +29,7 @@ [quantum.untyped.core.print :refer [ppr]] [quantum.untyped.core.reducers :as r - :refer [educe reducei]] + :refer [educe join reducei]] [quantum.untyped.core.spec :as s] [quantum.untyped.core.type :as t :refer [?]] @@ -869,8 +869,20 @@ quantum.untyped.core.print/*collapse-symbols?* true] (quantum.untyped.core.print/ppr x))) +#?(:clj +(uvar/def sort-guide "for use in arglist sorting, in increasing conceptual (and bit) size" + {t/boolean? 0 + t/byte? 1 + t/short? 2 + t/char? 3 + t/int? 4 + t/long? 5 + t/float? 6 + t/double? 7 + t/object? 8})) + ;; TODO move? -(defns split-type +(defns type>split "Only `t/or`s are splittable for now" [t t/type? > (s/vec-of t/type?)] (if (utr/or-type? t) @@ -897,10 +909,13 @@ env' (update env :opts #(assoc % :arglist-syms|queue (conj arglist-syms|queue arg-sym) :arglist-syms|unanalyzed arglist-syms|unanalyzed)) - _ (println "About to analyze") analyzed (-> (analyze env' arg-type-form) (update :type t/unvalue)) - ;; If a deduced argtype needs to be split, we don't put it in the env yet - t-split (-> analyzed :type split-type)] + primitive-subtypes + (->> analyzed :type + t/type>primitive-subtypes + (sort-by sort-guide) ; For cleanliness and reproducibility in tests + vec) + t-split (c/distinct (join primitive-subtypes (-> analyzed :type type>split)))] (pr! {:t (:type analyzed) :t-split t-split} #_{:analyzed analyzed}) (if (-> t-split count (= 1)) (let [env' (assoc (:env analyzed) arg-sym analyzed)] @@ -911,14 +926,15 @@ (:arglist-syms|unanalyzed analyzed) (inc n|iter))) (->> t-split - (c/mapcat+ (fn [t] - (analyze-arg-syms* - (assoc (:env analyzed) arg-sym (assoc analyzed :type t)) - arg-sym->arg-type-form - out-type-form - (:arglist-syms|queue analyzed) - (:arglist-syms|unanalyzed analyzed) - (inc n|iter)))) + (c/mapcat+ + (fn [t] + (analyze-arg-syms* + (assoc (:env analyzed) arg-sym (assoc analyzed :type t)) + arg-sym->arg-type-form + out-type-form + (:arglist-syms|queue analyzed) + (:arglist-syms|unanalyzed analyzed) + (inc n|iter)))) r/join))))) (defns analyze-arg-syms @@ -940,23 +956,3 @@ :arg-sym->arg-type-form arg-sym->arg-type-form :out-type-form out-type-form)) arg-sym->arg-type-form out-type-form #{} (-> arg-sym->arg-type-form keys set) 0))) - -#_" -[a b c > out] - split?=true --> [a0 b c > out] - -> [a0 b0 c > out] - -> [a0 b0 c0 > out] done! - [a0 b0 c1 > out] - [a0 b1 c > out] - -> [a0 b1 c0 > out] - [a0 b1 c1 > out] - [a1 b c > out] - -> [a1 b0 c > out] - -> [a1 b0 c0 > out] - [a1 b0 c1 > out] - [a1 b1 c > out] - -> [a1 b1 c0 > out] - [a1 b1 c1 > out] -We want all the leaves to make it in but not the rest -" diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index 6794c208..b71fece5 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -268,6 +268,8 @@ (def remove-vals+ (pred-vals remove+)) (defeager remove-vals remove-vals+ 1) +(defn keys+ [xs] (->> xs (map+ key))) + (defn indexed+ [xs] (map-indexed+ vector xs)) (defn lindexed [xs] (lmap-indexed vector xs)) (defeager indexed indexed+ 0) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 5b69e75a..a0867626 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -15,6 +15,7 @@ type]) (:require [clojure.core :as c] + [clojure.set] [clojure.string :as str] [quantum.untyped.core.analyze.expr :refer [>expr #?(:cljs Expression)]] @@ -501,6 +502,8 @@ Float/TYPE Float Double/TYPE Double})) +#?(:clj (def boxed-class->unboxed-class (clojure.set/map-invert unboxed-class->boxed-class))) + ;; TODO figure out the best place to put this #?(:clj (def boxed-class->unboxed-symbol @@ -539,10 +542,41 @@ (err! "Not sure how to handle type" t))) (defns type>classes - "Outputs the set of all the classes ->`t` can embody according to its various conditional - branches, if any. Ignores nils, treating in Clojure simply as a `java.lang.Object`." + "Outputs the set of all the classes ->`t` can embody, possibly including nil." [t utr/type? > (us/set-of (us/nilable #?(:clj c/class? :cljs c/fn?)))] (-type>classes t #{})) +;; TODO move +#?(:clj +(defns class>boxed-subclasses+ [c (us/nilable c/class?) #_> #_(educer-of c/class?)] + (when (some? c) + (->> boxed-class->unboxed-class + uc/keys+ + (uc/filter+ (fn [^Class uc] (.isAssignableFrom ^Class c uc))))))) + +;; TODO move +#?(:clj +(defns class>most-primitive-class + "Unboxes the class if possible." + [c (us/nilable c/class?) > (us/nilable c/class?)] + (c/or (boxed-class->unboxed-class c) c))) + +#?(:clj +(defns type>most-primitive-classes + "The same as `type>classes` except unboxes all possible classes. + Distinct from primitive-expansion / primitivization." + [t type? > (us/set-of (us/nilable c/class?))] + (let [cs (type>classes t)] + (if-let [nilable? (c/or (-> t c/meta :quantum.core.type/ref?) (contains? cs nil))] + cs + (->> cs (uc/map+ class>most-primitive-class) (ur/join #{})))))) + +#?(:clj +(defns type>primitive-subtypes [t type? > (us/vec-of type?)] + (->> t type>classes + (uc/mapcat+ class>boxed-subclasses+) + (join #{}) + (uc/map isa?)))) + #?(:clj (defns- -type>?class-value [t utr/type?, type-nilable? c/boolean?] (if (utr/value-type? t) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 47ac5067..f9a1bee2 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -152,18 +152,6 @@ ;; time the function gets run; e.g. extern it (core/defn >with-post-type|form [body post-type|form] `(t/validate ~body ~post-type|form)) -#?(:clj -(uvar/def sort-guide "for use in arity sorting, in increasing conceptual (and bit) size" - {Object 0 - tdef/boolean 1 - tdef/byte 2 - tdef/short 3 - tdef/char 4 - tdef/int 5 - tdef/long 6 - tdef/float 7 - tdef/double 8})) - ;; TODO move (def index? #(and (integer? %) (>= % 0))) @@ -176,18 +164,6 @@ [c (s/nilable class?) > (s/nilable class?)] (if (t/primitive-class? c) c java.lang.Object))) -#?(:clj -(defns class>most-primitive-class [c (s/nilable class?), nilable? t/boolean? > (s/nilable class?)] - (if nilable? c (or (tcore/boxed->unboxed c) c)))) - -#?(:clj -(defns type>most-primitive-classes [t t/type? > (s/set-of (s/nilable class?))] - (let [cs (t/type>classes t) - nilable? (or (-> t meta :quantum.core.type/ref?) (contains? cs nil))] - (->> cs - (c/map+ #(class>most-primitive-class % nilable?)) - (r/join #{}))))) - #?(:clj (defns out-type>class [t t/type? > (s/nilable class?)] (if (-> t meta :quantum.core.type/ref?) @@ -198,23 +174,10 @@ ;; NOTE: we don't need to vary the output class if there are multiple output possibilities ;; or just nil java.lang.Object - (-> (class>most-primitive-class (first cs') (contains? cs nil)) - class>simplest-class)))))) - -#?(:clj -(defns arg-type>arg-classes-seq|primitivized [arg-type t/type? > (s/seq-of class?)] - (if (-> arg-type meta :quantum.core.type/ref?) - (-> arg-type t/type>classes (disj nil) seq) - (let [cs (type>most-primitive-classes arg-type) - base-classes - (cond-> cs - (contains? cs nil) (-> (disj nil) (conj java.lang.Object)))] - (->> cs - (c/map+ tcore/class>prim-subclasses) - (educe (aritoid nil identity uset/union) base-classes) - ;; for purposes of cleanliness and reproducibility in tests - (sort-by sort-guide)))))) + (-> (first cs') + (cond-> (not (contains? cs nil)) t/class>most-primitive-class) class>simplest-class)))))) +;; TODO rework in light of new type splitting #?(:clj (defns arg-types>arg-classes-seq|primitivized "'primitivized' meaning given an arglist whose types are `[t/any?]` this will output: @@ -230,7 +193,7 @@ which includes all primitive subclasses of the type." [arg-types (s/seq-of t/type?) > (s/seq-of ::expanded-overload|arg-classes)] (->> arg-types - (c/lmap arg-type>arg-classes-seq|primitivized) + (c/lmap uana/arg-type>arg-classes-seq|primitivized) (apply ucombo/cartesian-product) (c/lmap >vec)))) @@ -339,6 +302,7 @@ ;; supported (assert kind :sym) binding-))) + ;; TODO this splitting and expansion is rendered unnecessary by the dep. type analyzer arg-types|split (->> arg-types (c/map uana/split-type)) arg-types|expanded-seq (->> arg-types|split diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index 1477c9c7..9dbb37f7 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -86,4 +86,26 @@ `(t/type ~'x))] (is= [[{'x tt/boolean?} tt/boolean?] [{'x tt/string?} tt/string?]] + (transform-ana ana)))) + (testing "Output type dependent on primitive-splittable input" + #_"1. Analyze `x` = `t/any?`. Primitive-splittable. + 2. Split `t/any?`: + [[x tt/boolean? > (t/type x)] + [x ... > (t/type x)]] + 3. Analyze split 0. + 1. Analyze `x` = `tt/boolean?` + -> Put `x` in env as `(t/isa? Boolean)` + 2. Analyze out-type = `(t/type x)` + -> `(t/isa? Boolean)` + 4. Analyze rest of splits in the same way." + (let [ana (self/analyze-arg-syms {'x 't/any?} `(t/type ~'x))] + (is= [[{'x tt/boolean?} tt/boolean?] + [{'x tt/byte?} tt/byte?] + [{'x tt/short?} tt/short?] + [{'x tt/char?} tt/char?] + [{'x tt/int?} tt/int?] + [{'x tt/long?} tt/long?] + [{'x tt/float?} tt/float?] + [{'x tt/double?} tt/double?] + [{'x t/any?} t/any?]] (transform-ana ana))))) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 62ae5ad7..933360ca 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1401,17 +1401,7 @@ (testing "Output type dependent on primitive-splittable input" (let [actual (macroexpand ' - (self/defn dependent-type-psplit - #_"1. Analyze `x` = `t/any?`. Primitive-splittable. - 2. Split `t/any?`: - [[x tt/boolean? > (t/type x)] - [x ... > (t/type x)]] - 3. Analyze split 0. - 1. Analyze `x` = `tt/boolean?` - -> Put `x` in env as `(t/isa? Boolean)` - 2. Analyze out-type = `(t/type x)` - -> `(t/isa? Boolean)` - 4. Analyze rest of splits in the same way." + (self/defn dependent-type-split ([x t/any? > (t/type x)] x))) expected (case (env-lang) From daa48787cf7c7539a2418ae7ccf3825bc5b879a2 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 6 Oct 2018 09:56:09 -0600 Subject: [PATCH 463/810] Refine documentation --- src-untyped/quantum/untyped/core/analyze.cljc | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 71e579f7..e1b063cd 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -943,12 +943,12 @@ the provided arglist. - The maximum number of generated arglists is equal to the product of the cardinalities of the deduced types of the inputs. In other words, in the worst case scenario each of the arg types - would be a 'splittable' type like `t/or` (whose cardinality is the number of arguments to it + might be a 'splittable' type like `t/or` (whose cardinality is the number of arguments to it when simplified) which would require a Cartesian product of the splits of the arg types." - > vector? ; one level deep + > vector? #_(s/vec-of (s/kv {:env ::env :out-type-node uast/node?})) ([arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _] (analyze-arg-syms {} arg-sym->arg-type-form out-type-form)) - ([env ::env arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _ + ([env ::env, arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _ > (s/kv {:env ::env :out-type-node uast/node?})] (analyze-arg-syms* (update env :opts From c8637ae8a38bdc5531a450e47dffe6dfb3de9f33 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 7 Oct 2018 13:58:49 -0600 Subject: [PATCH 464/810] Part 1 of incorporating dependent types into `defnt` (broken) --- .../quantum/untyped/core/type/defnt.cljc | 609 +++++++----------- 1 file changed, 240 insertions(+), 369 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index f9a1bee2..fcda5201 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -60,60 +60,53 @@ ;; Internal specs -(s/def ::expanded-overload|arg-classes (s/vec-of class?)) -(s/def ::expanded-overload|arg-types (s/seq-of t/type?)) +(s/def ::lang #{:clj :cljs}) + +;; "global" because they apply to the whole fnt +(s/def ::fn|globals + (s/kv {:fn|meta (s/nilable :quantum.core.specs/meta) + :fn|name ::uss/fn|name + :fn|type utr/fn-type? + :fn|output-type|form t/any? + :fn|output-type t/type?})) + +(s/def ::opts + (s/kv {:gen-gensym t/fn? + :lang ::lang})) + + ;; Technically it's partially analyzed — its type definitions are analyzed (with the exception of + ;; requests for type inference) while its body is not. + (s/def ::unanalyzed-overload + (s/kv {:arg-bindings (s/vec-of t/any?) + :varargs-binding t/any? + :arg-types|form (s/vec-of t/any?) + :arg-types (s/vec-of t/type?) + :output-type|form t/any? + :output-type t/type? + :body-codelist|pre-analyze t/any?})) + +(s/def ::overload|arg-classes (s/vec-of class?)) +(s/def ::overload|arg-types (s/seq-of t/type?)) ;; This is the overload after the input specs are split by their respective `t/or` constituents, ;; and after primitivization, but before readiness for incorporation into a `reify`. ;; One of these corresponds to one reify overload. -(s/def ::expanded-overload - (s/kv {:arg-classes ::expanded-overload|arg-classes - :arg-types ::expanded-overload|arg-types +(s/def ::overload + (s/kv {:arg-classes ::overload|arg-classes + :arg-types ::overload|arg-types :arglist-code|fn|hinted t/any? :arglist-code|reify|unhinted t/any? :body-form t/any? - :out-class (s/nilable class?) - :out-type t/type? + :output-class (s/nilable class?) + :output-type t/type? :positional-args-ct (s/and integer? #(>= % 0)) ;; When present, varargs are considered to be of class Object :variadic? t/boolean?})) -(s/def ::reify|overload - (s/keys :req-un [:quantum.core.specs/interface - :reify|overload/out-class - :reify/method-sym - :reify/arglist-code - :reify|overload/body-form])) - (s/def ::reify - (s/kv {:form t/any? - :name simple-symbol? - :non-primitivized-overload ::reify|overload - :overloads (s/vec-of ::reify|overload)})) - -(s/def ::lang #{:clj :cljs}) - -;; "global" because they apply to the whole fnt -(s/def ::fnt-globals - (s/kv {:fn|meta (s/nilable :quantum.core.specs/meta) - :fn|name ::uss/fn|name - :fnt|output-type|form t/any? - :fnt|type t/type?})) - -(s/def ::opts - (s/kv {:gen-gensym t/fn? - :lang ::lang})) - -(s/def ::overload-data - (s/kv {:args (s/vec-of t/any?) - :varargs t/any? - :body-codelist|pre-analyze t/any? - :arg-types|form t/any? - :arg-types (s/vec-of t/type?) - :pre-type|form t/any? - :pre-type (? t/type?) - :post-type|form t/any? - :post-type t/type?})) + (s/kv {:form t/any? + :name simple-symbol? + :overload ::overload})) (s/def ::input-types-decl (s/kv {:form t/any? @@ -130,19 +123,6 @@ (s/kv {:form t/any? :i-overload->direct-dispatch-data ::i-overload->direct-dispatch-data})) -(s/def ::expanded-overload-group - (s/kv {:arg-types|form|expanded (s/vec-of t/any?) - :non-primitivized ::expanded-overload - :primitivized (s/nilable (s/seq-of ::expanded-overload))})) - -(s/def ::expanded-overload-groups|arg-types|split (s/vec-of (s/vec-of t/type?))) - -(s/def ::expanded-overload-groups - (s/kv {:arg-types|expanded-seq (s/vec-of (s/vec-of t/type?)) - :arg-types|split ::expanded-overload-groups|arg-types|split - :expanded-overload-group-seq (s/seq-of ::expanded-overload-group) - :overload-data ::overload-data})) - #_(:clj (core/defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] (cond (not= k :spec) java.lang.Object; default class @@ -150,7 +130,7 @@ ;; TODO optimize such that `post-type|form` doesn't create a new type-validator wholesale every ;; time the function gets run; e.g. extern it -(core/defn >with-post-type|form [body post-type|form] `(t/validate ~body ~post-type|form)) +(core/defn >with-runtime-output-type [body output-type|form] `(t/validate ~body ~output-type|form)) ;; TODO move (def index? #(and (integer? %) (>= % 0))) @@ -161,162 +141,81 @@ (defns class>simplest-class "This ensures that special overloads are not created for non-primitive subclasses of java.lang.Object (e.g. String, etc.)." - [c (s/nilable class?) > (s/nilable class?)] + [c class? > class?] (if (t/primitive-class? c) c java.lang.Object))) #?(:clj -(defns out-type>class [t t/type? > (s/nilable class?)] +(defns type>class + "Converts type to class after type has gone through the split+primitivization process." + [t t/type? > class?] (if (-> t meta :quantum.core.type/ref?) java.lang.Object (let [cs (t/type>classes t) cs' (disj cs nil)] (if (-> cs' count (not= 1)) - ;; NOTE: we don't need to vary the output class if there are multiple output possibilities - ;; or just nil java.lang.Object (-> (first cs') (cond-> (not (contains? cs nil)) t/class>most-primitive-class) class>simplest-class)))))) -;; TODO rework in light of new type splitting -#?(:clj -(defns arg-types>arg-classes-seq|primitivized - "'primitivized' meaning given an arglist whose types are `[t/any?]` this will output: - [[java.lang.Object] - [boolean] - [byte] - [short] - [char] - [int] - [long] - [float] - [double]] - which includes all primitive subclasses of the type." - [arg-types (s/seq-of t/type?) > (s/seq-of ::expanded-overload|arg-classes)] - (->> arg-types - (c/lmap uana/arg-type>arg-classes-seq|primitivized) - (apply ucombo/cartesian-product) - (c/lmap >vec)))) +(defns- >actual-output-type [declared-output-type t/type?, body-node uast/node? > t/type?] + (let [err-info {:form (:form body-node) + :type (:type body-node) + :declared-output-type declared-output-type}] + (case (t/compare (:type body-node) declared-output-type) + ;; If the deduced body type is `t/<=` declared output type then we pick the body type + (-1 0) (cond-> (:type body-node) + (-> declared-output-type meta :quantum.core.type/ref?) t/ref) + 1 (if (or (-> declared-output-type meta :quantum.core.type/runtime?) + (-> declared-output-type meta :quantum.core.type/assume?)) + declared-output-type + (err! "Body type incompatible with declared output type" err-info)) + (2 3) (err! "Body type incompatible with declared output type" err-info)))) #?(:clj -(defns- >expanded-overload - [{:keys [varargs _, post-type|form _, post-type _, body-codelist|pre-analyze _]} ::overload-data - {:as fnt-globals :keys [fn|name _, fnt|type _]} ::fnt-globals - {:as opts :keys [lang _]} ::opts - arg-bindings _ - arg-types|satisfying-primitivization (s/vec-of t/type?) - arg-classes (s/vec-of class?) - varargs-binding _ - > ::expanded-overload] +(defns- unanalyzed-overload>overload + "Given an `::unanalyzed-overload`, performs type analysis on the body and computes a resulting + `t/fn` overload, which is the foundation for one `reify`." + [{:keys [arg-bindings _, varargs-binding _, arg-types _, output-type|form _ + body-codelist|pre-analyze _] + declared-output-type [:output-type _]} + ::unanalyzed-overload + {:as fn|globals :keys [fn|name _, fn|type _, fn|output-type _]} ::fn|globals + {:as opts :keys [lang _]} ::opts + > ::overload] (let [;; Not sure if `nil` is the right approach for the value - recursive-ast-node-reference (uast/symbol {} fn|name nil fnt|type) - env (->> (zipmap arg-bindings arg-types|satisfying-primitivization) + recursive-ast-node-reference (uast/symbol {} fn|name nil fn|type) + env (->> (zipmap arg-bindings arg-types) (c/map' (fn [[arg-binding arg-type]] [arg-binding (uast/unbound nil arg-binding arg-type)])) ;; To support recursion (<- (assoc fn|name recursive-ast-node-reference))) - analyzed (uana/analyze env (ufgen/?wrap-do body-codelist|pre-analyze)) - arg-classes|simplest (->> arg-classes (c/map class>simplest-class)) + body-node (uana/analyze env (ufgen/?wrap-do body-codelist|pre-analyze)) + arg-classes (->> arg-types (c/map type>class)) hint-arg|fn (fn [i arg-binding] (ufth/with-type-hint arg-binding (ufth/>fn-arglist-tag - (c/get arg-classes|simplest i) + (c/get arg-classes i) lang (c/count arg-bindings) - varargs))) - post-type|assume? (-> post-type meta :quantum.core.type/assume?) - post-type|ref? (-> post-type meta :quantum.core.type/ref?) - post-type|runtime? (-> post-type meta :quantum.core.type/runtime?) - err-info {:form (:form analyzed) - :type (:type analyzed) - :declared-output-type post-type} - out-type (if post-type - (case (t/compare (:type analyzed) post-type) - (-1 0) (cond-> (:type analyzed) post-type|ref? t/ref) - 1 (if (or post-type|runtime? post-type|assume?) - post-type - (err! (str "Body type incompatible with declared output type even" - " when relaxing compile-time type enforcement") - err-info)) - (2 3) (err! "Body type incompatible with declared output type" err-info)) - (cond-> (:type analyzed) post-type|ref? t/ref)) + (boolean varargs-binding)))) + actual-output-type (>actual-output-type declared-output-type body-node) body-form - (-> (:form analyzed) - (cond-> post-type|runtime? (>with-post-type|form post-type|form)) + (-> (:form body-node) + (cond-> (-> actual-output-type meta :quantum.core.type/runtime?) + (>with-runtime-output-type output-type|form)) (ufth/cast-bindings|code (->> (c/zipmap-into (umap/om) arg-bindings arg-classes) (c/remove-vals' (fn-or nil? (fn= java.lang.Object) t/primitive-class?)))))] - {:arg-classes arg-classes|simplest - :arg-types arg-types|satisfying-primitivization + {:arg-classes arg-classes + :arg-types arg-types :arglist-code|fn|hinted (cond-> (->> arg-bindings (c/map-indexed hint-arg|fn)) - varargs-binding (conj '& varargs-binding)) ; TODO use `` + varargs-binding (conj '& varargs-binding)) :arglist-code|reify|unhinted (cond-> arg-bindings varargs-binding (conj varargs-binding)) :body-form body-form :positional-args-ct (count arg-bindings) - :out-type out-type - :out-class (out-type>class out-type) - :variadic? (boolean varargs)}))) - -(defns >expanded-overload-group - [overload-data ::overload-data - fnt-globals ::fnt-globals, opts ::opts, arg-bindings _, varargs-binding _, arg-types|expanded _ - > ::expanded-overload-group] - (let [arg-types|form|expanded (mapv >form arg-types|expanded) - ;; `non-primitivized` is first because of class sorting - [non-primitivized & primitivized :as overloads] - (->> arg-types|expanded - arg-types>arg-classes-seq|primitivized - (mapv (fn [arg-classes #_::expanded-overload|arg-classes] - (let [arg-types|satisfying-primitivization - (c/mergev-with - (fn [_ t #_t/type? c #_class?] - (cond-> t (t/primitive-class? c) (t/and c))) - arg-types|expanded arg-classes)] - (>expanded-overload overload-data fnt-globals opts - arg-bindings arg-types|satisfying-primitivization arg-classes - varargs-binding)))))] - (kw-map arg-types|form|expanded non-primitivized primitivized))) - -#?(:clj ; really, reserve for metalanguage -(defns fnt|overload-data>expanded-overload-groups - "Given an `fnt` overload, computes a seq of 'expanded-overload groups'. Each expanded-overload - group is the foundation for one `reify`. - - We decide to evaluate types in languages in which the metalanguage (compiler language) is the - same as the object language. As such, for CLJS, we choose to use only a CLJS-in-CLJS / - bootstrapped compiler even if that means alienating the mainstream CLJS-in-CLJ workflow." - [{:as overload-data - :keys [args _, varargs _ - arg-types|form _, arg-types _, pre-type|form _, post-type|form _]} ::overload-data - {:as fnt-globals :keys [fn|name _, fnt|type _]} ::fnt-globals - {:as opts :keys [lang _]} ::opts - > ::expanded-overload-groups] - (let [;; TODO support varargs - varargs-binding (when varargs - ;; TODO this assertion is purely temporary until destructuring is - ;; supported - (assert (-> varargs :binding-form first (= :sym)))) - arg-bindings - (->> args - (mapv (fn [{[kind binding-] :binding-form}] - ;; TODO this assertion is purely temporary until destructuring is - ;; supported - (assert kind :sym) - binding-))) - ;; TODO this splitting and expansion is rendered unnecessary by the dep. type analyzer - arg-types|split - (->> arg-types (c/map uana/split-type)) - arg-types|expanded-seq (->> arg-types|split - (apply ucombo/cartesian-product) - (c/map vec)) - expanded-overload-group-seq - (->> arg-types|expanded-seq - (mapv (fn [arg-types|expanded] ; TODO use this - (>expanded-overload-group overload-data fnt-globals opts - arg-bindings varargs-binding arg-types|expanded))))] - (kw-map arg-types|expanded-seq arg-types|split expanded-overload-group-seq - overload-data)))) - -(def fnt-method-sym 'invoke) + :output-type actual-output-type + :output-class (type>class actual-output-type) + :variadic? (boolean varargs-binding)}))) (defns- class>interface-part-name [c class? > string?] (if (= c java.lang.Object) @@ -326,122 +225,59 @@ (err! "Class cannot contain pattern" {:class c :pattern illegal-pattern}) (-> c >name (str/replace "." "|")))))) -(defns fnt-overload>interface-sym [args-classes (s/seq-of class?), out-class class? > symbol?] +;; ===== Direct dispatch ===== ;; + +;; ----- Direct dispatch: `reify` ---- ;; + +(defns- overload-classes>interface-sym [args-classes (s/seq-of class?), out-class class? > symbol?] (>symbol (str (->> args-classes (c/lmap class>interface-part-name) (str/join "+")) ">" (class>interface-part-name out-class)))) -;; TODO finish specing args -(defns fnt-overload>interface [args-classes _, out-class class?, gen-gensym fn?] - (let [interface-sym (fnt-overload>interface-sym args-classes out-class) - hinted-method-sym (ufth/with-type-hint fnt-method-sym +(def reify-method-sym 'invoke) + +(defns- overload-classes>interface + [args-classes (s/vec-of class?), out-class class?, gen-gensym fn?] + (let [interface-sym (overload-classes>interface-sym args-classes out-class) + hinted-method-sym (ufth/with-type-hint reify-method-sym (ufth/>interface-method-tag out-class)) hinted-args (ufth/hint-arglist-with - (ufgen/gen-args 0 (count args-classes) "xint" gen-gensym) + (ufgen/gen-args 0 (count args-classes) "x" gen-gensym) (map ufth/>interface-method-tag args-classes))] `(~'definterface ~interface-sym (~hinted-method-sym ~hinted-args)))) -;; TODO spec args #?(:clj -(defns expanded-overload>reify-overload - [{:as overload - :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, out-class class?]} - ::expanded-overload +(defns overload>reify + [{:as overload + :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, out-class _]} ::overload {:as opts :keys [gen-gensym _]} ::opts - > ::reify|overload] + {:keys [fn|name _]} ::fn|globals + i|unanalyzed-overload index? + i|overload index? + > ::reify] (let [interface-k {:out out-class :in arg-classes} interface (-> *interfaces (swap! update interface-k - #(or % (eval (fnt-overload>interface arg-classes out-class gen-gensym)))) + #(or % (eval (overload-classes>interface arg-classes out-class gen-gensym)))) (c/get interface-k)) arglist-code (>vec (concat [(gen-gensym '_)] (->> arglist-code|reify|unhinted (map-indexed - (fn [i arg] - (ufth/with-type-hint arg - (-> arg-classes (c/get i) ufth/>arglist-embeddable-tag)))))))] - {:arglist-code arglist-code - :body-form body-form - :interface interface - :method-sym fnt-method-sym - :out-class out-class}))) - -(defns >reify|name - [{:keys [::uss/fn|name ::uss/fn|name, i|fnt-overload index? - i|expanded-overload-group index?]} _ > simple-symbol?] - (>symbol (str fn|name "|__" i|fnt-overload "|" i|expanded-overload-group))) - -#?(:clj -(defns expanded-overload-group>reify - [{:as in - :keys [::uss/fn|name ::uss/fn|name, i|fnt-overload index?, i|expanded-overload-group index? - expanded-overload-group ::expanded-overload-group]} _ - {:as opts :keys [gen-gensym _]} ::opts - > ::reify] - (let [reify-overloads (->> (concat [(:non-primitivized expanded-overload-group)] - (:primitivized expanded-overload-group)) - (c/map #(expanded-overload>reify-overload % opts))) - reify-name (>reify|name in) + (fn [i|arg arg|form] + (ufth/with-type-hint arg|form + (-> arg-classes (c/get i|arg) ufth/>arglist-embeddable-tag))))))) + reify-name (>symbol (str fn|name "|__" i|unanalyzed-overload "|" i|overload)) form `(~'def ~reify-name - ~(list* `reify* - (->> reify-overloads (mapv #(-> % :interface >name >symbol))) - (->> reify-overloads - (c/lmap (fn [{:keys [out-class method-sym arglist-code - body-form]} #_::reify|overload] - `(~(ufth/with-type-hint method-sym - (ufth/>arglist-embeddable-tag out-class)) - ~arglist-code ~body-form))))))] - {:form form - :name reify-name - :non-primitivized-overload (first reify-overloads) - :overloads reify-overloads}))) - -(defns >input-type-decl|name - [fn|name ::uss/fn|name, i|fnt-overload index?, i|arg index? > simple-symbol?] - (>symbol (str fn|name "|__" i|fnt-overload "|input" i|arg "|types"))) - -(defns >i-arg->input-types-decl - "The evaluated `form` of each input-types-decl is an array of non-primitivized types that the - dynamic dispatch uses to dispatch off input types." - [{:keys [fn|name _]} ::fnt-globals - arg-types|split ::expanded-overload-groups|arg-types|split, i|fnt-overload index? - > (s/vec-of ::input-types-decl)] - (->> arg-types|split - (c/map-indexed - (fn [i|arg arg-type|split] - (let [decl-name (>input-type-decl|name fn|name i|fnt-overload i|arg) - form (list 'def (ufth/with-type-hint decl-name "[Ljava.lang.Object;") - (list* `uarr/*<> (map >form arg-type|split)))] - (assoc (kw-map form arg-type|split) :name decl-name)))))) - -(def allowed-shorthand-tag-chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") -(def min-shorthand-tag-length 1) -(def max-shorthand-tag-length 64) ; for now - -(core/defn >all-shorthand-tags [] - (->> (range min-shorthand-tag-length (inc max-shorthand-tag-length)) - c/unchunk - (c/lmap (fn [n] (apply ucombo/cartesian-product (repeat n allowed-shorthand-tag-chars)))) - c/lcat - (c/lmap #(apply str %)) - c/unchunk)) - -(defonce *class>shorthand-tag|cache - (atom {:remaining (>all-shorthand-tags)})) - -;; dynamic for testing purposes -(def ^:dynamic **class>shorthand-tag|cache* *class>shorthand-tag|cache) - -(defns class>shorthand-tag [c class?] - (or (c/get @**class>shorthand-tag|cache* c) - (-> (swap! **class>shorthand-tag|cache* - (fn [{:as m :keys [remaining]}] - (assoc m c (first remaining) - :remaining (next remaining)))) - (get c)))) + (reify* [~(-> interface >name >symbol)] + (~(ufth/with-type-hint reify-method-sym (ufth/>arglist-embeddable-tag out-class)) + ~arglist-code ~body-form)))] + {:form form + :name reify-name + :overload overload}))) ;; TODO spec +;; TODO use!! (core/defn assert-monotonically-increasing-types! "Asserts that each type in an overload of the same arity and arg-position are in monotonically increasing order in terms of `t/compare`." @@ -465,50 +301,50 @@ nil overloads))) -;; TODO spec -(defns unsupported! [name- _ #_t/qualified-symbol?, args _ #_indexed?, i index?] - (TODO)) +;; ----- Direct dispatch: putting it all together ----- ;; + +(defns >input-type-decl|name + [fn|name ::uss/fn|name, i|fnt-overload index?, i|arg index? > simple-symbol?] + (>symbol (str fn|name "|__" i|fnt-overload "|input" i|arg "|types"))) + +(defns >i-arg->input-types-decl + "The evaluated `form` of each input-types-decl is an array of non-primitivized types that the + dynamic dispatch uses to dispatch off input types." + [{:keys [fn|name _]} ::fn|globals + arg-types|split ::expanded-overload-groups|arg-types|split, i|fnt-overload index? + > (s/vec-of ::input-types-decl)] + (->> arg-types|split + (c/map-indexed + (fn [i|arg arg-type|split] + (let [decl-name (>input-type-decl|name fn|name i|fnt-overload i|arg) + form (list 'def (ufth/with-type-hint decl-name "[Ljava.lang.Object;") + (list* `uarr/*<> (map >form arg-type|split)))] + (assoc (kw-map form arg-type|split) :name decl-name)))))) (defns >direct-dispatch - [{:as fnt-globals :keys [fn|name _]} ::fnt-globals - {:as opts :keys [gen-gensym _, lang _]} ::opts - expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups) + [{:as fn|globals :keys [fn|name _]} ::fn|globals + {:as opts :keys [gen-gensym _, lang _]} ::opts + ; expanded-overload-groups-by-fnt-overload + overloads (s/vec-of ::overload) > ::direct-dispatch] (case lang - :clj - (let [i-overload->direct-dispatch-data - (->> expanded-overload-groups-by-fnt-overload - (c/map-indexed - (fn [i|fnt-overload {:keys [arg-types|split expanded-overload-group-seq]}] - {:i-arg->input-types-decl - (>i-arg->input-types-decl fnt-globals arg-types|split i|fnt-overload) - :reify-seq - (->> expanded-overload-group-seq - (c/map-indexed - (fn [i|expanded-overload-group - {:as expanded-overload-group :keys [arg-types|form]}] - (let [in (assoc (kw-map i|fnt-overload - i|expanded-overload-group - expanded-overload-group) - ::uss/fn|name fn|name)] - (expanded-overload-group>reify in opts)))))}))) - form (->> i-overload->direct-dispatch-data - (c/map (fn [{:keys [i-arg->input-types-decl reify-seq]}] - (concat (c/lmap :form i-arg->input-types-decl) - (c/lmap :form reify-seq)))) - c/lcat)] - (kw-map form i-overload->direct-dispatch-data)) + :clj (let [i-overload->direct-dispatch-data + (->> expanded-overload-groups-by-fnt-overload + (c/map-indexed + (fn [i|fnt-overload {:keys [arg-types|split expanded-overload-group-seq]}] + {:i-arg->input-types-decl + (>i-arg->input-types-decl fn|globals arg-types|split i|fnt-overload) + :reify (overload>reify overload opts fn|globals + i|unanalyzed-overload i|overload)}))) + form (->> i-overload->direct-dispatch-data + (c/map (fn [{:keys [i-arg->input-types-decl reify-seq]}] + (concat (c/lmap :form i-arg->input-types-decl) + (c/lmap :form reify-seq)))) + c/lcat)] + (kw-map form i-overload->direct-dispatch-data)) :cljs (TODO))) -(defns >dynamic-dispatch-fn|type-decl - [{:keys [fnt|output-type|form _, fnt|type _]} ::fnt-globals - expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups)] - (list* `t/ftype fnt|output-type|form - (->> expanded-overload-groups-by-fnt-overload - (map (fn [{{:keys [arg-types|form pre-type|form post-type|form]} :overload-data}] - (cond-> (or arg-types|form []) - pre-type|form (conj :| pre-type|form) - post-type|form (conj :> post-type|form))))))) +;; ===== Dynamic dispatch ===== ;; (defns >dynamic-dispatch|reify-call [reify- ::reify, arglist (s/vec-of simple-symbol?)] (let [dotted-reify-method-sym @@ -518,6 +354,9 @@ (-> reify- :non-primitivized-overload :interface >name))] `(~dotted-reify-method-sym ~hinted-reify-sym ~@arglist))) +;; TODO spec +(defns unsupported! [name- _ #_t/qualified-symbol?, args _ #_indexed?, i index?] (TODO)) + (defns >dynamic-dispatch|conditional [fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?), i|arg index?, body _] (if (-> body count (= 1)) @@ -557,13 +396,12 @@ c/lcat)))) (defns >dynamic-dispatch-fn|form - [{:as fnt-globals :keys [fn|meta _, fn|name _]} ::fnt-globals - {:as opts :keys [gen-gensym _, lang _]} ::opts + [{:as fn|globals :keys [fn|meta _, fn|name _]} ::fn|globals + {:as opts :keys [gen-gensym _, lang _]} ::opts expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups) i-overload->direct-dispatch-data ::i-overload->direct-dispatch-data] `(core/defn ~fn|name - ~(assoc fn|meta :quantum.core.type/type - (>dynamic-dispatch-fn|type-decl fnt-globals expanded-overload-groups-by-fnt-overload)) + ~(assoc fn|meta :quantum.core.type/type (>form fn|type)) ~@(->> i-overload->direct-dispatch-data (group-by (fn-> :i-arg->input-types-decl count)) (map (fn [[arg-ct direct-dispatch-data-for-arity]] @@ -572,72 +410,101 @@ fn|name arglist direct-dispatch-data-for-arity)] (list arglist body))))))) -(defns fnt|overloads-data>type - [overloads-data (s/vec-of ::overload-data), fnt|output-type t/type? > t/type?] - (->> overloads-data - (c/lmap (fn [{:keys [arg-types pre-type post-type]}] - (cond-> arg-types - pre-type (conj :| pre-type) - post-type (conj :> post-type)))) - (apply t/ftype fnt|output-type))) - -(defns fnt|parsed-overload>overload-data - [{:as in {:keys [args _, varargs _] - pre-type|form [:pre _] - [_ _, post-type|form _] [:post _]} [:arglist _] - body-codelist|pre-analyze [:body _]} _ - fnt|output-type t/type? - > ::overload-data] +;; ===== End dynamic dispatch ===== ;; + +(defns- overloads-basis>unanalyzed-overload + [{:as in {args [:args _] + varargs [:varargs _] + pre-type|form [:pre _] + [_ _, output-type|form _] [:post _]} [:arglist _] + body-codelist|pre-analyze [:body _]} _ + fn|output-type|form _ ; TODO excise this var when we default `output-type|form` to `?` + fn|output-type t/type? + > (s/seq-of ::unanalyzed-overload)] (when pre-type|form (TODO "Need to handle pre")) - (when varargs (TODO "Need to handle varargs")) - (let [arg-types|form (->> args - (mapv (fn [{[kind #_#{:any :spec}, t #_t/form?] :spec}] - (case kind :any `t/any? :spec t)))) - arg-types (->> arg-types|form (mapv (fn-> eval t/>type))) - pre-type nil ; TODO fix - post-type|form (if (= post-type|form '_) `t/any? post-type|form) - ;; TODO this becomes an issue when `post-type|form` references local bindings - post-type|overload-specific (some-> post-type|form eval) - _ (when (and post-type|overload-specific - (not (t/<= post-type|overload-specific fnt|output-type))) - (err! (str "Overload's declared output type does not satisfy function's overall " - "declared output type"))) - post-type (or post-type|overload-specific fnt|output-type)] - (kw-map args varargs body-codelist|pre-analyze - arg-types|form arg-types, pre-type|form pre-type, post-type|form post-type))) + (when varargs (TODO "Need to handle varargs")) + (let [arg-types|form (->> args (mapv (fn [{[kind #_#{:any :spec}, t #_t/form?] :spec}] + (case kind :any `t/any? :spec t)))) + output-type|form (case output-type|form + _ `t/any? + ;; TODO if the output-type|form is nil then we should default to `?`; + ;; otherwise the `fn|output-type|form` gets analyzed over and over + nil fn|output-type|form + output-type|form) + arg-bindings + (->> args + (mapv (fn [{[kind binding-] :binding-form}] + ;; TODO this assertion is purely temporary until destructuring is + ;; supported + (assert kind :sym) + binding-))) + ;; TODO support varargs + varargs-binding (when varargs + ;; TODO this assertion is purely temporary until destructuring is + ;; supported + (assert (-> varargs :binding-form first (= :sym)))) + arg-types|expanded-seq ; split and primitivized + (->> (uana/analyze-arg-syms {} (zipmap arg-bindings arg-types|form) output-type|form) + (c/map (fn [{:keys [env out-type-node]}] + (let [output-type (:type out-type-node) + arg-types (->> arg-bindings (mapv #(get env %)))] + (when (and ;; TODO excise clause when we default `output-type|form` to `?` + (not (identical? output-type|form fn|output-type|form)) + (not (t/<= output-type fn|output-type))) + (err! (str "Overload's declared output type does not satisfy function's" + "overall declared output type") + (kw-map output-type fn|output-type))) + (kw-map arg-types output-type)))))] + (->> arg-types|expanded-seq + (fn [{:keys [arg-types output-type]}] + (kw-map arg-bindings varargs-binding + arg-types|form arg-types + output-type|form output-type + body-codelist|pre-analyze))))) + +(defns unanalyzed-overloads>fn|type + [unanalyzed-overloads (s/seq-of ::unanalyzed-overload), fn|output-type t/type? > utr/fn-type?] + (->> unanalyzed-overloads + (c/lmap (fn [{:keys [arg-types pre-type output-type]}] + (cond-> arg-types + pre-type (conj :| pre-type) + output-type (conj :> output-type)))) + (apply t/ftype fn|output-type))) (defns fn|code [kind #{:fn :defn}, lang ::lang, args _] (let [{:as args' :keys [:quantum.core.specs/fn|name - :quantum.core.defnt/overloads :quantum.core.defnt/output-spec] + overloads-bases :quantum.core.defnt/overloads fn|meta :quantum.core.specs/meta} (s/validate args (case kind :defn :quantum.core.defnt/defnt :fn :quantum.core.defnt/fnt)) - fnt|output-type|form (or (second output-spec) `t/any?) - fnt|output-type (eval fnt|output-type|form) - gen-gensym-base (ufgen/>reproducible-gensym|generator) - gen-gensym (fn [x] (symbol (str (gen-gensym-base x) "__"))) - inline? (s/validate (:inline fn|meta) (t/? t/boolean?)) - fn|meta (if inline? - (do (ulog/pr :warn "requested `:inline`; ignoring until feature is implemented") - (dissoc fn|meta :inline)) - fn|meta) - overloads-data (->> overloads (mapv #(fnt|parsed-overload>overload-data % fnt|output-type))) - fnt|type (fnt|overloads-data>type overloads-data fnt|output-type) - fnt-globals (kw-map fn|meta fn|name fnt|output-type|form fnt|type) - opts (kw-map gen-gensym lang) - expanded-overload-groups-by-fnt-overload - (->> overloads-data - (mapv #(fnt|overload-data>expanded-overload-groups % fnt-globals opts))) + gen-gensym-base (ufgen/>reproducible-gensym|generator) + gen-gensym (fn [x] (symbol (str (gen-gensym-base x) "__"))) + opts (kw-map gen-gensym lang) + inline? (s/validate (:inline fn|meta) (t/? t/boolean?)) + fn|meta (if inline? + (do (ulog/pr :warn "requested `:inline`; ignoring until feature is" + "implemented") + (dissoc fn|meta :inline)) + fn|meta) + fn|output-type|form (or (second output-spec) `t/any?) + ;; TODO this needs to be analyzed for dependent types referring tp local vars + fn|output-type (eval fn|output-type|form) + unanalyzed-overloads (->> overloads-bases + (c/mapcat #(overloads-basis>unanalyzed-overload + % fn|output-type|form fn|output-type))) + fn|type (unanalyzed-overloads>fn|type unanalyzed-overloads fn|output-type) + fn|globals (kw-map fn|name fn|meta fn|type fn|output-type|form fn|output-type) + overloads (->> unanalyzed-overloads + (c/map #(unanalyzed-overload>overload % fn|globals opts))) {:as direct-dispatch :keys [i-overload->direct-dispatch-data]} - (>direct-dispatch fnt-globals opts expanded-overload-groups-by-fnt-overload) + (>direct-dispatch fn|globals opts overloads) fn-codelist (case lang :clj (->> `[(declare ~fn|name) ; for recursion ~@(:form direct-dispatch) - ~(>dynamic-dispatch-fn|form fnt-globals opts - expanded-overload-groups-by-fnt-overload + ~(>dynamic-dispatch-fn|form fn|globals opts overloads i-overload->direct-dispatch-data)] (remove nil?)) :cljs (TODO)) @@ -676,7 +543,11 @@ Metadata directives special to `t/fn` include: - `:inline` : Applicable within the metadata of `t/fn` or `t/defn`. A directive to inline the - function if possible." + function if possible. + + `fnt` only works in languages in which the metalanguage (compiler language) is the same as the + object language. As such, for CLJS, we choose to use only a CLJS-in-CLJS / bootstrapped compiler + even if that means alienating the mainstream CLJS-in-CLJ workflow." [& args] (fn|code :fn (ufeval/env-lang) args))) #?(:clj (defmacro defn [& args] (fn|code :defn (ufeval/env-lang) args))) From e472114b83af86b93029d94d11a8b78cb80939bf Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 9 Oct 2018 00:17:58 -0600 Subject: [PATCH 465/810] Add `>combinatoric-tree` --- .../quantum/untyped/core/collections.cljc | 28 +++++++++++++++++- src/quantum/core/collections.cljc | 1 + .../test/untyped/core/collections.cljc | 29 +++++++++++++++++-- 3 files changed, 54 insertions(+), 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index b71fece5..b53b7dd9 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -6,7 +6,8 @@ (:require [clojure.core :as core] [fast-zip.core :as zip] - [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.core :as ucore + :refer [sentinel]] [quantum.untyped.core.data :refer [transient?]] [quantum.untyped.core.data @@ -396,3 +397,28 @@ (or a-nil? (and (eq-f (first a) (first b)) (recur (next a) (next b)))))))))) + +(defn >combinatoric-tree + "Assumes all are sorted and of the same count." + {:todo #{"Generalize to handle uneven input lengths"}} + ([n xs] (>combinatoric-tree n = conj conj xs)) + ([n eq-f rf combinef xs] + (if (<= n 1) + (->> xs (map+ (fn [[k [x*]]] [x* k])) (educe rf)) + (let [ct (-> xs first second count) + terminate-group + (fn [grouped curr-group curr-x*] + (combinef grouped + [curr-x* (>combinatoric-tree (dec n) eq-f rf combinef curr-group)]))] + (->> xs + (educe (fn ([] [(combinef) (rf) sentinel]) + ([[grouped curr-group curr-x*]] + (terminate-group grouped curr-group curr-x*)) + ([[grouped curr-group curr-x*] [k [x* & xs*]]] + (ifs (identical? curr-x* sentinel) + [grouped [[k xs*]] x*] + (eq-f curr-x* x*) + [grouped (rf curr-group [k xs*]) curr-x*] + [(terminate-group grouped curr-group curr-x*) + [[k xs*]] + x*]))))))))) diff --git a/src/quantum/core/collections.cljc b/src/quantum/core/collections.cljc index 612c015c..86a3f7a2 100644 --- a/src/quantum/core/collections.cljc +++ b/src/quantum/core/collections.cljc @@ -113,6 +113,7 @@ :cljs (:import goog.string.StringBuffer))) (defalias val? quantum.core.type-old/val?) +(defalias >combinatoric-tree u/>combinatoric-tree) #?(:clj (defmacro getf diff --git a/test/quantum/test/untyped/core/collections.cljc b/test/quantum/test/untyped/core/collections.cljc index 1e8bc30c..0ed32909 100644 --- a/test/quantum/test/untyped/core/collections.cljc +++ b/test/quantum/test/untyped/core/collections.cljc @@ -1,8 +1,8 @@ (ns quantum.test.untyped.core.collections (:require - [quantum.core.test - :refer [deftest is is= testing]] - [quantum.untyped.core.collections :as self])) + [quantum.untyped.core.collections :as self] + [quantum.untyped.core.test + :refer [deftest is is= testing]])) (deftest test|flatten (is= (self/flatten [[0 1] [2 3 4]] 0) @@ -13,3 +13,26 @@ (is= (self/flatten [[[0 1]] [[2 3 4]]] 2) [0 1 2 3 4])) + +(def conj|map (fn ([] {}) ([x] x) ([ret x] (conj ret x)))) + +(deftest test|>combinatoric-tree + (let [in '[[0 [a b a]] + [1 [a b c]] + [2 [a c d]] + [3 [c b a]] + [4 [c c a]] + [5 [d a a]]]] + (is= (self/>combinatoric-tree 3 in) + '[[a [[b [[a 0] + [c 1]]] + [c [[d 2]]]]] + [c [[b [[a 3]]] + [c [[a 4]]]]] + [d [[a [[a 5]]]]]]) + (is= (self/>combinatoric-tree 3 = conj|map conj|map in) + '{a {c {d 2} + b {a 0, c 1}} + c {c {a 4} + b {a 3}} + d {a {a 5}}}))) From 4d56dc759efe67c5b18f6590dfb48be0753e517f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 9 Oct 2018 15:23:21 -0600 Subject: [PATCH 466/810] Enhance `>combinatoric-tree` --- .../quantum/untyped/core/collections.cljc | 46 +++++++++-------- .../test/untyped/core/collections.cljc | 50 +++++++++++++------ 2 files changed, 60 insertions(+), 36 deletions(-) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index b53b7dd9..6bf4b26a 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -399,26 +399,30 @@ (recur (next a) (next b)))))))))) (defn >combinatoric-tree - "Assumes all are sorted and of the same count." - {:todo #{"Generalize to handle uneven input lengths"}} - ([n xs] (>combinatoric-tree n = conj conj xs)) - ([n eq-f rf combinef xs] + "See tests for examples. + + Assumes all are sorted and of the same count." + {:todo #{"Generalize to handle uneven input lengths and unsorted combination"}} + ([n #_pos-int?, xs #_(t/of (t/tuple (t/spec t/any? "identifier") (t/of)))] + (>combinatoric-tree + n = conj conj (fn ([] []) ([ret] ret) ([ret [k [x*]]] (conj ret [x* k]))) xs)) + ([n #_pos-int?, eq-f groupsf groupf terminalf xs] (if (<= n 1) - (->> xs (map+ (fn [[k [x*]]] [x* k])) (educe rf)) - (let [ct (-> xs first second count) - terminate-group + (educe terminalf xs) + (let [terminate-group (fn [grouped curr-group curr-x*] - (combinef grouped - [curr-x* (>combinatoric-tree (dec n) eq-f rf combinef curr-group)]))] - (->> xs - (educe (fn ([] [(combinef) (rf) sentinel]) - ([[grouped curr-group curr-x*]] - (terminate-group grouped curr-group curr-x*)) - ([[grouped curr-group curr-x*] [k [x* & xs*]]] - (ifs (identical? curr-x* sentinel) - [grouped [[k xs*]] x*] - (eq-f curr-x* x*) - [grouped (rf curr-group [k xs*]) curr-x*] - [(terminate-group grouped curr-group curr-x*) - [[k xs*]] - x*]))))))))) + (groupsf grouped + [curr-x* + (>combinatoric-tree + (dec n) eq-f groupsf groupf terminalf (groupf curr-group))]))] + (educe + (fn ([] [(groupsf) (groupf) sentinel]) + ([[grouped curr-group curr-x*]] + (groupsf (terminate-group grouped curr-group curr-x*))) + ([[grouped curr-group curr-x*] [k [x* & xs*]]] + (ifs (identical? curr-x* sentinel) [grouped (groupf curr-group [k xs*]) x*] + (eq-f curr-x* x*) [grouped (groupf curr-group [k xs*]) curr-x*] + [(terminate-group grouped curr-group curr-x*) + (groupf (groupf) [k xs*]) + x*]))) + xs))))) diff --git a/test/quantum/test/untyped/core/collections.cljc b/test/quantum/test/untyped/core/collections.cljc index 0ed32909..f72a0edf 100644 --- a/test/quantum/test/untyped/core/collections.cljc +++ b/test/quantum/test/untyped/core/collections.cljc @@ -1,6 +1,8 @@ (ns quantum.test.untyped.core.collections (:require [quantum.untyped.core.collections :as self] + [quantum.untyped.core.fn + :refer [aritoid fn']] [quantum.untyped.core.test :refer [deftest is is= testing]])) @@ -14,7 +16,9 @@ (is= (self/flatten [[[0 1]] [[2 3 4]]] 2) [0 1 2 3 4])) -(def conj|map (fn ([] {}) ([x] x) ([ret x] (conj ret x)))) +(def conj|map (aritoid (fn' {}) identity conj)) + +(def conj|!vec (aritoid (fn [] (transient [])) persistent! conj!)) (deftest test|>combinatoric-tree (let [in '[[0 [a b a]] @@ -22,17 +26,33 @@ [2 [a c d]] [3 [c b a]] [4 [c c a]] - [5 [d a a]]]] - (is= (self/>combinatoric-tree 3 in) - '[[a [[b [[a 0] - [c 1]]] - [c [[d 2]]]]] - [c [[b [[a 3]]] - [c [[a 4]]]]] - [d [[a [[a 5]]]]]]) - (is= (self/>combinatoric-tree 3 = conj|map conj|map in) - '{a {c {d 2} - b {a 0, c 1}} - c {c {a 4} - b {a 3}} - d {a {a 5}}}))) + [5 [d a a]]] + vec-result '[[a [[b [[a 0] + [c 1]]] + [c [[d 2]]]]] + [c [[b [[a 3]]] + [c [[a 4]]]]] + [d [[a [[a 5]]]]]]] + (is= (self/>combinatoric-tree 3 in) vec-result) + (testing "All arities of the combinatory fns are exercised" + (is= (self/>combinatoric-tree 3 = conj|!vec conj|!vec + (fn ([] (transient [])) + ([ret] (persistent! ret)) + ([ret [k [x*]]] (conj! ret [x* k]))) + in))) + (is= (self/>combinatoric-tree 3 = conj|map conj|map + (fn ([] {}) ([ret] ret) ([ret [k [x*]]] (assoc ret x* k))) in) + '{a {b {a 0 + c 1} + c {d 2}} + c {b {a 3} + c {a 4}} + d {a {a 5}}}) + (is= (self/>combinatoric-tree 3 = conj|map conj + (fn ([] []) ([ret] ret) ([ret [k [x*]]] (conj ret [x* k]))) in) + '{a {b [[a 0] + [c 1]] + c [[d 2]]} + c {b [[a 3]] + c [[a 4]]} + d {a [[a 5]]}}))) From 72424e51e4a24d17c8a63492cd706fb11aef832d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 9 Oct 2018 17:32:01 -0600 Subject: [PATCH 467/810] `c/conj!|rf` --- src-untyped/quantum/untyped/core/collections.cljc | 15 +++++++++++++-- 1 file changed, 13 insertions(+), 2 deletions(-) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index 6bf4b26a..86f23ece 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -1,8 +1,8 @@ (ns quantum.untyped.core.collections "Operations on collections." (:refer-clojure :exclude - [#?(:cljs array?) assoc-in cat contains? count distinct distinct? first get group-by filter - flatten last map map-indexed mapcat partition-all pmap remove reverse zipmap]) + [#?(:cljs array?) assoc-in cat conj! contains? count distinct distinct? first get group-by + filter flatten last map map-indexed mapcat partition-all pmap remove reverse zipmap]) (:require [clojure.core :as core] [fast-zip.core :as zip] @@ -33,6 +33,17 @@ (defn ?persistent! [x] (if (transient? x) (persistent! x) x)) +(def conj!|rf + (fn ([] (transient [])) + ([x] (persistent! x)) + ([xs x] (core/conj! xs x)))) + +(defn conj! + ([] (transient [])) + ([xs] xs) + ([xs x0] (core/conj! xs x0)) + ([xs x0 x1] (-> xs (conj! x0) (conj! x1)))) + (def first|rf (aritoid ufn/fn-nil identity (fn [_ x] (reduced x)))) (defn first [xs] From ded6a92baa90bbde29302eb0683a83ae3b3fee3a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 9 Oct 2018 17:32:17 -0600 Subject: [PATCH 468/810] Add `t/extend-defn!` notes --- resources-dev/defnt.cljc | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index cb3ff790..64b3f3b8 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -71,8 +71,20 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - `(t/input-type reduce :_ :_ :?)` - Then if those fns ever get extended then it should trigger a chain-reaction of recompilations [4] - t/output-type - [5] - Direct dispatch needs to actually work correctly in `t/defn` - [6] - No trailing `>` means `> ?` + [5] - t/extend-defn! + - We could just recreate the dispatch every time, in the beginning. It would make for slower + compilation but faster execution for dynamic dispatch, and quicker time to use. So whenever + something extends a `t/defn`, the type overloads have to be put in the right place in the dispatch + order. We could find the first place where the inputs are t/<. + - But then you have to trigger a recompilation of everything that depended on that `t/defn` + because your input-types and output-types have both gotten bigger. Maybe not on that overload + but still. + - This will be a more advanced feature. For now we just accept that we might have some odd behavior around extending `t/defn`s. + - When you overwrite a `reify` then it's fine as long as the interface class stays the same. + Of course, pending auto-recompilation, you'll have to manually recompile its dependents + for them to pick up on changes to its type. + [6] - Direct dispatch needs to actually work correctly in `t/defn` + [7] - No trailing `>` means `> ?` - ? : type inference - use logic programming and variable unification e.g. `?1` `?2` ? - For this situation: `?` is `(t/- dc/counted?)` @@ -133,7 +145,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - We'll should make a special class or *something* like that to ensure that typed bindings are only bound within typed contexts. - `t/defn` declaration: `(t/defn >std-fixint > std-fixint?)` - - t/extend-defn! - t/defrecord - t/def-concrete-type (i.e. `t/deftype`) - expressions (`quantum.untyped.core.analyze.expr`) From b5c7eb92213b96fd4d8d09f025d8c12d4bd7eea9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 9 Oct 2018 17:32:40 -0600 Subject: [PATCH 469/810] Add combinatoric tree for dynamic dispatch --- .../quantum/untyped/core/type/defnt.cljc | 230 ++++++++++-------- 1 file changed, 125 insertions(+), 105 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index fcda5201..d21aa738 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -11,7 +11,7 @@ [quantum.untyped.core.analyze :as uana] [quantum.untyped.core.analyze.ast :as uast] [quantum.untyped.core.core - :refer [istr]] ; TODO use quantum.untyped.core.string/istr instead + :refer [istr sentinel]] ; TODO use quantum.untyped.core.string/istr instead [quantum.untyped.core.defnt :refer [defns defns- fns]] [quantum.untyped.core.collections :as c @@ -103,25 +103,23 @@ ;; When present, varargs are considered to be of class Object :variadic? t/boolean?})) -(s/def ::reify - (s/kv {:form t/any? - :name simple-symbol? - :overload ::overload})) - (s/def ::input-types-decl - (s/kv {:form t/any? - :name simple-symbol? - :arg-type|split (s/vec-of t/type?)})) + (s/kv {:form t/any? + :name simple-symbol?})) -(s/def ::direct-dispatch-data - (s/kv {:i-arg->input-types-decl (s/vec-of ::input-types-decl) - :reify-seq (s/vec-of ::reify)})) +(s/def ::reify + (s/kv {:form t/any? + :interface class? + :name simple-symbol? + :overload ::overload})) -(s/def ::i-overload->direct-dispatch-data (s/vec-of ::direct-dispatch-data)) +(s/def ::direct-dispatch-data + (s/kv {:input-types-decl ::input-types-decl + :reify ::reify})) (s/def ::direct-dispatch - (s/kv {:form t/any? - :i-overload->direct-dispatch-data ::i-overload->direct-dispatch-data})) + (s/kv {:form t/any? + :direct-dispatch-data-seq (s/vec-of ::direct-dispatch-data)})) #_(:clj (core/defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] @@ -250,9 +248,8 @@ [{:as overload :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, out-class _]} ::overload {:as opts :keys [gen-gensym _]} ::opts - {:keys [fn|name _]} ::fn|globals - i|unanalyzed-overload index? - i|overload index? + {:keys [fn|name _]} ::fn|globals + i|overload index? > ::reify] (let [interface-k {:out out-class :in arg-classes} interface @@ -267,14 +264,15 @@ (fn [i|arg arg|form] (ufth/with-type-hint arg|form (-> arg-classes (c/get i|arg) ufth/>arglist-embeddable-tag))))))) - reify-name (>symbol (str fn|name "|__" i|unanalyzed-overload "|" i|overload)) + reify-name (>symbol (str fn|name "|__" i|overload)) form `(~'def ~reify-name (reify* [~(-> interface >name >symbol)] (~(ufth/with-type-hint reify-method-sym (ufth/>arglist-embeddable-tag out-class)) ~arglist-code ~body-form)))] - {:form form - :name reify-name - :overload overload}))) + {:form form + :interface interface + :name reify-name + :overload overload}))) ;; TODO spec ;; TODO use!! @@ -303,111 +301,135 @@ ;; ----- Direct dispatch: putting it all together ----- ;; -(defns >input-type-decl|name - [fn|name ::uss/fn|name, i|fnt-overload index?, i|arg index? > simple-symbol?] - (>symbol (str fn|name "|__" i|fnt-overload "|input" i|arg "|types"))) - -(defns >i-arg->input-types-decl +(defns >input-types-decl "The evaluated `form` of each input-types-decl is an array of non-primitivized types that the dynamic dispatch uses to dispatch off input types." - [{:keys [fn|name _]} ::fn|globals - arg-types|split ::expanded-overload-groups|arg-types|split, i|fnt-overload index? - > (s/vec-of ::input-types-decl)] - (->> arg-types|split - (c/map-indexed - (fn [i|arg arg-type|split] - (let [decl-name (>input-type-decl|name fn|name i|fnt-overload i|arg) - form (list 'def (ufth/with-type-hint decl-name "[Ljava.lang.Object;") - (list* `uarr/*<> (map >form arg-type|split)))] - (assoc (kw-map form arg-type|split) :name decl-name)))))) + [{:keys [fn|name _]} ::fn|globals, arg-types (s/vec-of t/type?), i|overload index? + > ::input-types-decl] + (let [decl-name (>symbol (str fn|name "|__" i|overload "|types")) + form (list 'def (ufth/with-type-hint decl-name "[Ljava.lang.Object;") + (list* `uarr/*<> (c/lmap >form arg-types)))] + {:form form :name decl-name})) (defns >direct-dispatch [{:as fn|globals :keys [fn|name _]} ::fn|globals {:as opts :keys [gen-gensym _, lang _]} ::opts - ; expanded-overload-groups-by-fnt-overload overloads (s/vec-of ::overload) > ::direct-dispatch] (case lang - :clj (let [i-overload->direct-dispatch-data - (->> expanded-overload-groups-by-fnt-overload + :clj (let [direct-dispatch-data-seq + (->> overloads (c/map-indexed - (fn [i|fnt-overload {:keys [arg-types|split expanded-overload-group-seq]}] - {:i-arg->input-types-decl - (>i-arg->input-types-decl fn|globals arg-types|split i|fnt-overload) - :reify (overload>reify overload opts fn|globals - i|unanalyzed-overload i|overload)}))) - form (->> i-overload->direct-dispatch-data - (c/map (fn [{:keys [i-arg->input-types-decl reify-seq]}] - (concat (c/lmap :form i-arg->input-types-decl) - (c/lmap :form reify-seq)))) - c/lcat)] - (kw-map form i-overload->direct-dispatch-data)) + (fn [i|overload {:keys [arg-types]}] + {:input-types-decl + (>input-types-decl fn|globals arg-types i|overload) + :reify (overload>reify overload opts fn|globals i|overload)}))) + form (->> direct-dispatch-data-seq + (c/mapcat + (fn [{:as direct-dispatch-data :keys [input-types-decl]}] + (list (:form input-types-decl) + (-> direct-dispatch-data :reify :form))]))) + (kw-map form direct-dispatch-data-seq)) :cljs (TODO))) ;; ===== Dynamic dispatch ===== ;; -(defns >dynamic-dispatch|reify-call [reify- ::reify, arglist (s/vec-of simple-symbol?)] - (let [dotted-reify-method-sym - (symbol (str "." (-> reify- :non-primitivized-overload :method-sym))) - hinted-reify-sym - (ufth/with-type-hint (:name reify-) - (-> reify- :non-primitivized-overload :interface >name))] - `(~dotted-reify-method-sym ~hinted-reify-sym ~@arglist))) +(defns- >dynamic-dispatch|reify-call [reify- ::reify, arglist (s/vec-of simple-symbol?)] + (let [hinted-reify-sym (-> reify- :name (ufth/with-type-hint (-> reify- :interface >name)))] + `(. ~hinted-reify-sym ~reify-method-sym ~@arglist))) ;; TODO spec (defns unsupported! [name- _ #_t/qualified-symbol?, args _ #_indexed?, i index?] (TODO)) -(defns >dynamic-dispatch|conditional - [fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?), i|arg index?, body _] - (if (-> body count (= 1)) - (first body) - `(ifs ~@body (unsupported! (quote ~(uid/qualify fn|name)) [~@arglist] ~i|arg)))) - -(defns >dynamic-dispatch|body-for-arity - ([fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?) - direct-dispatch-data-for-arity (s/seq-of ::direct-dispatch-data)] - (if (empty? arglist) - (>dynamic-dispatch|reify-call - (-> direct-dispatch-data-for-arity first :reify-seq first) arglist) - (let [i|arg 0 - branches (->> direct-dispatch-data-for-arity - (c/lmap - (fn [{:keys [reify-seq i-arg->input-types-decl]}] - (>dynamic-dispatch|body-for-arity fn|name arglist reify-seq - i-arg->input-types-decl (atom 0) i|arg))) - c/lcat)] - (>dynamic-dispatch|conditional fn|name arglist i|arg branches)))) - ([fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?), reify-seq (s/vec-of ::reify) - input-types-decl-group' (s/seq-of ::input-types-decl), *i|reify _, i|arg index?] - (let [{:as input-types-decl :keys [arg-type|split]} (first input-types-decl-group') - input-types-decl-group'' (rest input-types-decl-group')] - (->> arg-type|split - (c/lmap-indexed - (fn [i|arg-type' _] - [`((Array/get ~(:name input-types-decl) ~i|arg-type') ~(get arglist i|arg)) - (if (empty? input-types-decl-group'') - (with-do (>dynamic-dispatch|reify-call (get reify-seq @*i|reify) arglist) - ;; TODO take out this ugly bit - (swap! *i|reify inc)) - (let [i|arg' (inc i|arg) - next-branch (>dynamic-dispatch|body-for-arity fn|name arglist reify-seq - input-types-decl-group'' *i|reify i|arg')] - (>dynamic-dispatch|conditional fn|name arglist i|arg' next-branch)))])) - c/lcat)))) +(let [fn|name 'the-name + arglist '[x0 x1 x2] + >unsupported!-form (fn [i|arg] `(unsupported! '~(uid/qualify fn|name) [~@arglist] ~i|arg)) + xs [['(.invoke overload0 x0 x1 x2) + [{:t t/boolean? :getter '((Array/get overload-types0 0) x0) :i 0} + {:t t/long? :getter '((Array/get overload-types0 1) x1) :i 1} + {:t t/boolean? :getter '((Array/get overload-types0 2) x2) :i 2}]] + ['(.invoke overload1 x0 x1 x2) + [{:t t/boolean? :getter '((Array/get overload-types1 0) x0) :i 0} + {:t t/long? :getter '((Array/get overload-types1 1) x1) :i 1} + {:t t/object? :getter '((Array/get overload-types1 2) x2) :i 2}]] + ['(.invoke overload2 x0 x1 x2) + [{:t t/byte? :getter '((Array/get overload-types2 0) x0) :i 0} + {:t t/long? :getter '((Array/get overload-types2 1) x1) :i 1} + {:t t/byte? :getter '((Array/get overload-types2 2) x2) :i 2}]] + ['(.invoke overload2 x0 x1 x2) + [{:t t/byte? :getter '((Array/get overload-types2 0) x0) :i 0} + {:t t/boolean? :getter '((Array/get overload-types2 1) x1) :i 1} + {:t t/byte? :getter '((Array/get overload-types2 2) x2) :i 2}]]] + *i|arg (atom 0) + combinef + (fn ([] (transient ['ifs])) + ([ret] (-> ret (conj! (>unsupported!-form @*i|arg)) persistent! seq)) + ([ret getter x i] + (reset! *i|arg i) + (c/conj! ret getter x)))] + (c/>combinatoric-tree (count arglist) + (fn [a b] (t/= (:t a) (:t b))) + (aritoid combinef combinef (fn [ret [{:keys [getter i]} group]] (combinef ret getter group i))) + c/conj!|rf + (aritoid combinef combinef (fn [ret [k [{:keys [getter i]}]]] (combinef ret getter k i))) + xs)) + +(defns- >combinatoric-seq+ + [direct-dispatch-data-seq-for-arity (s/seq-of ::direct-dispatch-data) + arglist (s/vec-of simple-symbol?)] + (->> direct-dispatch-data-seq-for-arity + (c/map+ (fn [{reify- :reify :keys [input-types-decl]}] + [(>dynamic-dispatch|reify-call reify- arglist) + (->> reify- + :overload + :arg-types + (c/map-indexed + (fn [i|arg arg-type] + {:i i|arg + :t arg-type + :getf `((Array/get ~(:name input-types-decl) ~i|arg) + ~(get arglist i|arg))})))])))) + +(defns- >dynamic-dispatch|body-for-arity + "Assumes the elements of `direct-dispatch-data-seq-for-arity` are ordered in increasing + generality of the input types of their respective `reify` declarations." + [fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?) + direct-dispatch-data-seq-for-arity (s/seq-of ::direct-dispatch-data)] + (if (empty? arglist) + (>dynamic-dispatch|reify-call (-> direct-dispatch-data-seq-for-arity first :reify) arglist) + (let [combinatoric-seq+ + + *i|arg (atom 0) + combinef + (fn ([] (transient [`ifs])) + ([ret] + (-> ret (conj! `(unsupported! '~(uid/qualify fn|name) ~arglist ~(deref *i|arg))) + persistent! + seq)) + ([ret getf x i] + (reset! *i|arg i) + (c/conj! ret getf x)))] + (c/>combinatoric-tree (count arglist) + (fn [a b] (t/= (:t a) (:t b))) + (aritoid combinef combinef (fn [x [{:keys [getf i]} group]] (combinef x getf group i))) + c/conj!|rf + (aritoid combinef combinef (fn [x [k [{:keys [getf i]}]]] (combinef x getf k i))) + (>combinatoric-seq+ direct-dispatch-data-seq-for-arity arglist)))))) (defns >dynamic-dispatch-fn|form [{:as fn|globals :keys [fn|meta _, fn|name _]} ::fn|globals {:as opts :keys [gen-gensym _, lang _]} ::opts - expanded-overload-groups-by-fnt-overload (s/vec-of ::expanded-overload-groups) - i-overload->direct-dispatch-data ::i-overload->direct-dispatch-data] + direct-dispatch ::direct-dispatch] `(core/defn ~fn|name ~(assoc fn|meta :quantum.core.type/type (>form fn|type)) - ~@(->> i-overload->direct-dispatch-data - (group-by (fn-> :i-arg->input-types-decl count)) - (map (fn [[arg-ct direct-dispatch-data-for-arity]] + ~@(->> direct-dispatch + :direct-dispatch-data-seq + (group-by (fn-> :reify :overload :arg-types count)) + (sort-by key) ; for purposes of reproducibility and organization + (map (fn [[arg-ct direct-dispatch-data-seq-for-arity]] (let [arglist (ufgen/gen-args 0 arg-ct "x" gen-gensym) body (>dynamic-dispatch|body-for-arity - fn|name arglist direct-dispatch-data-for-arity)] + fn|name arglist direct-dispatch-data-seq-for-arity)] (list arglist body))))))) ;; ===== End dynamic dispatch ===== ;; @@ -498,14 +520,12 @@ fn|globals (kw-map fn|name fn|meta fn|type fn|output-type|form fn|output-type) overloads (->> unanalyzed-overloads (c/map #(unanalyzed-overload>overload % fn|globals opts))) - {:as direct-dispatch :keys [i-overload->direct-dispatch-data]} - (>direct-dispatch fn|globals opts overloads) + direct-dispatch (>direct-dispatch fn|globals opts overloads) fn-codelist (case lang :clj (->> `[(declare ~fn|name) ; for recursion ~@(:form direct-dispatch) - ~(>dynamic-dispatch-fn|form fn|globals opts overloads - i-overload->direct-dispatch-data)] + ~(>dynamic-dispatch-fn|form fn|globals opts direct-dispatch)] (remove nil?)) :cljs (TODO)) code (case kind From 0c00dcf0162f3bc183e5be5c3b31873bcc8d793a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 9 Oct 2018 20:03:03 -0600 Subject: [PATCH 470/810] First test passes with dependent type rework! --- src-untyped/quantum/untyped/core/analyze.cljc | 12 ++-- .../quantum/untyped/core/type/defnt.cljc | 66 +++++-------------- .../untyped/core/type/reifications.cljc | 4 +- .../quantum/test/untyped/core/type/defnt.cljc | 20 +++--- 4 files changed, 39 insertions(+), 63 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index e1b063cd..dbaba2a8 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -671,6 +671,7 @@ (t/value t/isa?) (apply-arg-type-combine t/isa? input-nodes) (t/value t/or) (apply-arg-type-combine t/or input-nodes) (t/value t/and) (apply-arg-type-combine t/and input-nodes) + (t/value t/?) (apply-arg-type-combine t/? input-nodes) out-type)) (defns- analyze-seq|call @@ -804,9 +805,12 @@ (uast/var-value env form v (or (-> resolved meta :quantum.core.type/type) (t/value v)))))) (uast/class-value env (uid/>symbol resolved) resolved)))] - (if (uast/symbol? node) - (assoc node :env env) - (uast/symbol env form node (:type node)))))) + (ifs (uast/symbol? node) + (assoc node :env env) + (uast/class-value? node) + ;; To avoid unnecessary type hint + (quantum.untyped.core.analyze.ast.Symbol. env form node (:type node)) + (uast/symbol env form node (:type node)))))) (defns- analyze* [env ::env, form _ > uast/node?] (when (> (swap! *analyze-depth inc) 200) (throw (ex-info "Stack too deep" {:form form}))) @@ -949,7 +953,7 @@ ([arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _] (analyze-arg-syms {} arg-sym->arg-type-form out-type-form)) ([env ::env, arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _ - > (s/kv {:env ::env :out-type-node uast/node?})] + > (s/vec-of (s/kv {:env ::env :out-type-node uast/node?}))] (analyze-arg-syms* (update env :opts #(assoc % :arglist-context? true diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index d21aa738..236a715b 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -246,16 +246,16 @@ #?(:clj (defns overload>reify [{:as overload - :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, out-class _]} ::overload + :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, output-class _]} ::overload {:as opts :keys [gen-gensym _]} ::opts {:keys [fn|name _]} ::fn|globals i|overload index? > ::reify] - (let [interface-k {:out out-class :in arg-classes} + (let [interface-k {:out output-class :in arg-classes} interface (-> *interfaces (swap! update interface-k - #(or % (eval (overload-classes>interface arg-classes out-class gen-gensym)))) + #(or % (eval (overload-classes>interface arg-classes output-class gen-gensym)))) (c/get interface-k)) arglist-code (>vec (concat [(gen-gensym '_)] @@ -267,7 +267,8 @@ reify-name (>symbol (str fn|name "|__" i|overload)) form `(~'def ~reify-name (reify* [~(-> interface >name >symbol)] - (~(ufth/with-type-hint reify-method-sym (ufth/>arglist-embeddable-tag out-class)) + (~(ufth/with-type-hint reify-method-sym + (ufth/>arglist-embeddable-tag output-class)) ~arglist-code ~body-form)))] {:form form :interface interface @@ -320,7 +321,7 @@ :clj (let [direct-dispatch-data-seq (->> overloads (c/map-indexed - (fn [i|overload {:keys [arg-types]}] + (fn [i|overload {:as overload :keys [arg-types]}] {:input-types-decl (>input-types-decl fn|globals arg-types i|overload) :reify (overload>reify overload opts fn|globals i|overload)}))) @@ -328,7 +329,7 @@ (c/mapcat (fn [{:as direct-dispatch-data :keys [input-types-decl]}] (list (:form input-types-decl) - (-> direct-dispatch-data :reify :form))]))) + (-> direct-dispatch-data :reify :form)))))] (kw-map form direct-dispatch-data-seq)) :cljs (TODO))) @@ -341,39 +342,6 @@ ;; TODO spec (defns unsupported! [name- _ #_t/qualified-symbol?, args _ #_indexed?, i index?] (TODO)) -(let [fn|name 'the-name - arglist '[x0 x1 x2] - >unsupported!-form (fn [i|arg] `(unsupported! '~(uid/qualify fn|name) [~@arglist] ~i|arg)) - xs [['(.invoke overload0 x0 x1 x2) - [{:t t/boolean? :getter '((Array/get overload-types0 0) x0) :i 0} - {:t t/long? :getter '((Array/get overload-types0 1) x1) :i 1} - {:t t/boolean? :getter '((Array/get overload-types0 2) x2) :i 2}]] - ['(.invoke overload1 x0 x1 x2) - [{:t t/boolean? :getter '((Array/get overload-types1 0) x0) :i 0} - {:t t/long? :getter '((Array/get overload-types1 1) x1) :i 1} - {:t t/object? :getter '((Array/get overload-types1 2) x2) :i 2}]] - ['(.invoke overload2 x0 x1 x2) - [{:t t/byte? :getter '((Array/get overload-types2 0) x0) :i 0} - {:t t/long? :getter '((Array/get overload-types2 1) x1) :i 1} - {:t t/byte? :getter '((Array/get overload-types2 2) x2) :i 2}]] - ['(.invoke overload2 x0 x1 x2) - [{:t t/byte? :getter '((Array/get overload-types2 0) x0) :i 0} - {:t t/boolean? :getter '((Array/get overload-types2 1) x1) :i 1} - {:t t/byte? :getter '((Array/get overload-types2 2) x2) :i 2}]]] - *i|arg (atom 0) - combinef - (fn ([] (transient ['ifs])) - ([ret] (-> ret (conj! (>unsupported!-form @*i|arg)) persistent! seq)) - ([ret getter x i] - (reset! *i|arg i) - (c/conj! ret getter x)))] - (c/>combinatoric-tree (count arglist) - (fn [a b] (t/= (:t a) (:t b))) - (aritoid combinef combinef (fn [ret [{:keys [getter i]} group]] (combinef ret getter group i))) - c/conj!|rf - (aritoid combinef combinef (fn [ret [k [{:keys [getter i]}]]] (combinef ret getter k i))) - xs)) - (defns- >combinatoric-seq+ [direct-dispatch-data-seq-for-arity (s/seq-of ::direct-dispatch-data) arglist (s/vec-of simple-symbol?)] @@ -397,9 +365,7 @@ direct-dispatch-data-seq-for-arity (s/seq-of ::direct-dispatch-data)] (if (empty? arglist) (>dynamic-dispatch|reify-call (-> direct-dispatch-data-seq-for-arity first :reify) arglist) - (let [combinatoric-seq+ - - *i|arg (atom 0) + (let [*i|arg (atom 0) combinef (fn ([] (transient [`ifs])) ([ret] @@ -414,10 +380,10 @@ (aritoid combinef combinef (fn [x [{:keys [getf i]} group]] (combinef x getf group i))) c/conj!|rf (aritoid combinef combinef (fn [x [k [{:keys [getf i]}]]] (combinef x getf k i))) - (>combinatoric-seq+ direct-dispatch-data-seq-for-arity arglist)))))) + (>combinatoric-seq+ direct-dispatch-data-seq-for-arity arglist))))) -(defns >dynamic-dispatch-fn|form - [{:as fn|globals :keys [fn|meta _, fn|name _]} ::fn|globals +(defns- >dynamic-dispatch-fn|form + [{:as fn|globals :keys [fn|meta _, fn|name _, fn|type _]} ::fn|globals {:as opts :keys [gen-gensym _, lang _]} ::opts direct-dispatch ::direct-dispatch] `(core/defn ~fn|name @@ -478,11 +444,11 @@ (kw-map output-type fn|output-type))) (kw-map arg-types output-type)))))] (->> arg-types|expanded-seq - (fn [{:keys [arg-types output-type]}] - (kw-map arg-bindings varargs-binding - arg-types|form arg-types - output-type|form output-type - body-codelist|pre-analyze))))) + (c/map (fn [{:keys [arg-types output-type]}] + (kw-map arg-bindings varargs-binding + arg-types|form arg-types + output-type|form output-type + body-codelist|pre-analyze)))))) (defns unanalyzed-overloads>fn|type [unanalyzed-overloads (s/seq-of ::unanalyzed-overload), fn|output-type t/type? > utr/fn-type?] diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index c8b064ae..cba02022 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -282,8 +282,10 @@ ?Fn {invoke ([this args] (TODO))} ?Meta {meta ([this] meta) with-meta ([this meta'] (FnType. meta' name out-type arities-form arities))} + uform/PGenForm {>form ([this] (list* 'quantum.untyped.core.type/ftype + (>form out-type) (>form arities-form)))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (list 'quantum.untyped.core.type/fn out-type arities-form))}}) + fedn/IEdn {-edn ([this] (>form this))}}) (defns fn-type? [x _ > boolean?] (instance? FnType x)) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 933360ca..47904a5e 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -42,18 +42,22 @@ (let [actual (macroexpand ' (self/defn pid|test [> (? t/string?)] - (->> (java.lang.management.ManagementFactory/getRuntimeMXBean) - (.getName)))) + (->> ^:val (java.lang.management.ManagementFactory/getRuntimeMXBean) + (.getName)))) expected - ($ (do (def ~'pid|test|__0|0 + ($ (do (declare ~'pid|test) + (def ~(O<> 'pid|test|__0|types) (quantum.untyped.core.data.array/*<>)) + (def ~'pid|test|__0 (reify* [>Object] (~(O 'invoke) [~'_0__] - ~(STR '(. (. java.lang.management.ManagementFactory getRuntimeMXBean) - getName))))) + ~(STR (list '. + (tag "java.lang.management.RuntimeMXBean" + '(. java.lang.management.ManagementFactory getRuntimeMXBean)) + 'getName))))) (defn ~'pid|test - {:quantum.core.type/type (t/fn t/any? ~'[:> (? t/string?)])} - ([] (.invoke ~(tag (str `>Object) - 'pid|test|__0|0))))))] + {:quantum.core.type/type + (t/ftype t/any? [:> (t/or (t/value nil) (t/isa? String))])} + ([] (. ~(tag (str `>Object) 'pid|test|__0|0) invoke)))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) From ef38d1917d9ad1b54ad6dcc0f0f096c4d1ad8918 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 9 Oct 2018 21:07:31 -0600 Subject: [PATCH 471/810] Fix compilation --- src-untyped/quantum/untyped/core/analyze.cljc | 4 ++-- src-untyped/quantum/untyped/core/compare.cljc | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index dbaba2a8..fc16426f 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -919,7 +919,7 @@ t/type>primitive-subtypes (sort-by sort-guide) ; For cleanliness and reproducibility in tests vec) - t-split (c/distinct (join primitive-subtypes (-> analyzed :type type>split)))] + t-split (uc/distinct (join primitive-subtypes (-> analyzed :type type>split)))] (pr! {:t (:type analyzed) :t-split t-split} #_{:analyzed analyzed}) (if (-> t-split count (= 1)) (let [env' (assoc (:env analyzed) arg-sym analyzed)] @@ -930,7 +930,7 @@ (:arglist-syms|unanalyzed analyzed) (inc n|iter))) (->> t-split - (c/mapcat+ + (uc/mapcat+ (fn [t] (analyze-arg-syms* (assoc (:env analyzed) arg-sym (assoc analyzed :type t)) diff --git a/src-untyped/quantum/untyped/core/compare.cljc b/src-untyped/quantum/untyped/core/compare.cljc index 943a3e6b..c8c4d934 100644 --- a/src-untyped/quantum/untyped/core/compare.cljc +++ b/src-untyped/quantum/untyped/core/compare.cljc @@ -15,11 +15,11 @@ (def not== (comp not identical?)) (def comparison= zero?) +(def comparison-not= (comp not comparison=)) (def comparison< neg?) (def comparison<= (fn-or comparison< comparison=)) -(def comparison-not= (comp not comparison=)) -(def comparison>= (fn-or comparison> comparison=)) (def comparison> pos?) +(def comparison>= (fn-or comparison> comparison=)) (defn comp< ([ x0 x1] (comp< compare x0 x1)) ([compf x0 x1] (comparison< (compf x0 x1)))) From 4567eb2d1e207acf9a799e4b5f6371d6466fc754 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 9 Oct 2018 21:07:36 -0600 Subject: [PATCH 472/810] Add `+map-entry?` --- src-untyped/quantum/untyped/core/data/map.cljc | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/map.cljc b/src-untyped/quantum/untyped/core/data/map.cljc index fbef046f..d73ac657 100644 --- a/src-untyped/quantum/untyped/core/data/map.cljc +++ b/src-untyped/quantum/untyped/core/data/map.cljc @@ -1,5 +1,5 @@ -(ns "Map functions. |map-entry|, a better merge, sorted-maps, etc." - quantum.untyped.core.data.map +(ns quantum.untyped.core.data.map + "Map functions. |map-entry|, a better merge, sorted-maps, etc." (:refer-clojure :exclude [split-at, merge, sorted-map sorted-map-by, array-map, hash-map]) (:require @@ -26,6 +26,8 @@ [it.unimi.dsi.fastutil.objects Reference2LongOpenHashMap]] :cljs [[goog.structs AvlTree LinkedMap]]))) +(defn +map-entry? [x] (instance? #?(:clj clojure.lang.MapEntry :cljs cljs.core.MapEntry) x)) + ;; ----- Hash maps ----- ;; #?(:clj (def hash-map? (partial instance? clojure.lang.PersistentHashMap))) From 236d6ebc403a56135d001b420f861cecf4ac0dfc Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 9 Oct 2018 21:07:42 -0600 Subject: [PATCH 473/810] `clojure.lang.ASeq` `>form` --- src-untyped/quantum/untyped/core/form.cljc | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index 73d7fac2..cd01bbd5 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -62,6 +62,8 @@ :cljs cljs.core/PersistentList) (>form [x] (->> x (map >form) list*)) + #?@(:clj [clojure.lang.ASeq (>form [x] (->> x (map >form)))]) + #?(:clj clojure.lang.Var :cljs cljs.core/Var) (>form [x] #?(:clj (list 'var (symbol (-> x .-ns ns-name name) (-> x .-sym name))) From fd3f303ab06b06cb75eb1a32cf3101439625285d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 9 Oct 2018 21:10:05 -0600 Subject: [PATCH 474/810] `test/code=` better logging --- src-untyped/quantum/untyped/core/test.cljc | 67 ++++++++++++---------- 1 file changed, 38 insertions(+), 29 deletions(-) diff --git a/src-untyped/quantum/untyped/core/test.cljc b/src-untyped/quantum/untyped/core/test.cljc index 457ce686..6a4a95d7 100644 --- a/src-untyped/quantum/untyped/core/test.cljc +++ b/src-untyped/quantum/untyped/core/test.cljc @@ -1,13 +1,14 @@ (ns quantum.untyped.core.test (:require - [clojure.spec.alpha :as s] - [clojure.spec.test.alpha :as stest] - [clojure.string :as str] - [clojure.test :as test] - [quantum.untyped.core.collections - :refer [seq=]] - [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.error :as uerr] + [clojure.spec.alpha :as s] + [clojure.spec.test.alpha :as stest] + [clojure.string :as str] + [clojure.test :as test] + [quantum.untyped.core.collections :as uc] + [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.data.map + :refer [+map-entry?]] + [quantum.untyped.core.error :as uerr] [quantum.untyped.core.log :refer [pr!]] [quantum.untyped.core.print @@ -26,37 +27,45 @@ (defn test-nss-where [pred] (->> (all-ns) (filter #(-> % ns-name name pred)) (map test-ns) doall))) +(defn- code=|similar-class [c0 c1] + (let [similar-class? + (cond (seq? c0) (seq? c1) + (seq? c1) (seq? c0) + (vector? c0) (vector? c1) + (vector? c1) (vector? c0) + (map? c0) (map? c1) + (map? c1) (map? c0) + (+map-entry? c0) (+map-entry? c1) + (+map-entry? c1) (+map-entry? c0) + :else ::not-applicable)] + (if (= similar-class? ::not-applicable) + (or (= c0 c1) + (do (pr! "FAIL: should be `(= code0 code1)`" (pr-str c0) (pr-str c1)) false)) + (and (or similar-class? + (do (pr! "FAIL: should be similar class" (pr-str c0) (pr-str c1)) + false)) + (or (uc/seq= (seq c0) (seq c1) code=) + (do (pr! "FAIL: `(seq= code0 code1 code=)`" (pr-str c0) (pr-str c1)) + false)))))) + (defn code= "`code=` but with helpful test-related logging" ([c0 c1] (if (metable? c0) - (and (metable? c1) + (and (or (metable? c1) + (do (pr! "FAIL: should be `(metable? c1)`" c1) + false)) (let [meta0 (-> c0 meta (or {}) (dissoc :line :column)) meta1 (-> c1 meta (or {}) (dissoc :line :column))] (or (= meta0 meta1) (do (pr! "FAIL: meta should be match for" (pr-str meta0) (pr-str meta1) "on code" (pr-str c0) (pr-str c1)) false))) - (let [similar-class? - (cond (seq? c0) (seq? c1) - (seq? c1) (seq? c0) - (vector? c0) (vector? c1) - (vector? c1) (vector? c0) - (map? c0) (map? c1) - (map? c1) (map? c0) - :else ::not-applicable)] - (if (= similar-class? ::not-applicable) - (or (= c0 c1) - (do (pr! "FAIL: should be `(= code0 code1)`" (pr-str c0) (pr-str c1)) false)) - (and (or similar-class? - (do (pr! "FAIL: should be similar class" (pr-str c0) (pr-str c1)) - false)) - (or (seq= (seq c0) (seq c1) code=) - (do (pr! "FAIL: `(seq= code0 code1 code=)`" (pr-str c0) (pr-str c1)) - false)))))) - (and (not (metable? c1)) - (or (= c0 c1) - (println "FAIL: should be `(= code0 code1)`" (pr-str c0) (pr-str c1)))))) + (code=|similar-class c0 c1)) + (and (or (not (metable? c1)) + (do (pr! "FAIL: should be `(not (metable? c1))`" c1) + false)) + (code=|similar-class c0 c1)))) ([c0 c1 & codes] (and (code= c0 c1) (every? #(code= c0 %) codes)))) (defn is-code= [& args] (is (apply code= args))) From e4e3bd26f39a518038f6fb610efa1ccdbb16fac2 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 9 Oct 2018 21:10:14 -0600 Subject: [PATCH 475/810] Fix compilation --- src-untyped/quantum/untyped/core/type.cljc | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index a0867626..4cb9a243 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -24,11 +24,12 @@ [quantum.untyped.core.collections.logic :refer [seq-and seq-or]] [quantum.untyped.core.compare :as ucomp - :refer [== ident >ident]] + :refer [==]] [quantum.untyped.core.core :as ucore] [quantum.untyped.core.data.bits :as ubit] [quantum.untyped.core.data.hash :as uhash] - [quantum.untyped.core.data.set :as uset] + [quantum.untyped.core.data.set :as uset + :refer [ident >ident]] [quantum.untyped.core.data.tuple] [quantum.untyped.core.defnt :refer [defns defns-]] @@ -308,7 +309,7 @@ (defns complementary? [t0 utr/type? t1 utr/type?] (= t0 (not t1))) (defns- create-logical-type|inner|or - [{:as accum :keys [t' utr/type?]} _, t* utr/type?, c* ucomp/comparison?] + [{:as accum :keys [t' utr/type?]} _, t* utr/type?, c* uset/comparison?] (if #?(:clj (c/or (c/and (c/= t' object?) (c/= t* nil?)) (c/and (c/= t* object?) (c/= t' nil?))) :cljs false) @@ -324,7 +325,7 @@ (defns- create-logical-type|inner|and [{:as accum :keys [conj-t? c/boolean?, prefer-orig-args? c/boolean?, t' utr/type?, types _]} _ - t* utr/type?, c* ucomp/comparison?] + t* utr/type?, c* uset/comparison?] (if ;; Contradiction/empty-set: (& A (! A)) (c/or (c/= c* <>ident) ; optimization before `complementary?` (complementary? t' t*)) @@ -430,7 +431,7 @@ (uc/group-by #(-> % :input-types count)))] (FnType. nil name- out-type arities-form arities))) -(defns compare|in [x0 utr/fn-type?, x1 utr/fn-type? > ucomp/comparison?] +(defns compare|in [x0 utr/fn-type?, x1 utr/fn-type? > uset/comparison?] (let [ct->overloads|x0 (utr/fn-type>arities x0) ct->overloads|x1 (utr/fn-type>arities x1) cts-only-in-x0 (uset/- (-> ct->overloads|x0 keys set) (-> ct->overloads|x1 keys set)) @@ -459,7 +460,7 @@ (uc/lmap :output-type) (apply or))) -(defns compare|out [x0 utr/fn-type?, x1 utr/fn-type? > ucomp/comparison?] +(defns compare|out [x0 utr/fn-type?, x1 utr/fn-type? > uset/comparison?] (utcomp/compare (fn-type>output-type x0) (fn-type>output-type x1))) ;; ===== Dependent types ===== ;; From ca4dc6d1e539b3b55331890c112dc175f19dbb30 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 9 Oct 2018 21:10:23 -0600 Subject: [PATCH 476/810] Fix type extraction --- src-untyped/quantum/untyped/core/type/defnt.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 236a715b..68cd3713 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -435,7 +435,7 @@ (->> (uana/analyze-arg-syms {} (zipmap arg-bindings arg-types|form) output-type|form) (c/map (fn [{:keys [env out-type-node]}] (let [output-type (:type out-type-node) - arg-types (->> arg-bindings (mapv #(get env %)))] + arg-types (->> arg-bindings (mapv #(:type (get env %))))] (when (and ;; TODO excise clause when we default `output-type|form` to `?` (not (identical? output-type|form fn|output-type|form)) (not (t/<= output-type fn|output-type))) From b75f3d2f6a256f8c9f946ce76c0a2346ee0d331e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 9 Oct 2018 21:10:32 -0600 Subject: [PATCH 477/810] Fix cyclic dep --- src-untyped/quantum/untyped/core/vars.cljc | 22 ++++++++++------------ 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/src-untyped/quantum/untyped/core/vars.cljc b/src-untyped/quantum/untyped/core/vars.cljc index 37fa2b52..a67400c0 100644 --- a/src-untyped/quantum/untyped/core/vars.cljc +++ b/src-untyped/quantum/untyped/core/vars.cljc @@ -4,8 +4,6 @@ (:require [clojure.core :as core] [quantum.untyped.core.core :as ucore] - [quantum.untyped.core.logic - :refer [ifs]] [quantum.untyped.core.form.evaluate :refer [case-env case-env*]] [quantum.untyped.core.form.generate :as ufgen]) @@ -124,13 +122,13 @@ (when-let [sym-ns-val (resolve-ns sym)] (.findInternedVar ^clojure.lang.Namespace sym-ns-val (-> sym name symbol))) (let [^String sym-name (name sym)] - (ifs (or (and (pos? (.indexOf sym-name ".")) - (not (.endsWith sym-name "."))) - (= (.charAt sym-name 0) \[)) - (try (clojure.lang.RT/classForName sym-name) - (catch ClassNotFoundException _ nil)) - (= sym 'ns) - #'core/ns - (= sym 'in-ns) - #'core/in-ns - (.getMapping ^clojure.lang.Namespace ns-val sym))))))) + (cond (or (and (pos? (.indexOf sym-name ".")) + (not (.endsWith sym-name "."))) + (= (.charAt sym-name 0) \[)) + (try (clojure.lang.RT/classForName sym-name) + (catch ClassNotFoundException _ nil)) + (= sym 'ns) + #'core/ns + (= sym 'in-ns) + #'core/in-ns + :else (.getMapping ^clojure.lang.Namespace ns-val sym))))))) From 10c31f4d214d107c133db5a338c2317c54cb9925 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 9 Oct 2018 21:10:42 -0600 Subject: [PATCH 478/810] Begin to do second test --- .../quantum/test/untyped/core/type/defnt.cljc | 122 ++++++++++++------ 1 file changed, 79 insertions(+), 43 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 47904a5e..805d532f 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -33,9 +33,17 @@ (do (require '[orchestra.spec.test :as st]) (orchestra.spec.test/instrument)) +(defn B [form] (tag "boolean" form)) +(defn Y [form] (tag "byte" form)) +(defn S [form] (tag "short" form)) +(defn C [form] (tag "char" form)) +(defn I [form] (tag "int" form)) +(defn L [form] (tag "long" form)) +(defn F [form] (tag "float" form)) +(defn D [form] (tag "double" form)) (defn O [form] (tag "java.lang.Object" form)) (defn O<> [form] (tag "[Ljava.lang.Object;" form)) -(defn STR [form] (tag "java.lang.String" form)) +(defn ST [form] (tag "java.lang.String" form)) #?(:clj (deftest test|pid @@ -50,14 +58,14 @@ (def ~'pid|test|__0 (reify* [>Object] (~(O 'invoke) [~'_0__] - ~(STR (list '. - (tag "java.lang.management.RuntimeMXBean" - '(. java.lang.management.ManagementFactory getRuntimeMXBean)) - 'getName))))) + ~(ST (list '. + (tag "java.lang.management.RuntimeMXBean" + '(. java.lang.management.ManagementFactory getRuntimeMXBean)) + 'getName))))) (defn ~'pid|test {:quantum.core.type/type (t/ftype t/any? [:> (t/or (t/value nil) (t/isa? String))])} - ([] (. ~(tag (str `>Object) 'pid|test|__0|0) invoke)))))] + ([] (. ~(tag (str `>Object) 'pid|test|__0) ~'invoke)))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) @@ -73,42 +81,70 @@ expected (case (env-lang) :clj - ($ (do ;; [x t/any?] + ($ (do (declare ~'identity|uninlined) - (def ~(O<> 'identity|uninlined|__0|input0|types) - (*<> t/any?)) - ;; One `reify` because `t/any?` in CLJ does not have any `t/or`-separability - (def ~'identity|uninlined|__0|0 - (reify* [Object>Object boolean>boolean byte>byte short>short char>char - int>int long>long float>float double>double] - (~(tag "java.lang.Object" 'invoke) - [~'_0__ ~(tag "java.lang.Object" 'x)] ~(O 'x)) - (~(tag "boolean" 'invoke) - [~'_1__ ~(tag "boolean" 'x)] ~'x) - (~(tag "byte" 'invoke) - [~'_2__ ~(tag "byte" 'x)] ~'x) - (~(tag "short" 'invoke) - [~'_3__ ~(tag "short" 'x)] ~'x) - (~(tag "char" 'invoke) - [~'_4__ ~(tag "char" 'x)] ~'x) - (~(tag "int" 'invoke) - [~'_5__ ~(tag "int" 'x)] ~'x) - (~(tag "long" 'invoke) - [~'_6__ ~(tag "long" 'x)] ~'x) - (~(tag "float" 'invoke) - [~'_7__ ~(tag "float" 'x)] ~'x) - (~(tag "double" 'invoke) - [~'_8__ ~(tag "double" 'x)] ~'x))) + ;; [x t/any?] + + (def ~(O<> 'identity|uninlined|__0|types) (*<> (t/isa? Boolean))) + (def ~'identity|uninlined|__0 + (reify* [boolean>boolean] (~(B 'invoke) [~'_0__ ~(B 'x)] ~'x))) + (def ~(O<> 'identity|uninlined|__1|types) (*<> (t/isa? Byte))) + (def ~'identity|uninlined|__1 + (reify* [byte>byte] (~(Y 'invoke) [~'_1__ ~(Y 'x)] ~'x))) + (def ~(O<> 'identity|uninlined|__2|types) (*<> (t/isa? Short))) + (def ~'identity|uninlined|__2 + (reify* [short>short] (~(S 'invoke) [~'_2__ ~(S 'x)] ~'x))) + (def ~(O<> 'identity|uninlined|__3|types) (*<> (t/isa? Character))) + (def ~'identity|uninlined|__3 + (reify* [char>char] (~(C 'invoke) [~'_3__ ~(C 'x)] ~'x))) + (def ~(O<> 'identity|uninlined|__4|types) (*<> (t/isa? Integer))) + (def ~'identity|uninlined|__4 + (reify* [int>int] (~(I 'invoke) [~'_4__ ~(I 'x)] ~'x))) + (def ~(O<> 'identity|uninlined|__5|types) (*<> (t/isa? Long))) + (def ~'identity|uninlined|__5 + (reify* [long>long] (~(L 'invoke) [~'_5__ ~(L 'x)] ~'x))) + (def ~(O<> 'identity|uninlined|__6|types) (*<> (t/isa? Float))) + (def ~'identity|uninlined|__6 + (reify* [float>float] (~(F 'invoke) [~'_6__ ~(F 'x)] ~'x))) + (def ~(O<> 'identity|uninlined|__7|types) (*<> (t/isa? Double))) + (def ~'identity|uninlined|__7 + (reify* [double>double] (~(D 'invoke) [~'_7__ ~(D 'x)] ~'x))) + (def ~(O<> 'identity|uninlined|__8|types) (*<> t/any?)) + (def ~'identity|uninlined|__8 + (reify* [Object>Object] (~(O 'invoke) [~'_8__ ~(O 'x)] ~(O 'x)))) (defn ~'identity|uninlined - {:quantum.core.type/type (t/fn t/any? ~'[t/any?])} - ([~'x00__] - ;; TODO elide check because `t/any?` doesn't require a check - ;; and all args are `t/=` `t/any?` - (ifs ((Array/get ~'identity|uninlined|__0|input0|types 0) ~'x00__) - (.invoke ~(tag (str `Object>Object) - 'identity|uninlined|__0|0) ~'x00__) - (unsupported! `identity|uninlined [~'x00__] 0)))))) + {:quantum.core.type/type + (t/ftype t/any? [(t/isa? Boolean) :> (t/isa? Boolean)] + [(t/isa? Byte) :> (t/isa? Byte)] + [(t/isa? Short) :> (t/isa? Short)] + [(t/isa? Character) :> (t/isa? Character)] + [(t/isa? Integer) :> (t/isa? Integer)] + [(t/isa? Long) :> (t/isa? Long)] + [(t/isa? Float) :> (t/isa? Float)] + [(t/isa? Double) :> (t/isa? Double)] + [t/any? :> t/any?])} + ([~'x00__] + (ifs ((Array/get ~'identity|uninlined|__0|types 0) ~'x00__) + (. ~(tag (str `boolean>boolean) 'identity|uninlined|__0) ~'invoke ~'x00__) + ((Array/get ~'identity|uninlined|__1|types 0) ~'x00__) + (. ~(tag (str `byte>byte) 'identity|uninlined|__1) ~'invoke ~'x00__) + ((Array/get ~'identity|uninlined|__2|types 0) ~'x00__) + (. ~(tag (str `short>short) 'identity|uninlined|__2) ~'invoke ~'x00__) + ((Array/get ~'identity|uninlined|__3|types 0) ~'x00__) + (. ~(tag (str `char>char) 'identity|uninlined|__3) ~'invoke ~'x00__) + ((Array/get ~'identity|uninlined|__4|types 0) ~'x00__) + (. ~(tag (str `int>int) 'identity|uninlined|__4) ~'invoke ~'x00__) + ((Array/get ~'identity|uninlined|__5|types 0) ~'x00__) + (. ~(tag (str `long>long) 'identity|uninlined|__5) ~'invoke ~'x00__) + ((Array/get ~'identity|uninlined|__6|types 0) ~'x00__) + (. ~(tag (str `float>float) 'identity|uninlined|__6) ~'invoke ~'x00__) + ((Array/get ~'identity|uninlined|__7|types 0) ~'x00__) + (. ~(tag (str `double>double) 'identity|uninlined|__7) ~'invoke ~'x00__) + ((Array/get ~'identity|uninlined|__8|types 0) ~'x00__) + (. ~(tag (str `Object>Object) 'identity|uninlined|__8) ~'invoke ~'x00__) + ;; TODO no need for `unsupported!` because it will always get a valid branch + (unsupported! `identity|uninlined [~'x00__] 0)))))) :cljs ;; Direct dispatch will be simple functions, not `reify`s ($ (do (defn ~'identity|uninlined [~'x] ~'x))))] @@ -139,7 +175,7 @@ (def ~'name|test|__0|0 (reify* [Object>Object] (~(O 'invoke) [~'_0__ ~(O 'x)] - (let* [~(STR 'x) ~'x] ~(STR 'x))))) + (let* [~(ST 'x) ~'x] ~(ST 'x))))) ;; [(t/isa? Named)] @@ -149,7 +185,7 @@ (reify* [Object>Object] (~(O 'invoke) [~'_1__ ~(O 'x)] (let* [~(tag "clojure.lang.Named" 'x) ~'x] - (t/validate ~(STR '(. x getName)) + (t/validate ~(ST '(. x getName)) ~'(* t/string?)))))) (defn ~'name|test @@ -1239,9 +1275,9 @@ (def ~'!str|__1|0 (reify* [Object>Object] (~(O 'invoke) [~'_1__ ~(O 'x)] - (let* [~(Str 'x) ~'x] + (let* [~(ST 'x) ~'x] ~(tag "java.lang.StringBuilder" - (list 'new 'StringBuilder (STR 'x))))))) + (list 'new 'StringBuilder (ST 'x))))))) (def ~(O<> '!str|__2|input0|types) (*<> (t/isa? java.lang.CharSequence) From 8cd55636c034ae655d1196ca970d1b67dfececbe Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 9 Oct 2018 21:33:30 -0600 Subject: [PATCH 479/810] Second test passes! --- src-untyped/quantum/untyped/core/analyze.cljc | 16 ++++++---------- test/quantum/test/untyped/core/type/defnt.cljc | 2 +- 2 files changed, 7 insertions(+), 11 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index fc16426f..2d886df8 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -632,12 +632,6 @@ (get inputs-ct)))}))) :dispatchable-overloads-seq)) -(defn- dependent-type-call-node? [x] - (and (uast/call-node? x) - (case (-> x :unanalyzed-form first) - (quantum.core.type/type quantum.untyped.core.type/type) true - false))) - (defns- analyze-seq|dependent-type-call [env ::env, [caller|form _, arg-form _ & extra-args-form _ :as form] _ > uast/node?] (if (not (empty? extra-args-form)) @@ -755,10 +749,12 @@ var (analyze-seq|var env form) (if (-> env :opts :arglist-context?) (if-let [caller-form-dependent-type-call? - (case caller|form - (quantum.core.type/type - quantum.untyped.core.type/type) true - false)] + (and (symbol? caller|form) + (when-let [sym (some-> (uvar/resolve *ns* caller|form) uid/>symbol)] + (case sym + (quantum.core.type/type + quantum.untyped.core.type/type) true + false)))] (analyze-seq|dependent-type-call env form) (analyze-seq|call env form)) (analyze-seq|call env form)))) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 805d532f..38a92e96 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -77,7 +77,7 @@ (deftest test|identity|uninlined (let [actual (macroexpand ' - (self/defn identity|uninlined ([x t/any?] x))) + (self/defn identity|uninlined ([x t/any? > (t/type x)] x))) expected (case (env-lang) :clj From 6b9486bc772124276ddae473f254a5376195a3b4 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 9 Oct 2018 23:21:48 -0600 Subject: [PATCH 480/810] Another test passes! --- resources-dev/defnt.cljc | 2 + src-untyped/quantum/untyped/core/analyze.cljc | 1 + src-untyped/quantum/untyped/core/test.cljc | 2 + .../untyped/core/type/reifications.cljc | 65 ++++++++++----- .../quantum/test/untyped/core/type/defnt.cljc | 81 +++++++++---------- 5 files changed, 85 insertions(+), 66 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 64b3f3b8..d001c1de 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -92,6 +92,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative ([n dn/std-integer?, xs ?] ...) - (comp/t== x) - dependent type such that the passed input must be identical to x + - `(t/validate x (t/* t/string?))` for `(t/* t/string?)` needs to be more performant + - Don't re-create type on each call - Type Logic and Predicates - We should probably have a 'normal form' so we can correctly hash if we do spec lookup - t/- : fix diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 2d886df8..d2f2619d 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -666,6 +666,7 @@ (t/value t/or) (apply-arg-type-combine t/or input-nodes) (t/value t/and) (apply-arg-type-combine t/and input-nodes) (t/value t/?) (apply-arg-type-combine t/? input-nodes) + (t/value t/*) (apply-arg-type-combine t/* input-nodes) out-type)) (defns- analyze-seq|call diff --git a/src-untyped/quantum/untyped/core/test.cljc b/src-untyped/quantum/untyped/core/test.cljc index 6a4a95d7..e0983504 100644 --- a/src-untyped/quantum/untyped/core/test.cljc +++ b/src-untyped/quantum/untyped/core/test.cljc @@ -27,6 +27,8 @@ (defn test-nss-where [pred] (->> (all-ns) (filter #(-> % ns-name name pred)) (map test-ns) doall))) +(declare code=) + (defn- code=|similar-class [c0 c1] (let [similar-class? (cond (seq? c0) (seq? c1) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index cba02022..7d4ea16c 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -26,7 +26,17 @@ (defprotocol PType) -(defns type? [x _ > boolean?] (satisfies? PType x)) +(defn type? [x #_> #_boolean?] (satisfies? PType x)) + +(defn- accounting-for-meta [t meta-] + (if meta- + (cond->> (with-meta t + (dissoc meta- + :quantum.core.type/assume? :quantum.core.type/ref? :quantum.core.type/runtime?)) + (:quantum.core.type/assume? meta-) (list 'quantum.untyped.core.type/assume) + (:quantum.core.type/ref? meta-) (list 'quantum.untyped.core.type/ref) + (:quantum.core.type/runtime? meta-) (list 'quantum.untyped.core.type/*)) + t)) ;; Here `c/=` tests for structural equivalence @@ -43,9 +53,10 @@ ?Hash {hash ([this] (hash UniversalSetType))} ?Object {hash-code ([this] (uhash/code UniversalSetType)) equals ([this that] (or (== this that) (instance? UniversalSetType that)))} - uform/PGenForm {>form ([this] 'quantum.untyped.core.type/any?)} + uform/PGenForm {>form ([this] (-> 'quantum.untyped.core.type/any? + (accounting-for-meta meta)))} fedn/IOverride nil - fedn/IEdn {-edn ([this] 'quantum.untyped.core.type/U)}}) + fedn/IEdn {-edn ([this] (>form this))}}) (def universal-set (UniversalSetType. nil)) @@ -62,9 +73,10 @@ ?Hash {hash ([this] (hash EmptySetType))} ?Object {hash-code ([this] (uhash/code EmptySetType)) equals ([this that] (or (== this that) (instance? EmptySetType that)))} - uform/PGenForm {>form ([this] 'quantum.untyped.core.type/none?)} + uform/PGenForm {>form ([this] (-> 'quantum.untyped.core.type/none? + (accounting-for-meta meta)))} fedn/IOverride nil - fedn/IEdn {-edn ([this] 'quantum.untyped.core.type/∅)}}) + fedn/IEdn {-edn ([this] (>form this))}}) (def empty-set (EmptySetType. nil)) @@ -85,7 +97,8 @@ (or (== this that) (and (instance? NotType that) (= t (.-t ^NotType that)))))} - uform/PGenForm {>form ([this] (list 'quantum.untyped.core.type/not (>form t)))} + uform/PGenForm {>form ([this] (-> (list 'quantum.untyped.core.type/not (>form t)) + (accounting-for-meta meta)))} fedn/IOverride nil fedn/IEdn {-edn ([this] (>form this))}}) @@ -116,7 +129,8 @@ (or (== this that) (and (instance? OrType that) (= args (.-args ^OrType that)))))} - uform/PGenForm {>form ([this] (list* 'quantum.untyped.core.type/or (map >form args)))} + uform/PGenForm {>form ([this] (-> (list* 'quantum.untyped.core.type/or (map >form args)) + (accounting-for-meta meta)))} fedn/IOverride nil fedn/IEdn {-edn ([this] (>form this))}}) @@ -145,7 +159,8 @@ (or (== this that) (and (instance? AndType that) (= args (.-args ^AndType that)))))} - uform/PGenForm {>form ([this] (list* 'quantum.untyped.core.type/and (map >form args)))} + uform/PGenForm {>form ([this] (-> (list* 'quantum.untyped.core.type/and (map >form args)) + (accounting-for-meta meta)))} fedn/IOverride nil fedn/IEdn {-edn ([this] (>form this))}}) @@ -175,11 +190,12 @@ (or (== this that) (and (instance? ProtocolType that) (= p (.-p ^ProtocolType that)))))} - uform/PGenForm {>form ([this] (with-meta - (list 'quantum.untyped.core.type/isa?|protocol (:on p)) - meta))} + uform/PGenForm {>form ([this] (-> (list 'quantum.untyped.core.type/isa?|protocol (:on p)) + (accounting-for-meta meta)))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (or name (>form this)))}}) + fedn/IEdn {-edn ([this] (if name + (-> name (accounting-for-meta meta)) + (>form this)))}}) (defns protocol-type? [x _] (instance? ProtocolType x)) @@ -207,11 +223,12 @@ (or (== this that) (and (instance? ProtocolType that) (= p (.-p ^ProtocolType that)))))} - uform/PGenForm {>form ([this] (with-meta - (list 'quantum.untyped.core.type/isa?|protocol (:on p)) - meta))} + uform/PGenForm {>form ([this] (-> (list 'quantum.untyped.core.type/isa?|protocol (:on p)) + (accounting-for-meta meta)))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (or name (>form this)))}})) + fedn/IEdn {-edn ([this] (if name + (-> name (accounting-for-meta meta)) + (>form this)))}})) #?(:cljs (defns direct-protocol-type? [x _] (instance? DirectProtocolType x))) @@ -235,10 +252,12 @@ (or (== this that) (and (instance? ClassType that) (= c (.-c ^ClassType that)))))} - uform/PGenForm {>form ([this] - (with-meta (list 'quantum.untyped.core.type/isa? (>form c)) meta))} + uform/PGenForm {>form ([this] (-> (list 'quantum.untyped.core.type/isa? (>form c)) + (accounting-for-meta meta)))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (or name (>form this)))}}) + fedn/IEdn {-edn ([this] (if name + (-> name (accounting-for-meta meta)) + (>form this)))}}) (defns class-type? [x _] (instance? ClassType x)) @@ -261,7 +280,8 @@ (or (== this that) (and (instance? ValueType that) (= v (.-v ^ValueType that)))))} - uform/PGenForm {>form ([this] (list 'quantum.untyped.core.type/value (>form v)))} + uform/PGenForm {>form ([this] (-> (list 'quantum.untyped.core.type/value (>form v)) + (accounting-for-meta meta)))} fedn/IOverride nil fedn/IEdn {-edn ([this] (>form this))}}) @@ -282,8 +302,9 @@ ?Fn {invoke ([this args] (TODO))} ?Meta {meta ([this] meta) with-meta ([this meta'] (FnType. meta' name out-type arities-form arities))} - uform/PGenForm {>form ([this] (list* 'quantum.untyped.core.type/ftype - (>form out-type) (>form arities-form)))} + uform/PGenForm {>form ([this] (-> (list* 'quantum.untyped.core.type/ftype + (>form out-type) (>form arities-form)) + (accounting-for-meta meta)))} fedn/IOverride nil fedn/IEdn {-edn ([this] (>form this))}}) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 38a92e96..f70e7823 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1,9 +1,8 @@ -;; See https://jsperf.com/js-property-access-comparison — all property accesses (at least of length 1) seem to be equal - (ns quantum.test.untyped.core.type.defnt (:refer-clojure :exclude - [* count get seq]) + [count get name seq]) (:require + [clojure.core :as core] [quantum.test.untyped.core.type :as tt] [quantum.untyped.core.type.defnt :as self :refer [fnt unsupported!]] @@ -21,7 +20,7 @@ [quantum.untyped.core.test :as utest :refer [deftest is is= is-code= testing throws]] [quantum.untyped.core.type :as t - :refer [? *]] + :refer [?]] [quantum.untyped.core.type.reifications :as utr]) (:import [clojure.lang ASeq ISeq LazySeq Named Reduced Seqable] @@ -157,66 +156,60 @@ (deftest test|name (let [actual (macroexpand ' - (self/defn #_:inline name|test > t/string? + (self/defn #_:inline name > t/string? ([x t/string?] x) - #?(:clj ([x (t/isa? Named) > (* t/string?)] (.getName x)) - :cljs ([x (t/isa? INamed) > (* t/string?)] (-name x))))) + #?(:clj ([x (t/isa? Named) > (t/* t/string?)] (.getName x)) + :cljs ([x (t/isa? INamed) > (t/* t/string?)] (-name x))))) expected (case (env-lang) :clj - ($ (do ;; Only direct dispatch for prims or for Object, not for subclasses of Object - ;; Return value can be primitive; in this case it's not - ;; The macro in a typed context will find the right dispatch at compile time + ($ (do (declare ~'name) - ;; [t/string?] + ;; [x t/string?] - (def ~(O<> 'name|test|__0|input0|types) + (def ~(O<> 'name|__0|types) (*<> (t/isa? java.lang.String))) - (def ~'name|test|__0|0 + (def ~'name|__0 (reify* [Object>Object] - (~(O 'invoke) [~'_0__ ~(O 'x)] - (let* [~(ST 'x) ~'x] ~(ST 'x))))) + (~(O 'invoke) [~'_0__ ~(O 'x)] ~(ST 'x)))) - ;; [(t/isa? Named)] + ;; [x (t/isa? Named)] > (t/* t/string?) - (def ~(O<> 'name|test|__1|input0|types) + (def ~(O<> 'name|__1|types) (*<> (t/isa? Named))) - (def ~'name|test|__1|0 + (def ~'name|__1 (reify* [Object>Object] (~(O 'invoke) [~'_1__ ~(O 'x)] - (let* [~(tag "clojure.lang.Named" 'x) ~'x] - (t/validate ~(ST '(. x getName)) - ~'(* t/string?)))))) + (t/validate ~(ST (list '. (tag "clojure.lang.Named" 'x) 'getName)) + ~'(t/* t/string?))))) - (defn ~'name|test + (defn ~'name {:quantum.core.type/type - (t/fn ~'t/string? - ~'[t/string?] - ~'[(t/isa? Named) :> (* t/string?)])} + (t/ftype (t/isa? String) + [(t/isa? String) :> (t/isa? String)] + [(t/isa? Named) :> (t/* (t/isa? String))])} ([~'x00__] - (ifs ((Array/get ~'name|test|__0|input0|types 0) ~'x00__) - (.invoke ~(tag (str `Object>Object) - 'name|test|__0|0) ~'x00__) - ((Array/get ~'name|test|__1|input0|types 0) ~'x00__) - (.invoke ~(tag (str `Object>Object) - 'name|test|__1|0) ~'x00__) - (unsupported! `name|test [~'x00__] 0)))))) + (ifs ((Array/get ~'name|__0|types 0) ~'x00__) + (. ~(tag (str `Object>Object) 'name|__0) ~'invoke ~'x00__) + ((Array/get ~'name|__1|types 0) ~'x00__) + (. ~(tag (str `Object>Object) 'name|__1) ~'invoke ~'x00__) + (unsupported! `name [~'x00__] 0)))))) :cljs - ($ (do (defn ~'name|test [~'x00__] + ($ (do (defn ~'name [~'x00__] (ifs (t/string? x) x (satisfies? INamed x) (-name x) - (unsupported! `name|test [~'x00__] 0))))))] + (unsupported! `name [~'x00__] 0))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) - (eval '(do (is= (name|test "") (name "")) - (is= (name|test "abc") (name "abc")) - (is= (name|test :abc) (name :abc)) - (is= (name|test 'abc) (name 'abc)) - (is= (name|test :abc/def) (name :abc/def)) - (is= (name|test 'abc/def) (name 'abc/def)) - (throws (name|test nil)) - (throws (name|test 1))))))) + (eval '(do (is= (name "") (core/name "")) + (is= (name "abc") (core/name "abc")) + (is= (name :abc) (core/name :abc)) + (is= (name 'abc) (core/name 'abc)) + (is= (name :abc/def) (core/name :abc/def)) + (is= (name 'abc/def) (core/name 'abc/def)) + (throws (name nil)) + (throws (name 1))))))) (deftest test|some? (let [actual @@ -1034,7 +1027,7 @@ (testing "code equivalence" (is-code= actual expected))))) (self/defn >big-integer > (t/isa? java.math.BigInteger) - ([x tt/ratio? > (* (t/isa? java.math.BigInteger))] (.bigIntegerValue x))) + ([x tt/ratio? > (t/* (t/isa? java.math.BigInteger))] (.bigIntegerValue x))) ;; NOTE would use `>long` but that's already an interface (deftest test|>long-checked @@ -1764,7 +1757,7 @@ ([] "") ([x t/nil?] "") ;; could have inferred but there may be other objects who have overridden .toString - #?(#_:clj #_([x (t/isa? Object) > (* t/string?)] (.toString x)) + #?(#_:clj #_([x (t/isa? Object) > (t/* t/string?)] (.toString x)) ;; Can't infer that it returns a string (without a pre-constructed list of built-in fns) ;; As such, must explicitly mark :cljs ([x t/any? > (t/assume t/string?)] (.join #js [x] ""))) From 324357d01f6c8f474ead01a41489fa8abf807646 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 9 Oct 2018 23:39:07 -0600 Subject: [PATCH 481/810] Another test passes! --- .../quantum/test/untyped/core/type/defnt.cljc | 134 +++++++++++------- 1 file changed, 80 insertions(+), 54 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index f70e7823..cacf4519 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1,6 +1,6 @@ (ns quantum.test.untyped.core.type.defnt (:refer-clojure :exclude - [count get name seq]) + [count get name seq some?]) (:require [clojure.core :as core] [quantum.test.untyped.core.type :as tt] @@ -167,16 +167,14 @@ ;; [x t/string?] - (def ~(O<> 'name|__0|types) - (*<> (t/isa? java.lang.String))) + (def ~(O<> 'name|__0|types) (*<> (t/isa? java.lang.String))) (def ~'name|__0 (reify* [Object>Object] (~(O 'invoke) [~'_0__ ~(O 'x)] ~(ST 'x)))) ;; [x (t/isa? Named)] > (t/* t/string?) - (def ~(O<> 'name|__1|types) - (*<> (t/isa? Named))) + (def ~(O<> 'name|__1|types) (*<> (t/isa? Named))) (def ~'name|__1 (reify* [Object>Object] (~(O 'invoke) [~'_1__ ~(O 'x)] @@ -215,62 +213,90 @@ (let [actual ;; Perhaps silly in ClojureScript, but avoids boxing in Clojure (macroexpand ' - (self/defn #_:inline some?|test + (self/defn #_:inline some? > t/boolean? ([x t/nil?] false) ;; Implicitly, `(- t/any? t/nil?)`, so `t/val?` ([x t/any?] true))) expected - (case (env-lang) - :clj - ($ (do ;; [x t/nil?] - - (def ~(O<> 'some?|test|__0|input0|types) - (*<> (t/value nil))) - (def ~'some?|test|__0|0 - (reify* [Object>boolean] - (~(tag "boolean" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] false))) - - ;; [x t/any?] - - (def ~(O<> 'some?|test|__1|input0|types) - (*<> t/any?)) - (def ~'some?|test|__1|0 - (reify* [Object>boolean boolean>boolean byte>boolean short>boolean - char>boolean int>boolean long>boolean float>boolean double>boolean] - (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] true) - (~(tag "boolean" 'invoke) [~'_2__ ~(tag "boolean" 'x)] true) - (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'x)] true) - (~(tag "boolean" 'invoke) [~'_4__ ~(tag "short" 'x)] true) - (~(tag "boolean" 'invoke) [~'_5__ ~(tag "char" 'x)] true) - (~(tag "boolean" 'invoke) [~'_6__ ~(tag "int" 'x)] true) - (~(tag "boolean" 'invoke) [~'_7__ ~(tag "long" 'x)] true) - (~(tag "boolean" 'invoke) [~'_8__ ~(tag "float" 'x)] true) - (~(tag "boolean" 'invoke) [~'_9__ ~(tag "double" 'x)] true))) - - (defn ~'some?|test - {:quantum.core.type/type - (t/fn t/any? - ~'[t/nil?] - ~'[t/any?])} - ([~'x00__] - (ifs ((Array/get ~'some?|test|__0|input0|types 0) ~'x00__) - (.invoke ~(tag (str `Object>boolean) 'some?|test|__0|0) ~'x00__) - ;; TODO eliminate this check because it's not needed (`t/any?`) - ((Array/get ~'some?|test|__1|input0|types 0) ~'x00__) - (.invoke ~(tag (str `Object>boolean) 'some?|test|__1|0) ~'x00__) - (unsupported! `some?|test [~'x00__] 0)))))) - :cljs - ($ (do (defn ~'some?|test [~'x] - (ifs (nil? x) false - true)))))] + (case (env-lang) + :clj + ($ (do (declare ~'some?) + + ;; [x t/nil?] + + (def ~(O<> 'some?|__0|types) (*<> (t/value nil))) + (def ~'some?|__0 + (reify* [Object>boolean] (~(B 'invoke) [~'_0__ ~(O 'x)] false))) + + ;; [x t/any?] + + (def ~(O<> 'some?|__1|types) (*<> (t/isa? Boolean))) + (def ~'some?|__1 (reify* [boolean>boolean] (~(B 'invoke) [~'_1__ ~(B 'x)] true))) + (def ~(O<> 'some?|__2|types) (*<> (t/isa? Byte))) + (def ~'some?|__2 (reify* [byte>boolean] (~(B 'invoke) [~'_2__ ~(Y 'x)] true))) + (def ~(O<> 'some?|__3|types) (*<> (t/isa? Short))) + (def ~'some?|__3 (reify* [short>boolean] (~(B 'invoke) [~'_3__ ~(S 'x)] true))) + (def ~(O<> 'some?|__4|types) (*<> (t/isa? Character))) + (def ~'some?|__4 (reify* [char>boolean] (~(B 'invoke) [~'_4__ ~(C 'x)] true))) + (def ~(O<> 'some?|__5|types) (*<> (t/isa? Integer))) + (def ~'some?|__5 (reify* [int>boolean] (~(B 'invoke) [~'_5__ ~(I 'x)] true))) + (def ~(O<> 'some?|__6|types) (*<> (t/isa? Long))) + (def ~'some?|__6 (reify* [long>boolean] (~(B 'invoke) [~'_6__ ~(L 'x)] true))) + (def ~(O<> 'some?|__7|types) (*<> (t/isa? Float))) + (def ~'some?|__7 (reify* [float>boolean] (~(B 'invoke) [~'_7__ ~(F 'x)] true))) + (def ~(O<> 'some?|__8|types) (*<> (t/isa? Double))) + (def ~'some?|__8 (reify* [double>boolean] (~(B 'invoke) [~'_8__ ~(D 'x)] true))) + (def ~(O<> 'some?|__9|types) (*<> t/any?)) + (def ~'some?|__9 (reify* [Object>boolean] (~(B 'invoke) [~'_9__ ~(O 'x)] true))) + + (defn ~'some? + {:quantum.core.type/type + (t/ftype (t/isa? Boolean) + [(t/value nil) :> (t/isa? Boolean)] + [(t/isa? Boolean) :> (t/isa? Boolean)] + [(t/isa? Byte) :> (t/isa? Boolean)] + [(t/isa? Short) :> (t/isa? Boolean)] + [(t/isa? Character) :> (t/isa? Boolean)] + [(t/isa? Integer) :> (t/isa? Boolean)] + [(t/isa? Long) :> (t/isa? Boolean)] + [(t/isa? Float) :> (t/isa? Boolean)] + [(t/isa? Double) :> (t/isa? Boolean)] + [t/any? :> (t/isa? Boolean)])} + ([~'x00__] + (ifs ((Array/get ~'some?|__0|types 0) ~'x00__) + (. ~(tag (str `Object>boolean) 'some?|__0) ~'invoke ~'x00__) + ;; TODO eliminate these checks below because they're not needed + ((Array/get ~'some?|__1|types 0) ~'x00__) + (. ~(tag (str `boolean>boolean) 'some?|__1) ~'invoke ~'x00__) + ((Array/get ~'some?|__2|types 0) ~'x00__) + (. ~(tag (str `byte>boolean) 'some?|__2) ~'invoke ~'x00__) + ((Array/get ~'some?|__3|types 0) ~'x00__) + (. ~(tag (str `short>boolean) 'some?|__3) ~'invoke ~'x00__) + ((Array/get ~'some?|__4|types 0) ~'x00__) + (. ~(tag (str `char>boolean) 'some?|__4) ~'invoke ~'x00__) + ((Array/get ~'some?|__5|types 0) ~'x00__) + (. ~(tag (str `int>boolean) 'some?|__5) ~'invoke ~'x00__) + ((Array/get ~'some?|__6|types 0) ~'x00__) + (. ~(tag (str `long>boolean) 'some?|__6) ~'invoke ~'x00__) + ((Array/get ~'some?|__7|types 0) ~'x00__) + (. ~(tag (str `float>boolean) 'some?|__7) ~'invoke ~'x00__) + ((Array/get ~'some?|__8|types 0) ~'x00__) + (. ~(tag (str `double>boolean) 'some?|__8) ~'invoke ~'x00__) + ((Array/get ~'some?|__9|types 0) ~'x00__) + (. ~(tag (str `Object>boolean) 'some?|__9) ~'invoke ~'x00__) + (unsupported! `some? [~'x00__] 0)))))) + :cljs + ($ (do (defn ~'some?| [~'x] + (ifs (nil? x) false + true)))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) - (eval '(do (throws (some?|test)) - (is= (some?|test 123) (some? 123)) - (is= (some?|test true) (some? true)) - (is= (some?|test false) (some? false)) - (is= (some?|test nil) (some? nil))))))) + (eval '(do (throws (some?)) + (is= (some? 123) (core/some? 123)) + (is= (some? true) (core/some? true)) + (is= (some? false) (core/some? false)) + (is= (some? nil) (core/some? nil))))))) (deftest test|reduced? (let [actual From 9660f9e0985ed79b72aca79754af3300a717bf3f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 10 Oct 2018 00:06:38 -0600 Subject: [PATCH 482/810] Add some more combinator handlers; note failing test --- src-untyped/quantum/untyped/core/analyze.cljc | 13 ++++++++----- src-untyped/quantum/untyped/core/type.cljc | 10 ++++++---- src-untyped/quantum/untyped/core/type/defnt.cljc | 4 +++- test/quantum/test/untyped/core/analyze.cljc | 11 ++++++++++- test/quantum/test/untyped/core/type/defnt.cljc | 14 ++++++-------- 5 files changed, 33 insertions(+), 19 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index d2f2619d..4c24070a 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -662,11 +662,14 @@ (defns- handle-type-combinators [caller|node uast/node?, input-nodes _, out-type t/type? > t/type?] (condp = (:type caller|node) - (t/value t/isa?) (apply-arg-type-combine t/isa? input-nodes) - (t/value t/or) (apply-arg-type-combine t/or input-nodes) - (t/value t/and) (apply-arg-type-combine t/and input-nodes) - (t/value t/?) (apply-arg-type-combine t/? input-nodes) - (t/value t/*) (apply-arg-type-combine t/* input-nodes) + (t/value t/isa?) (apply-arg-type-combine t/isa? input-nodes) + (t/value t/or) (apply-arg-type-combine t/or input-nodes) + (t/value t/and) (apply-arg-type-combine t/and input-nodes) + (t/value t/-) (apply-arg-type-combine t/- input-nodes) + (t/value t/?) (apply-arg-type-combine t/? input-nodes) + (t/value t/*) (apply-arg-type-combine t/* input-nodes) + (t/value t/ref) (apply-arg-type-combine t/ref input-nodes) + (t/value t/assume) (apply-arg-type-combine t/assume input-nodes) out-type)) (defns- analyze-seq|call diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 4cb9a243..29e312a4 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -573,10 +573,12 @@ #?(:clj (defns type>primitive-subtypes [t type? > (us/vec-of type?)] - (->> t type>classes - (uc/mapcat+ class>boxed-subclasses+) - (join #{}) - (uc/map isa?)))) + (if (-> t c/meta :quantum.core.type/ref?) + #{} + (->> t type>classes + (uc/mapcat+ class>boxed-subclasses+) + (join #{}) + (uc/map isa?))))) #?(:clj (defns- -type>?class-value [t utr/type?, type-nilable? c/boolean?] diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 68cd3713..23ed7f7a 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -340,7 +340,9 @@ `(. ~hinted-reify-sym ~reify-method-sym ~@arglist))) ;; TODO spec -(defns unsupported! [name- _ #_t/qualified-symbol?, args _ #_indexed?, i index?] (TODO)) +(defns unsupported! [name- _ #_t/qualified-symbol?, args _ #_indexed?, i index?] + (throw (ex-info "This function is unsupported for the type combination at the argument index." + {:name name- :args args :arg-index i}))) (defns- >combinatoric-seq+ [direct-dispatch-data-seq-for-arity (s/seq-of ::direct-dispatch-data) diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index 9dbb37f7..4ec8548f 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -108,4 +108,13 @@ [{'x tt/float?} tt/float?] [{'x tt/double?} tt/double?] [{'x t/any?} t/any?]] - (transform-ana ana))))) + (transform-ana ana)))) + (testing "Input type dependent on other input type" + (testing "Dependent type is not for first input" + #_"1. Analyze `a` = `tt/byte?` + -> Put `a` in env as `(t/isa? Byte)` + 2. Analyze `b` = `(t/type a)` + -> Put `b` in env as `(t/isa? Byte)`" + (let [ana (self/analyze-arg-syms {'a 'tt/byte?, 'b `(t/type ~'a)} `t/any?)] + (is= [[{'a tt/byte? 'b tt/byte?} t/any?]] + (transform-ana ana)))))) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index cacf4519..e9d9e338 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1,6 +1,6 @@ (ns quantum.test.untyped.core.type.defnt (:refer-clojure :exclude - [count get name seq some?]) + [> count get name seq some?]) (:require [clojure.core :as core] [quantum.test.untyped.core.type :as tt] @@ -542,13 +542,11 @@ (deftest test|> (let [actual (macroexpand ' - (self/defn #_:inline >|test - ;; This is admittedly a place where inference might be nice, but luckily - ;; there are no "sparse" combinations - #?(:clj ([a comparable-primitive? b comparable-primitive? > tt/boolean?] - (Numeric/gt a b)) - :cljs ([a double? b double? > (t/assume tt/boolean?)] - (cljs.core/> a b))))) + (self/defn #_:inline > + #?(:clj ([a tt/comparable-primitive? b tt/comparable-primitive? > tt/boolean?] + (Numeric/gt a b)) + :cljs ([a tt/double? b tt/double? > (t/assume tt/boolean?)] + (cljs.core/> a b))))) expected (case (env-lang) :clj From 5799ed56227111c8a1326e5d4214b2a2650731cb Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 10 Oct 2018 12:01:17 -0600 Subject: [PATCH 483/810] Another test passes! --- resources-dev/defnt.cljc | 17 +- src-untyped/quantum/untyped/core/analyze.cljc | 48 +- test/quantum/test/untyped/core/analyze.cljc | 207 ++- .../quantum/test/untyped/core/type/defnt.cljc | 1381 ++++++----------- 4 files changed, 750 insertions(+), 903 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index d001c1de..4eb5bf62 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -60,12 +60,11 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: [1 .] t/type - - [x] Make sure that (t/type t/boolean?) is not (t/value t/boolean?) but rather t/boolean?. - We need to 'un-`t/value`' it somehow? - - [x] We need to ensure that operators are recognized as such. `t/or` should not return - `t/any?` but rather the `t/or` of its arguments. + - [ ] Get all dependent-type-related tests to pass [2] t/value-of - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` + [ ] - (comp/t== x) + - dependent type such that the passed input must be identical to x [3] - t/input-type - `(t/input-type >namespace :?)` meaning the possible input types to the first input to `>namespace` - `(t/input-type reduce :_ :_ :?)` @@ -74,8 +73,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative [5] - t/extend-defn! - We could just recreate the dispatch every time, in the beginning. It would make for slower compilation but faster execution for dynamic dispatch, and quicker time to use. So whenever - something extends a `t/defn`, the type overloads have to be put in the right place in the dispatch - order. We could find the first place where the inputs are t/<. + something extends a `t/defn`, the type overloads have to be put in the right place in the dispatch order. We could find the first place where the inputs are t/<. - But then you have to trigger a recompilation of everything that depended on that `t/defn` because your input-types and output-types have both gotten bigger. Maybe not on that overload but still. @@ -90,8 +88,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - For this situation: `?` is `(t/- dc/counted?)` ([n dn/std-integer?, xs dc/counted?] (count xs)) ([n dn/std-integer?, xs ?] ...) - - (comp/t== x) - - dependent type such that the passed input must be identical to x - `(t/validate x (t/* t/string?))` for `(t/* t/string?)` needs to be more performant - Don't re-create type on each call - Type Logic and Predicates @@ -159,6 +155,10 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - t/declare - declare-fnt (a way to do protocols/interfaces) - extend-fnt! + - ^:dyn + - `(name (read ...))` fails at compile-time; we want it to at least try at runtime. So instead + we annotate like `(name ^:dyn (read ...))`, meaning figure out at runtime what the out-type of + the call to `(read ...)` is, not, call `name` dynamically. - `t/defn` - Arity elision: if any type in an arity is `t/none?` then elide it and emit a warning - `([x bigint?] x)` @@ -169,6 +169,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - t/extend-defn! - `(t/extend-defn! id/>name (^:inline [x namespace?] (-> x .getName id/>name)))` - ^:inline + - Applicable only if in a typed context and not used as a function - if you do (Numeric/bitAnd a b) inline then bitAnd needs to know the primitive type so maybe we do the `let*`-binding approach to typing vars? - should be able to be per-arity like so: diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 4c24070a..d160a619 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -793,7 +793,16 @@ "Analyzes vars as if their value is constant, unless they're marked as dynamic." [env ::env, form symbol? > uast/symbol?] (if-not-let [{:keys [resolved resolved-via]} (?resolve env form)] - (err! "Could not resolve symbol" {:sym form}) + ;; Handles forward dependent-type dependencies e.g. `[a (type b) b t/any?]` + (l/if-let [_ (-> env :opts :arglist-context?) + arg-type-form (-> env :opts :arg-sym->arg-type-form (get form))] + (TODO) + #_(let [_ (pr! (:opts env)) + env' (update-in env [:opts :arglist-syms|queue] conj form) + analyzed (analyze* env' arg-type-form)] + (pr! analyzed) + (TODO)) + (err! "Could not resolve symbol" {:sym form})) (let [node (case resolved-via (:env :dot) resolved :resolve @@ -827,12 +836,6 @@ (analyze-seq env form) (throw (ex-info "Unrecognized form" {:form form})))) -;; ===== Dependent types functionality ===== ;; - - - -;; ===== End dependent types functionality ===== ;; - (defns analyze "`env` consists of a map from simple symbol to `uast/node?`, with one exception: `env` admits one optional key that is not a symbol: `:opts`. The reason `:opts` exists on the `env` map is that @@ -893,6 +896,14 @@ (utr/or-type>args t) [t])) +(defns type>split+primitivized [t t/type? > (s/vec-of t/type?)] + (let [primitive-subtypes + (->> t + t/type>primitive-subtypes + (sort-by sort-guide) ; For cleanliness and reproducibility in tests + vec)] + (uc/distinct (join primitive-subtypes (type>split t))))) + (defn- analyze-arg-syms* [env #_::env arg-sym->arg-type-form #_::arg-sym->arg-type-form @@ -906,21 +917,18 @@ :out-type-node (-> (analyze env out-type-form) (update :type t/unvalue))}] (>= n|iter analyze-arg-syms|max-iter) (err! "Max number of iterations reached for `analyze-arg-syms" {:n n|iter}) - ;; TODO if it finds a symbol it doesn't recognize then it should end up in the - ;; env via not this loop (let [arg-sym (first arglist-syms|unanalyzed) arg-type-form (arg-sym->arg-type-form arg-sym) env' (update env :opts #(assoc % :arglist-syms|queue (conj arglist-syms|queue arg-sym) :arglist-syms|unanalyzed arglist-syms|unanalyzed)) analyzed (-> (analyze env' arg-type-form) (update :type t/unvalue)) - primitive-subtypes - (->> analyzed :type - t/type>primitive-subtypes - (sort-by sort-guide) ; For cleanliness and reproducibility in tests - vec) - t-split (uc/distinct (join primitive-subtypes (-> analyzed :type type>split)))] - (pr! {:t (:type analyzed) :t-split t-split} #_{:analyzed analyzed}) + t-split (-> analyzed :type type>split+primitivized)] + (pr! {:arg-sym arg-sym + :t (:type analyzed) + :t-split t-split + :arglist-syms|queue (:arglist-syms|queue analyzed) + :arglist-syms|unanalyzed (:arglist-syms|unanalyzed analyzed)}) (if (-> t-split count (= 1)) (let [env' (assoc (:env analyzed) arg-sym analyzed)] (recur env' @@ -936,8 +944,12 @@ (assoc (:env analyzed) arg-sym (assoc analyzed :type t)) arg-sym->arg-type-form out-type-form - (:arglist-syms|queue analyzed) - (:arglist-syms|unanalyzed analyzed) + (conj arglist-syms|queue arg-sym) + ;; TODO re-enable + #_(:arglist-syms|queue analyzed) + (disj arglist-syms|unanalyzed arg-sym) + ;; TODO re-enable + #_(:arglist-syms|unanalyzed analyzed) (inc n|iter)))) r/join))))) diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index 4ec8548f..f5cd3666 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -35,7 +35,7 @@ -> Put `x` in env as `(t/isa? Boolean)` 2. Analyze out-type = `(t/type x)` -> `(t/isa? Boolean)`" - (let [ana (self/analyze-arg-syms {'x `tt/boolean?} `(t/type ~'x))] + (let [ana (self/analyze-arg-syms '{x tt/boolean?} '(t/type x))] (is= [[{'x tt/boolean?} tt/boolean?]] (transform-ana ana)))) (testing "Nested within another type" @@ -46,7 +46,7 @@ 1. Analyze `(t/type x)` -> `(t/isa? Boolean)` -> `(t/or (t/isa? Byte) (t/isa? Boolean))`" - (let [ana (self/analyze-arg-syms {'x 'tt/boolean?} `(t/or tt/byte? (t/type ~'x)))] + (let [ana (self/analyze-arg-syms '{x tt/boolean?} '(t/or tt/byte? (t/type x)))] (is= [[{'x tt/boolean?} (t/or tt/byte? tt/boolean?)]] (transform-ana ana)))) (testing "With arg shadowing" @@ -61,9 +61,9 @@ -> `(t/isa? Long)` -> `(t/or (t/isa? Byte) (t/isa? Long))" (let [ana (self/analyze-arg-syms - {'x 'tt/boolean?} - `(let [~'x (>long-checked "123")] - (t/or (t/isa? Byte) (t/type ~'x))))] + '{x tt/boolean?} + '(let [x (>long-checked "123")] + (t/or (t/isa? Byte) (t/type x))))] (is= [[{'x tt/boolean?} (t/or (t/isa? Byte) tt/long?)]] (transform-ana ana)))))) (testing "Output type dependent on splittable but non-primitive-splittable input" @@ -83,7 +83,7 @@ -> `(t/isa? String)`" (let [ana (self/analyze-arg-syms {'x '(t/or tt/boolean? tt/string?)} - `(t/type ~'x))] + '(t/type x))] (is= [[{'x tt/boolean?} tt/boolean?] [{'x tt/string?} tt/string?]] (transform-ana ana)))) @@ -98,7 +98,7 @@ 2. Analyze out-type = `(t/type x)` -> `(t/isa? Boolean)` 4. Analyze rest of splits in the same way." - (let [ana (self/analyze-arg-syms {'x 't/any?} `(t/type ~'x))] + (let [ana (self/analyze-arg-syms {'x 't/any?} '(t/type x))] (is= [[{'x tt/boolean?} tt/boolean?] [{'x tt/byte?} tt/byte?] [{'x tt/short?} tt/short?] @@ -115,6 +115,195 @@ -> Put `a` in env as `(t/isa? Byte)` 2. Analyze `b` = `(t/type a)` -> Put `b` in env as `(t/isa? Byte)`" - (let [ana (self/analyze-arg-syms {'a 'tt/byte?, 'b `(t/type ~'a)} `t/any?)] + (let [ana (self/analyze-arg-syms '{a tt/byte?, b (t/type a)} 't/any?)] (is= [[{'a tt/byte? 'b tt/byte?} t/any?]] - (transform-ana ana)))))) + (transform-ana ana)))) + (testing "Dependent type is for first input" + #_"1. Analyze `a` = `(t/type b)`. + 2. Analyze `b` = `tt/byte?` + -> Put `b` in env as `(t/isa? Byte)` + -> Put `a` in env as `(t/isa? Byte)`" + (let [ana (self/analyze-arg-syms '{a (t/type b) b tt/byte?} 't/any?)]))) + (testing "Output type dependent on input type which is dependent on other input type" + (testing "First input not splittable; second input not splittable" + #_"1. Analyze `a` = `tt/byte?` + -> Put `a` in env as `(t/isa? Byte)` + 2. Analyze `b` = `(t/type a)` + -> Put `b` in env as `(t/isa? Byte)` + 3. Analyze out-type = `(t/type b)` + -> `(t/isa? Byte)`" + (let [ana (self/analyze-arg-syms '{a tt/byte? b (t/type a)} '(t/type b))])) + (testing "First input splittable; second input not splittable" + #_"1. Analyze `a` = `(t/or tt/boolean? tt/byte?)`. Splittable. + 2. Split: + [[a tt/boolean?, b (t/type a) > (t/type b)] + [a tt/byte? , b (t/type a) > (t/type b)]] + 3. Analyze split 0. + 1. Analyze `a` = `tt/boolean?` + -> Put `a` in env as `(t/isa? Boolean)` + 2. Analyze `b` = `(t/type a)` + -> Put `b` in env as `(t/isa? Boolean)` + 3. Analyze out-type = `(t/type b)` + -> `(t/isa? Boolean)` + 4. Analyze split 1 in the same way." + (let [ana (self/analyze-arg-syms + '{a (t/or tt/boolean? tt/byte?) b (t/type a)} '(t/type b))])) + (testing "Two input types directly depend on each other" + (testing "Symbolically" + #_"1. Analyze `a` = `(t/type b)` + - Put `a` on queue + 1. Analyze `b` = `(t/type a)` + - Put `b` on queue + -> ERROR: `a` not in environment and `a` already on queue; circular + dependency detected" + (let [ana (self/analyze-arg-syms '{a (t/type b) b (t/type a)} 't/any?)])) + (testing "Non-symbolically" + #_"1. Analyze `a` = `(t/type b)` + - Put `a` on queue + 1. Analyze `b` = `(t/type [a])` + - Put `b` on queue + 1. Analyze `[a]` + 1. Analyze `a` + -> ERROR: `a` not in environment and `a` already on queue; + circular dependency detected" + (let [ana (self/analyze-arg-syms '{a (t/type b) b (t/type [a])} 't/any?)]))) + (testing "Two input types indirectly depend on each other" + #_"1. Analyze `a` = `(t/type b)` + 1. Analyze `b` = `(t/type c)` + 1. Analyze `c` = `(t/type a)` + -> ERROR `a` not in environment and `a` already in queue; circular + dependency detected" + (let [ana (self/analyze-arg-syms + '{a (t/type b) b (t/type c) c (t/type a)} 't/any?)])) + (testing "Combination/integration test" + ;; This test overview was put up in ~30 minutes on 9/30/2018 during a seemingly random walk of + ;; thoughts without any testing or research whatsoever that happened to actually coalesce + ;; into a working, clear, simple algorithm for handling dependent types. Not sure if + ;; listening to Bach's Passacaglia & Fugue In C Minor for organ and then orchestra helped, + ;; but there you go :) + #_"1. Analyze `a` = `(t/or tt/boolean? (t/type b))` + - Put `a` on queue + 1. Analyze `tt/boolean?` + -> `(t/isa? Boolean)` + 2. Analyze `(t/type b)` + 1. Analyze `b` = `(t/or tt/byte? (t/type d))` + - Put `b` on queue + 1. Analyze `tt/byte?` + -> `(t/isa? Byte)` + 2. Analyze `(t/type d)` + 1. Analyze `d` = `(let [b (t/- tt/char? tt/long?)] + (t/or tt/char? (t/type b) (t/type c)))` + - Put `d` on queue + 1. Analyze `b` = `(t/- tt/char? tt/long?)` + -> Put `b` in env as `t/none?` + 2. Analyze `(t/or tt/char? (t/type b) (t/type c))` + 1. Analyze `tt/char?` + -> `(t/isa? Character)` + 2. Analyze `(t/type b)` + -> `t/none-type?` <-- be careful of this + 3. Analyze `(t/type c)` + 1. Analyze `c` = `(t/or tt/short? tt/char?)` + 1. Analyze `tt/short?` + -> `(t/isa? Short)` + 2. Analyze `tt/char?` + -> `(t/isa? Character)` + -> `c` candidate is: + `(t/or (t/isa? Short) (t/isa? Character))` + Splittable. + - Split: + [[a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) + c (t/isa? Short) + d (let [b (t/- tt/char? tt/long?)] + (t/or tt/char? (t/type b) (t/type c))) + > (t/or (t/type b) (t/type d))] + [a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) + c (t/isa? Character) + d (let [b (t/- tt/char? tt/long?)] + (t/or tt/char? (t/type b) (t/type c))) + > (t/or (t/type b) (t/type d))]] + - We continue with only Split 0 for brevity. Other + splits should be handled the same. + -> Put `c` in env as `(t/isa? Short)` + -> `(t/isa? Short)` + -> `(t/or (t/isa? Character) + t/none-type? + (t/isa? Short))` + - Remove `b` from env + - Remove `d` from queue + -> `d` candidate is: + `(t/or (t/isa? Character) + t/none-type? + (t/isa? Short))`. + Splittable. + - Split: + [[a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) + c (t/isa? Short) + d (t/isa? Character) + > (t/or (t/type b) (t/type d))] + [a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) + c (t/isa? Short) + d t/none-type? + > (t/or (t/type b) (t/type d))] + [a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) + c (t/isa? Short) + d (t/isa? Short) + > (t/or (t/type b) (t/type d))]] + - We continue with only Split 0 for brevity. Other splits + should be handled the same. + -> Put `d` in env as `(t/isa? Character)` + -> `(t/isa? Character)` + -> `(t/isa? Character)` + - Remove `b` from queue + -> `b` candidate is: + `(t/or (t/isa? Byte) (t/isa? Character))` + Splittable. + - Split: + [[a (t/or tt/boolean? (t/type b)) + b (t/isa? Byte) + c (t/isa? Short) + d (t/isa? Character) + > (t/or (t/type b) (t/type d))] + [a (t/or tt/boolean? (t/type b)) + b (t/isa? Character) + c (t/isa? Short) + d (t/isa? Character) + > (t/or (t/type b) (t/type d))]] + - We continue with only Split 0 for brevity. Other splits should be + handled the same. + -> Put `b` in env as `(t/isa? Byte)` + -> `(t/isa? Byte)` + - Remove `a` from queue + -> `a` candidate is: + `(t/or (t/isa? Boolean) (t/isa? Byte))` + Splittable. + - Split: + [[a (t/isa? Boolean) + b (t/isa? Byte) + c (t/isa? Short) + d (t/isa? Character) + > (t/or (t/type b) (t/type d))] + [a (t/isa? Byte) + b (t/isa? Character) + c (t/isa? Short) + d (t/isa? Character) + > (t/or (t/type b) (t/type d))]] + - We continue with only Split 0 for brevity. Other splits should be handled + the same. + -> Put `a` in env as `(t/isa? Boolean)` + 2. Analyze out-type = `(t/or (t/type b) (t/type d))` + -> (Cutting obvious corners) `(t/or (t/isa? Byte) (t/isa? Character))` + - No splitting necessary because out-type + - All input types are in env and output-type was analyzed. DONE" + (let [ana (self/analyze-arg-syms + '{a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) + c (t/or tt/short? tt/char?) + d (let [b (t/- tt/char? tt/long?)] + (t/or tt/char? (t/type b) (t/type c)))} + '(t/or (t/type b) (t/type d)))] + (transform-ana ana))))) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index e9d9e338..687c61c7 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1,6 +1,6 @@ (ns quantum.test.untyped.core.type.defnt (:refer-clojure :exclude - [> count get name seq some?]) + [> count get name seq some? zero?]) (:require [clojure.core :as core] [quantum.test.untyped.core.type :as tt] @@ -315,7 +315,7 @@ (*<> (t/isa? Reduced))) (def ~'reduced?|test|__0|0 (reify* [Object>boolean] - (~(tag "boolean" 'invoke) [~'_0__ ~(tag "java.lang.Object" 'x)] + (~(B 'invoke) [~'_0__ ~(O 'x)] (let* [~(tag "clojure.lang.Reduced" 'x) ~'x] true)))) ;; [x t/any?] @@ -325,15 +325,15 @@ (def ~'reduced?|test|__1|0 (reify* [Object>boolean boolean>boolean byte>boolean short>boolean char>boolean int>boolean long>boolean float>boolean double>boolean] - (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false) - (~(tag "boolean" 'invoke) [~'_2__ ~(tag "boolean" 'x)] false) - (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'x)] false) - (~(tag "boolean" 'invoke) [~'_4__ ~(tag "short" 'x)] false) - (~(tag "boolean" 'invoke) [~'_5__ ~(tag "char" 'x)] false) - (~(tag "boolean" 'invoke) [~'_6__ ~(tag "int" 'x)] false) - (~(tag "boolean" 'invoke) [~'_7__ ~(tag "long" 'x)] false) - (~(tag "boolean" 'invoke) [~'_8__ ~(tag "float" 'x)] false) - (~(tag "boolean" 'invoke) [~'_9__ ~(tag "double" 'x)] false))) + (~(B 'invoke) [~'_1__ ~(O 'x)] false) + (~(B 'invoke) [~'_2__ ~(B 'x)] false) + (~(B 'invoke) [~'_3__ ~(Y 'x)] false) + (~(B 'invoke) [~'_4__ ~(S 'x)] false) + (~(B 'invoke) [~'_5__ ~(C 'x)] false) + (~(B 'invoke) [~'_6__ ~(I 'x)] false) + (~(B 'invoke) [~'_7__ ~(L 'x)] false) + (~(B 'invoke) [~'_8__ ~(F 'x)] false) + (~(B 'invoke) [~'_9__ ~(D 'x)] false))) (defn ~'reduced?|test {:quantum.core.type/type @@ -379,7 +379,7 @@ (*<> (t/isa? Boolean))) (def ~'>boolean|__0|0 (reify* [boolean>boolean] - (~(tag "boolean" 'invoke) [~'_0__ ~(tag "boolean" 'x)] ~'x))) + (~(B 'invoke) [~'_0__ ~(B 'x)] ~'x))) ;; [x t/nil? -> (- t/nil? tt/boolean?)] @@ -387,7 +387,7 @@ (*<> (t/value nil))) (def ~'>boolean|__1|0 (reify* [Object>boolean] - (~(tag "boolean" 'invoke) [~'_1__ ~(tag "java.lang.Object" 'x)] false))) + (~(B 'invoke) [~'_1__ ~(O 'x)] false))) ;; [x t/any? -> (- t/any? t/nil? tt/boolean?)] @@ -396,15 +396,15 @@ (def ~'>boolean|__2|0 (reify* [Object>boolean boolean>boolean byte>boolean short>boolean char>boolean int>boolean long>boolean float>boolean double>boolean] - (~(tag "boolean" 'invoke) [~'_2__ ~(tag "java.lang.Object" 'x)] true) - (~(tag "boolean" 'invoke) [~'_3__ ~(tag "boolean" 'x)] true) - (~(tag "boolean" 'invoke) [~'_4__ ~(tag "byte" 'x)] true) - (~(tag "boolean" 'invoke) [~'_5__ ~(tag "short" 'x)] true) - (~(tag "boolean" 'invoke) [~'_6__ ~(tag "char" 'x)] true) - (~(tag "boolean" 'invoke) [~'_7__ ~(tag "int" 'x)] true) - (~(tag "boolean" 'invoke) [~'_8__ ~(tag "long" 'x)] true) - (~(tag "boolean" 'invoke) [~'_9__ ~(tag "float" 'x)] true) - (~(tag "boolean" 'invoke) [~'_10__ ~(tag "double" 'x)] true))) + (~(B 'invoke) [~'_2__ ~(O 'x)] true) + (~(B 'invoke) [~'_3__ ~(B 'x)] true) + (~(B 'invoke) [~'_4__ ~(Y 'x)] true) + (~(B 'invoke) [~'_5__ ~(S 'x)] true) + (~(B 'invoke) [~'_6__ ~(C 'x)] true) + (~(B 'invoke) [~'_7__ ~(I 'x)] true) + (~(B 'invoke) [~'_8__ ~(L 'x)] true) + (~(B 'invoke) [~'_9__ ~(F 'x)] true) + (~(B 'invoke) [~'_10__ ~(D 'x)] true))) (defn ~'>boolean {:quantum.core.type/type @@ -450,81 +450,74 @@ ([x (t/- tt/primitive? tt/boolean?)] (Primitive/uncheckedIntCast x)) ([x (t/ref (t/isa? Number))] (.intValue x)))) expected - (case (env-lang) - :clj - ($ (do ;; [x (t/- tt/primitive? tt/boolean?)] - - ;; These are non-primitivized - (def ~(O<> '>int*|__0|input0|types) - (*<> (t/isa? java.lang.Byte) - (t/isa? java.lang.Short) - (t/isa? java.lang.Character) - (t/isa? java.lang.Integer) - (t/isa? java.lang.Long) - (t/isa? java.lang.Float) - (t/isa? java.lang.Double))) - (def ~'>int*|__0|0 - (reify* [byte>int] - (~(tag "int" 'invoke) [~'_0__ ~(tag "byte" 'x)] - ~'(. Primitive uncheckedIntCast x)))) - (def ~'>int*|__0|1 - (reify* [short>int] - (~(tag "int" 'invoke) [~'_1__ ~(tag "short" 'x)] - ~'(. Primitive uncheckedIntCast x)))) - (def ~'>int*|__0|2 - (reify* [char>int] - (~(tag "int" 'invoke) [~'_2__ ~(tag "char" 'x)] - ~'(. Primitive uncheckedIntCast x)))) - (def ~'>int*|__0|3 - (reify* [int>int] - (~(tag "int" 'invoke) [~'_3__ ~(tag "int" 'x)] - ~'(. Primitive uncheckedIntCast x)))) - (def ~'>int*|__0|4 - (reify* [long>int] - (~(tag "int" 'invoke) [~'_4__ ~(tag "long" 'x)] - ~'(. Primitive uncheckedIntCast x)))) - (def ~'>int*|__0|5 - (reify* [float>int] - (~(tag "int" 'invoke) [~'_5__ ~(tag "float" 'x)] - ~'(. Primitive uncheckedIntCast x)))) - (def ~'>int*|__0|6 - (reify* [double>int] - (~(tag "int" 'invoke) [~'_6__ ~(tag "double" 'x)] - ~'(. Primitive uncheckedIntCast x)))) - - ;; [x (t/ref (t/isa? Number)) - ;; -> (t/- (t/ref (t/isa? Number)) (t/- tt/primitive? tt/boolean?))] - - (def ~(O<> '>int*|__1|input0|types) - (*<> ~(with-meta `(t/isa? Number) {:quantum.core.type/ref? true}))) - (def ~'>int*|__1|0 - (reify* [Object>int] - (~(tag "int" 'invoke) [~'_7__ ~(tag "java.lang.Object" 'x)] - (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(. x intValue))))) - - (defn ~'>int* - {:quantum.core.type/type - (t/fn ~'tt/int? - ~'[(t/- tt/primitive? tt/boolean?)] - ~'[(t/ref (t/isa? Number))])} - ([~'x00__] - (ifs ((Array/get ~'>int*|__0|input0|types 0) ~'x00__) - (.invoke ~(tag (str `byte>int) '>int*|__0|0) ~'x00__) - ((Array/get ~'>int*|__0|input0|types 1) ~'x00__) - (.invoke ~(tag (str `short>int) '>int*|__0|1) ~'x00__) - ((Array/get ~'>int*|__0|input0|types 2) ~'x00__) - (.invoke ~(tag (str `char>int) '>int*|__0|2) ~'x00__) - ((Array/get ~'>int*|__0|input0|types 3) ~'x00__) - (.invoke ~(tag (str `int>int) '>int*|__0|3) ~'x00__) - ((Array/get ~'>int*|__0|input0|types 4) ~'x00__) - (.invoke ~(tag (str `long>int) '>int*|__0|4) ~'x00__) - ((Array/get ~'>int*|__0|input0|types 5) ~'x00__) - (.invoke ~(tag (str `float>int) '>int*|__0|5) ~'x00__) - ((Array/get ~'>int*|__0|input0|types 6) ~'x00__) - (.invoke ~(tag (str `double>int) '>int*|__0|6) ~'x00__) - ((Array/get ~'>int*|__1|input0|types 0) ~'x00__) - (.invoke ~(tag (str `Object>int) '>int*|__1|0) ~'x00__) - (unsupported! `>int* [~'x00__] 0)))))))] + (case (env-lang) + :clj + ($ (do ;; [x (t/- tt/primitive? tt/boolean?)] + + ;; These are non-primitivized + (def ~(O<> '>int*|__0|input0|types) + (*<> (t/isa? java.lang.Byte) + (t/isa? java.lang.Short) + (t/isa? java.lang.Character) + (t/isa? java.lang.Integer) + (t/isa? java.lang.Long) + (t/isa? java.lang.Float) + (t/isa? java.lang.Double))) + (def ~'>int*|__0|0 + (reify* [byte>int] + (~(I 'invoke) [~'_0__ ~(Y 'x)] ~'(. Primitive uncheckedIntCast x)))) + (def ~'>int*|__0|1 + (reify* [short>int] + (~(I 'invoke) [~'_1__ ~(S 'x)] ~'(. Primitive uncheckedIntCast x)))) + (def ~'>int*|__0|2 + (reify* [char>int] + (~(I 'invoke) [~'_2__ ~(C 'x)] ~'(. Primitive uncheckedIntCast x)))) + (def ~'>int*|__0|3 + (reify* [int>int] + (~(I 'invoke) [~'_3__ ~(I 'x)] ~'(. Primitive uncheckedIntCast x)))) + (def ~'>int*|__0|4 + (reify* [long>int] + (~(I 'invoke) [~'_4__ ~(L 'x)] ~'(. Primitive uncheckedIntCast x)))) + (def ~'>int*|__0|5 + (reify* [float>int] + (~(I 'invoke) [~'_5__ ~(F 'x)] ~'(. Primitive uncheckedIntCast x)))) + (def ~'>int*|__0|6 + (reify* [double>int] + (~(I 'invoke) [~'_6__ ~(D 'x)] ~'(. Primitive uncheckedIntCast x)))) + + ;; [x (t/ref (t/isa? Number)) + ;; -> (t/- (t/ref (t/isa? Number)) (t/- tt/primitive? tt/boolean?))] + + (def ~(O<> '>int*|__1|input0|types) + (*<> ~(with-meta `(t/isa? Number) {:quantum.core.type/ref? true}))) + (def ~'>int*|__1|0 + (reify* [Object>int] + (~(I 'invoke) [~'_7__ ~(O 'x)] + (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(. x intValue))))) + + (defn ~'>int* + {:quantum.core.type/type + (t/fn ~'tt/int? + ~'[(t/- tt/primitive? tt/boolean?)] + ~'[(t/ref (t/isa? Number))])} + ([~'x00__] + (ifs ((Array/get ~'>int*|__0|input0|types 0) ~'x00__) + (.invoke ~(tag (str `byte>int) '>int*|__0|0) ~'x00__) + ((Array/get ~'>int*|__0|input0|types 1) ~'x00__) + (.invoke ~(tag (str `short>int) '>int*|__0|1) ~'x00__) + ((Array/get ~'>int*|__0|input0|types 2) ~'x00__) + (.invoke ~(tag (str `char>int) '>int*|__0|2) ~'x00__) + ((Array/get ~'>int*|__0|input0|types 3) ~'x00__) + (.invoke ~(tag (str `int>int) '>int*|__0|3) ~'x00__) + ((Array/get ~'>int*|__0|input0|types 4) ~'x00__) + (.invoke ~(tag (str `long>int) '>int*|__0|4) ~'x00__) + ((Array/get ~'>int*|__0|input0|types 5) ~'x00__) + (.invoke ~(tag (str `float>int) '>int*|__0|5) ~'x00__) + ((Array/get ~'>int*|__0|input0|types 6) ~'x00__) + (.invoke ~(tag (str `double>int) '>int*|__0|6) ~'x00__) + ((Array/get ~'>int*|__1|input0|types 0) ~'x00__) + (.invoke ~(tag (str `Object>int) '>int*|__1|0) ~'x00__) + (unsupported! `>int* [~'x00__] 0)))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) @@ -539,377 +532,412 @@ (is (identical? (>int* -1.1) (clojure.lang.RT/uncheckedIntCast -1.1))) (is (identical? (>int* (byte 1)) (clojure.lang.RT/uncheckedIntCast (byte 1))))))))) +;; Because "Method code too large" error +(def >|ftype-form + ($ (t/ftype #?(:clj (t/isa? Boolean) :cljs tt/boolean?) + #?@(:clj [[(t/isa? Byte) (t/isa? Byte) :> (t/isa? Boolean)] + [(t/isa? Byte) (t/isa? Short) :> (t/isa? Boolean)] + [(t/isa? Byte) (t/isa? Character) :> (t/isa? Boolean)] + [(t/isa? Byte) (t/isa? Integer) :> (t/isa? Boolean)] + [(t/isa? Byte) (t/isa? Long) :> (t/isa? Boolean)] + [(t/isa? Byte) (t/isa? Float) :> (t/isa? Boolean)] + [(t/isa? Byte) (t/isa? Double) :> (t/isa? Boolean)] + [(t/isa? Short) (t/isa? Byte) :> (t/isa? Boolean)] + [(t/isa? Short) (t/isa? Short) :> (t/isa? Boolean)] + [(t/isa? Short) (t/isa? Character) :> (t/isa? Boolean)] + [(t/isa? Short) (t/isa? Integer) :> (t/isa? Boolean)] + [(t/isa? Short) (t/isa? Long) :> (t/isa? Boolean)] + [(t/isa? Short) (t/isa? Float) :> (t/isa? Boolean)] + [(t/isa? Short) (t/isa? Double) :> (t/isa? Boolean)] + [(t/isa? Character) (t/isa? Byte) :> (t/isa? Boolean)] + [(t/isa? Character) (t/isa? Short) :> (t/isa? Boolean)] + [(t/isa? Character) (t/isa? Character) :> (t/isa? Boolean)] + [(t/isa? Character) (t/isa? Integer) :> (t/isa? Boolean)] + [(t/isa? Character) (t/isa? Long) :> (t/isa? Boolean)] + [(t/isa? Character) (t/isa? Float) :> (t/isa? Boolean)] + [(t/isa? Character) (t/isa? Double) :> (t/isa? Boolean)] + [(t/isa? Integer) (t/isa? Byte) :> (t/isa? Boolean)] + [(t/isa? Integer) (t/isa? Short) :> (t/isa? Boolean)] + [(t/isa? Integer) (t/isa? Character) :> (t/isa? Boolean)] + [(t/isa? Integer) (t/isa? Integer) :> (t/isa? Boolean)] + [(t/isa? Integer) (t/isa? Long) :> (t/isa? Boolean)] + [(t/isa? Integer) (t/isa? Float) :> (t/isa? Boolean)] + [(t/isa? Integer) (t/isa? Double) :> (t/isa? Boolean)] + [(t/isa? Long) (t/isa? Byte) :> (t/isa? Boolean)] + [(t/isa? Long) (t/isa? Short) :> (t/isa? Boolean)] + [(t/isa? Long) (t/isa? Character) :> (t/isa? Boolean)] + [(t/isa? Long) (t/isa? Integer) :> (t/isa? Boolean)] + [(t/isa? Long) (t/isa? Long) :> (t/isa? Boolean)] + [(t/isa? Long) (t/isa? Float) :> (t/isa? Boolean)] + [(t/isa? Long) (t/isa? Double) :> (t/isa? Boolean)] + [(t/isa? Float) (t/isa? Byte) :> (t/isa? Boolean)] + [(t/isa? Float) (t/isa? Short) :> (t/isa? Boolean)] + [(t/isa? Float) (t/isa? Character) :> (t/isa? Boolean)] + [(t/isa? Float) (t/isa? Integer) :> (t/isa? Boolean)] + [(t/isa? Float) (t/isa? Long) :> (t/isa? Boolean)] + [(t/isa? Float) (t/isa? Float) :> (t/isa? Boolean)] + [(t/isa? Float) (t/isa? Double) :> (t/isa? Boolean)] + [(t/isa? Double) (t/isa? Byte) :> (t/isa? Boolean)] + [(t/isa? Double) (t/isa? Short) :> (t/isa? Boolean)] + [(t/isa? Double) (t/isa? Character) :> (t/isa? Boolean)] + [(t/isa? Double) (t/isa? Integer) :> (t/isa? Boolean)] + [(t/isa? Double) (t/isa? Long) :> (t/isa? Boolean)] + [(t/isa? Double) (t/isa? Float) :> (t/isa? Boolean)] + [(t/isa? Double) (t/isa? Double) :> (t/isa? Boolean)]] + :cljs [[tt/double? tt/double? :> (t/assume tt/boolean?)]])))) + +(def >|dynamic-dispatch-form + ($ (defn ~'> {:quantum.core.type/type ~>|ftype-form} + ([~'x00__ ~'x10__] + (ifs + ((Array/get ~'>|__0|types 0) ~'x00__) + (ifs + ((Array/get ~'>|__0|types 1) ~'x10__) + (. ~(tag (str `byte+byte>boolean) '>|__0) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 1) ~'x10__) + (. ~(tag (str `byte+short>boolean) '>|__1) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__2|types 1) ~'x10__) + (. ~(tag (str `byte+char>boolean) '>|__2) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__3|types 1) ~'x10__) + (. ~(tag (str `byte+int>boolean) '>|__3) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__4|types 1) ~'x10__) + (. ~(tag (str `byte+long>boolean) '>|__4) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__5|types 1) ~'x10__) + (. ~(tag (str `byte+float>boolean) '>|__5) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__6|types 1) ~'x10__) + (. ~(tag (str `byte+double>boolean) '>|__6) ~'invoke ~'x00__ ~'x10__) + (unsupported! `>|test [~'x00__ ~'x10__] 1)) + ((Array/get ~'>|__1|types 0) ~'x00__) + (ifs + ((Array/get ~'>|__7|types 1) ~'x10__) + (. ~(tag (str `short+byte>boolean) '>|__7) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__8|types 1) ~'x10__) + (. ~(tag (str `short+short>boolean) '>|__8) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__9|types 1) ~'x10__) + (. ~(tag (str `short+char>boolean) '>|__9) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__10|types 1) ~'x10__) + (. ~(tag (str `short+int>boolean) '>|__10) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__11|types 1) ~'x10__) + (. ~(tag (str `short+long>boolean) '>|__11) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__12|types 1) ~'x10__) + (. ~(tag (str `short+float>boolean) '>|__12) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__13|types 1) ~'x10__) + (. ~(tag (str `short+double>boolean) '>|__13) ~'invoke ~'x00__ ~'x10__) + (unsupported! `>|test [~'x00__ ~'x10__] 1)) + ((Array/get ~'>|__2|types 0) ~'x00__) + (ifs + ((Array/get ~'>|__1|types 0) ~'x10__) + (. ~(tag (str `char+byte>boolean) '>|__14) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 1) ~'x10__) + (. ~(tag (str `char+short>boolean) '>|__15) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 2) ~'x10__) + (. ~(tag (str `char+char>boolean) '>|__16) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 3) ~'x10__) + (. ~(tag (str `char+int>boolean) '>|__17) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 4) ~'x10__) + (. ~(tag (str `char+long>boolean) '>|__18) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 5) ~'x10__) + (. ~(tag (str `char+float>boolean) '>|__19) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 6) ~'x10__) + (. ~(tag (str `char+double>boolean) '>|__20) ~'invoke ~'x00__ ~'x10__) + (unsupported! `>|test [~'x00__ ~'x10__] 1)) + ((Array/get ~'>|__3|types 0) ~'x00__) + (ifs + ((Array/get ~'>|__1|types 0) ~'x10__) + (. ~(tag (str `int+byte>boolean) '>|__21) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 1) ~'x10__) + (. ~(tag (str `int+short>boolean) '>|__22) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 2) ~'x10__) + (. ~(tag (str `int+char>boolean) '>|__23) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 3) ~'x10__) + (. ~(tag (str `int+int>boolean) '>|__24) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 4) ~'x10__) + (. ~(tag (str `int+long>boolean) '>|__25) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 5) ~'x10__) + (. ~(tag (str `int+float>boolean) '>|__26) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 6) ~'x10__) + (. ~(tag (str `int+double>boolean) '>|__27) ~'invoke ~'x00__ ~'x10__) + (unsupported! `>|test [~'x00__ ~'x10__] 1)) + ((Array/get ~'>|__4|types 0) ~'x00__) + (ifs + ((Array/get ~'>|__1|types 0) ~'x10__) + (. ~(tag (str `long+byte>boolean) '>|__28) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 1) ~'x10__) + (. ~(tag (str `long+short>boolean) '>|__29) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 2) ~'x10__) + (. ~(tag (str `long+char>boolean) '>|__30) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 3) ~'x10__) + (. ~(tag (str `long+int>boolean) '>|__31) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 4) ~'x10__) + (. ~(tag (str `long+long>boolean) '>|__32) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 5) ~'x10__) + (. ~(tag (str `long+float>boolean) '>|__33) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 6) ~'x10__) + (. ~(tag (str `long+double>boolean) '>|__34) ~'invoke ~'x00__ ~'x10__) + (unsupported! `>|test [~'x00__ ~'x10__] 1)) + ((Array/get ~'>|__5|types 0) ~'x00__) + (ifs + ((Array/get ~'>|__1|types 0) ~'x10__) + (. ~(tag (str `float+byte>boolean) '>|__35) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 1) ~'x10__) + (. ~(tag (str `float+short>boolean) '>|__36) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 2) ~'x10__) + (. ~(tag (str `float+char>boolean) '>|__37) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 3) ~'x10__) + (. ~(tag (str `float+int>boolean) '>|__38) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 4) ~'x10__) + (. ~(tag (str `float+long>boolean) '>|__39) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 5) ~'x10__) + (. ~(tag (str `float+float>boolean) '>|__40) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 6) ~'x10__) + (. ~(tag (str `float+double>boolean) '>|__41) ~'invoke ~'x00__ ~'x10__) + (unsupported! `>|test [~'x00__ ~'x10__] 1)) + ((Array/get ~'>|__6|types 0) ~'x00__) + (ifs + ((Array/get ~'>|__1|types 0) ~'x10__) + (. ~(tag (str `double+byte>boolean) '>|__42) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 1) ~'x10__) + (. ~(tag (str `double+short>boolean) '>|__43) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 2) ~'x10__) + (. ~(tag (str `double+char>boolean) '>|__44) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 3) ~'x10__) + (. ~(tag (str `double+int>boolean) '>|__45) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 4) ~'x10__) + (. ~(tag (str `double+long>boolean) '>|__46) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 5) ~'x10__) + (. ~(tag (str `double+float>boolean) '>|__47) ~'invoke ~'x00__ ~'x10__) + ((Array/get ~'>|__1|types 6) ~'x10__) + (. ~(tag (str `double+double>boolean) '>|__48) ~'invoke ~'x00__ ~'x10__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + (unsupported! `> [~'x00__ ~'x10__] 0)))))) + (deftest test|> (let [actual (macroexpand ' - (self/defn #_:inline > + (self/defn #_:inline > > tt/boolean? #?(:clj ([a tt/comparable-primitive? b tt/comparable-primitive? > tt/boolean?] (Numeric/gt a b)) :cljs ([a tt/double? b tt/double? > (t/assume tt/boolean?)] (cljs.core/> a b))))) expected - (case (env-lang) - :clj - ($ (do ;; [a t/comparable-primitive? b t/comparable-primitive? > tt/boolean?] - - ;; These are non-primitivized - (def ~(O<> '>|test|__0|input0|types) - (*<> (t/isa? java.lang.Byte) - (t/isa? java.lang.Short) - (t/isa? java.lang.Character) - (t/isa? java.lang.Integer) - (t/isa? java.lang.Long) - (t/isa? java.lang.Float) - (t/isa? java.lang.Double))) - (def ~(O<> '>|test|__0|input1|types) - (*<> (t/isa? java.lang.Byte) - (t/isa? java.lang.Short) - (t/isa? java.lang.Character) - (t/isa? java.lang.Integer) - (t/isa? java.lang.Long) - (t/isa? java.lang.Float) - (t/isa? java.lang.Double))) - (def ~'>|test|__0|0 - (reify* [byte+byte>boolean] - (~(tag "boolean" 'invoke) [~'_0__ ~(tag "byte" 'a) ~(tag "byte" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|1 - (reify* [byte+short>boolean] - (~(tag "boolean" 'invoke) [~'_1__ ~(tag "byte" 'a) ~(tag "short" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|2 - (reify* [byte+char>boolean] - (~(tag "boolean" 'invoke) [~'_2__ ~(tag "byte" 'a) ~(tag "char" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|3 - (reify* [byte+int>boolean] - (~(tag "boolean" 'invoke) [~'_3__ ~(tag "byte" 'a) ~(tag "int" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|4 - (reify* [byte+long>boolean] - (~(tag "boolean" 'invoke) [~'_4__ ~(tag "byte" 'a) ~(tag "long" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|5 - (reify* [byte+float>boolean] - (~(tag "boolean" 'invoke) [~'_5__ ~(tag "byte" 'a) ~(tag "float" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|6 - (reify* [byte+double>boolean] - (~(tag "boolean" 'invoke) [~'_6__ ~(tag "byte" 'a) ~(tag "double" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|7 - (reify* [short+byte>boolean] - (~(tag "boolean" 'invoke) [~'_7__ ~(tag "short" 'a) ~(tag "byte" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|8 - (reify* [short+short>boolean] - (~(tag "boolean" 'invoke) [~'_8__ ~(tag "short" 'a) ~(tag "short" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|9 - (reify* [short+char>boolean] - (~(tag "boolean" 'invoke) [~'_9__ ~(tag "short" 'a) ~(tag "char" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|10 - (reify* [short+int>boolean] - (~(tag "boolean" 'invoke) [~'_10__ ~(tag "short" 'a) ~(tag "int" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|11 - (reify* [short+long>boolean] - (~(tag "boolean" 'invoke) [~'_11__ ~(tag "short" 'a) ~(tag "long" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|12 - (reify* [short+float>boolean] - (~(tag "boolean" 'invoke) [~'_12__ ~(tag "short" 'a) ~(tag "float" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|13 - (reify* [short+double>boolean] - (~(tag "boolean" 'invoke) [~'_13__ ~(tag "short" 'a) ~(tag "double" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|14 - (reify* [char+byte>boolean] - (~(tag "boolean" 'invoke) [~'_14__ ~(tag "char" 'a) ~(tag "byte" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|15 - (reify* [char+short>boolean] - (~(tag "boolean" 'invoke) [~'_15__ ~(tag "char" 'a) ~(tag "short" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|16 - (reify* [char+char>boolean] - (~(tag "boolean" 'invoke) [~'_16__ ~(tag "char" 'a) ~(tag "char" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|17 - (reify* [char+int>boolean] - (~(tag "boolean" 'invoke) [~'_17__ ~(tag "char" 'a) ~(tag "int" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|18 - (reify* [char+long>boolean] - (~(tag "boolean" 'invoke) [~'_18__ ~(tag "char" 'a) ~(tag "long" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|19 - (reify* [char+float>boolean] - (~(tag "boolean" 'invoke) [~'_19__ ~(tag "char" 'a) ~(tag "float" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|20 - (reify* [char+double>boolean] - (~(tag "boolean" 'invoke) [~'_20__ ~(tag "char" 'a) ~(tag "double" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|21 - (reify* [int+byte>boolean] - (~(tag "boolean" 'invoke) [~'_21__ ~(tag "int" 'a) ~(tag "byte" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|22 - (reify* [int+short>boolean] - (~(tag "boolean" 'invoke) [~'_22__ ~(tag "int" 'a) ~(tag "short" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|23 - (reify* [int+char>boolean] - (~(tag "boolean" 'invoke) [~'_23__ ~(tag "int" 'a) ~(tag "char" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|24 - (reify* [int+int>boolean] - (~(tag "boolean" 'invoke) [~'_24__ ~(tag "int" 'a) ~(tag "int" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|25 - (reify* [int+long>boolean] - (~(tag "boolean" 'invoke) [~'_25__ ~(tag "int" 'a) ~(tag "long" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|26 - (reify* [int+float>boolean] - (~(tag "boolean" 'invoke) [~'_26__ ~(tag "int" 'a) ~(tag "float" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|27 - (reify* [int+double>boolean] - (~(tag "boolean" 'invoke) [~'_27__ ~(tag "int" 'a) ~(tag "double" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|28 - (reify* [long+byte>boolean] - (~(tag "boolean" 'invoke) [~'_28__ ~(tag "long" 'a) ~(tag "byte" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|29 - (reify* [long+short>boolean] - (~(tag "boolean" 'invoke) [~'_29__ ~(tag "long" 'a) ~(tag "short" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|30 - (reify* [long+char>boolean] - (~(tag "boolean" 'invoke) [~'_30__ ~(tag "long" 'a) ~(tag "char" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|31 - (reify* [long+int>boolean] - (~(tag "boolean" 'invoke) [~'_31__ ~(tag "long" 'a) ~(tag "int" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|32 - (reify* [long+long>boolean] - (~(tag "boolean" 'invoke) [~'_32__ ~(tag "long" 'a) ~(tag "long" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|33 - (reify* [long+float>boolean] - (~(tag "boolean" 'invoke) [~'_33__ ~(tag "long" 'a) ~(tag "float" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|34 - (reify* [long+double>boolean] - (~(tag "boolean" 'invoke) [~'_34__ ~(tag "long" 'a) ~(tag "double" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|35 - (reify* [float+byte>boolean] - (~(tag "boolean" 'invoke) [~'_35__ ~(tag "float" 'a) ~(tag "byte" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|36 - (reify* [float+short>boolean] - (~(tag "boolean" 'invoke) [~'_36__ ~(tag "float" 'a) ~(tag "short" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|37 - (reify* [float+char>boolean] - (~(tag "boolean" 'invoke) [~'_37__ ~(tag "float" 'a) ~(tag "char" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|38 - (reify* [float+int>boolean] - (~(tag "boolean" 'invoke) [~'_38__ ~(tag "float" 'a) ~(tag "int" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|39 - (reify* [float+long>boolean] - (~(tag "boolean" 'invoke) [~'_39__ ~(tag "float" 'a) ~(tag "long" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|40 - (reify* [float+float>boolean] - (~(tag "boolean" 'invoke) [~'_40__ ~(tag "float" 'a) ~(tag "float" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|41 - (reify* [float+double>boolean] - (~(tag "boolean" 'invoke) [~'_41__ ~(tag "float" 'a) ~(tag "double" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|42 - (reify* [double+byte>boolean] - (~(tag "boolean" 'invoke) [~'_42__ ~(tag "double" 'a) ~(tag "byte" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|43 - (reify* [double+short>boolean] - (~(tag "boolean" 'invoke) [~'_43__ ~(tag "double" 'a) ~(tag "short" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|44 - (reify* [double+char>boolean] - (~(tag "boolean" 'invoke) [~'_44__ ~(tag "double" 'a) ~(tag "char" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|45 - (reify* [double+int>boolean] - (~(tag "boolean" 'invoke) [~'_45__ ~(tag "double" 'a) ~(tag "int" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|46 - (reify* [double+long>boolean] - (~(tag "boolean" 'invoke) [~'_46__ ~(tag "double" 'a) ~(tag "long" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|47 - (reify* [double+float>boolean] - (~(tag "boolean" 'invoke) [~'_47__ ~(tag "double" 'a) ~(tag "float" 'b)] - ~'(. Numeric gt a b)))) - (def ~'>|test|__0|48 - (reify* [double+double>boolean] - (~(tag "boolean" 'invoke) [~'_48__ ~(tag "double" 'a) ~(tag "double" 'b)] - ~'(. Numeric gt a b)))) - - ;; Unindented for greater vertical brevity - (defn ~'>|test - {:quantum.core.type/type - (t/fn t/any? - #?(:clj ~'[comparable-primitive? comparable-primitive? - :> tt/boolean?] - :cljs ~'[double? double? - :> (t/assume tt/boolean?)]))} - ([~'x00__ ~'x10__] - (ifs - ((Array/get ~'>|test|__0|input0|types 0) ~'x00__) - (ifs - ((Array/get ~'>|test|__0|input1|types 0) ~'x10__) - (.invoke ~(tag (str `byte+byte>boolean) '>|test|__0|0) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 1) ~'x10__) - (.invoke ~(tag (str `byte+short>boolean) '>|test|__0|1) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 2) ~'x10__) - (.invoke ~(tag (str `byte+char>boolean) '>|test|__0|2) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 3) ~'x10__) - (.invoke ~(tag (str `byte+int>boolean) '>|test|__0|3) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 4) ~'x10__) - (.invoke ~(tag (str `byte+long>boolean) '>|test|__0|4) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 5) ~'x10__) - (.invoke ~(tag (str `byte+float>boolean) '>|test|__0|5) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 6) ~'x10__) - (.invoke ~(tag (str `byte+double>boolean) '>|test|__0|6) ~'x00__ ~'x10__) - (unsupported! `>|test [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|test|__0|input0|types 1) ~'x00__) - (ifs - ((Array/get ~'>|test|__0|input1|types 0) ~'x10__) - (.invoke ~(tag (str `short+byte>boolean) '>|test|__0|7) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 1) ~'x10__) - (.invoke ~(tag (str `short+short>boolean) '>|test|__0|8) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 2) ~'x10__) - (.invoke ~(tag (str `short+char>boolean) '>|test|__0|9) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 3) ~'x10__) - (.invoke ~(tag (str `short+int>boolean) '>|test|__0|10) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 4) ~'x10__) - (.invoke ~(tag (str `short+long>boolean) '>|test|__0|11) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 5) ~'x10__) - (.invoke ~(tag (str `short+float>boolean) '>|test|__0|12) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 6) ~'x10__) - (.invoke ~(tag (str `short+double>boolean) '>|test|__0|13) ~'x00__ ~'x10__) - (unsupported! `>|test [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|test|__0|input0|types 2) ~'x00__) - (ifs - ((Array/get ~'>|test|__0|input1|types 0) ~'x10__) - (.invoke ~(tag (str `char+byte>boolean) '>|test|__0|14) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 1) ~'x10__) - (.invoke ~(tag (str `char+short>boolean) '>|test|__0|15) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 2) ~'x10__) - (.invoke ~(tag (str `char+char>boolean) '>|test|__0|16) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 3) ~'x10__) - (.invoke ~(tag (str `char+int>boolean) '>|test|__0|17) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 4) ~'x10__) - (.invoke ~(tag (str `char+long>boolean) '>|test|__0|18) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 5) ~'x10__) - (.invoke ~(tag (str `char+float>boolean) '>|test|__0|19) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 6) ~'x10__) - (.invoke ~(tag (str `char+double>boolean) '>|test|__0|20) ~'x00__ ~'x10__) - (unsupported! `>|test [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|test|__0|input0|types 3) ~'x00__) - (ifs - ((Array/get ~'>|test|__0|input1|types 0) ~'x10__) - (.invoke ~(tag (str `int+byte>boolean) '>|test|__0|21) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 1) ~'x10__) - (.invoke ~(tag (str `int+short>boolean) '>|test|__0|22) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 2) ~'x10__) - (.invoke ~(tag (str `int+char>boolean) '>|test|__0|23) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 3) ~'x10__) - (.invoke ~(tag (str `int+int>boolean) '>|test|__0|24) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 4) ~'x10__) - (.invoke ~(tag (str `int+long>boolean) '>|test|__0|25) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 5) ~'x10__) - (.invoke ~(tag (str `int+float>boolean) '>|test|__0|26) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 6) ~'x10__) - (.invoke ~(tag (str `int+double>boolean) '>|test|__0|27) ~'x00__ ~'x10__) - (unsupported! `>|test [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|test|__0|input0|types 4) ~'x00__) - (ifs - ((Array/get ~'>|test|__0|input1|types 0) ~'x10__) - (.invoke ~(tag (str `long+byte>boolean) '>|test|__0|28) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 1) ~'x10__) - (.invoke ~(tag (str `long+short>boolean) '>|test|__0|29) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 2) ~'x10__) - (.invoke ~(tag (str `long+char>boolean) '>|test|__0|30) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 3) ~'x10__) - (.invoke ~(tag (str `long+int>boolean) '>|test|__0|31) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 4) ~'x10__) - (.invoke ~(tag (str `long+long>boolean) '>|test|__0|32) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 5) ~'x10__) - (.invoke ~(tag (str `long+float>boolean) '>|test|__0|33) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 6) ~'x10__) - (.invoke ~(tag (str `long+double>boolean) '>|test|__0|34) ~'x00__ ~'x10__) - (unsupported! `>|test [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|test|__0|input0|types 5) ~'x00__) - (ifs - ((Array/get ~'>|test|__0|input1|types 0) ~'x10__) - (.invoke ~(tag (str `float+byte>boolean) '>|test|__0|35) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 1) ~'x10__) - (.invoke ~(tag (str `float+short>boolean) '>|test|__0|36) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 2) ~'x10__) - (.invoke ~(tag (str `float+char>boolean) '>|test|__0|37) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 3) ~'x10__) - (.invoke ~(tag (str `float+int>boolean) '>|test|__0|38) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 4) ~'x10__) - (.invoke ~(tag (str `float+long>boolean) '>|test|__0|39) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 5) ~'x10__) - (.invoke ~(tag (str `float+float>boolean) '>|test|__0|40) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 6) ~'x10__) - (.invoke ~(tag (str `float+double>boolean) '>|test|__0|41) ~'x00__ ~'x10__) - (unsupported! `>|test [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|test|__0|input0|types 6) ~'x00__) - (ifs - ((Array/get ~'>|test|__0|input1|types 0) ~'x10__) - (.invoke ~(tag (str `double+byte>boolean) '>|test|__0|42) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 1) ~'x10__) - (.invoke ~(tag (str `double+short>boolean) '>|test|__0|43) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 2) ~'x10__) - (.invoke ~(tag (str `double+char>boolean) '>|test|__0|44) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 3) ~'x10__) - (.invoke ~(tag (str `double+int>boolean) '>|test|__0|45) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 4) ~'x10__) - (.invoke ~(tag (str `double+long>boolean) '>|test|__0|46) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 5) ~'x10__) - (.invoke ~(tag (str `double+float>boolean) '>|test|__0|47) ~'x00__ ~'x10__) - ((Array/get ~'>|test|__0|input1|types 6) ~'x10__) - (.invoke ~(tag (str `double+double>boolean) '>|test|__0|48) ~'x00__ ~'x10__) - (unsupported! `>|test [~'x00__ ~'x10__] 1)) - (unsupported! `>|test [~'x00__ ~'x10__] 0)))))) - :cljs - ($ (do (defn ~'>|test - ([a0 a1] - (ifs (double? a0) - (ifs (double? a1) - (let* [a a0 b a1] (cljs.core/> a b)) - (unsupported! `>|test [a0 a1] 1)) - (unsupported! `>|test [a0 a1] 0)))))))] + (case (env-lang) + :clj + ($ (do (declare ~'>) + + ;; [a t/comparable-primitive? b t/comparable-primitive? > tt/boolean?] + + (def ~(O<> '>|__0|types) (*<> (t/isa? Byte) (t/isa? Byte))) + (def ~'>|__0 + (reify* [byte+byte>boolean] + (~(B 'invoke) [~'_0__ ~(Y 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__1|types) (*<> (t/isa? Byte) (t/isa? Short))) + (def ~'>|__1 + (reify* [byte+short>boolean] + (~(B 'invoke) [~'_1__ ~(Y 'a) ~(S 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__2|types) (*<> (t/isa? Byte) (t/isa? Character))) + (def ~'>|__2 + (reify* [byte+char>boolean] + (~(B 'invoke) [~'_2__ ~(Y 'a) ~(C 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__3|types) (*<> (t/isa? Byte) (t/isa? Integer))) + (def ~'>|__3 + (reify* [byte+int>boolean] + (~(B 'invoke) [~'_3__ ~(Y 'a) ~(I 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__4|types) (*<> (t/isa? Byte) (t/isa? Long))) + (def ~'>|__4 + (reify* [byte+long>boolean] + (~(B 'invoke) [~'_4__ ~(Y 'a) ~(L 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__5|types) (*<> (t/isa? Byte) (t/isa? Float))) + (def ~'>|__5 + (reify* [byte+float>boolean] + (~(B 'invoke) [~'_5__ ~(Y 'a) ~(F 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__6|types) (*<> (t/isa? Byte) (t/isa? Double))) + (def ~'>|__6 + (reify* [byte+double>boolean] + (~(B 'invoke) [~'_6__ ~(Y 'a) ~(D 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__7|types) (*<> (t/isa? Short) (t/isa? Byte))) + (def ~'>|__7 + (reify* [short+byte>boolean] + (~(B 'invoke) [~'_7__ ~(S 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__8|types) (*<> (t/isa? Short) (t/isa? Short))) + (def ~'>|__8 + (reify* [short+short>boolean] + (~(B 'invoke) [~'_8__ ~(S 'a) ~(S 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__9|types) (*<> (t/isa? Short) (t/isa? Character))) + (def ~'>|__9 + (reify* [short+char>boolean] + (~(B 'invoke) [~'_9__ ~(S 'a) ~(C 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__10|types) (*<> (t/isa? Short) (t/isa? Integer))) + (def ~'>|__10 + (reify* [short+int>boolean] + (~(B 'invoke) [~'_10__ ~(S 'a) ~(I 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__11|types) (*<> (t/isa? Short) (t/isa? Long))) + (def ~'>|__11 + (reify* [short+long>boolean] + (~(B 'invoke) [~'_11__ ~(S 'a) ~(L 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__12|types) (*<> (t/isa? Short) (t/isa? Float))) + (def ~'>|__12 + (reify* [short+float>boolean] + (~(B 'invoke) [~'_12__ ~(S 'a) ~(F 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__13|types) (*<> (t/isa? Short) (t/isa? Double))) + (def ~'>|__13 + (reify* [short+double>boolean] + (~(B 'invoke) [~'_13__ ~(S 'a) ~(D 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__14|types) (*<> (t/isa? Character) (t/isa? Byte))) + (def ~'>|__14 + (reify* [char+byte>boolean] + (~(B 'invoke) [~'_14__ ~(C 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__15|types) (*<> (t/isa? Character) (t/isa? Short))) + (def ~'>|__15 + (reify* [char+short>boolean] + (~(B 'invoke) [~'_15__ ~(C 'a) ~(S 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__16|types) (*<> (t/isa? Character) (t/isa? Character))) + (def ~'>|__16 + (reify* [char+char>boolean] + (~(B 'invoke) [~'_16__ ~(C 'a) ~(C 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__17|types) (*<> (t/isa? Character) (t/isa? Integer))) + (def ~'>|__17 + (reify* [char+int>boolean] + (~(B 'invoke) [~'_17__ ~(C 'a) ~(I 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__18|types) (*<> (t/isa? Character) (t/isa? Long))) + (def ~'>|__18 + (reify* [char+long>boolean] + (~(B 'invoke) [~'_18__ ~(C 'a) ~(L 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__19|types) (*<> (t/isa? Character) (t/isa? Float))) + (def ~'>|__19 + (reify* [char+float>boolean] + (~(B 'invoke) [~'_19__ ~(C 'a) ~(F 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__20|types) (*<> (t/isa? Character) (t/isa? Double))) + (def ~'>|__20 + (reify* [char+double>boolean] + (~(B 'invoke) [~'_20__ ~(C 'a) ~(D 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__21|types) (*<> (t/isa? Integer) (t/isa? Byte))) + (def ~'>|__21 + (reify* [int+byte>boolean] + (~(B 'invoke) [~'_21__ ~(I 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__22|types) (*<> (t/isa? Integer) (t/isa? Short))) + (def ~'>|__22 + (reify* [int+short>boolean] + (~(B 'invoke) [~'_22__ ~(I 'a) ~(S 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__23|types) (*<> (t/isa? Integer) (t/isa? Character))) + (def ~'>|__23 + (reify* [int+char>boolean] + (~(B 'invoke) [~'_23__ ~(I 'a) ~(C 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__24|types) (*<> (t/isa? Integer) (t/isa? Integer))) + (def ~'>|__24 + (reify* [int+int>boolean] + (~(B 'invoke) [~'_24__ ~(I 'a) ~(I 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__25|types) (*<> (t/isa? Integer) (t/isa? Long))) + (def ~'>|__25 + (reify* [int+long>boolean] + (~(B 'invoke) [~'_25__ ~(I 'a) ~(L 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__26|types) (*<> (t/isa? Integer) (t/isa? Float))) + (def ~'>|__26 + (reify* [int+float>boolean] + (~(B 'invoke) [~'_26__ ~(I 'a) ~(F 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__27|types) (*<> (t/isa? Integer) (t/isa? Double))) + (def ~'>|__27 + (reify* [int+double>boolean] + (~(B 'invoke) [~'_27__ ~(I 'a) ~(D 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__28|types) (*<> (t/isa? Long) (t/isa? Byte))) + (def ~'>|__28 + (reify* [long+byte>boolean] + (~(B 'invoke) [~'_28__ ~(L 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__29|types) (*<> (t/isa? Long) (t/isa? Short))) + (def ~'>|__29 + (reify* [long+short>boolean] + (~(B 'invoke) [~'_29__ ~(L 'a) ~(S 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__30|types) (*<> (t/isa? Long) (t/isa? Character))) + (def ~'>|__30 + (reify* [long+char>boolean] + (~(B 'invoke) [~'_30__ ~(L 'a) ~(C 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__31|types) (*<> (t/isa? Long) (t/isa? Integer))) + (def ~'>|__31 + (reify* [long+int>boolean] + (~(B 'invoke) [~'_31__ ~(L 'a) ~(I 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__32|types) (*<> (t/isa? Long) (t/isa? Long))) + (def ~'>|__32 + (reify* [long+long>boolean] + (~(B 'invoke) [~'_32__ ~(L 'a) ~(L 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__33|types) (*<> (t/isa? Long) (t/isa? Float))) + (def ~'>|__33 + (reify* [long+float>boolean] + (~(B 'invoke) [~'_33__ ~(L 'a) ~(F 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__34|types) (*<> (t/isa? Long) (t/isa? Double))) + (def ~'>|__34 + (reify* [long+double>boolean] + (~(B 'invoke) [~'_34__ ~(L 'a) ~(D 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__35|types) (*<> (t/isa? Float) (t/isa? Byte))) + (def ~'>|__35 + (reify* [float+byte>boolean] + (~(B 'invoke) [~'_35__ ~(F 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__36|types) (*<> (t/isa? Float) (t/isa? Short))) + (def ~'>|__36 + (reify* [float+short>boolean] + (~(B 'invoke) [~'_36__ ~(F 'a) ~(S 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__37|types) (*<> (t/isa? Float) (t/isa? Character))) + (def ~'>|__37 + (reify* [float+char>boolean] + (~(B 'invoke) [~'_37__ ~(F 'a) ~(C 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__38|types) (*<> (t/isa? Float) (t/isa? Integer))) + (def ~'>|__38 + (reify* [float+int>boolean] + (~(B 'invoke) [~'_38__ ~(F 'a) ~(I 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__39|types) (*<> (t/isa? Float) (t/isa? Long))) + (def ~'>|__39 + (reify* [float+long>boolean] + (~(B 'invoke) [~'_39__ ~(F 'a) ~(L 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__40|types) (*<> (t/isa? Float) (t/isa? Float))) + (def ~'>|__40 + (reify* [float+float>boolean] + (~(B 'invoke) [~'_40__ ~(F 'a) ~(F 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__41|types) (*<> (t/isa? Float) (t/isa? Double))) + (def ~'>|__41 + (reify* [float+double>boolean] + (~(B 'invoke) [~'_41__ ~(F 'a) ~(D 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__42|types) (*<> (t/isa? Double) (t/isa? Byte))) + (def ~'>|__42 + (reify* [double+byte>boolean] + (~(B 'invoke) [~'_42__ ~(D 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__43|types) (*<> (t/isa? Double) (t/isa? Short))) + (def ~'>|__43 + (reify* [double+short>boolean] + (~(B 'invoke) [~'_43__ ~(D 'a) ~(S 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__44|types) (*<> (t/isa? Double) (t/isa? Character))) + (def ~'>|__44 + (reify* [double+char>boolean] + (~(B 'invoke) [~'_44__ ~(D 'a) ~(C 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__45|types) (*<> (t/isa? Double) (t/isa? Integer))) + (def ~'>|__45 + (reify* [double+int>boolean] + (~(B 'invoke) [~'_45__ ~(D 'a) ~(I 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__46|types) (*<> (t/isa? Double) (t/isa? Long))) + (def ~'>|__46 + (reify* [double+long>boolean] + (~(B 'invoke) [~'_46__ ~(D 'a) ~(L 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__47|types) (*<> (t/isa? Double) (t/isa? Float))) + (def ~'>|__47 + (reify* [double+float>boolean] + (~(B 'invoke) [~'_47__ ~(D 'a) ~(F 'b)] ~'(. Numeric gt a b)))) + (def ~(O<> '>|__48|types) (*<> (t/isa? Double) (t/isa? Double))) + (def ~'>|__48 + (reify* [double+double>boolean] + (~(B 'invoke) [~'_48__ ~(D 'a) ~(D 'b)] ~'(. Numeric gt a b)))) + + ~>|dynamic-dispatch-form)) + :cljs + ($ (do (defn ~'> + ([a0 a1] + (ifs (double? a0) + (ifs (double? a1) + (let* [a a0 b a1] (cljs.core/> a b)) + (unsupported! `> [a0 a1] 1)) + (unsupported! `> [a0 a1] 0)))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) - (eval '(do (is= (>|test 0 1) (> 0 1)) - (is= (>|test 1 0) (> 1 0)) - (is= (>|test 1.0 0) (> 1.0 0)))))) + (eval '(do (is= (> 0 1) (core/> 0 1)) + (is= (> 1 0) (core/> 1 0)) + (is= (> 1.0 0) (core/> 1.0 0)))))) (deftest test|>long* (let [actual @@ -933,31 +961,31 @@ (t/isa? java.lang.Double))) (def ~'>long*|__0|0 (reify* [byte>long] - (~(tag "long" 'invoke) [~'_0__ ~(tag "byte" 'x)] + (~(L 'invoke) [~'_0__ ~(Y 'x)] ~'(. Primitive uncheckedLongCast x)))) (def ~'>long*|__0|1 (reify* [short>long] - (~(tag "long" 'invoke) [~'_1__ ~(tag "short" 'x)] + (~(L 'invoke) [~'_1__ ~(S 'x)] ~'(. Primitive uncheckedLongCast x)))) (def ~'>long*|__0|2 (reify* [char>long] - (~(tag "long" 'invoke) [~'_2__ ~(tag "char" 'x)] + (~(L 'invoke) [~'_2__ ~(C 'x)] ~'(. Primitive uncheckedLongCast x)))) (def ~'>long*|__0|3 (reify* [int>long] - (~(tag "long" 'invoke) [~'_3__ ~(tag "int" 'x)] + (~(L 'invoke) [~'_3__ ~(I 'x)] ~'(. Primitive uncheckedLongCast x)))) (def ~'>long*|__0|4 (reify* [long>long] - (~(tag "long" 'invoke) [~'_4__ ~(tag "long" 'x)] + (~(L 'invoke) [~'_4__ ~(L 'x)] ~'(. Primitive uncheckedLongCast x)))) (def ~'>long*|__0|5 (reify* [float>long] - (~(tag "long" 'invoke) [~'_5__ ~(tag "float" 'x)] + (~(L 'invoke) [~'_5__ ~(F 'x)] ~'(. Primitive uncheckedLongCast x)))) (def ~'>long*|__0|6 (reify* [double>long] - (~(tag "long" 'invoke) [~'_6__ ~(tag "double" 'x)] + (~(L 'invoke) [~'_6__ ~(D 'x)] ~'(. Primitive uncheckedLongCast x)))) ;; [x (t/ref (t/isa? Number))] @@ -966,7 +994,7 @@ (*<> ~(with-meta `(t/isa? Number) {:quantum.core.type/ref? true}))) (def ~'>long*|__1|0 (reify* [Object>long] - (~(tag "long" 'invoke) [~'_7__ ~(tag "java.lang.Object" 'x)] + (~(L 'invoke) [~'_7__ ~(O 'x)] (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(. x longValue))))) (defn ~'>long* @@ -1024,7 +1052,7 @@ (*<> (t/isa? java.lang.Boolean))) (def ~'ref-output-type|__0|0 (reify* [boolean>Object] - (~(O 'invoke) [~'_0__ ~(tag "boolean" 'x)] (new ~'Boolean ~'x)))) + (~(O 'invoke) [~'_0__ ~(B 'x)] (new ~'Boolean ~'x)))) ;; [x tt/byte? > (t/ref tt/byte?)] @@ -1032,7 +1060,7 @@ (*<> (t/isa? java.lang.Byte))) (def ~'ref-output-type|__1|0 (reify* [byte>Object] - (~(O 'invoke) [~'_1__ ~(tag "byte" 'x)] (new ~'Byte ~'x)))) + (~(O 'invoke) [~'_1__ ~(Y 'x)] (new ~'Byte ~'x)))) (defn ~'ref-output-type {:quantum.core.type/type @@ -1086,35 +1114,35 @@ #_(def ~'>long|__0|input-types (*<> byte?)) (def ~'>long|__0 (reify byte>long - (~(tag "long" 'invoke) [_## ~(tag "byte" 'x)] + (~(L 'invoke) [_## ~(Y 'x)] ;; Resolved from `(>long* x)` (.invoke >long*|__0 ~'x)))) #_(def ~'>long|__1|input-types (*<> char?)) (def ~'>long|__1 (reify char>long - (~(tag "long" 'invoke) [_## ~(tag "char" 'x)] + (~(L 'invoke) [_## ~(C 'x)] ;; Resolved from `(>long* x)` (.invoke >long*|__1 ~'x)))) #_(def ~'>long|__2|input-types (*<> short?)) (def ~'>long|__2 (reify short>long - (~(tag "long" 'invoke) [_## ~(tag "short" 'x)] + (~(L 'invoke) [_## ~(S 'x)] ;; Resolved from `(>long* x)` (.invoke >long*|__2 ~'x)))) #_(def ~'>long|__3|input-types (*<> tt/int?)) (def ~'>long|__3 (reify int>long - (~(tag "long" 'invoke) [_## ~(tag "int" 'x)] + (~(L 'invoke) [_## ~(I 'x)] ;; Resolved from `(>long* x)` (.invoke >long*|__3 ~'x)))) #_(def ~'>long|__4|input-types (*<> tt/long?)) (def ~'>long|__4 (reify long>long - (~(tag "long" 'invoke) [_## ~(tag "long" 'x)] + (~(L 'invoke) [_## ~(L 'x)] ;; Resolved from `(>long* x)` (.invoke >long*|__4 ~'x)))) @@ -1128,7 +1156,7 @@ (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE)))))) (def ~'>long|__5 (reify double>long - (~(tag "long" 'invoke) [_## ~(tag "double" 'x)] + (~(L 'invoke) [_## ~(D 'x)] ;; Resolved from `(>long* x)` (.invoke >long*|__6 ~'x)))) @@ -1138,7 +1166,7 @@ (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE)))))) (def ~'>long|__6 (reify float>long - (~(tag "long" 'invoke) [_## ~(tag "float" 'x)] + (~(L 'invoke) [_## ~(F 'x)] ;; Resolved from `(>long* x)` (.invoke >long*|__5 ~'x)))) @@ -1150,7 +1178,7 @@ (fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x)))))) (def ~'>long|__7 (reify Object>long - (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] + (~(L 'invoke) [_## ~(O 'x)] (let* [~(tag "clojure.lang.BigInt" 'x) ~'x] ~'(.lpart x))))) #_[x (t/and (t/isa? java.math.BigInteger) @@ -1161,7 +1189,7 @@ (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64))))) (def ~'>long|__8 (reify Object>long - (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] + (~(L 'invoke) [_## ~(O 'x)] (let* [~(tag "java.math.BigInteger" 'x) ~'x] ~'(.longValue x))))) #_[x ratio?] @@ -1172,7 +1200,7 @@ (*<> (-> long|__8|input-types (core/get 0) utr/and-type>args (core/get 1)))) (def ~'>long|__9 (reify Object>long - (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] + (~(L 'invoke) [_## ~(O 'x)] (let* [~(tag "clojure.lang.Ratio" 'x) ~'x] ;; Resolved from `(>long (.bigIntegerValue x))` ;; In this case, `(t/compare (t/type-of '(.bigIntegerValue x)) overload-type)`: @@ -1201,7 +1229,7 @@ (*<> (t/value true))) (def ~'>long|__10 (reify boolean>long - (~(tag "long" 'invoke) [_## ~(tag "boolean" 'x)] 1))) + (~(L 'invoke) [_## ~(B 'x)] 1))) #_[x (t/value false)] @@ -1209,7 +1237,7 @@ (*<> (t/value false))) (def ~'>long|__11 (reify boolean>long - (~(tag "long" 'invoke) [_## ~(tag "boolean" 'x)] 0))) + (~(L 'invoke) [_## ~(B 'x)] 0))) #_[x t/string?] @@ -1217,7 +1245,7 @@ (*<> t/string?)) (def ~'>long|__12 (reify Object>long - (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x)] + (~(L 'invoke) [_## ~(O 'x)] ~'(Long/parseLong x)))) #_[x t/string?] @@ -1226,7 +1254,7 @@ (*<> t/string? tt/int?)) (def ~'>long|__13 (reify Object+int>long - (~(tag "long" 'invoke) [_## ~(tag "java.lang.Object" 'x) ~(tag "int" 'radix)] + (~(L 'invoke) [_## ~(O 'x) ~(I 'radix)] ~'(Long/parseLong x radix)))) #_(defn >long @@ -1308,7 +1336,7 @@ (tag "java.lang.CharSequence" 'x))))))) (def ~'!str|__2|1 (reify* [int>Object] - (~(O 'invoke) [~'_3__ ~(tag "int" 'x)] + (~(O 'invoke) [~'_3__ ~(I 'x)] ~(tag "java.lang.StringBuilder" '(new StringBuilder x))))) (defn ~'!str @@ -1381,7 +1409,7 @@ (case (env-lang) :clj ($ (do (declare ~'defn-reference) (def ~'defn-reference|__0|0 - (reify* [>long] (~(tag "long" 'invoke) [~'_0__] ~'(>long* 1)))) + (reify* [>long] (~(L 'invoke) [~'_0__] ~'(>long* 1)))) (defn ~'defn-reference {:quantum.core.type/type (t/fn t/any? [])} ([] (.invoke ~(tag (str `>long) 'defn-reference|__0|0)))))))] @@ -1400,154 +1428,6 @@ nil))) (deftest dependent-type-test - (testing "Output type dependent on non-splittable input" - (testing "Not nested within another type" - (let [actual - (macroexpand ' - (self/defn dependent-type - ([x tt/boolean? > (t/type x)] x)) - expected - (case (env-lang) - :clj - ($ (do ...)))] - (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" - (eval actual) - (eval '(do ...)))))) - (testing "Nested within another type" - (testing "Without arg shadowing" - (let [actual - (macroexpand ' - (self/defn dependent-type-nest - ([x tt/boolean? > (t/or t/byte? (t/type x))] (if x x 1))) - expected - (case (env-lang) - :clj - ($ (do ...)))] - (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" - (eval actual) - (eval '(do ...)))))) - (testing "With arg shadowing" - (let [actual - (macroexpand ' - (self/defn dependent-type-nest-shadow - ([x tt/boolean? > (let [x (>long-checked "123")] - (t/or (t/isa? Byte) (t/type x)))] (if x x 1))) - expected - (case (env-lang) - :clj - ($ (do ...)))] - (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" - (eval actual) - (eval '(do ...)))))))) - (testing "Output type dependent on splittable but non-primitive-splittable input" - (let [actual - (macroexpand ' - (self/defn dependent-type-split - ([x (t/or tt/boolean? tt/string?) > (t/type x)] x)) - expected - (case (env-lang) - :clj - ($ (do ...)))] - (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" - (eval actual) - (eval '(do ...))))) - (testing "Output type dependent on primitive-splittable input" - (let [actual - (macroexpand ' - (self/defn dependent-type-split - ([x t/any? > (t/type x)] x))) - expected - (case (env-lang) - :clj - ($ (do ...)))] - (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" - (eval actual) - (eval '(do ...))))) - (testing "Input type dependent on other input type" - (testing "Dependent type is not for first input" - (let [actual - (macroexpand ' - (self/defn dependent-type-input - #_"1. Analyze `a` = `tt/byte?` - -> Put `a` in env as `(t/isa? Byte)` - 2. Analyze `b` = `(t/type a)` - -> Put `b` in env as `(t/isa? Byte)`" - ([a tt/byte?, b (t/type a)] a))) - expected - (case (env-lang) - :clj - ($ (do ...)))] - (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" - (eval actual) - (eval '(do ...))))) - (testing "Dependent type is for first input" - (let [actual - (macroexpand ' - (self/defn dependent-type-input-first - #_"1. Analyze `a` = `(t/type b)`. - 2. Analyze `b` = `tt/byte?` - -> Put `b` in env as `(t/isa? Byte)` - -> Put `a` in env as `(t/isa? Byte)`" - ([a (t/type b), b tt/byte?] a))) - expected - (case (env-lang) - :clj - ($ (do ...)))] - (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" - (eval actual) - (eval '(do ...)))))) - (testing "Output type dependent on input type which is dependent on other input type" - (testing "First input not splittable; second input not splittable" - (let [actual - (macroexpand ' - (self/defn dependent-type-2input - #_"1. Analyze `a` = `tt/byte?` - -> Put `a` in env as `(t/isa? Byte)` - 2. Analyze `b` = `(t/type a)` - -> Put `b` in env as `(t/isa? Byte)` - 3. Analyze out-type = `(t/type b)` - -> `(t/isa? Byte)`" - ([a tt/byte?, b (t/type a) > (t/type b)] b))) - expected - (case (env-lang) - :clj - ($ (do ...)))] - (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" - (eval actual) - (eval '(do ...))))) - (testing "First input splittable; second input not splittable" - (let [actual - (macroexpand ' - (self/defn dependent-type-2input-0split - #_"1. Analyze `a` = `(t/or tt/boolean? tt/byte?)`. Splittable. - 2. Split: - [[a tt/boolean?, b (t/type a) > (t/type b)] - [a tt/byte? , b (t/type a) > (t/type b)]] - 3. Analyze split 0. - 1. Analyze `a` = `tt/boolean?` - -> Put `a` in env as `(t/isa? Boolean)` - 2. Analyze `b` = `(t/type a)` - -> Put `b` in env as `(t/isa? Boolean)` - 3. Analyze out-type = `(t/type b)` - -> `(t/isa? Boolean)` - 4. Analyze split 1 in the same way." - ([a (t/or tt/boolean? tt/byte?), b (t/type a) > (t/type b)] b))) - expected - (case (env-lang) - :clj - ($ (do ...)))] - (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" - (eval actual) - (eval '(do ...)))))) (testing "Combination/integration test" (let [actual (macroexpand ' @@ -1558,129 +1438,6 @@ -> Put `out` in env as `(t/value 23)`" [out (t/type (>long-checked "23"))] (self/fn dependent-type-combo-inner - ;; This test overview was put up in ~30 minutes during a seemingly random walk of - ;; thoughts without any testing or research whatsoever that happened to actually - ;; coalesce into a working, clear, simple algorithm for handling dependent types. - ;; Not sure if listening to Bach Passacaglia & Fugue In C Minor for organ and - ;; then orchestra helped, but there you go :) - #_"1. Analyze `a` = `(t/or tt/boolean? (t/type b))` - - Put `a` on queue - 1. Analyze `tt/boolean?` - -> `(t/isa? Boolean)` - 2. Analyze `(t/type b)` - 1. Analyze `b` = `(t/or tt/byte? (t/type d))` - - Put `b` on queue - 1. Analyze `tt/byte?` - -> `(t/isa? Byte)` - 2. Analyze `(t/type d)` - 1. Analyze `d` = `(let [b (t/- tt/char? tt/long?)] - (t/or tt/char? (t/type b) (t/type c)))` - - Put `d` on queue - 1. Analyze `b` = `(t/- tt/char? tt/long?)` - -> Put `b` in env as `t/none?` - 2. Analyze `(t/or tt/char? (t/type b) (t/type c))` - 1. Analyze `tt/char?` - -> `(t/isa? Character)` - 2. Analyze `(t/type b)` - -> `t/none-type?` <-- be careful of this - 3. Analyze `(t/type c)` - 1. Analyze `c` = `(t/or tt/short? tt/char?)` - 1. Analyze `tt/short?` - -> `(t/isa? Short)` - 2. Analyze `tt/char?` - -> `(t/isa? Character)` - -> `c` candidate is: - `(t/or (t/isa? Short) (t/isa? Character))` - Splittable. - - Split: - [[a (t/or tt/boolean? (t/type b)) - b (t/or tt/byte? (t/type d)) - c (t/isa? Short) - d (let [b (t/- tt/char? tt/long?)] - (t/or tt/char? (t/type b) (t/type c))) - > (t/or (t/type b) (t/type d))] - [a (t/or tt/boolean? (t/type b)) - b (t/or tt/byte? (t/type d)) - c (t/isa? Character) - d (let [b (t/- tt/char? tt/long?)] - (t/or tt/char? (t/type b) (t/type c))) - > (t/or (t/type b) (t/type d))]] - - We continue with only Split 0 for brevity. Other - splits should be handled the same. - -> Put `c` in env as `(t/isa? Short)` - -> `(t/isa? Short)` - -> `(t/or (t/isa? Character) - t/none-type? - (t/isa? Short))` - - Remove `b` from env - - Remove `d` from queue - -> `d` candidate is: - `(t/or (t/isa? Character) - t/none-type? - (t/isa? Short))`. - Splittable. - - Split: - [[a (t/or tt/boolean? (t/type b)) - b (t/or tt/byte? (t/type d)) - c (t/isa? Short) - d (t/isa? Character) - > (t/or (t/type b) (t/type d))] - [a (t/or tt/boolean? (t/type b)) - b (t/or tt/byte? (t/type d)) - c (t/isa? Short) - d t/none-type? - > (t/or (t/type b) (t/type d))] - [a (t/or tt/boolean? (t/type b)) - b (t/or tt/byte? (t/type d)) - c (t/isa? Short) - d (t/isa? Short) - > (t/or (t/type b) (t/type d))]] - - We continue with only Split 0 for brevity. Other splits - should be handled the same. - -> Put `d` in env as `(t/isa? Character)` - -> `(t/isa? Character)` - -> `(t/isa? Character)` - - Remove `b` from queue - -> `b` candidate is: - `(t/or (t/isa? Byte) (t/isa? Character))` - Splittable. - - Split: - [[a (t/or tt/boolean? (t/type b)) - b (t/isa? Byte) - c (t/isa? Short) - d (t/isa? Character) - > (t/or (t/type b) (t/type d))] - [a (t/or tt/boolean? (t/type b)) - b (t/isa? Character) - c (t/isa? Short) - d (t/isa? Character) - > (t/or (t/type b) (t/type d))]] - - We continue with only Split 0 for brevity. Other splits should be - handled the same. - -> Put `b` in env as `(t/isa? Byte)` - -> `(t/isa? Byte)` - - Remove `a` from queue - -> `a` candidate is: - `(t/or (t/isa? Boolean) (t/isa? Byte))` - Splittable. - - Split: - [[a (t/isa? Boolean) - b (t/isa? Byte) - c (t/isa? Short) - d (t/isa? Character) - > (t/or (t/type b) (t/type d))] - [a (t/isa? Byte) - b (t/isa? Character) - c (t/isa? Short) - d (t/isa? Character) - > (t/or (t/type b) (t/type d))]] - - We continue with only Split 0 for brevity. Other splits should be handled - the same. - -> Put `a` in env as `(t/isa? Boolean)` - 2. Analyze out-type = `(t/or (t/type b) (t/type d))` - -> (Cutting obvious corners) `(t/or (t/isa? Byte) (t/isa? Character))` - - No splitting necessary because out-type - - All input types are in env and output-type was analyzed. DONE" ([a (t/or tt/boolean? (t/type b)) b (t/or tt/byte? (t/type d)) c (t/or tt/short? tt/char?) @@ -1694,48 +1451,7 @@ (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) - (eval '(do ...))))) - (testing "Two input types directly depend on each other" - (testing "Symbolically" - (let [actual - (macroexpand ' - (self/defn dependent-type-directin - #_"1. Analyze `a` = `(t/type b)` - - Put `a` on queue - 1. Analyze `b` = `(t/type a)` - - Put `b` on queue - -> ERROR: `a` not in environment and `a` already on queue; circular - dependency detected" - ([a (t/type b), b (t/type a)] b)))] - (testing "functionality" - (throws? (eval actual))))) - (testing "Non-symbolically" - (let [actual - (macroexpand ' - (self/defn dependent-type-directin - #_"1. Analyze `a` = `(t/type b)` - - Put `a` on queue - 1. Analyze `b` = `(t/type [a])` - - Put `b` on queue - 1. Analyze `[a]` - 1. Analyze `a` - -> ERROR: `a` not in environment and `a` already on queue; - circular dependency detected" - ([a (t/type b), b (t/type [a])] b)))] - (testing "functionality" - (throws? (eval actual)))))) - (testing "Two input types indirectly depend on each other" - (let [actual - (macroexpand ' - (self/defn dependent-type-indirectin - #_"1. Analyze `a` = `(t/type b)` - 1. Analyze `b` = `(t/type c)` - 1. Analyze `c` = `(t/type a)` - -> ERROR `a` not in environment and `a` already in queue; circular - dependency detected" - ([a (t/type b), b (t/type c), c (t/type a)] b)))] - (testing "functionality" - (throws? (eval actual)))))) + (eval '(do ...)))))) ;; ----- expanded code ----- ;; @@ -1878,7 +1594,7 @@ ;; =====|=====|=====|=====|===== ;; (self/defn zero? > tt/boolean? - ([x (t/- tt/boolean? tt/boolean?)] (Numeric/isZero x))) + ([x (t/- tt/primitive? tt/boolean?)] (Numeric/isZero x))) ; TODO CLJS version will come after #?(:clj @@ -1899,9 +1615,6 @@ (clojure.core/seq xs)))) ) -;; Works! -(seq (quantum.untyped.core.data.map/!hash-map 1 2)) - ;; ----- expanded code ----- ;; #?(:clj @@ -2063,35 +1776,6 @@ ;; ----- expanded code ----- ;; -; ================================================ ; - -(do - -; (optional) function — only when the `t/defn` has an arity with 0 arguments - -; (optional) inline macros — invoked only if in a typed context and not used as a function -(do #?(:clj (defmacro clj:name:java:lang:String [a0] `(let [~'x ~a0] ~'x))) - #?(:clj (defmacro cljs:name:string [a0] `(let [~'x ~a0] ~'x))) - #?(:clj (defmacro clj:name:clojure:lang:Named [a0] `(let [~'x ~a0] ~'(-name x)))) - #?(:clj (defmacro cljs:name:cljs:core:INamed [a0] `(let [~'x ~a0] ~'(.getName x))))) -) - -(self/extend-defn! abc/name ; for use outside of ns - ([a ?, b ?] (...))) - -;; This is necessarily dynamic dispatch -(name (read )) - -(do -; (optional) function — only when the `t/defn` has an arity with 0 arguments - -; (optional) inline macros — invoked only if in a typed context and not used as a function -(do #?(:clj (defmacro clj:name:java:lang:String [a0] `(let* [~'x ~a0] ~'x))) - #?(:clj (defmacro cljs:name:string [a0] `(let* [~'x ~a0] ~'x))) - #?(:clj (defmacro clj:name:clojure:lang:Named [a0] `(let* [~'x ~a0] ~'(-name x)))) - #?(:clj (defmacro cljs:name:cljs:core:INamed [a0] `(let* [~'x ~a0] ~'(.getName x))))) -) - ; ================================================ ; (self/defn ^:inline custom @@ -2100,42 +1784,3 @@ (s/fnt [x ?] (< x 0.1))) (t/or str? !str?)) y ?] (str x (name y))) ; uses the above-defined `name` - - -;; ===== CLOJURESCRIPT ===== ;; - -;; In order for specs to be enforceable at compile time, they must be able to be executed by the -;; compilation language. The case of one language compiled in a different one (e.g. ClojureScript -;; in Clojure/Java) is thus problematic. - -;; For instance, this is only able to be checked in CLJS, because `js-object?` is not implemented -;; in CLJ: -(self/defn abcde1 - [x #?(:clj str? :cljs js-object?)] ...) - -;; This could be checked in CLJ, but it would be an error to do so: -(defn my-spec [x] #?(:clj (check-this) :cljs (check-that))) - -(self/defn abcde2 - [x my-spec] ...) - -;; So what is the solution? One solution is to forgo some functionality in ClojureScript and -;; instead rely fundamentally on the aggregative relationships among predicates created using the -;; `t/defn` spec system. - -;; For instance: - -(self/defn abcde1 [x (t/pc :clj str? :cljs js-object?)] ...) - -;; Or: - -(t/def abcde1|x? :clj str? :cljs js-object?) - -(self/defn abcde1 [x abcde1|x?] ...) - -;; Because the spec was registered using the `t/defn` spec system, the quoted forms can be analyzed and -;; at least some things can be deduced. - -;; In this case, the spec of `x` is deducible: `abcde1|x?` (`js-object?` deeper down). The return spec is also deducible as being the return spec of `abcde1`: - -(self/defn abcde2 [x ?] (abcde1 x)) From 5f49512bfa7bc48e245e8b8119c033a8e2eddc33 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 11 Oct 2018 12:09:05 -0600 Subject: [PATCH 484/810] Mark as refused --- resources-dev/defnt.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 4eb5bf62..bf137c58 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -285,7 +285,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] binding - [ ] binding-conveyor-fn - [. .] bit-and - - [. .] bit-and-not + - [! !] bit-and-not - [x .] bit-clear - [| ] bit-count - [x .] bit-flip From 6eabdafa9340fc922d70880450c68e58d4f1b78c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 11 Oct 2018 12:09:20 -0600 Subject: [PATCH 485/810] We're not doing `err/msg+data>msg` anymore --- project-base.clj | 1 - src-untyped/quantum/untyped/core/error.cljc | 44 ++++++++------------- 2 files changed, 16 insertions(+), 29 deletions(-) diff --git a/project-base.clj b/project-base.clj index 9ea06393..a52d376d 100644 --- a/project-base.clj +++ b/project-base.clj @@ -409,7 +409,6 @@ 'quantum.untyped.core.print.prettier '[quantum.untyped.core.log :refer [prl!]]) (quantum.untyped.core.print.prettier/extend-pretty-printing!) - (reset! quantum.untyped.core.error/*pr-data-to-str? true) ;; For use with Atom's Proto-REPL ;; Interned in `clojure.core` in order to not be clobbered by `refresh` (intern 'clojure.core 'atom|proto-repl|print-fn diff --git a/src-untyped/quantum/untyped/core/error.cljc b/src-untyped/quantum/untyped/core/error.cljc index 80e4b0f4..4ca0650d 100644 --- a/src-untyped/quantum/untyped/core/error.cljc +++ b/src-untyped/quantum/untyped/core/error.cljc @@ -74,15 +74,6 @@ "Like `pr-str`, but pretty-prints." [x] (with-out-str (ppr x))) -(defonce *pr-data-to-str? - (atom #?(:clj false :cljs (boolean js/goog.DEBUG)))) - -(defn- msg+data>msg [msg data] - (if @*pr-data-to-str? - (str "Message: " msg "\n" - "Data:\n" (ppr-str data)) - msg)) - ;; ===== Error type: generic ===== ;; (def generic-error-type #?(:clj Throwable :cljs js/Error)) @@ -101,7 +92,7 @@ (defn >ex-info ([data] (>ex-info "Exception" data)) - ([msg data] (ex-info (msg+data>msg msg data) (or data {})))) + ([msg data] (ex-info msg (or data {})))) (def ex-info! (rcomp >ex-info (fn1 throw))) @@ -133,24 +124,24 @@ x (map? x) #?(:clj (err-constructor - (:ident x) (msg+data>msg (:message x) (:data x)) (:data x) (:trace x) (:cause x) + (:ident x) (:message x) (:data x) (:trace x) (:cause x) (meta x) (dissoc x :ident :message :data :trace :cause)) - :cljs (-> x map->Error (assoc :message (msg+data>msg (:message x) (:data x))))) + :cljs (-> x map->Error (assoc :message (:message x)))) (error? x) #?(:clj (let [^Throwable t x] (err-constructor - nil (msg+data>msg (.getLocalizedMessage t) (?ex-data t)) (?ex-data t) (.getStackTrace t) (some-> (.getCause t) >err) + nil (.getLocalizedMessage t) (?ex-data t) (.getStackTrace t) (some-> (.getCause t) >err) (meta t) {:type (class t)})) - :cljs (with-meta - (-> (err-constructor (.-name x) (msg+data>msg (.-message x) (?ex-data x)) (?ex-data x) (.-stack x) (.-cause x)) - ;; other non-standard fields - (cond-> (.-description x) (assoc :description (.-description x)) - (.-number x) (assoc :number (.-number x)) - (.-fileName x) (assoc :file-name (.-fileName x)) - (.-lineNumber x) (assoc :line-number (.-lineNumber x)) - (.-columnNumber x) (assoc :column-number (.-columnNumber x)))) - (meta x))) + :cljs (-> (err-constructor (.-name x) (.-message x) (?ex-data x) (.-stack x) + (.-cause x)) + ;; other non-standard fields + (cond-> (.-description x) (assoc :description (.-description x)) + (.-number x) (assoc :number (.-number x)) + (.-fileName x) (assoc :file-name (.-fileName x)) + (.-lineNumber x) (assoc :line-number (.-lineNumber x)) + (.-columnNumber x) (assoc :column-number (.-columnNumber x))) + (with-meta (meta x)))) (string? x) (>err nil x nil nil nil) :else @@ -161,12 +152,9 @@ (>err nil message data nil nil)) (let [ident a0 data a1] (>err ident nil data nil nil)))) - ([ident message data] - (>err ident message data nil nil)) - ([ident message data trace] - (>err ident message data trace nil)) - ([ident message data trace cause] - (err-constructor ident (msg+data>msg message data) data trace cause))) + ([ident message data] (>err ident message data nil nil)) + ([ident message data trace] (>err ident message data trace nil)) + ([ident message data trace cause] (err-constructor ident message data trace cause))) (def err! (rcomp >err (fn1 throw))) From 43bb104e7e9981f2a2296fa36a0df057d9f28ce8 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 11 Oct 2018 12:09:33 -0600 Subject: [PATCH 486/810] Add some mutable references to `quantum.untyped.core.refs` --- src-untyped/quantum/untyped/core/refs.cljc | 38 ++++++++++++++++++++++ 1 file changed, 38 insertions(+) diff --git a/src-untyped/quantum/untyped/core/refs.cljc b/src-untyped/quantum/untyped/core/refs.cljc index 2c286f4f..8203557f 100644 --- a/src-untyped/quantum/untyped/core/refs.cljc +++ b/src-untyped/quantum/untyped/core/refs.cljc @@ -1,4 +1,6 @@ (ns quantum.untyped.core.refs + (:refer-clojure :exclude + [get set]) (:require [quantum.untyped.core.core :as ucore])) @@ -13,3 +15,39 @@ :cljs (satisfies? cljs.core/IDeref x))) (defn ?deref [x] (if (derefable? x) @x x)) + +(defprotocol PMutableReference + (get [this]) + (set! [this v]) + (getAndSet [this v])) + +#?(:clj +(extend-protocol PMutableReference + ThreadLocal + (get [this] (.get this)) + (set! [this v] (.set this v) v) + (getAndSet [this v] (let [v-prev (.get this)] (.set this v) v-prev)))) + +(defn update! + "A nonatomic update." + [x f] (-> x (quantum.untyped.core.refs/set! (f (get x))))) + +;; ===== Unsynchronized mutability ===== ;; + +;; TODO create for every primitive datatype as well +(deftype MutableReference [#?(:clj ^:unsynchronized-mutable val :cljs ^:mutable val)] + PMutableReference + (get [this] val) + (set! [this v] (set! val v) val) + (getAndSet [this v] (let [v-prev val] (set! val v) v-prev)) + #?(:clj clojure.lang.IDeref + :cljs cljs.core/IDeref) + (#?(:clj deref :cljs -deref) [this] val)) + +;; ===== Thread-local mutability ===== ;; + +(defn >!thread-local #_> #_(t/isa? PMutableReference) + ([] #?(:clj (ThreadLocal.) + :cljs (MutableReference. nil))) + ([x] #?(:clj (doto (ThreadLocal.) (quantum.untyped.core.refs/set! x)) + :cljs (MutableReference. x)))) From a5ff0877513b9303b1e63092f5c2a454f84e8073 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 11 Oct 2018 12:10:29 -0600 Subject: [PATCH 487/810] Shorten `t/defn`s with dependent types --- src/quantum/core/data/bits.cljc | 120 ++++++++------------------------ src/quantum/core/data/meta.cljc | 6 +- 2 files changed, 32 insertions(+), 94 deletions(-) diff --git a/src/quantum/core/data/bits.cljc b/src/quantum/core/data/bits.cljc index 79ca1d9b..88c9ad6f 100644 --- a/src/quantum/core/data/bits.cljc +++ b/src/quantum/core/data/bits.cljc @@ -47,20 +47,11 @@ ([x p/double?] dec-double-bits)) ;; ===== Logical bit-operations ===== ;; -;; NOTE: we won't be supporting `and-not` +;; NOTE: we won't be supporting `clojure.core/and-not` -;; TODO TYPED we can shorten this by having dependent types (defnt ^:inline not "Bitwise `not`." - #?@(:clj [#_([x p/primitive? > (t/type x)] (Numeric/bitNot x)) - ([x p/boolean? > p/boolean?] (Numeric/bitNot x)) - ([x p/byte? > p/byte?] (Numeric/bitNot x)) - ([x p/short? > p/short?] (Numeric/bitNot x)) - ([x p/char? > p/char?] (Numeric/bitNot x)) - ([x p/int? > p/int?] (Numeric/bitNot x)) - ([x p/long? > p/long?] (Numeric/bitNot x)) - ([x p/float? > p/float?] (Numeric/bitNot x)) - ([x p/double? > p/double?] (Numeric/bitNot x))] + #?@(:clj [([x p/primitive? > (t/type x)] (Numeric/bitNot x))] :cljs [([x p/boolean? > p/boolean?] (if x false true)) ([x p/double? > (t/assume numerically-int?)] (core/bit-not x))])) @@ -191,120 +182,67 @@ ;; ----- Logical bit-shifts ---- ;; -;; TODO TYPED we can shorten this by having dependent types -;; TODO TYPED `t/numerically-integer?` (defnt ^:inline <<< "Unsigned (logical) bitwise shift left" -#?@(:clj [#_([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] - (Numeric/bitOr x n)) - ([x p/byte? , n p/integral? > p/byte?] (Numeric/shiftLeft x n)) - ([x p/short? , n p/integral? > p/short?] (Numeric/shiftLeft x n)) - ;; TODO implement this correctly because it likely isn't correct just to do `<<` in Java - #_([x p/char? , n p/integral? > p/char?] (Numeric/shiftLeft x n)) - ([x p/int? , n p/integral? > p/int?] (Numeric/shiftLeft x n)) - ([x p/long? , n p/integral? > p/long?] (Numeric/shiftLeft x n)) - ([x p/float? , n p/integral? > p/float?] (Numeric/shiftLeft x n)) - ([x p/double?, n p/integral? > p/double?] (Numeric/shiftLeft x n))] - :cljs [([x p/double?, n std-fixint? > (t/assume numerically-int?)] (core/bit-shift-left x n))])) +#?(:clj ;; TODO implement the `char` op correctly because it likely isn't correct just to do + ;; the straight bit op in Java + ([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] (Numeric/shiftLeft x n)) + :cljs ([x p/double?, n std-fixint? > (t/assume numerically-int?)] (core/bit-shift-left x n)))) + -;; TODO TYPED we can shorten this by having dependent types (defnt ^:inline >>> - "Unsigned (logical) bitwise shift right" -#?@(:clj [#_([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] - (Numeric/bitOr a b)) - ([x p/byte? , n p/integral? > p/byte?] (Numeric/uShiftRight x n)) - ([x p/short? , n p/integral? > p/short?] (Numeric/uShiftRight x n)) - ([x p/char? , n p/integral? > p/char?] (Numeric/uShiftRight x n)) - ([x p/int? , n p/integral? > p/int?] (Numeric/uShiftRight x n)) - ([x p/long? , n p/integral? > p/long?] (Numeric/uShiftRight x n)) - ([x p/float? , n p/integral? > p/float?] (Numeric/uShiftRight x n)) - ([x p/double?, n p/integral? > p/double?] (Numeric/uShiftRight x n))] - :cljs [([x p/double?, n std-fixint? > (t/assume numerically-int?)] - (core/unsigned-bit-shift-right x n))])) + "Unsigned logical) bitwise shift right" +#?(:clj ;; TODO implement the `char` op correctly because it likely isn't correct just to do + ;; the straight bit op in Java + ([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] (Numeric/uShiftRight a b)) + :cljs ([x p/double?, n std-fixint? > (t/assume numerically-int?)] + (core/unsigned-bit-shift-right x n)))) ;; ----- Arithmetic bit-shifts ----- ;; -;; TODO TYPED we can shorten this by having dependent types (defnt ^:inline << "Arithmetic bitwise shift left" -#?@(:clj [#_([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] - (Numeric/bitOr a b)) - ([x p/byte? , n p/integral? > p/byte?] (Numeric/shiftLeft x n)) - ([x p/short? , n p/integral? > p/short?] (Numeric/shiftLeft x n)) - ([x p/char? , n p/integral? > p/char?] (Numeric/shiftLeft x n)) - ([x p/int? , n p/integral? > p/int?] (Numeric/shiftLeft x n)) - ([x p/long? , n p/integral? > p/long?] (Numeric/shiftLeft x n)) - ([x p/float? , n p/integral? > p/float?] (Numeric/shiftLeft x n)) - ([x p/double?, n p/integral? > p/double?] (Numeric/shiftLeft x n))] - :cljs [([x p/double?, n std-fixint? > (t/assume numerically-int?)] (core/bit-shift-left x n))])) +#?(:clj ;; TODO implement the `char` op correctly because it likely isn't correct just to do + ;; the straight bit op in Java + ([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] (Numeric/shiftLeft a b)) + :cljs ([x p/double?, n std-fixint? > (t/assume numerically-int?)] (core/bit-shift-left x n)))) -;; TODO TYPED we can shorten this by having dependent types +;; TODO TYPED `t/numerically-int?` (defnt ^:inline >> "Arithmetic bitwise shift right" -#?@(:clj [#_([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] - (Numeric/bitOr a b)) - ([x p/byte? , n p/integral? > p/byte?] (Numeric/shiftRight x n)) - ([x p/short? , n p/integral? > p/short?] (Numeric/shiftRight x n)) - ([x p/char? , n p/integral? > p/char?] (Numeric/shiftRight x n)) - ([x p/int? , n p/integral? > p/int?] (Numeric/shiftRight x n)) - ([x p/long? , n p/integral? > p/long?] (Numeric/shiftRight x n)) - ([x p/float? , n p/integral? > p/float?] (Numeric/shiftRight x n)) - ([x p/double?, n p/integral? > p/double?] (Numeric/shiftRight x n))] - :cljs [([x p/double?, n std-fixint? > (t/assume numerically-int?)] - (core/bit-shift-right x n))])) +#?(:clj ;; TODO implement the `char` op correctly because it likely isn't correct just to do + ;; the straight bit op in Java + ([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] (Numeric/shiftRight a b)) + :cljs ([x p/double?, n std-fixint? > (t/assume numerically-int?)] (core/bit-shift-right x n)))) ;; ===== Single-bit operations ===== ;; ;; TODO add bit operations with checked indices -;; TODO TYPED we can shorten this by having dependent types (defnt ^:inline bit-set-false* "Makes the bit at the provided index ->`i` `bit-false`. Unchecked w.r.t. the bit index. Equivalent to `clojure.core/bit-clear`." {:todo #{"Extend index to non-longs"}} -#?@(:clj [#_([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitClear x i)) - ([x p/byte? , i p/long? > p/byte?] (Numeric/bitClear x i)) - ([x p/short? , i p/long? > p/short?] (Numeric/bitClear x i)) - ([x p/char? , i p/long? > p/char?] (Numeric/bitClear x i)) - ([x p/int? , i p/long? > p/int?] (Numeric/bitClear x i)) - ([x p/long? , i p/long? > p/long?] (Numeric/bitClear x i)) - ([x p/float? , i p/long? > p/float?] (Numeric/bitClear x i)) - ([x p/double?, i p/long? > p/double?] (Numeric/bitClear x i))] - :cljs [([x p/double?, i std-fixint? > (t/assume numerically-int?)] (core/bit-clear x i))])) +#?(:clj ([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitClear x i)) + :cljs ([x p/double?, i std-fixint? > (t/assume numerically-int?)] (core/bit-clear x i)))) + -;; TODO TYPED we can shorten this by having dependent types (defnt ^:inline bit-set-true* "Makes the bit at the provided index ->`i` `bit-true`. Unchecked w.r.t. the bit index. Equivalent to `clojure.core/bit-set`." {:todo #{"Extend index to non-longs"}} -#?@(:clj [#_([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitSet x i)) - ([x p/byte? , i p/long? > p/byte?] (Numeric/bitSet x i)) - ([x p/short? , i p/long? > p/short?] (Numeric/bitSet x i)) - ([x p/char? , i p/long? > p/char?] (Numeric/bitSet x i)) - ([x p/int? , i p/long? > p/int?] (Numeric/bitSet x i)) - ([x p/long? , i p/long? > p/long?] (Numeric/bitSet x i)) - ([x p/float? , i p/long? > p/float?] (Numeric/bitSet x i)) - ([x p/double?, i p/long? > p/double?] (Numeric/bitSet x i))] - :cljs [([x p/double?, i std/fixint? > (t/assume numerically-int?)] (core/bit-set x i))])) +#?(:clj ([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitSet x i)) + :cljs ([x p/double?, i std/fixint? > (t/assume numerically-int?)] (core/bit-set x i)))) -;; TODO TYPED we can shorten this by having dependent types (defnt ^:inline bit-not* "Applies `not` to the bit at the provided index ->`i`. Unchecked w.r.t. the bit index. Equivalent to `clojure.core/bit-flip`." {:todo #{"Extend index to non-longs"}} -#?@(:clj [#_([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitFlip x i)) - ([x p/byte? , i p/long? > p/byte?] (Numeric/bitFlip x i)) - ([x p/short? , i p/long? > p/short?] (Numeric/bitFlip x i)) - ([x p/char? , i p/long? > p/char?] (Numeric/bitFlip x i)) - ([x p/int? , i p/long? > p/int?] (Numeric/bitFlip x i)) - ([x p/long? , i p/long? > p/long?] (Numeric/bitFlip x i)) - ([x p/float? , i p/long? > p/float?] (Numeric/bitFlip x i)) - ([x p/double?, i p/long? > p/double?] (Numeric/bitFlip x i))] - :cljs [([x p/double?, i std-fixint? > (t/assume numerically-int?)] - (core/bit-flip x i))])) +#?(:clj ([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitFlip x i)) + :cljs ([x p/double?, i std-fixint? > (t/assume numerically-int?)] (core/bit-flip x i)))) (defnt ^:inline bit-true?* "Outputs whether the bit at the provided index ->`i` is `bit-true`. diff --git a/src/quantum/core/data/meta.cljc b/src/quantum/core/data/meta.cljc index adc5a15c..f54a43b2 100644 --- a/src/quantum/core/data/meta.cljc +++ b/src/quantum/core/data/meta.cljc @@ -36,13 +36,13 @@ ;; TODO `f` should more specifically be able to handle the args arity and specs {:incorporated '{clojure.core/vary-meta "9/2018" cljs.core/vary-meta "9/2018"}} - [x (t/and with-metable? metable?) f (t/fn meta? [& (t/type-of %args)]) & args _] + [x (t/and with-metable? metable?) f (t/fn meta? [& (t/type args)]) & args _] (with-meta x (apply f (meta x) args))) ;; TODO TYPED #_(t/defn merge-meta - {:alternate-implementations #{'cljs.tools.reader/merge-meta}} - [x (t/and with-metable? metable?) meta- meta? > (t/spec-of x)] + {:incorporated #{'cljs.tools.reader/merge-meta}} + [x (t/and with-metable? metable?) meta- meta? > (t/value-of x)] (update-meta x merge meta-)) ;; TODO TYPED From f8b5271a6fc50c3b381cd04c1b7a3e6784f0d042 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 11 Oct 2018 12:10:38 -0600 Subject: [PATCH 488/810] Add some mutable references to `quantum.core.refs` --- src/quantum/core/refs.cljc | 33 ++++++++------------------------- 1 file changed, 8 insertions(+), 25 deletions(-) diff --git a/src/quantum/core/refs.cljc b/src/quantum/core/refs.cljc index 0317ac98..18090e8d 100644 --- a/src/quantum/core/refs.cljc +++ b/src/quantum/core/refs.cljc @@ -27,6 +27,8 @@ [java.util.concurrent.atomic AtomicReference AtomicBoolean AtomicInteger AtomicLong] [com.google.common.util.concurrent AtomicDouble]))) +(defalias uref/>!thread-local) + ;; TODO technically this belongs in like `quantum.core.data.effects` or something (defprotocol Transactional (transact [target f] [target f opts] @@ -114,31 +116,12 @@ #_java.util.concurrent.atomic.AtomicDouble com.google.common.util.concurrent.AtomicDouble))) -;; TODO TYPED -(defprotocol IValue - (get [this]) - (set [this newv])) - -; ===== UNSYNCHRONIZED MUTABILITY ===== ; - -;; TODO TYPED (was interface in CLJ, not protocol) -(defprotocol IMutableReference - (get [this]) - (set [this v]) - (getAndSet [this v])) - -;; TODO create for every primitive datatype as well -(deftype MutableReference [#?(:clj ^:unsynchronized-mutable val :cljs ^:mutable val)] - IMutableReference - (get [this] val) - (set [this v] (set! val v) val) - (getAndSet [this v] (let [v-prev val] (set! val v) v-prev)) - #?(:clj clojure.lang.IDeref - :cljs cljs.core/IDeref) - (#?(:clj deref :cljs -deref) [this] val)) - - (defnt !ref* "Creates a mutable reference to an Object." [x] (MutableReference. x)) -#?(:clj (defmacro !ref ([] `(MutableReference. nil)) ([x] `(!ref* ~x)))) +;; ===== Unsynchronized mutability ===== ;; + +(defnt !ref + "Creates an unsynchronized mutable reference to an Object." + ([] (!ref nil)) + ([x (t/ref t/any?)] (MutableReference. x))) (defn gen-primitive-mutable-interface-and-deftype [kind] (let [interface-sym (symbol (str "IMutable" (str/capitalize (name kind)))) From 755d2d452b5b77afaf7d26eaa9a2a282702236b9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 11 Oct 2018 12:10:49 -0600 Subject: [PATCH 489/810] Efficient `last` for reversible --- .../quantum/untyped/core/collections.cljc | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index 86f23ece..8877367e 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -193,12 +193,18 @@ [xs] (dec (count xs))) -(defn last [xs] - (if (or (and (counted? xs) (indexed? xs)) - (string? xs) - (array? xs)) - (get xs (lasti xs)) - (core/last xs))) +(defn last + "Gets the last element of ->`xs` in as short a time as possible. + In the case of collections that are both counted and indexed, this is sublinear (often `O(1)`). + Otherwise, resorts to a linear traversal." + [xs] + (ifs (or (and (counted? xs) (indexed? xs)) + (string? xs) + (array? xs)) + (get xs (lasti xs)) + (reversible? xs) + (-> xs rseq first) + (core/last xs))) ;; ===== Keyed ==== ;; From 527e6dbc835d18df19ac8d1a20a561f0980852bc Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 11 Oct 2018 12:11:04 -0600 Subject: [PATCH 490/810] Get complicated example to actually work!! --- src-untyped/quantum/untyped/core/analyze.cljc | 153 +++++++++-------- test/quantum/test/untyped/core/analyze.cljc | 156 ++++++++++++++---- .../quantum/test/untyped/core/type/defnt.cljc | 94 +++++------ 3 files changed, 258 insertions(+), 145 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index d160a619..67a85961 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -12,6 +12,7 @@ :refer [istr]] [quantum.untyped.core.data :refer [kw-map]] + [quantum.untyped.core.data.set :as uset] [quantum.untyped.core.defnt :refer [defns defns- fns]] [quantum.untyped.core.error :as uerr @@ -30,6 +31,8 @@ :refer [ppr]] [quantum.untyped.core.reducers :as r :refer [educe join reducei]] + [quantum.untyped.core.refs :as uref + :refer [>!thread-local]] [quantum.untyped.core.spec :as s] [quantum.untyped.core.type :as t :refer [?]] @@ -156,7 +159,9 @@ ;; ----- End reflection support ----- ;; -(defonce *analyze-depth (atom 0)) +(defonce !!analyze-arg-syms|iter (>!thread-local 0)) ; `nneg-fixint?` + +(defonce !!analyze-depth (>!thread-local 0)) (defn add-file-context-from [to from] (let [{:keys [line column]} (meta from)] @@ -193,7 +198,7 @@ (s/def ::env (s/map-of (s/or* symbol? #(= % :opts)) t/any?)) -(declare analyze*) +(declare analyze* analyze-arg-syms*) (defns- analyze-non-map-seqable "Analyzes a non-map seqable." @@ -745,6 +750,7 @@ deftype* (TODO "deftype*") fn* (TODO "fn*") def (TODO "def") + set! (TODO "set!") . (analyze-seq|dot env form) if (analyze-seq|if env form) quote (analyze-seq|quote env form) @@ -778,7 +784,9 @@ :type (:type expanded)}))))) (defns- ?resolve [env ::env, sym symbol?] - (if-let [[_ local] (find env sym)] + (if-let [[_ local] (or (find env sym) + (and (-> env :opts :arglist-context?) + (-> env :opts :arg-env deref (find sym))))] {:resolved local :resolved-via :env} (let [resolved (uvar/resolve *ns* sym)] (ifs resolved @@ -789,20 +797,32 @@ :resolved-via :dot} nil)))) +(defns- analyze-symbol|arglist-context + "Handles forward dependent-type dependencies e.g. `[a (type b) b t/any?]`" + [env ::env form symbol?] + (l/if-let [_ (-> env :opts :arglist-context?) + arg-type-form (-> env :opts :arg-sym->arg-type-form (get form))] + (let [env' {:opts (update (:opts env) :arglist-syms|queue + (fn [q] + (if (contains? q form) + (err! "Cyclic dependency between two input types" + {:dependent-sym (uc/last q) + :dependent-type-form + (-> env :opts :arg-sym->arg-type-form (get (uc/last q))) + :dependee-sym form + :dependee-type-form arg-type-form}) + (conj q form))))} + result (analyze-arg-syms* env')] + ;; We need to propagate the result upward and this is arguably the cleanest control flow + ;; mechanism to do it, sadly + (err! ::arg-splits-performed "All arg-splits performed" {:result result})) + (err! "Could not resolve symbol" {:sym form}))) + (defns- analyze-symbol "Analyzes vars as if their value is constant, unless they're marked as dynamic." [env ::env, form symbol? > uast/symbol?] (if-not-let [{:keys [resolved resolved-via]} (?resolve env form)] - ;; Handles forward dependent-type dependencies e.g. `[a (type b) b t/any?]` - (l/if-let [_ (-> env :opts :arglist-context?) - arg-type-form (-> env :opts :arg-sym->arg-type-form (get form))] - (TODO) - #_(let [_ (pr! (:opts env)) - env' (update-in env [:opts :arglist-syms|queue] conj form) - analyzed (analyze* env' arg-type-form)] - (pr! analyzed) - (TODO)) - (err! "Could not resolve symbol" {:sym form})) + (analyze-symbol|arglist-context env form) (let [node (case resolved-via (:env :dot) resolved :resolve @@ -822,7 +842,7 @@ (uast/symbol env form node (:type node)))))) (defns- analyze* [env ::env, form _ > uast/node?] - (when (> (swap! *analyze-depth inc) 200) (throw (ex-info "Stack too deep" {:form form}))) + (when (> (uref/update! !!analyze-depth inc) 200) (throw (ex-info "Stack too deep" {:form form}))) (ifs (symbol? form) (analyze-symbol env form) (t/literal? form) @@ -863,12 +883,14 @@ > uast/node? ([form _] (analyze {} form)) ([env ::env, form _] - (reset! *analyze-depth 0) + (uref/set! !!analyze-depth 0) (analyze* env form))) +;; ===== Arglist analysis ===== ;; + (s/def ::arg-sym->arg-type-form (s/map-of simple-symbol? t/any?)) -(def analyze-arg-syms|max-iter 100) +(def analyze-arg-syms|max-iter 1000) ;; TODO excise (defn pr! [x] @@ -904,54 +926,37 @@ vec)] (uc/distinct (join primitive-subtypes (type>split t))))) -(defn- analyze-arg-syms* - [env #_::env - arg-sym->arg-type-form #_::arg-sym->arg-type-form - out-type-form - arglist-syms|queue #_(dc/set-of id/symbol?) - arglist-syms|unanalyzed #_(dc/set-of id/symbol?) - n|iter #_nneg-fixint?] - (pr! (kw-map #_env arglist-syms|queue arglist-syms|unanalyzed n|iter)) - (ifs (empty? arglist-syms|unanalyzed) - [{:env env - :out-type-node (-> (analyze env out-type-form) (update :type t/unvalue))}] - (>= n|iter analyze-arg-syms|max-iter) - (err! "Max number of iterations reached for `analyze-arg-syms" {:n n|iter}) - (let [arg-sym (first arglist-syms|unanalyzed) - arg-type-form (arg-sym->arg-type-form arg-sym) - env' (update env :opts - #(assoc % :arglist-syms|queue (conj arglist-syms|queue arg-sym) - :arglist-syms|unanalyzed arglist-syms|unanalyzed)) - analyzed (-> (analyze env' arg-type-form) (update :type t/unvalue)) - t-split (-> analyzed :type type>split+primitivized)] - (pr! {:arg-sym arg-sym - :t (:type analyzed) - :t-split t-split - :arglist-syms|queue (:arglist-syms|queue analyzed) - :arglist-syms|unanalyzed (:arglist-syms|unanalyzed analyzed)}) - (if (-> t-split count (= 1)) - (let [env' (assoc (:env analyzed) arg-sym analyzed)] - (recur env' - arg-sym->arg-type-form - out-type-form - (:arglist-syms|queue analyzed) - (:arglist-syms|unanalyzed analyzed) - (inc n|iter))) - (->> t-split - (uc/mapcat+ - (fn [t] - (analyze-arg-syms* - (assoc (:env analyzed) arg-sym (assoc analyzed :type t)) - arg-sym->arg-type-form - out-type-form - (conj arglist-syms|queue arg-sym) - ;; TODO re-enable - #_(:arglist-syms|queue analyzed) - (disj arglist-syms|unanalyzed arg-sym) - ;; TODO re-enable - #_(:arglist-syms|unanalyzed analyzed) - (inc n|iter)))) - r/join))))) +(defn- analyze-arg-syms* [env #_::env] + (uref/update! !!analyze-arg-syms|iter inc) + (let [{:keys [arg-sym->arg-type-form arglist-syms|queue arglist-syms|unanalyzed out-type-form]} + (:opts env)] + (ifs (empty? arglist-syms|unanalyzed) + [{:env env + :out-type-node (-> (analyze env out-type-form) (update :type t/unvalue))}] + (>= (uref/get !!analyze-arg-syms|iter) analyze-arg-syms|max-iter) + (err! "Max number of iterations reached for `analyze-arg-syms" + {:n (uref/get !!analyze-arg-syms|iter)}) + (let [_ (assert (not (empty? arglist-syms|queue))) + arg-sym (uc/last arglist-syms|queue) + arg-type-form (arg-sym->arg-type-form arg-sym) + analyzed (-> (analyze env arg-type-form) (update :type t/unvalue)) + env-analyzed (-> analyzed :env + (update-in [:opts :arglist-syms|queue] disj arg-sym) + (update-in [:opts :arglist-syms|unanalyzed] disj arg-sym)) + t-split (-> analyzed :type type>split+primitivized)] + (if (-> t-split count (= 1)) + (recur (update-in env-analyzed [:opts :arg-env] + #(doto % (swap! assoc arg-sym analyzed)))) + (->> t-split + (uc/mapcat+ + (fn [t] + (analyze-arg-syms* + (-> env-analyzed + (update-in [:opts :arg-env] + ;; `(atom (deref %))` in order to create a new env for a new split + #(-> % deref atom + (doto (swap! assoc arg-sym (assoc analyzed :type t))))))))) + r/join)))))) (defns analyze-arg-syms "Performance characteristics: @@ -966,9 +971,17 @@ (analyze-arg-syms {} arg-sym->arg-type-form out-type-form)) ([env ::env, arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _ > (s/vec-of (s/kv {:env ::env :out-type-node uast/node?}))] - (analyze-arg-syms* - (update env :opts - #(assoc % :arglist-context? true - :arg-sym->arg-type-form arg-sym->arg-type-form - :out-type-form out-type-form)) - arg-sym->arg-type-form out-type-form #{} (-> arg-sym->arg-type-form keys set) 0))) + (uref/set! !!analyze-arg-syms|iter 0) + (try (analyze-arg-syms* + {:opts (assoc (:opts env) + :arglist-context? true + :arglist-syms|queue (uset/ordered-set + (-> arg-sym->arg-type-form keys first)) + :arglist-syms|unanalyzed (-> arg-sym->arg-type-form keys set) + :arg-env (atom env) ; Mutable so it can cache + :arg-sym->arg-type-form arg-sym->arg-type-form + :out-type-form out-type-form)}) + (catch Throwable t + (if (and (uerr/error-map? t) (-> t :ident (= ::arg-splits-performed))) + (-> t :data :result) + (throw t)))))) diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index f5cd3666..ce3959c8 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -8,14 +8,9 @@ [quantum.untyped.core.fn :refer [<-]] [quantum.untyped.core.test - :refer [deftest is is= testing]] + :refer [deftest is is= testing throws]] [quantum.untyped.core.type :as t])) -(self/analyze-arg-syms {'x `tt/boolean?} `(t/type ~'x)) -(self/analyze-arg-syms {'x `tt/boolean?} `tt/byte) -(self/analyze-arg-syms {'x `tt/boolean?} `(tt/value tt/byte)) -(self/analyze-arg-syms {'x `tt/boolean?} `(t/isa? Byte)) - ;; Simulates a typed fn (defn- >long-checked {:quantum.core.type/type (t/ftype nil [t/string? :> tt/long?])} @@ -23,7 +18,7 @@ (defn- transform-ana [ana] (->> ana - (mapv #(do [(->> % :env (<- (dissoc :opts)) (uc/map-vals' :type)) + (mapv #(do [(->> % :env :opts :arg-env deref (uc/map-vals' :type)) (-> % :out-type-node :type)])))) ;; More dependent type tests in `quantum.test.untyped.core.type.defnt` but those are more like @@ -36,8 +31,8 @@ 2. Analyze out-type = `(t/type x)` -> `(t/isa? Boolean)`" (let [ana (self/analyze-arg-syms '{x tt/boolean?} '(t/type x))] - (is= [[{'x tt/boolean?} tt/boolean?]] - (transform-ana ana)))) + (is= (transform-ana ana) + [[{'x tt/boolean?} tt/boolean?]]))) (testing "Nested within another type" (testing "Without arg shadowing" #_"1. Analyze `x` = `tt/boolean?` @@ -47,8 +42,8 @@ -> `(t/isa? Boolean)` -> `(t/or (t/isa? Byte) (t/isa? Boolean))`" (let [ana (self/analyze-arg-syms '{x tt/boolean?} '(t/or tt/byte? (t/type x)))] - (is= [[{'x tt/boolean?} (t/or tt/byte? tt/boolean?)]] - (transform-ana ana)))) + (is= (transform-ana ana) + [[{'x tt/boolean?} (t/or tt/byte? tt/boolean?)]]))) (testing "With arg shadowing" #_"1. Analyze `x` = `tt/boolean?` -> Put `x` in env as `(t/isa? Boolean)` @@ -64,8 +59,8 @@ '{x tt/boolean?} '(let [x (>long-checked "123")] (t/or (t/isa? Byte) (t/type x))))] - (is= [[{'x tt/boolean?} (t/or (t/isa? Byte) tt/long?)]] - (transform-ana ana)))))) + (is= (transform-ana ana) + [[{'x tt/boolean?} (t/or (t/isa? Byte) tt/long?)]]))))) (testing "Output type dependent on splittable but non-primitive-splittable input" #_"1. Analyze `x` = `(t/or tt/boolean? tt/string?)`. Splittable. 2. Split `(t/or tt/boolean? tt/string?)`: @@ -84,9 +79,9 @@ (let [ana (self/analyze-arg-syms {'x '(t/or tt/boolean? tt/string?)} '(t/type x))] - (is= [[{'x tt/boolean?} tt/boolean?] - [{'x tt/string?} tt/string?]] - (transform-ana ana)))) + (is= (transform-ana ana) + [[{'x tt/boolean?} tt/boolean?] + [{'x tt/string?} tt/string?]]))) (testing "Output type dependent on primitive-splittable input" #_"1. Analyze `x` = `t/any?`. Primitive-splittable. 2. Split `t/any?`: @@ -99,7 +94,8 @@ -> `(t/isa? Boolean)` 4. Analyze rest of splits in the same way." (let [ana (self/analyze-arg-syms {'x 't/any?} '(t/type x))] - (is= [[{'x tt/boolean?} tt/boolean?] + (is= (transform-ana ana) + [[{'x tt/boolean?} tt/boolean?] [{'x tt/byte?} tt/byte?] [{'x tt/short?} tt/short?] [{'x tt/char?} tt/char?] @@ -107,23 +103,25 @@ [{'x tt/long?} tt/long?] [{'x tt/float?} tt/float?] [{'x tt/double?} tt/double?] - [{'x t/any?} t/any?]] - (transform-ana ana)))) + [{'x t/any?} t/any?]]))) (testing "Input type dependent on other input type" (testing "Dependent type is not for first input" #_"1. Analyze `a` = `tt/byte?` -> Put `a` in env as `(t/isa? Byte)` 2. Analyze `b` = `(t/type a)` -> Put `b` in env as `(t/isa? Byte)`" + ;; TODO (let [ana (self/analyze-arg-syms '{a tt/byte?, b (t/type a)} 't/any?)] - (is= [[{'a tt/byte? 'b tt/byte?} t/any?]] - (transform-ana ana)))) + (is= (transform-ana ana) + [[{'a tt/byte? 'b tt/byte?} t/any?]]))) (testing "Dependent type is for first input" #_"1. Analyze `a` = `(t/type b)`. 2. Analyze `b` = `tt/byte?` -> Put `b` in env as `(t/isa? Byte)` -> Put `a` in env as `(t/isa? Byte)`" - (let [ana (self/analyze-arg-syms '{a (t/type b) b tt/byte?} 't/any?)]))) + (let [ana (self/analyze-arg-syms '{a (t/type b) b tt/byte?} 't/any?)] + (is= (transform-ana ana) + [[{'a (t/isa? Byte) 'b (t/isa? Byte)} t/any?]])))) (testing "Output type dependent on input type which is dependent on other input type" (testing "First input not splittable; second input not splittable" #_"1. Analyze `a` = `tt/byte?` @@ -132,7 +130,9 @@ -> Put `b` in env as `(t/isa? Byte)` 3. Analyze out-type = `(t/type b)` -> `(t/isa? Byte)`" - (let [ana (self/analyze-arg-syms '{a tt/byte? b (t/type a)} '(t/type b))])) + ;; TODO + (let [ana (self/analyze-arg-syms '{a tt/byte? b (t/type a)} '(t/type b))] + (transform-ana ana))) (testing "First input splittable; second input not splittable" #_"1. Analyze `a` = `(t/or tt/boolean? tt/byte?)`. Splittable. 2. Split: @@ -146,6 +146,7 @@ 3. Analyze out-type = `(t/type b)` -> `(t/isa? Boolean)` 4. Analyze split 1 in the same way." + ;; TODO (let [ana (self/analyze-arg-syms '{a (t/or tt/boolean? tt/byte?) b (t/type a)} '(t/type b))])) (testing "Two input types directly depend on each other" @@ -156,7 +157,7 @@ - Put `b` on queue -> ERROR: `a` not in environment and `a` already on queue; circular dependency detected" - (let [ana (self/analyze-arg-syms '{a (t/type b) b (t/type a)} 't/any?)])) + (throws (self/analyze-arg-syms '{a (t/type b) b (t/type a)} 't/any?))) (testing "Non-symbolically" #_"1. Analyze `a` = `(t/type b)` - Put `a` on queue @@ -166,15 +167,14 @@ 1. Analyze `a` -> ERROR: `a` not in environment and `a` already on queue; circular dependency detected" - (let [ana (self/analyze-arg-syms '{a (t/type b) b (t/type [a])} 't/any?)]))) + (throws (self/analyze-arg-syms '{a (t/type b) b (t/type [a])} 't/any?)))) (testing "Two input types indirectly depend on each other" #_"1. Analyze `a` = `(t/type b)` 1. Analyze `b` = `(t/type c)` 1. Analyze `c` = `(t/type a)` -> ERROR `a` not in environment and `a` already in queue; circular dependency detected" - (let [ana (self/analyze-arg-syms - '{a (t/type b) b (t/type c) c (t/type a)} 't/any?)])) + (throws (self/analyze-arg-syms '{a (t/type b) b (t/type c) c (t/type a)} 't/any?))) (testing "Combination/integration test" ;; This test overview was put up in ~30 minutes on 9/30/2018 during a seemingly random walk of ;; thoughts without any testing or research whatsoever that happened to actually coalesce @@ -306,4 +306,104 @@ d (let [b (t/- tt/char? tt/long?)] (t/or tt/char? (t/type b) (t/type c)))} '(t/or (t/type b) (t/type d)))] - (transform-ana ana))))) + (is= (transform-ana ana) + [[{'a (t/isa? Boolean) + 'b (t/isa? Byte) + 'c (t/isa? Short) + 'd (t/isa? Short)} + (t/or (t/isa? Byte) (t/isa? Short))] + [{'a (t/isa? Byte) + 'b (t/isa? Byte) + 'c (t/isa? Short) + 'd (t/isa? Short)} + (t/or (t/isa? Byte) (t/isa? Short))] + [{'a (t/isa? Boolean) + 'b (t/isa? Short) + 'c (t/isa? Short) + 'd (t/isa? Short)} + (t/isa? Short)] + [{'a (t/isa? Short) + 'b (t/isa? Short) + 'c (t/isa? Short) + 'd (t/isa? Short)} + (t/isa? Short)] + [{'a (t/isa? Boolean) + 'b (t/isa? Byte) + 'c (t/isa? Short) + 'd (t/isa? Character)} + (t/or (t/isa? Byte) (t/isa? Character))] + [{'a (t/isa? Byte) + 'b (t/isa? Byte) + 'c (t/isa? Short) + 'd (t/isa? Character)} + (t/or (t/isa? Byte) (t/isa? Character))] + [{'a (t/isa? Boolean) + 'b (t/isa? Character) + 'c (t/isa? Short) + 'd (t/isa? Character)} + (t/isa? Character)] + [{'a (t/isa? Character) + 'b (t/isa? Character) + 'c (t/isa? Short) + 'd (t/isa? Character)} + (t/isa? Character)] + [{'a (t/isa? Boolean) + 'b (t/isa? Byte) + 'c (t/isa? Short) + 'd (t/value (t/isa? Character))} + (t/or (t/isa? Byte) (t/value (t/isa? Character)))] + [{'a (t/isa? Byte) + 'b (t/isa? Byte) + 'c (t/isa? Short) + 'd (t/value (t/isa? Character))} + (t/or (t/isa? Byte) (t/value (t/isa? Character)))] + [{'a (t/isa? Boolean) + 'b (t/value (t/isa? Character)) + 'c (t/isa? Short) + 'd (t/value (t/isa? Character))} + (t/value (t/isa? Character))] + [{'a (t/value (t/isa? Character)) + 'b (t/value (t/isa? Character)) + 'c (t/isa? Short) + 'd (t/value (t/isa? Character))} + (t/value (t/isa? Character))] + [{'a (t/isa? Boolean) + 'b (t/isa? Byte) + 'c (t/isa? Character) + 'd (t/isa? Character)} + (t/or (t/isa? Byte) (t/isa? Character))] + [{'a (t/isa? Byte) + 'b (t/isa? Byte) + 'c (t/isa? Character) + 'd (t/isa? Character)} + (t/or (t/isa? Byte) (t/isa? Character))] + [{'a (t/isa? Boolean) + 'b (t/isa? Character) + 'c (t/isa? Character) + 'd (t/isa? Character)} + (t/isa? Character)] + [{'a (t/isa? Character) + 'b (t/isa? Character) + 'c (t/isa? Character) + 'd (t/isa? Character)} + (t/isa? Character)] + [{'a (t/isa? Boolean) + 'b (t/isa? Byte) + 'c (t/isa? Character) + 'd (t/value (t/isa? Character))} + (t/or (t/isa? Byte) (t/value (t/isa? Character)))] + [{'a (t/isa? Byte) + 'b (t/isa? Byte) + 'c (t/isa? Character) + 'd (t/value (t/isa? Character))} + (t/or (t/isa? Byte) (t/value (t/isa? Character)))] + [{'a (t/isa? Boolean) + 'b (t/value (t/isa? Character)) + 'c (t/isa? Character) + 'd (t/value (t/isa? Character))} + (t/value (t/isa? Character))] + [{'a (t/value (t/isa? Character)) + 'b (t/value (t/isa? Character)) + 'c (t/isa? Character) + 'd (t/value (t/isa? Character))} + (t/value (t/isa? Character))]]))))) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 687c61c7..30cec03b 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -606,8 +606,8 @@ (. ~(tag (str `byte+float>boolean) '>|__5) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__6|types 1) ~'x10__) (. ~(tag (str `byte+double>boolean) '>|__6) ~'invoke ~'x00__ ~'x10__) - (unsupported! `>|test [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|__1|types 0) ~'x00__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + ((Array/get ~'>|__7|types 0) ~'x00__) (ifs ((Array/get ~'>|__7|types 1) ~'x10__) (. ~(tag (str `short+byte>boolean) '>|__7) ~'invoke ~'x00__ ~'x10__) @@ -623,90 +623,90 @@ (. ~(tag (str `short+float>boolean) '>|__12) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__13|types 1) ~'x10__) (. ~(tag (str `short+double>boolean) '>|__13) ~'invoke ~'x00__ ~'x10__) - (unsupported! `>|test [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|__2|types 0) ~'x00__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + ((Array/get ~'>|__14|types 0) ~'x00__) (ifs - ((Array/get ~'>|__1|types 0) ~'x10__) + ((Array/get ~'>|__14|types 1) ~'x10__) (. ~(tag (str `char+byte>boolean) '>|__14) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 1) ~'x10__) + ((Array/get ~'>|__15|types 1) ~'x10__) (. ~(tag (str `char+short>boolean) '>|__15) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 2) ~'x10__) + ((Array/get ~'>|__16|types 1) ~'x10__) (. ~(tag (str `char+char>boolean) '>|__16) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 3) ~'x10__) + ((Array/get ~'>|__17|types 1) ~'x10__) (. ~(tag (str `char+int>boolean) '>|__17) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 4) ~'x10__) + ((Array/get ~'>|__18|types 1) ~'x10__) (. ~(tag (str `char+long>boolean) '>|__18) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 5) ~'x10__) + ((Array/get ~'>|__19|types 1) ~'x10__) (. ~(tag (str `char+float>boolean) '>|__19) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 6) ~'x10__) + ((Array/get ~'>|__20|types 1) ~'x10__) (. ~(tag (str `char+double>boolean) '>|__20) ~'invoke ~'x00__ ~'x10__) - (unsupported! `>|test [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|__3|types 0) ~'x00__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + ((Array/get ~'>|__21|types 0) ~'x00__) (ifs - ((Array/get ~'>|__1|types 0) ~'x10__) + ((Array/get ~'>|__21|types 1) ~'x10__) (. ~(tag (str `int+byte>boolean) '>|__21) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 1) ~'x10__) + ((Array/get ~'>|__22|types 1) ~'x10__) (. ~(tag (str `int+short>boolean) '>|__22) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 2) ~'x10__) + ((Array/get ~'>|__23|types 1) ~'x10__) (. ~(tag (str `int+char>boolean) '>|__23) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 3) ~'x10__) + ((Array/get ~'>|__24|types 1) ~'x10__) (. ~(tag (str `int+int>boolean) '>|__24) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 4) ~'x10__) + ((Array/get ~'>|__25|types 1) ~'x10__) (. ~(tag (str `int+long>boolean) '>|__25) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 5) ~'x10__) + ((Array/get ~'>|__26|types 1) ~'x10__) (. ~(tag (str `int+float>boolean) '>|__26) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 6) ~'x10__) + ((Array/get ~'>|__27|types 1) ~'x10__) (. ~(tag (str `int+double>boolean) '>|__27) ~'invoke ~'x00__ ~'x10__) - (unsupported! `>|test [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|__4|types 0) ~'x00__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + ((Array/get ~'>|__28|types 0) ~'x00__) (ifs - ((Array/get ~'>|__1|types 0) ~'x10__) + ((Array/get ~'>|__28|types 1) ~'x10__) (. ~(tag (str `long+byte>boolean) '>|__28) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 1) ~'x10__) + ((Array/get ~'>|__29|types 1) ~'x10__) (. ~(tag (str `long+short>boolean) '>|__29) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 2) ~'x10__) + ((Array/get ~'>|__30|types 1) ~'x10__) (. ~(tag (str `long+char>boolean) '>|__30) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 3) ~'x10__) + ((Array/get ~'>|__31|types 1) ~'x10__) (. ~(tag (str `long+int>boolean) '>|__31) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 4) ~'x10__) + ((Array/get ~'>|__32|types 1) ~'x10__) (. ~(tag (str `long+long>boolean) '>|__32) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 5) ~'x10__) + ((Array/get ~'>|__33|types 1) ~'x10__) (. ~(tag (str `long+float>boolean) '>|__33) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 6) ~'x10__) + ((Array/get ~'>|__34|types 1) ~'x10__) (. ~(tag (str `long+double>boolean) '>|__34) ~'invoke ~'x00__ ~'x10__) - (unsupported! `>|test [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|__5|types 0) ~'x00__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + ((Array/get ~'>|__35|types 0) ~'x00__) (ifs - ((Array/get ~'>|__1|types 0) ~'x10__) + ((Array/get ~'>|__35|types 1) ~'x10__) (. ~(tag (str `float+byte>boolean) '>|__35) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 1) ~'x10__) + ((Array/get ~'>|__36|types 1) ~'x10__) (. ~(tag (str `float+short>boolean) '>|__36) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 2) ~'x10__) + ((Array/get ~'>|__37|types 1) ~'x10__) (. ~(tag (str `float+char>boolean) '>|__37) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 3) ~'x10__) + ((Array/get ~'>|__38|types 1) ~'x10__) (. ~(tag (str `float+int>boolean) '>|__38) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 4) ~'x10__) + ((Array/get ~'>|__39|types 1) ~'x10__) (. ~(tag (str `float+long>boolean) '>|__39) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 5) ~'x10__) + ((Array/get ~'>|__40|types 1) ~'x10__) (. ~(tag (str `float+float>boolean) '>|__40) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 6) ~'x10__) + ((Array/get ~'>|__41|types 1) ~'x10__) (. ~(tag (str `float+double>boolean) '>|__41) ~'invoke ~'x00__ ~'x10__) - (unsupported! `>|test [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|__6|types 0) ~'x00__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + ((Array/get ~'>|__42|types 0) ~'x00__) (ifs - ((Array/get ~'>|__1|types 0) ~'x10__) + ((Array/get ~'>|__42|types 1) ~'x10__) (. ~(tag (str `double+byte>boolean) '>|__42) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 1) ~'x10__) + ((Array/get ~'>|__43|types 1) ~'x10__) (. ~(tag (str `double+short>boolean) '>|__43) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 2) ~'x10__) + ((Array/get ~'>|__44|types 1) ~'x10__) (. ~(tag (str `double+char>boolean) '>|__44) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 3) ~'x10__) + ((Array/get ~'>|__45|types 1) ~'x10__) (. ~(tag (str `double+int>boolean) '>|__45) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 4) ~'x10__) + ((Array/get ~'>|__46|types 1) ~'x10__) (. ~(tag (str `double+long>boolean) '>|__46) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 5) ~'x10__) + ((Array/get ~'>|__47|types 1) ~'x10__) (. ~(tag (str `double+float>boolean) '>|__47) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 6) ~'x10__) + ((Array/get ~'>|__48|types 1) ~'x10__) (. ~(tag (str `double+double>boolean) '>|__48) ~'invoke ~'x00__ ~'x10__) (unsupported! `> [~'x00__ ~'x10__] 1)) (unsupported! `> [~'x00__ ~'x10__] 0)))))) From e2a0c3afb2f3d0c7b540b1c1854ee122585a9f38 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 11 Oct 2018 12:24:54 -0600 Subject: [PATCH 491/810] All dependent type tests pass!! --- test/quantum/test/untyped/core/analyze.cljc | 230 ++++++++++---------- 1 file changed, 115 insertions(+), 115 deletions(-) diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index ce3959c8..331da93b 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -110,7 +110,6 @@ -> Put `a` in env as `(t/isa? Byte)` 2. Analyze `b` = `(t/type a)` -> Put `b` in env as `(t/isa? Byte)`" - ;; TODO (let [ana (self/analyze-arg-syms '{a tt/byte?, b (t/type a)} 't/any?)] (is= (transform-ana ana) [[{'a tt/byte? 'b tt/byte?} t/any?]]))) @@ -130,9 +129,9 @@ -> Put `b` in env as `(t/isa? Byte)` 3. Analyze out-type = `(t/type b)` -> `(t/isa? Byte)`" - ;; TODO - (let [ana (self/analyze-arg-syms '{a tt/byte? b (t/type a)} '(t/type b))] - (transform-ana ana))) + (is= (-> (self/analyze-arg-syms '{a tt/byte? b (t/type a)} '(t/type b)) + transform-ana) + [[{'a (t/isa? Byte) 'b (t/isa? Byte)} (t/isa? Byte)]])) (testing "First input splittable; second input not splittable" #_"1. Analyze `a` = `(t/or tt/boolean? tt/byte?)`. Splittable. 2. Split: @@ -146,9 +145,10 @@ 3. Analyze out-type = `(t/type b)` -> `(t/isa? Boolean)` 4. Analyze split 1 in the same way." - ;; TODO - (let [ana (self/analyze-arg-syms - '{a (t/or tt/boolean? tt/byte?) b (t/type a)} '(t/type b))])) + (is= (-> (self/analyze-arg-syms '{a (t/or tt/boolean? tt/byte?) b (t/type a)} '(t/type b)) + transform-ana) + [[{'a (t/isa? Boolean) 'b (t/isa? Boolean)} (t/isa? Boolean)] + [{'a (t/isa? Byte) 'b (t/isa? Byte)} (t/isa? Byte)]])) (testing "Two input types directly depend on each other" (testing "Symbolically" #_"1. Analyze `a` = `(t/type b)` @@ -299,111 +299,111 @@ -> (Cutting obvious corners) `(t/or (t/isa? Byte) (t/isa? Character))` - No splitting necessary because out-type - All input types are in env and output-type was analyzed. DONE" - (let [ana (self/analyze-arg-syms - '{a (t/or tt/boolean? (t/type b)) - b (t/or tt/byte? (t/type d)) - c (t/or tt/short? tt/char?) - d (let [b (t/- tt/char? tt/long?)] - (t/or tt/char? (t/type b) (t/type c)))} - '(t/or (t/type b) (t/type d)))] - (is= (transform-ana ana) - [[{'a (t/isa? Boolean) - 'b (t/isa? Byte) - 'c (t/isa? Short) - 'd (t/isa? Short)} - (t/or (t/isa? Byte) (t/isa? Short))] - [{'a (t/isa? Byte) - 'b (t/isa? Byte) - 'c (t/isa? Short) - 'd (t/isa? Short)} - (t/or (t/isa? Byte) (t/isa? Short))] - [{'a (t/isa? Boolean) - 'b (t/isa? Short) - 'c (t/isa? Short) - 'd (t/isa? Short)} - (t/isa? Short)] - [{'a (t/isa? Short) - 'b (t/isa? Short) - 'c (t/isa? Short) - 'd (t/isa? Short)} - (t/isa? Short)] - [{'a (t/isa? Boolean) - 'b (t/isa? Byte) - 'c (t/isa? Short) - 'd (t/isa? Character)} - (t/or (t/isa? Byte) (t/isa? Character))] - [{'a (t/isa? Byte) - 'b (t/isa? Byte) - 'c (t/isa? Short) - 'd (t/isa? Character)} - (t/or (t/isa? Byte) (t/isa? Character))] - [{'a (t/isa? Boolean) - 'b (t/isa? Character) - 'c (t/isa? Short) - 'd (t/isa? Character)} - (t/isa? Character)] - [{'a (t/isa? Character) - 'b (t/isa? Character) - 'c (t/isa? Short) - 'd (t/isa? Character)} - (t/isa? Character)] - [{'a (t/isa? Boolean) - 'b (t/isa? Byte) - 'c (t/isa? Short) - 'd (t/value (t/isa? Character))} - (t/or (t/isa? Byte) (t/value (t/isa? Character)))] - [{'a (t/isa? Byte) - 'b (t/isa? Byte) - 'c (t/isa? Short) - 'd (t/value (t/isa? Character))} - (t/or (t/isa? Byte) (t/value (t/isa? Character)))] - [{'a (t/isa? Boolean) - 'b (t/value (t/isa? Character)) - 'c (t/isa? Short) - 'd (t/value (t/isa? Character))} - (t/value (t/isa? Character))] - [{'a (t/value (t/isa? Character)) - 'b (t/value (t/isa? Character)) - 'c (t/isa? Short) - 'd (t/value (t/isa? Character))} - (t/value (t/isa? Character))] - [{'a (t/isa? Boolean) - 'b (t/isa? Byte) - 'c (t/isa? Character) - 'd (t/isa? Character)} - (t/or (t/isa? Byte) (t/isa? Character))] - [{'a (t/isa? Byte) - 'b (t/isa? Byte) - 'c (t/isa? Character) - 'd (t/isa? Character)} - (t/or (t/isa? Byte) (t/isa? Character))] - [{'a (t/isa? Boolean) - 'b (t/isa? Character) - 'c (t/isa? Character) - 'd (t/isa? Character)} - (t/isa? Character)] - [{'a (t/isa? Character) - 'b (t/isa? Character) - 'c (t/isa? Character) - 'd (t/isa? Character)} - (t/isa? Character)] - [{'a (t/isa? Boolean) - 'b (t/isa? Byte) - 'c (t/isa? Character) - 'd (t/value (t/isa? Character))} - (t/or (t/isa? Byte) (t/value (t/isa? Character)))] - [{'a (t/isa? Byte) - 'b (t/isa? Byte) - 'c (t/isa? Character) - 'd (t/value (t/isa? Character))} - (t/or (t/isa? Byte) (t/value (t/isa? Character)))] - [{'a (t/isa? Boolean) - 'b (t/value (t/isa? Character)) - 'c (t/isa? Character) - 'd (t/value (t/isa? Character))} - (t/value (t/isa? Character))] - [{'a (t/value (t/isa? Character)) - 'b (t/value (t/isa? Character)) - 'c (t/isa? Character) - 'd (t/value (t/isa? Character))} - (t/value (t/isa? Character))]]))))) + (is= (-> (self/analyze-arg-syms + '{a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) + c (t/or tt/short? tt/char?) + d (let [b (t/- tt/char? tt/long?)] + (t/or tt/char? (t/type b) (t/type c)))} + '(t/or (t/type b) (t/type d))) + transform-ana) + [[{'a (t/isa? Boolean) + 'b (t/isa? Byte) + 'c (t/isa? Short) + 'd (t/isa? Short)} + (t/or (t/isa? Byte) (t/isa? Short))] + [{'a (t/isa? Byte) + 'b (t/isa? Byte) + 'c (t/isa? Short) + 'd (t/isa? Short)} + (t/or (t/isa? Byte) (t/isa? Short))] + [{'a (t/isa? Boolean) + 'b (t/isa? Short) + 'c (t/isa? Short) + 'd (t/isa? Short)} + (t/isa? Short)] + [{'a (t/isa? Short) + 'b (t/isa? Short) + 'c (t/isa? Short) + 'd (t/isa? Short)} + (t/isa? Short)] + [{'a (t/isa? Boolean) + 'b (t/isa? Byte) + 'c (t/isa? Short) + 'd (t/isa? Character)} + (t/or (t/isa? Byte) (t/isa? Character))] + [{'a (t/isa? Byte) + 'b (t/isa? Byte) + 'c (t/isa? Short) + 'd (t/isa? Character)} + (t/or (t/isa? Byte) (t/isa? Character))] + [{'a (t/isa? Boolean) + 'b (t/isa? Character) + 'c (t/isa? Short) + 'd (t/isa? Character)} + (t/isa? Character)] + [{'a (t/isa? Character) + 'b (t/isa? Character) + 'c (t/isa? Short) + 'd (t/isa? Character)} + (t/isa? Character)] + [{'a (t/isa? Boolean) + 'b (t/isa? Byte) + 'c (t/isa? Short) + 'd (t/value (t/isa? Character))} + (t/or (t/isa? Byte) (t/value (t/isa? Character)))] + [{'a (t/isa? Byte) + 'b (t/isa? Byte) + 'c (t/isa? Short) + 'd (t/value (t/isa? Character))} + (t/or (t/isa? Byte) (t/value (t/isa? Character)))] + [{'a (t/isa? Boolean) + 'b (t/value (t/isa? Character)) + 'c (t/isa? Short) + 'd (t/value (t/isa? Character))} + (t/value (t/isa? Character))] + [{'a (t/value (t/isa? Character)) + 'b (t/value (t/isa? Character)) + 'c (t/isa? Short) + 'd (t/value (t/isa? Character))} + (t/value (t/isa? Character))] + [{'a (t/isa? Boolean) + 'b (t/isa? Byte) + 'c (t/isa? Character) + 'd (t/isa? Character)} + (t/or (t/isa? Byte) (t/isa? Character))] + [{'a (t/isa? Byte) + 'b (t/isa? Byte) + 'c (t/isa? Character) + 'd (t/isa? Character)} + (t/or (t/isa? Byte) (t/isa? Character))] + [{'a (t/isa? Boolean) + 'b (t/isa? Character) + 'c (t/isa? Character) + 'd (t/isa? Character)} + (t/isa? Character)] + [{'a (t/isa? Character) + 'b (t/isa? Character) + 'c (t/isa? Character) + 'd (t/isa? Character)} + (t/isa? Character)] + [{'a (t/isa? Boolean) + 'b (t/isa? Byte) + 'c (t/isa? Character) + 'd (t/value (t/isa? Character))} + (t/or (t/isa? Byte) (t/value (t/isa? Character)))] + [{'a (t/isa? Byte) + 'b (t/isa? Byte) + 'c (t/isa? Character) + 'd (t/value (t/isa? Character))} + (t/or (t/isa? Byte) (t/value (t/isa? Character)))] + [{'a (t/isa? Boolean) + 'b (t/value (t/isa? Character)) + 'c (t/isa? Character) + 'd (t/value (t/isa? Character))} + (t/value (t/isa? Character))] + [{'a (t/value (t/isa? Character)) + 'b (t/value (t/isa? Character)) + 'c (t/isa? Character) + 'd (t/value (t/isa? Character))} + (t/value (t/isa? Character))]])))) From 7eb09de99eab3a9f4d090237dab2c3078fd30ada Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 11 Oct 2018 13:29:49 -0600 Subject: [PATCH 492/810] Sort input args and assert monotonically increasing --- resources-dev/defnt.cljc | 10 +- src-untyped/quantum/untyped/core/analyze.cljc | 12 +- .../quantum/untyped/core/data/set.cljc | 5 +- src-untyped/quantum/untyped/core/loops.cljc | 10 +- .../quantum/untyped/core/reducers.cljc | 13 +- .../quantum/untyped/core/type/compare.cljc | 1 + .../quantum/untyped/core/type/defnt.cljc | 111 ++++++++++++------ test/quantum/test/untyped/core/analyze.cljc | 4 +- 8 files changed, 119 insertions(+), 47 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index bf137c58..c25c7d1c 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -59,18 +59,16 @@ TODO: Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - [1 .] t/type - - [ ] Get all dependent-type-related tests to pass - [2] t/value-of + [1] t/value-of - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` [ ] - (comp/t== x) - dependent type such that the passed input must be identical to x - [3] - t/input-type + [2] - t/input-type - `(t/input-type >namespace :?)` meaning the possible input types to the first input to `>namespace` - `(t/input-type reduce :_ :_ :?)` - Then if those fns ever get extended then it should trigger a chain-reaction of recompilations - [4] - t/output-type - [5] - t/extend-defn! + [3] - t/output-type + [4] - t/extend-defn! - We could just recreate the dispatch every time, in the beginning. It would make for slower compilation but faster execution for dynamic dispatch, and quicker time to use. So whenever something extends a `t/defn`, the type overloads have to be put in the right place in the dispatch order. We could find the first place where the inputs are t/<. diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 67a85961..7206031a 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -926,6 +926,12 @@ vec)] (uc/distinct (join primitive-subtypes (type>split t))))) +(defn- enqueue-first-unanalyzed-if-queue-empty [env #_::env #_> #_::env] + (cond-> env + (-> env :opts :arglist-syms|queue empty?) + (update-in [:opts :arglist-syms|queue] conj + (-> env :opts :arglist-syms|unanalyzed first)))) + (defn- analyze-arg-syms* [env #_::env] (uref/update! !!analyze-arg-syms|iter inc) (let [{:keys [arg-sym->arg-type-form arglist-syms|queue arglist-syms|unanalyzed out-type-form]} @@ -945,13 +951,15 @@ (update-in [:opts :arglist-syms|unanalyzed] disj arg-sym)) t-split (-> analyzed :type type>split+primitivized)] (if (-> t-split count (= 1)) - (recur (update-in env-analyzed [:opts :arg-env] - #(doto % (swap! assoc arg-sym analyzed)))) + (recur (-> env-analyzed + (update-in [:opts :arg-env] #(doto % (swap! assoc arg-sym analyzed))) + enqueue-first-unanalyzed-if-queue-empty)) (->> t-split (uc/mapcat+ (fn [t] (analyze-arg-syms* (-> env-analyzed + enqueue-first-unanalyzed-if-queue-empty (update-in [:opts :arg-env] ;; `(atom (deref %))` in order to create a new env for a new split #(-> % deref atom diff --git a/src-untyped/quantum/untyped/core/data/set.cljc b/src-untyped/quantum/untyped/core/data/set.cljc index 3a542145..af782d5c 100644 --- a/src-untyped/quantum/untyped/core/data/set.cljc +++ b/src-untyped/quantum/untyped/core/data/set.cljc @@ -56,12 +56,15 @@ (def comparisons #{ident >ident}) (def comparison? comparisons) -(defn invert-comparison [c #_comparison? #_> #_comparison?] +(defn invert-comparison [^long c #_comparison? #_> #_comparison?] (case c -1 >ident 1 comparison?] (let [l (->> t0 .-args (seq-and (fn1 < t1))) r (->> t1 .-args (seq-and (fn1 < t0)))] diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 23ed7f7a..2b728d16 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -37,10 +37,10 @@ [quantum.untyped.core.logic :as ul :refer [fn-or fn= ifs]] [quantum.untyped.core.loops - :refer [reduce-2]] + :refer [reduce-2 reducei-2]] [quantum.untyped.core.numeric.combinatorics :as ucombo] - [quantum.untyped.core.reducers :as r - :refer [reducei educe]] + [quantum.untyped.core.reducers :as ur + :refer [educe educei reducei]] [quantum.untyped.core.spec :as s] [quantum.untyped.core.specs :as uss] [quantum.untyped.core.type :as t @@ -275,31 +275,6 @@ :name reify-name :overload overload}))) -;; TODO spec -;; TODO use!! -(core/defn assert-monotonically-increasing-types! - "Asserts that each type in an overload of the same arity and arg-position - are in monotonically increasing order in terms of `t/compare`." - [overloads|grouped-by-arity] - (doseq [[arity-ct overloads] overloads|grouped-by-arity] - (educe - (fn [prev-overload [i|overload overload]] - (when prev-overload - (reduce-2 - (fn [_ arg|type|prev [i|arg arg|type]] - (when (= (t/compare arg|type arg|type|prev) -1) - ;; TODO provide code context, line number, etc. - (err! (istr "At overload ~{i|overload}, arg ~{i|arg}: type is not in monotonically increasing order in terms of `t/compare`") - {:overload overload - :prev-overload prev-overload - :prev-type arg|type|prev - :type arg|type}))) - (:arg-types prev-overload) - (c/lindexed (:arg-types overload)))) - overload) - nil - overloads))) - ;; ----- Direct dispatch: putting it all together ----- ;; (defns >input-types-decl @@ -402,7 +377,60 @@ ;; ===== End dynamic dispatch ===== ;; -(defns- overloads-basis>unanalyzed-overload +;; ===== Arg type comparison ===== ;; + +(core/defn compare-arg-types [t0 #_t/type?, t1 #_t/type? #_> #_ucomp/comparison?] + (if-let [c0 (uana/sort-guide t0)] + (if-let [c1 (uana/sort-guide t1)] + (ifs (< c0 c1) -1 (> c0 c1) 1 0) + -1) + (if-let [c1 (uana/sort-guide t1)] + 1 + (uset/normalize-comparison (t/compare t0 t1))))) + +(core/defn compare-args-types [arg-types0 #_(s/vec-of t/type?) arg-types1 #_(s/vec-of t/type?)] + (let [ct-comparison (compare (count arg-types0) (count arg-types1))] + (if (zero? ct-comparison) + (reduce-2 + (core/fn [^long c t0 t1] + (let [c' (long (compare-arg-types t0 t1))] + (case c' + -1 (case c 1 (reduced 0) c') + 0 c + 1 (case c -1 (reduced 0) c')))) + 0 + arg-types0 arg-types1) + ct-comparison))) + +;; TODO spec +;; TODO use!! +(core/defn assert-monotonically-increasing-types! + "Asserts that each type in an overload of the same arity and arg-position are in monotonically + increasing order in terms of `t/compare`. + + Since its inputs are sorted via `compare-args-types`, this only need check the last overload of + `unanalyzed-overload-seq-accum` and the first overload of `unanalyzed-overload-seq`." + [unanalyzed-overload-seq-accum #_(s/seq-of ::unanalyzed-overload) + unanalyzed-overload-seq #_(s/seq-of ::unanalyzed-overload) + i|overload-basis #_index?] + (when-not (or (empty? unanalyzed-overload-seq-accum) (empty? unanalyzed-overload-seq)) + (let [prev-overload (c/last unanalyzed-overload-seq-accum) + overload (c/first unanalyzed-overload-seq)] + (reducei-2 + (fn [_ arg|type|prev arg|type i|arg] + (when (t/> arg|type|prev arg|type) + ;; TODO provide code context, line number, etc. + (err! (istr "At overload ~{i|overload-basis}, arg ~{i|arg}: type is not in monotonically increasing order in terms of `t/compare`") + {:prev-overload prev-overload + :overload overload + :prev-type arg|type|prev + :type arg|type}))) + (:arg-types prev-overload) + (:arg-types overload))))) + +;; ===== End arg type comparison ===== ;; + +(defns- overloads-basis>unanalyzed-overload-seq [{:as in {args [:args _] varargs [:varargs _] pre-type|form [:pre _] @@ -433,7 +461,7 @@ ;; TODO this assertion is purely temporary until destructuring is ;; supported (assert (-> varargs :binding-form first (= :sym)))) - arg-types|expanded-seq ; split and primitivized + arg-types|expanded-seq ; split, primitivized, and sorted (->> (uana/analyze-arg-syms {} (zipmap arg-bindings arg-types|form) output-type|form) (c/map (fn [{:keys [env out-type-node]}] (let [output-type (:type out-type-node) @@ -444,7 +472,9 @@ (err! (str "Overload's declared output type does not satisfy function's" "overall declared output type") (kw-map output-type fn|output-type))) - (kw-map arg-types output-type)))))] + (kw-map arg-types output-type)))) + (sort-by (fn [m0 m1] (compare-args-types (:arg-types m0) (:arg-types m1)))) + vec)] (->> arg-types|expanded-seq (c/map (fn [{:keys [arg-types output-type]}] (kw-map arg-bindings varargs-binding @@ -452,6 +482,20 @@ output-type|form output-type body-codelist|pre-analyze)))))) +(defns- overloads-bases>unanalyzed-overloads + [overloads-bases :quantum.core.defnt/overloads + fn|output-type|form _ ; TODO excise this var when we default `output-type|form` to `?` + fn|output-type t/type? + > (s/seq-of ::unanalyzed-overload)] + (->> overloads-bases + (c/map+ #(overloads-basis>unanalyzed-overload-seq % fn|output-type|form fn|output-type)) + (educei + (fn ([] []) + ([ret] ret) + ([ret unanalyzed-overload-seq i|overload-basis] + (assert-monotonically-increasing-types! ret unanalyzed-overload-seq i|overload-basis) + (ur/join ret unanalyzed-overload-seq)))))) + (defns unanalyzed-overloads>fn|type [unanalyzed-overloads (s/seq-of ::unanalyzed-overload), fn|output-type t/type? > utr/fn-type?] (->> unanalyzed-overloads @@ -481,9 +525,8 @@ fn|output-type|form (or (second output-spec) `t/any?) ;; TODO this needs to be analyzed for dependent types referring tp local vars fn|output-type (eval fn|output-type|form) - unanalyzed-overloads (->> overloads-bases - (c/mapcat #(overloads-basis>unanalyzed-overload - % fn|output-type|form fn|output-type))) + unanalyzed-overloads (overloads-bases>unanalyzed-overloads + overloads-bases fn|output-type|form fn|output-type) fn|type (unanalyzed-overloads>fn|type unanalyzed-overloads fn|output-type) fn|globals (kw-map fn|name fn|meta fn|type fn|output-type|form fn|output-type) overloads (->> unanalyzed-overloads diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index 331da93b..43367ad5 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -18,8 +18,8 @@ (defn- transform-ana [ana] (->> ana - (mapv #(do [(->> % :env :opts :arg-env deref (uc/map-vals' :type)) - (-> % :out-type-node :type)])))) + (mapv #(vector (->> % :env :opts :arg-env deref (uc/map-vals' :type)) + (-> % :out-type-node :type))))) ;; More dependent type tests in `quantum.test.untyped.core.type.defnt` but those are more like ;; integration tests From cd6eef8f9e8f347d6df06930c561f7123ad02c38 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 11 Oct 2018 14:02:25 -0600 Subject: [PATCH 493/810] The tests pass!! --- src-untyped/quantum/untyped/core/analyze.cljc | 23 +- src-untyped/quantum/untyped/core/type.cljc | 7 +- .../quantum/untyped/core/type/defnt.cljc | 109 ++++----- .../quantum/test/untyped/core/type/defnt.cljc | 216 +++++++++--------- 4 files changed, 184 insertions(+), 171 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 7206031a..e6206c52 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -890,7 +890,7 @@ (s/def ::arg-sym->arg-type-form (s/map-of simple-symbol? t/any?)) -(def analyze-arg-syms|max-iter 1000) +(def analyze-arg-syms|max-iter 10000) ;; TODO excise (defn pr! [x] @@ -900,15 +900,16 @@ #?(:clj (uvar/def sort-guide "for use in arglist sorting, in increasing conceptual (and bit) size" - {t/boolean? 0 - t/byte? 1 - t/short? 2 - t/char? 3 - t/int? 4 - t/long? 5 - t/float? 6 - t/double? 7 - t/object? 8})) + {t/nil? 0 + t/boolean? 1 + t/byte? 2 + t/short? 3 + t/char? 4 + t/int? 5 + t/long? 6 + t/float? 7 + t/double? 8 + t/object? 9})) ;; TODO move? (defns type>split @@ -940,7 +941,7 @@ [{:env env :out-type-node (-> (analyze env out-type-form) (update :type t/unvalue))}] (>= (uref/get !!analyze-arg-syms|iter) analyze-arg-syms|max-iter) - (err! "Max number of iterations reached for `analyze-arg-syms" + (err! "Max number of iterations reached for `analyze-arg-syms`" {:n (uref/get !!analyze-arg-syms|iter)}) (let [_ (assert (not (empty? arglist-syms|queue))) arg-sym (uc/last arglist-syms|queue) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 29e312a4..ce7d5096 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -572,13 +572,14 @@ (->> cs (uc/map+ class>most-primitive-class) (ur/join #{})))))) #?(:clj -(defns type>primitive-subtypes [t type? > (us/vec-of type?)] +(defns type>primitive-subtypes [t type? > (us/set-of type?)] (if (-> t c/meta :quantum.core.type/ref?) #{} (->> t type>classes (uc/mapcat+ class>boxed-subclasses+) - (join #{}) - (uc/map isa?))))) + uc/distinct+ + (uc/map+ isa?) + (ur/join #{}))))) #?(:clj (defns- -type>?class-value [t utr/type?, type-nilable? c/boolean?] diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 2b728d16..189bc5d7 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -14,7 +14,7 @@ :refer [istr sentinel]] ; TODO use quantum.untyped.core.string/istr instead [quantum.untyped.core.defnt :refer [defns defns- fns]] - [quantum.untyped.core.collections :as c + [quantum.untyped.core.collections :as uc :refer [>set >vec]] [quantum.untyped.core.compare :as ucomp] [quantum.untyped.core.data @@ -183,18 +183,18 @@ (let [;; Not sure if `nil` is the right approach for the value recursive-ast-node-reference (uast/symbol {} fn|name nil fn|type) env (->> (zipmap arg-bindings arg-types) - (c/map' (fn [[arg-binding arg-type]] - [arg-binding (uast/unbound nil arg-binding arg-type)])) + (uc/map' (fn [[arg-binding arg-type]] + [arg-binding (uast/unbound nil arg-binding arg-type)])) ;; To support recursion (<- (assoc fn|name recursive-ast-node-reference))) body-node (uana/analyze env (ufgen/?wrap-do body-codelist|pre-analyze)) - arg-classes (->> arg-types (c/map type>class)) + arg-classes (->> arg-types (uc/map type>class)) hint-arg|fn (fn [i arg-binding] (ufth/with-type-hint arg-binding (ufth/>fn-arglist-tag - (c/get arg-classes i) + (uc/get arg-classes i) lang - (c/count arg-bindings) + (uc/count arg-bindings) (boolean varargs-binding)))) actual-output-type (>actual-output-type declared-output-type body-node) body-form @@ -202,11 +202,11 @@ (cond-> (-> actual-output-type meta :quantum.core.type/runtime?) (>with-runtime-output-type output-type|form)) (ufth/cast-bindings|code - (->> (c/zipmap-into (umap/om) arg-bindings arg-classes) - (c/remove-vals' (fn-or nil? (fn= java.lang.Object) t/primitive-class?)))))] + (->> (uc/zipmap-into (umap/om) arg-bindings arg-classes) + (uc/remove-vals' (fn-or nil? (fn= java.lang.Object) t/primitive-class?)))))] {:arg-classes arg-classes :arg-types arg-types - :arglist-code|fn|hinted (cond-> (->> arg-bindings (c/map-indexed hint-arg|fn)) + :arglist-code|fn|hinted (cond-> (->> arg-bindings (uc/map-indexed hint-arg|fn)) varargs-binding (conj '& varargs-binding)) :arglist-code|reify|unhinted (cond-> arg-bindings varargs-binding (conj varargs-binding)) :body-form body-form @@ -228,7 +228,7 @@ ;; ----- Direct dispatch: `reify` ---- ;; (defns- overload-classes>interface-sym [args-classes (s/seq-of class?), out-class class? > symbol?] - (>symbol (str (->> args-classes (c/lmap class>interface-part-name) (str/join "+")) + (>symbol (str (->> args-classes (uc/lmap class>interface-part-name) (str/join "+")) ">" (class>interface-part-name out-class)))) (def reify-method-sym 'invoke) @@ -256,14 +256,14 @@ (-> *interfaces (swap! update interface-k #(or % (eval (overload-classes>interface arg-classes output-class gen-gensym)))) - (c/get interface-k)) + (uc/get interface-k)) arglist-code (>vec (concat [(gen-gensym '_)] (->> arglist-code|reify|unhinted (map-indexed (fn [i|arg arg|form] (ufth/with-type-hint arg|form - (-> arg-classes (c/get i|arg) ufth/>arglist-embeddable-tag))))))) + (-> arg-classes (uc/get i|arg) ufth/>arglist-embeddable-tag))))))) reify-name (>symbol (str fn|name "|__" i|overload)) form `(~'def ~reify-name (reify* [~(-> interface >name >symbol)] @@ -284,7 +284,7 @@ > ::input-types-decl] (let [decl-name (>symbol (str fn|name "|__" i|overload "|types")) form (list 'def (ufth/with-type-hint decl-name "[Ljava.lang.Object;") - (list* `uarr/*<> (c/lmap >form arg-types)))] + (list* `uarr/*<> (uc/lmap >form arg-types)))] {:form form :name decl-name})) (defns >direct-dispatch @@ -295,13 +295,13 @@ (case lang :clj (let [direct-dispatch-data-seq (->> overloads - (c/map-indexed + (uc/map-indexed (fn [i|overload {:as overload :keys [arg-types]}] {:input-types-decl (>input-types-decl fn|globals arg-types i|overload) :reify (overload>reify overload opts fn|globals i|overload)}))) form (->> direct-dispatch-data-seq - (c/mapcat + (uc/mapcat (fn [{:as direct-dispatch-data :keys [input-types-decl]}] (list (:form input-types-decl) (-> direct-dispatch-data :reify :form)))))] @@ -323,17 +323,17 @@ [direct-dispatch-data-seq-for-arity (s/seq-of ::direct-dispatch-data) arglist (s/vec-of simple-symbol?)] (->> direct-dispatch-data-seq-for-arity - (c/map+ (fn [{reify- :reify :keys [input-types-decl]}] - [(>dynamic-dispatch|reify-call reify- arglist) - (->> reify- - :overload - :arg-types - (c/map-indexed - (fn [i|arg arg-type] - {:i i|arg - :t arg-type - :getf `((Array/get ~(:name input-types-decl) ~i|arg) - ~(get arglist i|arg))})))])))) + (uc/map+ (fn [{reify- :reify :keys [input-types-decl]}] + [(>dynamic-dispatch|reify-call reify- arglist) + (->> reify- + :overload + :arg-types + (uc/map-indexed + (fn [i|arg arg-type] + {:i i|arg + :t arg-type + :getf `((Array/get ~(:name input-types-decl) ~i|arg) + ~(get arglist i|arg))})))])))) (defns- >dynamic-dispatch|body-for-arity "Assumes the elements of `direct-dispatch-data-seq-for-arity` are ordered in increasing @@ -351,11 +351,11 @@ seq)) ([ret getf x i] (reset! *i|arg i) - (c/conj! ret getf x)))] - (c/>combinatoric-tree (count arglist) + (uc/conj! ret getf x)))] + (uc/>combinatoric-tree (count arglist) (fn [a b] (t/= (:t a) (:t b))) (aritoid combinef combinef (fn [x [{:keys [getf i]} group]] (combinef x getf group i))) - c/conj!|rf + uc/conj!|rf (aritoid combinef combinef (fn [x [k [{:keys [getf i]}]]] (combinef x getf k i))) (>combinatoric-seq+ direct-dispatch-data-seq-for-arity arglist))))) @@ -414,17 +414,19 @@ unanalyzed-overload-seq #_(s/seq-of ::unanalyzed-overload) i|overload-basis #_index?] (when-not (or (empty? unanalyzed-overload-seq-accum) (empty? unanalyzed-overload-seq)) - (let [prev-overload (c/last unanalyzed-overload-seq-accum) - overload (c/first unanalyzed-overload-seq)] + (let [prev-overload (uc/last unanalyzed-overload-seq-accum) + overload (uc/first unanalyzed-overload-seq)] (reducei-2 (fn [_ arg|type|prev arg|type i|arg] - (when (t/> arg|type|prev arg|type) + (when ;; NOTE could use `compare-arg-types` here instead of `t/compare` if we want a more + ;; efficient combinatoric tree dispatch + (= 1 (t/compare arg|type|prev arg|type)) ;; TODO provide code context, line number, etc. (err! (istr "At overload ~{i|overload-basis}, arg ~{i|arg}: type is not in monotonically increasing order in terms of `t/compare`") - {:prev-overload prev-overload - :overload overload - :prev-type arg|type|prev - :type arg|type}))) + (umap/om :prev-overload prev-overload + :overload overload + :prev-type arg|type|prev + :type arg|type)))) (:arg-types prev-overload) (:arg-types overload))))) @@ -463,9 +465,11 @@ (assert (-> varargs :binding-form first (= :sym)))) arg-types|expanded-seq ; split, primitivized, and sorted (->> (uana/analyze-arg-syms {} (zipmap arg-bindings arg-types|form) output-type|form) - (c/map (fn [{:keys [env out-type-node]}] - (let [output-type (:type out-type-node) - arg-types (->> arg-bindings (mapv #(:type (get env %))))] + (uc/map (fn [{:keys [env out-type-node]}] + (let [output-type (:type out-type-node) + arg-env (->> env :opts :arg-env deref) + arg-types (->> arg-bindings (uc/map #(:type (get arg-env %))))] + (when (and ;; TODO excise clause when we default `output-type|form` to `?` (not (identical? output-type|form fn|output-type|form)) (not (t/<= output-type fn|output-type))) @@ -473,22 +477,23 @@ "overall declared output type") (kw-map output-type fn|output-type))) (kw-map arg-types output-type)))) - (sort-by (fn [m0 m1] (compare-args-types (:arg-types m0) (:arg-types m1)))) + (sort-by :arg-types compare-args-types) vec)] + (uana/pr! arg-types|expanded-seq) ; TODO excise (->> arg-types|expanded-seq - (c/map (fn [{:keys [arg-types output-type]}] - (kw-map arg-bindings varargs-binding - arg-types|form arg-types - output-type|form output-type - body-codelist|pre-analyze)))))) + (uc/map (fn [{:keys [arg-types output-type]}] + (kw-map arg-bindings varargs-binding + arg-types|form arg-types + output-type|form output-type + body-codelist|pre-analyze)))))) (defns- overloads-bases>unanalyzed-overloads - [overloads-bases :quantum.core.defnt/overloads + [overloads-bases _ #_:quantum.core.defnt/overloads fn|output-type|form _ ; TODO excise this var when we default `output-type|form` to `?` fn|output-type t/type? > (s/seq-of ::unanalyzed-overload)] (->> overloads-bases - (c/map+ #(overloads-basis>unanalyzed-overload-seq % fn|output-type|form fn|output-type)) + (uc/map+ #(overloads-basis>unanalyzed-overload-seq % fn|output-type|form fn|output-type)) (educei (fn ([] []) ([ret] ret) @@ -499,10 +504,10 @@ (defns unanalyzed-overloads>fn|type [unanalyzed-overloads (s/seq-of ::unanalyzed-overload), fn|output-type t/type? > utr/fn-type?] (->> unanalyzed-overloads - (c/lmap (fn [{:keys [arg-types pre-type output-type]}] - (cond-> arg-types - pre-type (conj :| pre-type) - output-type (conj :> output-type)))) + (uc/lmap (fn [{:keys [arg-types pre-type output-type]}] + (cond-> arg-types + pre-type (conj :| pre-type) + output-type (conj :> output-type)))) (apply t/ftype fn|output-type))) (defns fn|code [kind #{:fn :defn}, lang ::lang, args _] @@ -530,7 +535,7 @@ fn|type (unanalyzed-overloads>fn|type unanalyzed-overloads fn|output-type) fn|globals (kw-map fn|name fn|meta fn|type fn|output-type|form fn|output-type) overloads (->> unanalyzed-overloads - (c/map #(unanalyzed-overload>overload % fn|globals opts))) + (uc/map #(unanalyzed-overload>overload % fn|globals opts))) direct-dispatch (>direct-dispatch fn|globals opts overloads) fn-codelist (case lang diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 30cec03b..d0cf35f0 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -44,6 +44,11 @@ (defn O<> [form] (tag "[Ljava.lang.Object;" form)) (defn ST [form] (tag "java.lang.String" form)) +(defn cstr [x] + (if (-> x resolve class?) + (str x) + (str (namespace x) "." (name x)))) + #?(:clj (deftest test|pid (let [actual @@ -64,7 +69,7 @@ (defn ~'pid|test {:quantum.core.type/type (t/ftype t/any? [:> (t/or (t/value nil) (t/isa? String))])} - ([] (. ~(tag (str `>Object) 'pid|test|__0) ~'invoke)))))] + ([] (. ~(tag (cstr `>Object) 'pid|test|__0) ~'invoke)))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) @@ -124,24 +129,25 @@ [(t/isa? Double) :> (t/isa? Double)] [t/any? :> t/any?])} ([~'x00__] - (ifs ((Array/get ~'identity|uninlined|__0|types 0) ~'x00__) - (. ~(tag (str `boolean>boolean) 'identity|uninlined|__0) ~'invoke ~'x00__) - ((Array/get ~'identity|uninlined|__1|types 0) ~'x00__) - (. ~(tag (str `byte>byte) 'identity|uninlined|__1) ~'invoke ~'x00__) - ((Array/get ~'identity|uninlined|__2|types 0) ~'x00__) - (. ~(tag (str `short>short) 'identity|uninlined|__2) ~'invoke ~'x00__) - ((Array/get ~'identity|uninlined|__3|types 0) ~'x00__) - (. ~(tag (str `char>char) 'identity|uninlined|__3) ~'invoke ~'x00__) - ((Array/get ~'identity|uninlined|__4|types 0) ~'x00__) - (. ~(tag (str `int>int) 'identity|uninlined|__4) ~'invoke ~'x00__) - ((Array/get ~'identity|uninlined|__5|types 0) ~'x00__) - (. ~(tag (str `long>long) 'identity|uninlined|__5) ~'invoke ~'x00__) - ((Array/get ~'identity|uninlined|__6|types 0) ~'x00__) - (. ~(tag (str `float>float) 'identity|uninlined|__6) ~'invoke ~'x00__) - ((Array/get ~'identity|uninlined|__7|types 0) ~'x00__) - (. ~(tag (str `double>double) 'identity|uninlined|__7) ~'invoke ~'x00__) - ((Array/get ~'identity|uninlined|__8|types 0) ~'x00__) - (. ~(tag (str `Object>Object) 'identity|uninlined|__8) ~'invoke ~'x00__) + (ifs + ((Array/get ~'identity|uninlined|__0|types 0) ~'x00__) + (. ~(tag (cstr `boolean>boolean) 'identity|uninlined|__0) ~'invoke ~'x00__) + ((Array/get ~'identity|uninlined|__1|types 0) ~'x00__) + (. ~(tag (cstr `byte>byte) 'identity|uninlined|__1) ~'invoke ~'x00__) + ((Array/get ~'identity|uninlined|__2|types 0) ~'x00__) + (. ~(tag (cstr `short>short) 'identity|uninlined|__2) ~'invoke ~'x00__) + ((Array/get ~'identity|uninlined|__3|types 0) ~'x00__) + (. ~(tag (cstr `char>char) 'identity|uninlined|__3) ~'invoke ~'x00__) + ((Array/get ~'identity|uninlined|__4|types 0) ~'x00__) + (. ~(tag (cstr `int>int) 'identity|uninlined|__4) ~'invoke ~'x00__) + ((Array/get ~'identity|uninlined|__5|types 0) ~'x00__) + (. ~(tag (cstr `long>long) 'identity|uninlined|__5) ~'invoke ~'x00__) + ((Array/get ~'identity|uninlined|__6|types 0) ~'x00__) + (. ~(tag (cstr `float>float) 'identity|uninlined|__6) ~'invoke ~'x00__) + ((Array/get ~'identity|uninlined|__7|types 0) ~'x00__) + (. ~(tag (cstr `double>double) 'identity|uninlined|__7) ~'invoke ~'x00__) + ((Array/get ~'identity|uninlined|__8|types 0) ~'x00__) + (. ~(tag (cstr `Object>Object) 'identity|uninlined|__8) ~'invoke ~'x00__) ;; TODO no need for `unsupported!` because it will always get a valid branch (unsupported! `identity|uninlined [~'x00__] 0)))))) :cljs @@ -188,9 +194,9 @@ [(t/isa? Named) :> (t/* (t/isa? String))])} ([~'x00__] (ifs ((Array/get ~'name|__0|types 0) ~'x00__) - (. ~(tag (str `Object>Object) 'name|__0) ~'invoke ~'x00__) + (. ~(tag (cstr `Object>Object) 'name|__0) ~'invoke ~'x00__) ((Array/get ~'name|__1|types 0) ~'x00__) - (. ~(tag (str `Object>Object) 'name|__1) ~'invoke ~'x00__) + (. ~(tag (cstr `Object>Object) 'name|__1) ~'invoke ~'x00__) (unsupported! `name [~'x00__] 0)))))) :cljs ($ (do (defn ~'name [~'x00__] @@ -264,26 +270,26 @@ [t/any? :> (t/isa? Boolean)])} ([~'x00__] (ifs ((Array/get ~'some?|__0|types 0) ~'x00__) - (. ~(tag (str `Object>boolean) 'some?|__0) ~'invoke ~'x00__) + (. ~(tag (cstr `Object>boolean) 'some?|__0) ~'invoke ~'x00__) ;; TODO eliminate these checks below because they're not needed ((Array/get ~'some?|__1|types 0) ~'x00__) - (. ~(tag (str `boolean>boolean) 'some?|__1) ~'invoke ~'x00__) + (. ~(tag (cstr `boolean>boolean) 'some?|__1) ~'invoke ~'x00__) ((Array/get ~'some?|__2|types 0) ~'x00__) - (. ~(tag (str `byte>boolean) 'some?|__2) ~'invoke ~'x00__) + (. ~(tag (cstr `byte>boolean) 'some?|__2) ~'invoke ~'x00__) ((Array/get ~'some?|__3|types 0) ~'x00__) - (. ~(tag (str `short>boolean) 'some?|__3) ~'invoke ~'x00__) + (. ~(tag (cstr `short>boolean) 'some?|__3) ~'invoke ~'x00__) ((Array/get ~'some?|__4|types 0) ~'x00__) - (. ~(tag (str `char>boolean) 'some?|__4) ~'invoke ~'x00__) + (. ~(tag (cstr `char>boolean) 'some?|__4) ~'invoke ~'x00__) ((Array/get ~'some?|__5|types 0) ~'x00__) - (. ~(tag (str `int>boolean) 'some?|__5) ~'invoke ~'x00__) + (. ~(tag (cstr `int>boolean) 'some?|__5) ~'invoke ~'x00__) ((Array/get ~'some?|__6|types 0) ~'x00__) - (. ~(tag (str `long>boolean) 'some?|__6) ~'invoke ~'x00__) + (. ~(tag (cstr `long>boolean) 'some?|__6) ~'invoke ~'x00__) ((Array/get ~'some?|__7|types 0) ~'x00__) - (. ~(tag (str `float>boolean) 'some?|__7) ~'invoke ~'x00__) + (. ~(tag (cstr `float>boolean) 'some?|__7) ~'invoke ~'x00__) ((Array/get ~'some?|__8|types 0) ~'x00__) - (. ~(tag (str `double>boolean) 'some?|__8) ~'invoke ~'x00__) + (. ~(tag (cstr `double>boolean) 'some?|__8) ~'invoke ~'x00__) ((Array/get ~'some?|__9|types 0) ~'x00__) - (. ~(tag (str `Object>boolean) 'some?|__9) ~'invoke ~'x00__) + (. ~(tag (cstr `Object>boolean) 'some?|__9) ~'invoke ~'x00__) (unsupported! `some? [~'x00__] 0)))))) :cljs ($ (do (defn ~'some?| [~'x] @@ -342,10 +348,10 @@ ~'[t/any?])} ([~'x00__] (ifs ((Array/get ~'reduced?|test|__0|input0|types 0) ~'x00__) - (.invoke ~(tag (str `Object>boolean) 'reduced?|test|__0|0) ~'x00__) + (.invoke ~(tag (cstr `Object>boolean) 'reduced?|test|__0|0) ~'x00__) ;; TODO eliminate this check because it's not needed (`t/any?`) ((Array/get ~'reduced?|test|__1|input0|types 0) ~'x00__) - (.invoke ~(tag (str `Object>boolean) 'reduced?|test|__1|0) ~'x00__) + (.invoke ~(tag (cstr `Object>boolean) 'reduced?|test|__1|0) ~'x00__) (unsupported! `reduced?|test [~'x00__] 0)))))) :cljs ($ (do (defn ~'reduced?|test [~'x] @@ -414,12 +420,12 @@ ~'[t/any?])} ([~'x00__] (ifs ((Array/get ~'>boolean|__0|input0|types 0) ~'x00__) - (.invoke ~(tag (str `boolean>boolean) '>boolean|__0|0) ~'x00__) + (.invoke ~(tag (cstr `boolean>boolean) '>boolean|__0|0) ~'x00__) ((Array/get ~'>boolean|__1|input0|types 0) ~'x00__) - (.invoke ~(tag (str `Object>boolean) '>boolean|__1|0) ~'x00__) + (.invoke ~(tag (cstr `Object>boolean) '>boolean|__1|0) ~'x00__) ;; TODO eliminate this check because it's not needed (`t/any?`) ((Array/get ~'>boolean|__2|input0|types 0) ~'x00__) - (.invoke ~(tag (str `Object>boolean) '>boolean|__2|0) ~'x00__) + (.invoke ~(tag (cstr `Object>boolean) '>boolean|__2|0) ~'x00__) (unsupported! `>boolean [~'x00__] 0)))))) :cljs ($ (do (defn ~'>boolean [~'x] @@ -502,21 +508,21 @@ ~'[(t/ref (t/isa? Number))])} ([~'x00__] (ifs ((Array/get ~'>int*|__0|input0|types 0) ~'x00__) - (.invoke ~(tag (str `byte>int) '>int*|__0|0) ~'x00__) + (.invoke ~(tag (cstr `byte>int) '>int*|__0|0) ~'x00__) ((Array/get ~'>int*|__0|input0|types 1) ~'x00__) - (.invoke ~(tag (str `short>int) '>int*|__0|1) ~'x00__) + (.invoke ~(tag (cstr `short>int) '>int*|__0|1) ~'x00__) ((Array/get ~'>int*|__0|input0|types 2) ~'x00__) - (.invoke ~(tag (str `char>int) '>int*|__0|2) ~'x00__) + (.invoke ~(tag (cstr `char>int) '>int*|__0|2) ~'x00__) ((Array/get ~'>int*|__0|input0|types 3) ~'x00__) - (.invoke ~(tag (str `int>int) '>int*|__0|3) ~'x00__) + (.invoke ~(tag (cstr `int>int) '>int*|__0|3) ~'x00__) ((Array/get ~'>int*|__0|input0|types 4) ~'x00__) - (.invoke ~(tag (str `long>int) '>int*|__0|4) ~'x00__) + (.invoke ~(tag (cstr `long>int) '>int*|__0|4) ~'x00__) ((Array/get ~'>int*|__0|input0|types 5) ~'x00__) - (.invoke ~(tag (str `float>int) '>int*|__0|5) ~'x00__) + (.invoke ~(tag (cstr `float>int) '>int*|__0|5) ~'x00__) ((Array/get ~'>int*|__0|input0|types 6) ~'x00__) - (.invoke ~(tag (str `double>int) '>int*|__0|6) ~'x00__) + (.invoke ~(tag (cstr `double>int) '>int*|__0|6) ~'x00__) ((Array/get ~'>int*|__1|input0|types 0) ~'x00__) - (.invoke ~(tag (str `Object>int) '>int*|__1|0) ~'x00__) + (.invoke ~(tag (cstr `Object>int) '>int*|__1|0) ~'x00__) (unsupported! `>int* [~'x00__] 0)))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" @@ -593,121 +599,121 @@ ((Array/get ~'>|__0|types 0) ~'x00__) (ifs ((Array/get ~'>|__0|types 1) ~'x10__) - (. ~(tag (str `byte+byte>boolean) '>|__0) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `byte+byte>boolean) '>|__0) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__1|types 1) ~'x10__) - (. ~(tag (str `byte+short>boolean) '>|__1) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `byte+short>boolean) '>|__1) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__2|types 1) ~'x10__) - (. ~(tag (str `byte+char>boolean) '>|__2) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `byte+char>boolean) '>|__2) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__3|types 1) ~'x10__) - (. ~(tag (str `byte+int>boolean) '>|__3) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `byte+int>boolean) '>|__3) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__4|types 1) ~'x10__) - (. ~(tag (str `byte+long>boolean) '>|__4) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `byte+long>boolean) '>|__4) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__5|types 1) ~'x10__) - (. ~(tag (str `byte+float>boolean) '>|__5) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `byte+float>boolean) '>|__5) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__6|types 1) ~'x10__) - (. ~(tag (str `byte+double>boolean) '>|__6) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `byte+double>boolean) '>|__6) ~'invoke ~'x00__ ~'x10__) (unsupported! `> [~'x00__ ~'x10__] 1)) ((Array/get ~'>|__7|types 0) ~'x00__) (ifs ((Array/get ~'>|__7|types 1) ~'x10__) - (. ~(tag (str `short+byte>boolean) '>|__7) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `short+byte>boolean) '>|__7) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__8|types 1) ~'x10__) - (. ~(tag (str `short+short>boolean) '>|__8) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `short+short>boolean) '>|__8) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__9|types 1) ~'x10__) - (. ~(tag (str `short+char>boolean) '>|__9) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `short+char>boolean) '>|__9) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__10|types 1) ~'x10__) - (. ~(tag (str `short+int>boolean) '>|__10) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `short+int>boolean) '>|__10) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__11|types 1) ~'x10__) - (. ~(tag (str `short+long>boolean) '>|__11) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `short+long>boolean) '>|__11) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__12|types 1) ~'x10__) - (. ~(tag (str `short+float>boolean) '>|__12) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `short+float>boolean) '>|__12) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__13|types 1) ~'x10__) - (. ~(tag (str `short+double>boolean) '>|__13) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `short+double>boolean) '>|__13) ~'invoke ~'x00__ ~'x10__) (unsupported! `> [~'x00__ ~'x10__] 1)) ((Array/get ~'>|__14|types 0) ~'x00__) (ifs ((Array/get ~'>|__14|types 1) ~'x10__) - (. ~(tag (str `char+byte>boolean) '>|__14) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `char+byte>boolean) '>|__14) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__15|types 1) ~'x10__) - (. ~(tag (str `char+short>boolean) '>|__15) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `char+short>boolean) '>|__15) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__16|types 1) ~'x10__) - (. ~(tag (str `char+char>boolean) '>|__16) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `char+char>boolean) '>|__16) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__17|types 1) ~'x10__) - (. ~(tag (str `char+int>boolean) '>|__17) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `char+int>boolean) '>|__17) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__18|types 1) ~'x10__) - (. ~(tag (str `char+long>boolean) '>|__18) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `char+long>boolean) '>|__18) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__19|types 1) ~'x10__) - (. ~(tag (str `char+float>boolean) '>|__19) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `char+float>boolean) '>|__19) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__20|types 1) ~'x10__) - (. ~(tag (str `char+double>boolean) '>|__20) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `char+double>boolean) '>|__20) ~'invoke ~'x00__ ~'x10__) (unsupported! `> [~'x00__ ~'x10__] 1)) ((Array/get ~'>|__21|types 0) ~'x00__) (ifs ((Array/get ~'>|__21|types 1) ~'x10__) - (. ~(tag (str `int+byte>boolean) '>|__21) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `int+byte>boolean) '>|__21) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__22|types 1) ~'x10__) - (. ~(tag (str `int+short>boolean) '>|__22) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `int+short>boolean) '>|__22) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__23|types 1) ~'x10__) - (. ~(tag (str `int+char>boolean) '>|__23) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `int+char>boolean) '>|__23) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__24|types 1) ~'x10__) - (. ~(tag (str `int+int>boolean) '>|__24) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `int+int>boolean) '>|__24) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__25|types 1) ~'x10__) - (. ~(tag (str `int+long>boolean) '>|__25) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `int+long>boolean) '>|__25) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__26|types 1) ~'x10__) - (. ~(tag (str `int+float>boolean) '>|__26) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `int+float>boolean) '>|__26) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__27|types 1) ~'x10__) - (. ~(tag (str `int+double>boolean) '>|__27) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `int+double>boolean) '>|__27) ~'invoke ~'x00__ ~'x10__) (unsupported! `> [~'x00__ ~'x10__] 1)) ((Array/get ~'>|__28|types 0) ~'x00__) (ifs ((Array/get ~'>|__28|types 1) ~'x10__) - (. ~(tag (str `long+byte>boolean) '>|__28) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `long+byte>boolean) '>|__28) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__29|types 1) ~'x10__) - (. ~(tag (str `long+short>boolean) '>|__29) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `long+short>boolean) '>|__29) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__30|types 1) ~'x10__) - (. ~(tag (str `long+char>boolean) '>|__30) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `long+char>boolean) '>|__30) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__31|types 1) ~'x10__) - (. ~(tag (str `long+int>boolean) '>|__31) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `long+int>boolean) '>|__31) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__32|types 1) ~'x10__) - (. ~(tag (str `long+long>boolean) '>|__32) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `long+long>boolean) '>|__32) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__33|types 1) ~'x10__) - (. ~(tag (str `long+float>boolean) '>|__33) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `long+float>boolean) '>|__33) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__34|types 1) ~'x10__) - (. ~(tag (str `long+double>boolean) '>|__34) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `long+double>boolean) '>|__34) ~'invoke ~'x00__ ~'x10__) (unsupported! `> [~'x00__ ~'x10__] 1)) ((Array/get ~'>|__35|types 0) ~'x00__) (ifs ((Array/get ~'>|__35|types 1) ~'x10__) - (. ~(tag (str `float+byte>boolean) '>|__35) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `float+byte>boolean) '>|__35) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__36|types 1) ~'x10__) - (. ~(tag (str `float+short>boolean) '>|__36) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `float+short>boolean) '>|__36) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__37|types 1) ~'x10__) - (. ~(tag (str `float+char>boolean) '>|__37) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `float+char>boolean) '>|__37) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__38|types 1) ~'x10__) - (. ~(tag (str `float+int>boolean) '>|__38) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `float+int>boolean) '>|__38) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__39|types 1) ~'x10__) - (. ~(tag (str `float+long>boolean) '>|__39) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `float+long>boolean) '>|__39) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__40|types 1) ~'x10__) - (. ~(tag (str `float+float>boolean) '>|__40) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `float+float>boolean) '>|__40) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__41|types 1) ~'x10__) - (. ~(tag (str `float+double>boolean) '>|__41) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `float+double>boolean) '>|__41) ~'invoke ~'x00__ ~'x10__) (unsupported! `> [~'x00__ ~'x10__] 1)) ((Array/get ~'>|__42|types 0) ~'x00__) (ifs ((Array/get ~'>|__42|types 1) ~'x10__) - (. ~(tag (str `double+byte>boolean) '>|__42) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `double+byte>boolean) '>|__42) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__43|types 1) ~'x10__) - (. ~(tag (str `double+short>boolean) '>|__43) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `double+short>boolean) '>|__43) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__44|types 1) ~'x10__) - (. ~(tag (str `double+char>boolean) '>|__44) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `double+char>boolean) '>|__44) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__45|types 1) ~'x10__) - (. ~(tag (str `double+int>boolean) '>|__45) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `double+int>boolean) '>|__45) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__46|types 1) ~'x10__) - (. ~(tag (str `double+long>boolean) '>|__46) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `double+long>boolean) '>|__46) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__47|types 1) ~'x10__) - (. ~(tag (str `double+float>boolean) '>|__47) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `double+float>boolean) '>|__47) ~'invoke ~'x00__ ~'x10__) ((Array/get ~'>|__48|types 1) ~'x10__) - (. ~(tag (str `double+double>boolean) '>|__48) ~'invoke ~'x00__ ~'x10__) + (. ~(tag (cstr `double+double>boolean) '>|__48) ~'invoke ~'x00__ ~'x10__) (unsupported! `> [~'x00__ ~'x10__] 1)) (unsupported! `> [~'x00__ ~'x10__] 0)))))) @@ -1006,21 +1012,21 @@ ([~'x00__] (ifs ((Array/get ~'>long*|__0|input0|types 0) ~'x00__) - (.invoke ~(tag (str `byte>long) '>long*|__0|0) ~'x00__) + (.invoke ~(tag (cstr `byte>long) '>long*|__0|0) ~'x00__) ((Array/get ~'>long*|__0|input0|types 1) ~'x00__) - (.invoke ~(tag (str `short>long) '>long*|__0|1) ~'x00__) + (.invoke ~(tag (cstr `short>long) '>long*|__0|1) ~'x00__) ((Array/get ~'>long*|__0|input0|types 2) ~'x00__) - (.invoke ~(tag (str `char>long) '>long*|__0|2) ~'x00__) + (.invoke ~(tag (cstr `char>long) '>long*|__0|2) ~'x00__) ((Array/get ~'>long*|__0|input0|types 3) ~'x00__) - (.invoke ~(tag (str `int>long) '>long*|__0|3) ~'x00__) + (.invoke ~(tag (cstr `int>long) '>long*|__0|3) ~'x00__) ((Array/get ~'>long*|__0|input0|types 4) ~'x00__) - (.invoke ~(tag (str `long>long) '>long*|__0|4) ~'x00__) + (.invoke ~(tag (cstr `long>long) '>long*|__0|4) ~'x00__) ((Array/get ~'>long*|__0|input0|types 5) ~'x00__) - (.invoke ~(tag (str `float>long) '>long*|__0|5) ~'x00__) + (.invoke ~(tag (cstr `float>long) '>long*|__0|5) ~'x00__) ((Array/get ~'>long*|__0|input0|types 6) ~'x00__) - (.invoke ~(tag (str `double>long) '>long*|__0|6) ~'x00__) + (.invoke ~(tag (cstr `double>long) '>long*|__0|6) ~'x00__) ((Array/get ~'>long*|__1|input0|types 0) ~'x00__) - (.invoke ~(tag (str `Object>long) '>long*|__1|0) ~'x00__) + (.invoke ~(tag (cstr `Object>long) '>long*|__1|0) ~'x00__) (unsupported! `>long* [~'x00__] 0)))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" @@ -1070,10 +1076,10 @@ ([~'x00__] (ifs ((Array/get ~'ref-output-type|__0|input0|types 0) ~'x00__) - (.invoke ~(tag (str `boolean>Object) 'ref-output-type|__0|0) + (.invoke ~(tag (cstr `boolean>Object) 'ref-output-type|__0|0) ~'x00__) ((Array/get ~'ref-output-type|__1|input0|types 0) ~'x00__) - (.invoke ~(tag (str `byte>Object) 'ref-output-type|__1|0) + (.invoke ~(tag (cstr `byte>Object) 'ref-output-type|__1|0) ~'x00__) (unsupported! `ref-output-type [~'x00__] 0))))))] (testing "code equivalence" (is-code= actual expected))))) @@ -1393,7 +1399,7 @@ ([~'x00__] (ifs ((Array/get ~'defn-self-reference|__1|input0|types 0) ~'x00__) - (.invoke ~(tag (str `long>Object) 'defn-self-reference|__1|0) + (.invoke ~(tag (cstr `long>Object) 'defn-self-reference|__1|0) ~'x00__) (unsupported! `defn-self-reference [~'x00__] 0)))))))] (testing "code equivalence" (is-code= actual expected)) @@ -1412,7 +1418,7 @@ (reify* [>long] (~(L 'invoke) [~'_0__] ~'(>long* 1)))) (defn ~'defn-reference {:quantum.core.type/type (t/fn t/any? [])} - ([] (.invoke ~(tag (str `>long) 'defn-reference|__0|0)))))))] + ([] (.invoke ~(tag (cstr `>long) 'defn-reference|__0|0)))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) From dabdceacc8c24af6976a4e92da3e2cc0becb5f56 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 11 Oct 2018 14:05:54 -0600 Subject: [PATCH 494/810] Another test passes! --- .../quantum/test/untyped/core/type/defnt.cljc | 36 +++++++++---------- 1 file changed, 16 insertions(+), 20 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index d0cf35f0..28a6405c 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1052,35 +1052,31 @@ ([x tt/boolean? > (t/ref tt/boolean?)] (Boolean. x)) ([x tt/byte? > (t/ref tt/byte?)] (Byte. x)))) expected - ($ (do ;; [x tt/boolean? > (t/ref tt/boolean?)] + ($ (do (declare ~'ref-output-type) - (def ~(O<> 'ref-output-type|__0|input0|types) - (*<> (t/isa? java.lang.Boolean))) - (def ~'ref-output-type|__0|0 - (reify* [boolean>Object] - (~(O 'invoke) [~'_0__ ~(B 'x)] (new ~'Boolean ~'x)))) + ;; [x tt/boolean? > (t/ref tt/boolean?)] + + (def ~(O<> 'ref-output-type|__0|types) (*<> (t/isa? java.lang.Boolean))) + (def ~'ref-output-type|__0 + (reify* [boolean>Object] (~(O 'invoke) [~'_0__ ~(B 'x)] (new ~'Boolean ~'x)))) ;; [x tt/byte? > (t/ref tt/byte?)] - (def ~(O<> 'ref-output-type|__1|input0|types) - (*<> (t/isa? java.lang.Byte))) - (def ~'ref-output-type|__1|0 - (reify* [byte>Object] - (~(O 'invoke) [~'_1__ ~(Y 'x)] (new ~'Byte ~'x)))) + (def ~(O<> 'ref-output-type|__1|types) (*<> (t/isa? java.lang.Byte))) + (def ~'ref-output-type|__1 + (reify* [byte>Object] (~(O 'invoke) [~'_1__ ~(Y 'x)] (new ~'Byte ~'x)))) (defn ~'ref-output-type {:quantum.core.type/type - (t/fn t/any? - ~'[tt/boolean? :> (t/ref tt/boolean?)] - ~'[tt/byte? :> (t/ref tt/byte?)])} + (t/ftype t/any? + [(t/isa? Boolean) :> (t/ref (t/isa? Boolean))] + [(t/isa? Byte) :> (t/ref (t/isa? Byte))])} ([~'x00__] (ifs - ((Array/get ~'ref-output-type|__0|input0|types 0) ~'x00__) - (.invoke ~(tag (cstr `boolean>Object) 'ref-output-type|__0|0) - ~'x00__) - ((Array/get ~'ref-output-type|__1|input0|types 0) ~'x00__) - (.invoke ~(tag (cstr `byte>Object) 'ref-output-type|__1|0) - ~'x00__) + ((Array/get ~'ref-output-type|__0|types 0) ~'x00__) + (. ~(tag (cstr `boolean>Object) 'ref-output-type|__0) ~'invoke ~'x00__) + ((Array/get ~'ref-output-type|__1|types 0) ~'x00__) + (. ~(tag (cstr `byte>Object) 'ref-output-type|__1) ~'invoke ~'x00__) (unsupported! `ref-output-type [~'x00__] 0))))))] (testing "code equivalence" (is-code= actual expected))))) From 4fe35ace25ee9427041283fc553bf7f979280c36 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 11 Oct 2018 15:04:23 -0600 Subject: [PATCH 495/810] Ensure object types get cast appropriately --- src-untyped/quantum/untyped/core/analyze.cljc | 20 ++++--- src-untyped/quantum/untyped/core/type.cljc | 6 +- .../quantum/untyped/core/type/defnt.cljc | 55 +++++++++++-------- src/quantum/core/data/primitive.cljc | 32 +++++------ src/quantum/core/type.cljc | 7 ++- .../quantum/test/untyped/core/type/defnt.cljc | 4 +- 6 files changed, 71 insertions(+), 53 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index e6206c52..3f46cf14 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -667,14 +667,17 @@ (defns- handle-type-combinators [caller|node uast/node?, input-nodes _, out-type t/type? > t/type?] (condp = (:type caller|node) - (t/value t/isa?) (apply-arg-type-combine t/isa? input-nodes) - (t/value t/or) (apply-arg-type-combine t/or input-nodes) - (t/value t/and) (apply-arg-type-combine t/and input-nodes) - (t/value t/-) (apply-arg-type-combine t/- input-nodes) - (t/value t/?) (apply-arg-type-combine t/? input-nodes) - (t/value t/*) (apply-arg-type-combine t/* input-nodes) - (t/value t/ref) (apply-arg-type-combine t/ref input-nodes) - (t/value t/assume) (apply-arg-type-combine t/assume input-nodes) + (t/value t/isa?) (apply-arg-type-combine t/isa? input-nodes) + (t/value t/value) (apply-arg-type-combine t/value input-nodes) + (t/value t/or) (apply-arg-type-combine t/or input-nodes) + (t/value t/and) (apply-arg-type-combine t/and input-nodes) + (t/value t/-) (apply-arg-type-combine t/- input-nodes) + (t/value t/?) (apply-arg-type-combine t/? input-nodes) + (t/value t/*) (apply-arg-type-combine t/* input-nodes) + (t/value t/ref) (apply-arg-type-combine t/ref input-nodes) + (t/value t/unref) (apply-arg-type-combine t/unref input-nodes) + (t/value t/assume) (apply-arg-type-combine t/assume input-nodes) + (t/value t/unassume) (apply-arg-type-combine t/unassume input-nodes) out-type)) (defns- analyze-seq|call @@ -739,7 +742,6 @@ :args input-nodes :type out-type'}))))) -;; TODO break this fn up. It's "clean" but just not broken up (defns- analyze-seq* "Analyze a seq after it has been macro-expanded. The ->`form` is post- incremental macroexpansion." diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index ce7d5096..863d42ad 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -224,7 +224,7 @@ 1 (first args) (OrType. uhash/default uhash/default nil args (atom nil)))))))))) - ([t0 utr/type?, t1 utr/type? & ts (us/seq-of utr/type?) > utr/type?] (reduce - (- t0 t1) ts))) + ([t0 utr/type?, t1 utr/type? & ts _ > utr/type?] (reduce - (- t0 t1) ts))) ;; TODO clean up (defns >type @@ -282,6 +282,8 @@ be, it is assumed that the output satisfies that type." [t utr/type? > utr/type?] (update-meta t assoc :quantum.core.type/assume? true)) +(defns unassume [t utr/type? > utr/type?] (update-meta t dissoc :quantum.core.type/assume?)) + (defns * "Denote on a type that it must be enforced at runtime. For use with `defnt`." @@ -292,6 +294,8 @@ For use with `defnt`." [t utr/type? > utr/type?] (update-meta t assoc :quantum.core.type/ref? true)) +(defns unref [t utr/type? > utr/type?] (update-meta t dissoc :quantum.core.type/ref?)) + ;; ===== Logical ===== ;; (defns >logical-complement diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 189bc5d7..61988798 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -85,15 +85,12 @@ :output-type t/type? :body-codelist|pre-analyze t/any?})) -(s/def ::overload|arg-classes (s/vec-of class?)) -(s/def ::overload|arg-types (s/seq-of t/type?)) - ;; This is the overload after the input specs are split by their respective `t/or` constituents, ;; and after primitivization, but before readiness for incorporation into a `reify`. ;; One of these corresponds to one reify overload. (s/def ::overload - (s/kv {:arg-classes ::overload|arg-classes - :arg-types ::overload|arg-types + (s/kv {:arg-classes (s/vec-of class?) + :arg-types (s/seq-of t/type?) :arglist-code|fn|hinted t/any? :arglist-code|reify|unhinted t/any? :body-form t/any? @@ -146,14 +143,14 @@ (defns type>class "Converts type to class after type has gone through the split+primitivization process." [t t/type? > class?] - (if (-> t meta :quantum.core.type/ref?) - java.lang.Object - (let [cs (t/type>classes t) - cs' (disj cs nil)] - (if (-> cs' count (not= 1)) - java.lang.Object - (-> (first cs') - (cond-> (not (contains? cs nil)) t/class>most-primitive-class) class>simplest-class)))))) + (let [cs (t/type>classes t) + cs' (disj cs nil)] + (if (-> cs' count (not= 1)) + java.lang.Object + (-> (first cs') + (cond-> (and (not (contains? cs nil)) + (not (-> t meta :quantum.core.type/ref?))) + t/class>most-primitive-class)))))) (defns- >actual-output-type [declared-output-type t/type?, body-node uast/node? > t/type?] (let [err-info {:form (:form body-node) @@ -187,8 +184,17 @@ [arg-binding (uast/unbound nil arg-binding arg-type)])) ;; To support recursion (<- (assoc fn|name recursive-ast-node-reference))) - body-node (uana/analyze env (ufgen/?wrap-do body-codelist|pre-analyze)) arg-classes (->> arg-types (uc/map type>class)) + body|pre-analyze|with-casts + (->> arg-classes + (reducei (fn [body ^Class c i|arg] + (if (.isPrimitive c) + body + (let [arg-sym (get arg-bindings i|arg)] + `(let* [~(ufth/with-type-hint arg-sym (.getName c)) ~arg-sym] + ~body)))) + (ufgen/?wrap-do body-codelist|pre-analyze))) + body-node (uana/analyze env body|pre-analyze|with-casts) hint-arg|fn (fn [i arg-binding] (ufth/with-type-hint arg-binding (ufth/>fn-arglist-tag @@ -251,24 +257,27 @@ {:keys [fn|name _]} ::fn|globals i|overload index? > ::reify] - (let [interface-k {:out output-class :in arg-classes} + (let [arg-classes|reify (->> arg-classes (uc/map class>simplest-class)) + output-class|reify (class>simplest-class output-class) + interface-k {:out output-class|reify :in arg-classes|reify} interface (-> *interfaces (swap! update interface-k - #(or % (eval (overload-classes>interface arg-classes output-class gen-gensym)))) + #(or % (eval (overload-classes>interface arg-classes|reify output-class|reify + gen-gensym)))) (uc/get interface-k)) arglist-code - (>vec (concat [(gen-gensym '_)] - (->> arglist-code|reify|unhinted - (map-indexed - (fn [i|arg arg|form] - (ufth/with-type-hint arg|form - (-> arg-classes (uc/get i|arg) ufth/>arglist-embeddable-tag))))))) + (ur/join [(gen-gensym '_)] + (->> arglist-code|reify|unhinted + (uc/map-indexed + (fn [i|arg arg|form] + (ufth/with-type-hint arg|form + (-> arg-classes|reify (uc/get i|arg) ufth/>arglist-embeddable-tag)))))) reify-name (>symbol (str fn|name "|__" i|overload)) form `(~'def ~reify-name (reify* [~(-> interface >name >symbol)] (~(ufth/with-type-hint reify-method-sym - (ufth/>arglist-embeddable-tag output-class)) + (ufth/>arglist-embeddable-tag output-class|reify)) ~arglist-code ~body-form)))] {:form form :interface interface diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index fb23be39..8f2221d7 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -87,26 +87,26 @@ #?(:clj (t/defn ^:inline box - (^:intrinsic [x boolean? > (t/assume (t/ref boolean?))] (Boolean/valueOf x)) - (^:intrinsic [x byte? > (t/assume (t/ref byte?))] (Byte/valueOf x)) - (^:intrinsic [x char? > (t/assume (t/ref char?))] (Character/valueOf x)) - (^:intrinsic [x short? > (t/assume (t/ref short?))] (Short/valueOf x)) - (^:intrinsic [x int? > (t/assume (t/ref int?))] (Integer/valueOf x)) - (^:intrinsic [x long? > (t/assume (t/ref long?))] (Long/valueOf x)) - (^:intrinsic [x float? > (t/assume (t/ref float?))] (Float/valueOf x)) - (^:intrinsic [x double? > (t/assume (t/ref double?))] (Double/valueOf x)) + (^:intrinsic [x boolean? > (t/assume (t/ref (t/type x)))] (Boolean/valueOf x)) + (^:intrinsic [x byte? > (t/assume (t/ref (t/type x)))] (Byte/valueOf x)) + (^:intrinsic [x char? > (t/assume (t/ref (t/type x)))] (Character/valueOf x)) + (^:intrinsic [x short? > (t/assume (t/ref (t/type x)))] (Short/valueOf x)) + (^:intrinsic [x int? > (t/assume (t/ref (t/type x)))] (Integer/valueOf x)) + (^:intrinsic [x long? > (t/assume (t/ref (t/type x)))] (Long/valueOf x)) + (^:intrinsic [x float? > (t/assume (t/ref (t/type x)))] (Float/valueOf x)) + (^:intrinsic [x double? > (t/assume (t/ref (t/type x)))] (Double/valueOf x)) ( [x t/ref?] x))) #?(:clj (t/defn ^:inline unbox - (^:intrinsic [x (t/ref boolean?) > boolean?] (.booleanValue x)) - (^:intrinsic [x (t/ref byte?) > byte?] (.byteValue x)) - (^:intrinsic [x (t/ref char?) > char?] (.charValue x)) - (^:intrinsic [x (t/ref short?) > short?] (.shortValue x)) - (^:intrinsic [x (t/ref int?) > int?] (.intValue x)) - (^:intrinsic [x (t/ref long?) > long?] (.longValue x)) - (^:intrinsic [x (t/ref float?) > float?] (.floatValue x)) - (^:intrinsic [x (t/ref double?) > double?] (.doubleValue x)))) + (^:intrinsic [x (t/ref boolean?) > (t/unref (t/type x))] (.booleanValue x)) + (^:intrinsic [x (t/ref byte?) > (t/unref (t/type x))] (.byteValue x)) + (^:intrinsic [x (t/ref char?) > (t/unref (t/type x))] (.charValue x)) + (^:intrinsic [x (t/ref short?) > (t/unref (t/type x))] (.shortValue x)) + (^:intrinsic [x (t/ref int?) > (t/unref (t/type x))] (.intValue x)) + (^:intrinsic [x (t/ref long?) > (t/unref (t/type x))] (.longValue x)) + (^:intrinsic [x (t/ref float?) > (t/unref (t/type x))] (.floatValue x)) + (^:intrinsic [x (t/ref double?) > (t/unref (t/type x))] (.doubleValue x)))) ;; ===== Bit lengths ===== ;; diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index 929519de..d054e19d 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -1,7 +1,7 @@ (ns quantum.core.type "This is this the namespace upon which all other fully-typed namespaces rest." (:refer-clojure :exclude - [* - and any? defn fn fn? isa? not or ref seq? symbol? var?]) + [* - and any? defn fn fn? isa? not or ref seq? symbol? type var?]) (:require [quantum.untyped.core.type.defnt :as udefnt] [quantum.untyped.core.type :as ut] @@ -13,15 +13,16 @@ (defalias udefnt/defn) (defaliases ut + type ;; Generators ? * isa? ; fn ; TODO TYPED rename ftype - value + value, unvalue ;; Combinators and or - if not ;; Metadata suppliers - ref assume + ref unref, assume unassume ;; Predicates any? nil? diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 28a6405c..3e47997b 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -955,7 +955,9 @@ ([x (t/ref (t/isa? Number))] (.longValue x)))) expected (case (env-lang) - :clj ($ (do ;; [x (t/- tt/primitive? tt/boolean?)] + :clj ($ (do (declare ~'>long*) + + ;; [x (t/- tt/primitive? tt/boolean?)] (def ~(O<> '>long*|__0|input0|types) (*<> (t/isa? java.lang.Byte) From 9c0f5ee441b8c3bbf75859030bb29e9f677669fc Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 11 Oct 2018 18:23:10 -0600 Subject: [PATCH 496/810] More basic ops are in place --- resources-dev/clojure-lang-numbers-temp.java | 138 -------- resources-dev/clojure-lang-util-temp.java | 220 ++++++++++++ resources-dev/defnt.cljc | 107 +++--- src-java/quantum/core/Numeric.java | 14 +- src/quantum/core/compare.cljc | 65 +--- src/quantum/core/compare/core.cljc | 85 ++--- src/quantum/core/data/bits.cljc | 330 ++++++++++-------- src/quantum/core/data/map.cljc | 4 +- src/quantum/core/data/numeric.cljc | 51 ++- src/quantum/core/data/primitive.cljc | 346 +++++++------------ src/quantum/core/primitive.cljc | 199 +++++++++++ src/quantum/core/type.cljc | 2 +- 12 files changed, 876 insertions(+), 685 deletions(-) create mode 100644 resources-dev/clojure-lang-util-temp.java create mode 100644 src/quantum/core/primitive.cljc diff --git a/resources-dev/clojure-lang-numbers-temp.java b/resources-dev/clojure-lang-numbers-temp.java index 485d4250..036c0823 100644 --- a/resources-dev/clojure-lang-numbers-temp.java +++ b/resources-dev/clojure-lang-numbers-temp.java @@ -312,10 +312,6 @@ else if(d.equals(BigInteger.ONE.negate())) (d.signum() < 0 ? d.negate() : d)); } -static public int shiftLeftInt(int x, int n){ - return x << n; -} - static public long shiftLeft(Object x, Object y){ return shiftLeft(bitOpsCast(x),bitOpsCast(y)); } @@ -325,13 +321,6 @@ static public long shiftLeft(Object x, long y){ static public long shiftLeft(long x, Object y){ return shiftLeft(x,bitOpsCast(y)); } -static public long shiftLeft(long x, long n){ - return x << n; -} - -static public int shiftRightInt(int x, int n){ - return x >> n; -} static public long shiftRight(Object x, Object y){ return shiftRight(bitOpsCast(x),bitOpsCast(y)); @@ -342,13 +331,7 @@ static public long shiftRight(Object x, long y){ static public long shiftRight(long x, Object y){ return shiftRight(x,bitOpsCast(y)); } -static public long shiftRight(long x, long n){ - return x >> n; -} -static public int unsignedShiftRightInt(int x, int n){ - return x >>> n; -} static public long unsignedShiftRight(Object x, Object y){ return unsignedShiftRight(bitOpsCast(x),bitOpsCast(y)); @@ -359,9 +342,6 @@ static public long unsignedShiftRight(Object x, long y){ static public long unsignedShiftRight(long x, Object y){ return unsignedShiftRight(x,bitOpsCast(y)); } -static public long unsignedShiftRight(long x, long n){ - return x >>> n; -} final static class LongOps implements Ops{ public Ops combine(Ops y){ @@ -1459,26 +1439,6 @@ static public double divide(double x, double y){ return x / y; } -static public boolean equiv(double x, double y){ - return x == y; -} - -static public boolean lt(double x, double y){ - return x < y; -} - -static public boolean lte(double x, double y){ - return x <= y; -} - -static public boolean gt(double x, double y){ - return x > y; -} - -static public boolean gte(double x, double y){ - return x >= y; -} - static public boolean isPos(double x){ return x > 0; } @@ -1537,13 +1497,6 @@ static public int unchecked_int_multiply(int x, int y){ static public long not(Object x){ return not(bitOpsCast(x)); } -static public long not(long x){ - return ~x; -} -//static public int and(int x, int y){ -// return x & y; -//} - static public long and(Object x, Object y){ return and(bitOpsCast(x),bitOpsCast(y)); } @@ -1553,13 +1506,6 @@ static public long and(Object x, long y){ static public long and(long x, Object y){ return and(x,bitOpsCast(y)); } -static public long and(long x, long y){ - return x & y; -} - -//static public int or(int x, int y){ -// return x | y; -//} static public long or(Object x, Object y){ return or(bitOpsCast(x),bitOpsCast(y)); @@ -1570,13 +1516,6 @@ static public long or(Object x, long y){ static public long or(long x, Object y){ return or(x,bitOpsCast(y)); } -static public long or(long x, long y){ - return x | y; -} - -//static public int xor(int x, int y){ -// return x ^ y; -//} static public long xor(Object x, Object y){ return xor(bitOpsCast(x),bitOpsCast(y)); @@ -1587,22 +1526,6 @@ static public long xor(Object x, long y){ static public long xor(long x, Object y){ return xor(x,bitOpsCast(y)); } -static public long xor(long x, long y){ - return x ^ y; -} - -static public long andNot(Object x, Object y){ - return andNot(bitOpsCast(x),bitOpsCast(y)); -} -static public long andNot(Object x, long y){ - return andNot(bitOpsCast(x),y); -} -static public long andNot(long x, Object y){ - return andNot(x,bitOpsCast(y)); -} -static public long andNot(long x, long y){ - return x & ~y; -} static public long clearBit(Object x, Object y){ return clearBit(bitOpsCast(x),bitOpsCast(y)); @@ -1897,26 +1820,6 @@ static public long remainder(long x, long y){ return x % y; } -static public boolean equiv(long x, long y){ - return x == y; -} - -static public boolean lt(long x, long y){ - return x < y; -} - -static public boolean lte(long x, long y){ - return x <= y; -} - -static public boolean gt(long x, long y){ - return x > y; -} - -static public boolean gte(long x, long y){ - return x >= y; -} - static public boolean isPos(long x){ return x > 0; } @@ -2120,14 +2023,6 @@ static public boolean lt(Object x, double y){ return ((Number)x).doubleValue() < y; } -static public boolean lt(double x, long y){ - return x < y; -} - -static public boolean lt(long x, double y){ - return x < y; -} - static public boolean lte(long x, Object y){ return lte((Object)x,y); } @@ -2144,14 +2039,6 @@ static public boolean lte(Object x, double y){ return ((Number)x).doubleValue() <= y; } -static public boolean lte(double x, long y){ - return x <= y; -} - -static public boolean lte(long x, double y){ - return x <= y; -} - static public boolean gt(long x, Object y){ return gt((Object)x,y); } @@ -2168,14 +2055,6 @@ static public boolean gt(Object x, double y){ return ((Number)x).doubleValue() > y; } -static public boolean gt(double x, long y){ - return x > y; -} - -static public boolean gt(long x, double y){ - return x > y; -} - static public boolean gte(long x, Object y){ return gte((Object)x,y); } @@ -2192,14 +2071,6 @@ static public boolean gte(Object x, double y){ return ((Number)x).doubleValue() >= y; } -static public boolean gte(double x, long y){ - return x >= y; -} - -static public boolean gte(long x, double y){ - return x >= y; -} - static public boolean equiv(long x, Object y){ return equiv((Object)x,y); } @@ -2216,15 +2087,6 @@ static public boolean equiv(Object x, double y){ return ((Number)x).doubleValue() == y; } -static public boolean equiv(double x, long y){ - return x == y; -} - -static public boolean equiv(long x, double y){ - return x == y; -} - - static boolean isNaN(Object x){ return (x instanceof Double) && ((Double)x).isNaN() || (x instanceof Float) && ((Float)x).isNaN(); diff --git a/resources-dev/clojure-lang-util-temp.java b/resources-dev/clojure-lang-util-temp.java new file mode 100644 index 00000000..0adecfab --- /dev/null +++ b/resources-dev/clojure-lang-util-temp.java @@ -0,0 +1,220 @@ +public class Util{ +static public boolean equiv(Object k1, Object k2){ + if(k1 == k2) + return true; + if(k1 != null) + { + if(k1 instanceof Number && k2 instanceof Number) + return Numbers.equal((Number)k1, (Number)k2); + else if(k1 instanceof IPersistentCollection || k2 instanceof IPersistentCollection) + return pcequiv(k1,k2); + return k1.equals(k2); + } + return false; +} + +public interface EquivPred{ + boolean equiv(Object k1, Object k2); +} + +static EquivPred equivNull = new EquivPred() { + public boolean equiv(Object k1, Object k2) { + return k2 == null; + } + }; + +static EquivPred equivEquals = new EquivPred(){ + public boolean equiv(Object k1, Object k2) { + return k1.equals(k2); + } + }; + +static EquivPred equivNumber = new EquivPred(){ + public boolean equiv(Object k1, Object k2) { + if(k2 instanceof Number) + return Numbers.equal((Number) k1, (Number) k2); + return false; + } + }; + +static EquivPred equivColl = new EquivPred(){ + public boolean equiv(Object k1, Object k2) { + if(k1 instanceof IPersistentCollection || k2 instanceof IPersistentCollection) + return pcequiv(k1, k2); + return k1.equals(k2); + } + }; + +static public EquivPred equivPred(Object k1){ + if(k1 == null) + return equivNull; + else if (k1 instanceof Number) + return equivNumber; + else if (k1 instanceof String || k1 instanceof Symbol) + return equivEquals; + else if (k1 instanceof Collection || k1 instanceof Map) + return equivColl; + return equivEquals; +} + +static public boolean equiv(Object k1, long k2){ + return equiv(k1, (Object)k2); +} + +static public boolean equiv(long k1, Object k2){ + return equiv((Object)k1, k2); +} + +static public boolean equiv(Object k1, double k2){ + return equiv(k1, (Object)k2); +} + +static public boolean equiv(double k1, Object k2){ + return equiv((Object)k1, k2); +} + +static public boolean equiv(Object k1, boolean k2){ + return equiv(k1, (Object)k2); +} + +static public boolean equiv(boolean k1, Object k2){ + return equiv((Object)k1, k2); +} + +static public boolean equiv(char c1, char c2) { + return c1 == c2; +} + +static public boolean pcequiv(Object k1, Object k2){ + if(k1 instanceof IPersistentCollection) + return ((IPersistentCollection)k1).equiv(k2); + return ((IPersistentCollection)k2).equiv(k1); +} + +static public boolean equals(Object k1, Object k2){ + if(k1 == k2) + return true; + return k1 != null && k1.equals(k2); +} + +static public Class classOf(Object x){ + if(x != null) + return x.getClass(); + return null; +} + +static public int compare(Object k1, Object k2){ + if(k1 == k2) + return 0; + if(k1 != null) + { + if(k2 == null) + return 1; + if(k1 instanceof Number) + return Numbers.compare((Number) k1, (Number) k2); + return ((Comparable) k1).compareTo(k2); + } + return -1; +} + +static public int hash(Object o){ + if(o == null) + return 0; + return o.hashCode(); +} + +public static int hasheq(Object o){ + if(o == null) + return 0; + if(o instanceof IHashEq) + return dohasheq((IHashEq) o); + if(o instanceof Number) + return Numbers.hasheq((Number)o); + if(o instanceof String) + return Murmur3.hashInt(o.hashCode()); + return o.hashCode(); +} + +private static int dohasheq(IHashEq o) { + return o.hasheq(); +} + +static public int hashCombine(int seed, int hash){ + //a la boost + seed ^= hash + 0x9e3779b9 + (seed << 6) + (seed >> 2); + return seed; +} + +static public boolean isPrimitive(Class c){ + return c != null && c.isPrimitive() && !(c == Void.TYPE); +} + +static public boolean isInteger(Object x){ + return x instanceof Integer + || x instanceof Long + || x instanceof BigInt + || x instanceof BigInteger; +} + +static public Object ret1(Object ret, Object nil){ + return ret; +} + +static public ISeq ret1(ISeq ret, Object nil){ + return ret; +} + +static public void clearCache(ReferenceQueue rq, ConcurrentHashMap> cache){ + //cleanup any dead entries + if(rq.poll() != null) + { + while(rq.poll() != null) + ; + for(Map.Entry> e : cache.entrySet()) + { + Reference val = e.getValue(); + if(val != null && val.get() == null) + cache.remove(e.getKey(), val); + } + } +} + +static public RuntimeException runtimeException(String s){ + return new RuntimeException(s); +} + +static public RuntimeException runtimeException(String s, Throwable e){ + return new RuntimeException(s, e); +} + +/** + * Throw even checked exceptions without being required + * to declare them or catch them. Suggested idiom: + *

+ * throw sneakyThrow( some exception ); + */ +static public RuntimeException sneakyThrow(Throwable t) { + // http://www.mail-archive.com/javaposse@googlegroups.com/msg05984.html + if (t == null) + throw new NullPointerException(); + Util.sneakyThrow0(t); + return null; +} + +@SuppressWarnings("unchecked") +static private void sneakyThrow0(Throwable t) throws T { + throw (T) t; +} + +static public Object loadWithClass(String scriptbase, Class loadFrom) throws IOException, ClassNotFoundException{ + Var.pushThreadBindings(RT.map(new Object[] { Compiler.LOADER, loadFrom.getClassLoader() })); + try { + return RT.var("clojure.core", "load").invoke(scriptbase); + } + finally + { + Var.popThreadBindings(); + } +} + +} diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index c25c7d1c..87e95280 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -59,15 +59,32 @@ TODO: Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - [1] t/value-of - - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` + [1] - t/numerically : e.g. a double representing exactly what a float is able to represent + - and variants thereof: `numerically-long?` etc. + - t/numerically-integer? + - In order to have this, you have to have comparisons in place + - In order for comparisons to be in place you need primitives to compare by + - For primitive conversions you need comparisons and `numerically` to determine ranges + - This is why we can have core.data.primitive and core.primitive + - core.data.primitive + - just type definitions and characteristics + - core.data.numeric (requires data.primitive) + - numeric definitions + - numeric ranges + - numeric characteristics + [ ] - t/value-of + - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` [ ] - (comp/t== x) - dependent type such that the passed input must be identical to x [2] - t/input-type - - `(t/input-type >namespace :?)` meaning the possible input types to the first input to `>namespace` - - `(t/input-type reduce :_ :_ :?)` - - Then if those fns ever get extended then it should trigger a chain-reaction of recompilations + - `(t/input-type >namespace :?)` meaning the possible input types to the first input to + `>namespace` + - `(t/input-type reduce :_ :_ :?)` + - This is pretty simple with the current dependent type system + - Then if those fns ever get extended then it should trigger a chain-reaction of recompilations [3] - t/output-type + - This is pretty simple with the current dependent type system + [ ] - Non-boxed `def`s: `(var/def- min-float (Numeric/negate Float/MAX_VALUE))` [4] - t/extend-defn! - We could just recreate the dispatch every time, in the beginning. It would make for slower compilation but faster execution for dynamic dispatch, and quicker time to use. So whenever @@ -92,9 +109,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - We should probably have a 'normal form' so we can correctly hash if we do spec lookup - t/- : fix - (t/- (t/isa? java.util.Queue) (t/or ?!+queue? !!queue?)) - - t/numerically : e.g. a double representing exactly what a float is able to represent - - and variants thereof: `numerically-long?` etc. - - t/numerically-integer? - dc/of - (dc/of number?) ; implicitly the container is a `reducible?` - (dc/of map/+map? symbol? dstr/string?) @@ -184,8 +198,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative ([x p/nil?] true) ([xs dc/counted?] (-> xs count num/zero?)) ([xs (t/input-type educe :_ :_ :?)] (educe empty?|rf x))) - - handle varargs + - handle varargs / variadic arity - [& args _] shouldn't result in `t/any?` but rather like `t/reducible?` or whatever + - should configurably auto-generate arities and/or perform variadic proxying - do the defnt-equivalences / `t/defn` test namespace - a linting warning that you can narrow the type to whatever the deduced type is from whatever wider declared type there is @@ -212,12 +227,12 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - List of semi-approximately topologically ordered namespaces to make typed: - [.] clojure.core / cljs.core (note that many things unexpectedly have associated macros) - [! !] .. - - [. .] < - - [. .] <= + - [x x] < + - [x x] <= - [. .] = — look at coercive-= - - [. .] == - - [. .] > - - [. .] >= + - [x x] == + - [x x] > + - [x x] >= - [. .] + - [. .] +' - [. .] - @@ -282,19 +297,19 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] biginteger - [ ] binding - [ ] binding-conveyor-fn - - [. .] bit-and + - [x .] bit-and - [! !] bit-and-not - [x .] bit-clear - [| ] bit-count - [x .] bit-flip - [x .] bit-not - - [. .] bit-or + - [x .] bit-or - [x .] bit-set - [x .] bit-shift-left - [x .] bit-shift-right - - [| ] bit-shift-right-zero-fill + - [| !] bit-shift-right-zero-fill - [x .] bit-test - - [. .] bit-xor + - [x .] bit-xor - [x .] boolean - [x x] boolean? - [ ] boolean-array @@ -494,7 +509,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [| ] hash-string* - [| ] hash-string - [x x] ident? - - [x .] identical? — NOTE CLJS has macro + - [x x] identical? - [x x] identity - [ ] if-let - [ ] if-not (not as performant as we thought) @@ -920,40 +935,41 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] zipmap - [.] Intrinsics https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/Intrinsics.java + (Clojure 1.10) - [ ] Numbers.add(double,double) - - [ ] Numbers.and(long,long) + - [x] Numbers.and(long,long) - [ ] Numbers.divide(double,double) - - [ ] Numbers.equiv(double,double) - - [ ] Numbers.equiv(long,long) - - [ ] Numbers.gt(long,long) - - [ ] Numbers.gt(double,double) - - [ ] Numbers.gte(long,long) - - [ ] Numbers.gte(double,double) + - [x] Numbers.equiv(double,double) + - [x] Numbers.equiv(long,long) + - [x] Numbers.gt(long,long) + - [x] Numbers.gt(double,double) + - [x] Numbers.gte(long,long) + - [x] Numbers.gte(double,double) - [ ] Numbers.isPos(long) - [ ] Numbers.isPos(double) - [ ] Numbers.isNeg(long) - [ ] Numbers.isNeg(double) - [ ] Numbers.isZero(double) - [ ] Numbers.isZero(long) - - [ ] Numbers.lt(long,long) - - [ ] Numbers.lt(double,double) - - [ ] Numbers.lte(long,long) - - [ ] Numbers.lte(double,double) - - [ ] Numbers.multiply(double,double) - - [ ] Numbers.or(long,long) - - [ ] Numbers.xor(long,long) - - [ ] Numbers.remainder(long,long) - - [ ] Numbers.shiftLeft(long,long) - - [ ] Numbers.shiftRight(long,long) - - [ ] Numbers.unsignedShiftRight(long,long) + - [x] Numbers.lt(long,long) + - [x] Numbers.lt(double,double) + - [x] Numbers.lte(long,long) + - [x] Numbers.lte(double,double) - [ ] Numbers.minus(double) - [ ] Numbers.minus(double,double) + - [ ] Numbers.multiply(double,double) + - [x] Numbers.or(long,long) + - [x] Numbers.xor(long,long) + - [ ] Numbers.remainder(long,long) - [ ] Numbers.inc(double) - [ ] Numbers.dec(double) - [ ] Numbers.quotient(long,long) - - [ ] Numbers.shiftLeftInt(int,int) - - [ ] Numbers.shiftRightInt(int,int) - - [ ] Numbers.unsignedShiftRightInt(int,int) + - [x] Numbers.shiftLeftInt(int,int) + - [x] Numbers.shiftLeft(long,long) + - [x] Numbers.shiftRightInt(int,int) + - [x] Numbers.shiftRight(long,long) + - [x] Numbers.unsignedShiftRightInt(int,int) + - [x] Numbers.unsignedShiftRight(long,long) - [ ] Numbers.unchecked_int_add(int,int) - [ ] Numbers.unchecked_int_subtract(int,int) - [ ] Numbers.unchecked_int_negate(int) @@ -1021,9 +1037,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] RT.uncheckedLongCast(byte) - [ ] RT.uncheckedLongCast(long) - [ ] RT.uncheckedLongCast(int) - - [ ] Util.equiv(long,long) - - [ ] Util.equiv(boolean,boolean) - - [ ] Util.equiv(double,double) + - [!] Util.equiv(long,long) + - [x] Util.equiv(boolean,boolean) + - [!] Util.equiv(double,double) - [ ] JS built-in functions (the most common/relevant ones) - ... - [ ] Java intrinsics @@ -1503,7 +1519,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] add - [ ] addP - [ ] and - - [ ] andNot + - [!] andNot - [ ] boolean_array - [ ] booleans - [ ] byte_array @@ -1625,7 +1641,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] `>str` - [.] quantum.core.data.map - [.] quantum.core.data.meta - - [.] quantum.core.compare + - [.] quantum.core.compare - should provide comparisons for all data in quantum.core.data - [ ] `compare` - [x] quantum.core.ns ; TODO split up into data.ns? - [.] quantum.core.vars @@ -1747,6 +1763,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative (fn ([] (vector)) ([x0] (identity x0)) ([x0 x1] (conj x0 x1)))}} + - :in — a Clojure or Java intrinsic - Instead of e.g. `ns-` or `var-` we can do `ns-val` and `var-val` [ ] Compile-Time (Direct) Dispatch diff --git a/src-java/quantum/core/Numeric.java b/src-java/quantum/core/Numeric.java index a5ceca64..f33e935e 100644 --- a/src-java/quantum/core/Numeric.java +++ b/src-java/quantum/core/Numeric.java @@ -22,12 +22,14 @@ public class Numeric { // ================================= Boolean Operations ===================================== // - public static boolean isTrue (final boolean a ) { return a; } - public static boolean isFalse (final boolean a ) { return !a; } - public static boolean isNil (final Object a ) { return a == null; } - public static boolean not (final boolean a ) { return !a; } - public static boolean and (final boolean a, final boolean b) { return a && b; } - public static boolean or (final boolean a, final boolean b) { return a || b; } + public static boolean identical (final Object a, final Object b) { return a == b; } + public static boolean nonIdentical(final Object a, final Object b) { return a != b; } + public static boolean isTrue (final boolean a ) { return a; } + public static boolean isFalse (final boolean a ) { return !a; } + public static boolean isNil (final Object a ) { return a == null; } + public static boolean not (final boolean a ) { return !a; } + public static boolean and (final boolean a, final boolean b) { return a && b; } + public static boolean or (final boolean a, final boolean b) { return a || b; } // =================================== Bit Operations ======================================= // diff --git a/src/quantum/core/compare.cljc b/src/quantum/core/compare.cljc index 657cbec7..8dcc7e8a 100644 --- a/src/quantum/core/compare.cljc +++ b/src/quantum/core/compare.cljc @@ -39,64 +39,13 @@ (:import clojure.lang.BigInt quantum.core.Numeric))) -;; TODO TYPED incorporate this commented code - -; (defnt ^boolean identical? -; [^Object k1, ^Object k2] -; (clojure.lang.RT/identical k1 k2)) - -; static public boolean pcequiv(Object k1, Object k2){ -; if(k1 instanceof IPersistentCollection) -; return ((IPersistentCollection)k1).equiv(k2); -; return ((IPersistentCollection)k2).equiv(k1); -; } - -; static public boolean equals(Object k1, Object k2){ -; if(k1 == k2) -; return true; -; return k1 != null && k1.equals(k2); -; } - -; static public boolean equiv(Object k1, Object k2){ -; if(k1 == k2) -; return true; -; if(k1 != null) -; { -; if(k1 instanceof Number && k2 instanceof Number) -; return Numbers.equal((Number)k1, (Number)k2); -; else if(k1 instanceof IPersistentCollection || k2 instanceof IPersistentCollection) -; return pcequiv(k1,k2); -; return k1.equals(k2); -; } -; return false; -; } - -; equivNull : boolean equiv(Object k1, Object k2) return k2 == null -; equivEquals : boolean equiv(Object k1, Object k2) return k1.equals(k2) -; equivNumber : boolean equiv(Object k1, Object k2) -; if(k2 instanceof Number) -; return Numbers.equal((Number) k1, (Number) k2); -; return false - -; equivColl : boolean equiv(Object k1, Object k2) -; if(k1 instanceof IPersistentCollection || k2 instanceof IPersistentCollection) -; return pcequiv(k1, k2); -; return k1.equals(k2); - -; ; equivPred: -; ; nil : equivNull -; ; Number : equivNumber -; ; String, Symbol : equivEquals -; ; Collection, Map : equivColl -; ; :else : equivEquals - -; (defnt equiv ^boolean -; ([^Object a #{long double boolean} b] (clojure.lang.RT/equiv a b)) -; ([#{long double boolean} a ^Object b] (clojure.lang.RT/equiv a b)) -; ([#{long double boolean} a #{long double boolean} b] (clojure.lang.RT/equiv a b)) -; ([^char a ^char b] (clojure.lang.RT/equiv a b)) - -; ) +;; TODO incorporate (CLJS) +(defn ^boolean = + ([x y] + (if (nil? x) + (nil? y) + (or (identical? x y) + ^boolean (-equiv x y))))) ;; TODO TYPED; also incorporate `core/fn->comparator` (defn fn->comparator [f] diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index f6654b6b..46376249 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -30,8 +30,6 @@ #?(:clj (:import [quantum.core Numeric]))) -;; TODO `==` from Numeric/equals - ;; Some of the ideas here adapted from gfredericks/compare ;; TODO include diffing ;; TODO use -compare in CLJS @@ -43,108 +41,73 @@ ;; `='` <- `=`: strict like `core/=` with numbers ;; `==` <- `identical?` ;; TODO `hash=` +;; TODO .equals vs. .equiv vs. all the others? ; ===== `==`, `=`, `not=` ===== ; -;; TODO TYPED +;; TODO add variadic arity (t/defn ^:inline == "Tests identity-equality." - > p/boolean? {:incorporated '{clojure.lang.Util/identical "9/27/2018" clojure.core/identical? "9/27/2018" cljs.core/identical? "9/27/2018"}} - ([x t/any?] true) - ([a ..., b ...] (clojure.lang.Util/identical a b))) + > p/boolean? + ([x t/any?] true) ; everything is self-identical +#?(:clj ([a t/ref?, b t/ref?] (clojure.lang.Util/identical a b)) + :cljs ([a t/any?, b t/any?] (cljs.core/identical? a b)))) +;; TODO add variadic arity (t/defn ^:inline not== "Tests identity-inequality." - ...) - -(defn ^boolean = - ([x y] - (if (nil? x) - (nil? y) - (or (identical? x y) - ^boolean (-equiv x y))))) - -;; TODO .equals vs. .equiv vs. all the others? - -(defn = - ([x y] (clojure.lang.Util/equiv x y)) - ([x y & more] - (if (clojure.lang.Util/equiv x y) - (if (next more) - (recur y (first more) (next more)) - (clojure.lang.Util/equiv y (first more))) - false))) - + > p/boolean? + ([x t/any?] false) ; everything is self-identical +#?(:clj ([a t/ref?, b t/ref?] (Numeric/nonIdentical a b)) + :cljs ([a t/any?, b t/any?] (js* "(~{} !== ~{})" a b)))) +;; TODO add variadic arity (t/defn ^:inline = "Tests value-equality." {:incorporated '{clojure.lang.Util/equiv "9/27/2018" clojure.core/= "9/27/2018" cljs.core/= "9/27/2018"}} > p/boolean? - ([x t/any?] true) -#?(:clj ([a p/boolean? , b p/boolean?] (Numeric/eq a b))) -#?(:clj ([a (t/- p/primitive? t/boolean?), b (t/- p/primitive? t/boolean?)] (Numeric/eq a b))) - ([a p/boolean? , b (t/- p/primitive? t/boolean?)] false) - ([a (t/- p/primitive? t/boolean?), b p/boolean?] false)) + ([x t/any?] true)) ; everything is self-equal +;; TODO add variadic arity (t/defn ^:inline not= "Tests value-inequality." - > p/boolean? {:incorporated '{clojure.core/not= "9/27/2018" cljs.core/not= "9/27/2018"}} - ([x t/any?] false) -#?(:clj ([a p/boolean? , b p/boolean?] (Numeric/neq a b))) -#?(:clj ([a (t/- p/primitive? t/boolean?), b (t/- p/primitive? t/boolean?)] (Numeric/neq a b))) - ([a p/boolean? , b (t/- p/primitive? t/boolean?)] true) - ([a (t/- p/primitive? t/boolean?), b p/boolean?] true)) + > p/boolean? + ([x t/any?] false)) ; everything is self-equal ; ===== `<` ===== ; +;; TODO add variadic arity (t/defn ^:inline < "Numeric less-than comparison." - > p/boolean? - ([x p/numeric?] true) - ([a p/numeric?, b p/numeric?] (Numeric/lt a b)) - ;; TODO numbers, but not nil - ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) - ) + > p/boolean?) ; ===== `<=` ===== ; +;; TODO add variadic arity (t/defn ^:inline <= "Numeric less-than-or-value-equal comparison." - > p/boolean? - ([x p/numeric?] true) - ([a p/numeric?, b p/numeric?] (Numeric/lte a b)) - ;; TODO numbers, but not nil - ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) - ) + > p/boolean?) ; ===== `>` ===== ; +;; TODO add variadic arity (t/defn ^:inline > "Numeric greater-than comparison." - > p/boolean? - ([x p/numeric?] true) - ([a p/numeric?, b p/numeric?] (Numeric/gt a b)) - ;; TODO numbers, but not nil - ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) - ) + > p/boolean?) ; ===== `>=` ===== ; +;; TODO add variadic arity (t/defn ^:inline >= "Numeric greater-than-or-value-equal comparison." - > p/boolean? - ([x p/numeric?] true) - ([a p/numeric?, b p/numeric?] (Numeric/gte a b)) - ; TODO numbers, but not nil - ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) - ) + > p/boolean?) ; ===== `compare` ===== ; diff --git a/src/quantum/core/data/bits.cljc b/src/quantum/core/data/bits.cljc index 88c9ad6f..e0944af5 100644 --- a/src/quantum/core/data/bits.cljc +++ b/src/quantum/core/data/bits.cljc @@ -10,13 +10,15 @@ [and conj contains? empty not or]) (:require [clojure.core :as core] + [quantum.core.data.numeric :as dnum + :refer [std-fixint?]] [quantum.core.data.primitive :as p :refer [>long]] - [quantum.core.type :as t - :refer [defnt]] + [quantum.core.type :as t] [quantum.core.vars :as var :refer [defalias]]) #?(:clj (:import + [clojure.lang Numbers] [quantum.core Numeric]))) ;; TODO make sure that for all bit ops here, there's a checked and unchecked version Because @@ -36,215 +38,259 @@ (var/def dec-float-bits (core/dec p/float-bits))) (var/def dec-double-bits (core/dec p/double-bits))) -(t/defn ^:inline dec-bits-of +(t/defn ^:inline dec-bits-of ; > dnum/fixint? ; TODO TYPED "For bit manipulation purposes" - ([x p/boolean?] dec-boolean-bits) -#?(:clj ([x p/byte?] dec-byte-bits)) -#?(:clj ([x p/short?] dec-short-bits)) -#?(:clj ([x p/int?] dec-int-bits)) -#?(:clj ([x p/long?] dec-long-bits)) -#?(:clj ([x p/float?] dec-float-bits)) - ([x p/double?] dec-double-bits)) + ([x p/boolean? > p/long?] dec-boolean-bits) +#?(:clj ([x p/byte? > p/long?] dec-byte-bits)) +#?(:clj ([x p/short? > p/long?] dec-short-bits)) +#?(:clj ([x p/int? > p/long?] dec-int-bits)) +#?(:clj ([x p/long? > p/long?] dec-long-bits)) +#?(:clj ([x p/float? > p/long?] dec-float-bits)) + ([x p/double? > p/long?] dec-double-bits)) ;; ===== Logical bit-operations ===== ;; ;; NOTE: we won't be supporting `clojure.core/and-not` -(defnt ^:inline not +(t/defn ^:inline not "Bitwise `not`." + {:incorporated {'clojure.core/bit-not #inst "2018-10-11" + 'cljs.core/bit-not #inst "2018-10-11"}} #?@(:clj [([x p/primitive? > (t/type x)] (Numeric/bitNot x))] - :cljs [([x p/boolean? > p/boolean?] (if x false true)) - ([x p/double? > (t/assume numerically-int?)] (core/bit-not x))])) + :cljs [([x p/boolean? > (t/type x)] (if x false true)) + ([x p/double? > (t/assume numerically-int?)] (core/bit-not x))])) ;; TODO make variadic ;; TODO TYPED we can shorten this by having dependent types -(defnt ^:inline and +(t/defn ^:inline and "Bitwise `and`." + {:incorporated {'clojure.core/bit-and #inst "2018-10-11" + 'cljs.core/bit-and #inst "2018-10-11"}} #?@(:clj [#_([a p/boolean?, b p/boolean? > ?] (Numeric/bitAnd a b)) - #_([a (t/- p/primitive? t/boolean?) - b (t/- p/primitive? t/boolean?) > ?] (Numeric/bitAnd a b)) - ([a p/boolean?, b p/boolean? > p/boolean?] (Numeric/bitAnd a b)) - ([a p/byte? , b p/byte? > p/byte?] (Numeric/bitAnd a b)) - ([a p/byte? , b p/short? > p/short?] (Numeric/bitAnd a b)) - ([a p/byte? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitAnd a b)) - ([a p/byte? , b p/long? > p/long?] (Numeric/bitAnd a b)) - ([a p/byte? , b p/float? > p/float?] (Numeric/bitAnd a b)) - ([a p/byte? , b p/double? > p/double?] (Numeric/bitAnd a b)) - ([a p/short? , b (t/or p/byte? p/short?) > p/short?] (Numeric/bitAnd a b)) - ([a p/short? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitAnd a b)) - ([a p/short? , b p/long? > p/long?] (Numeric/bitAnd a b)) - ([a p/short? , b p/float? > p/float?] (Numeric/bitAnd a b)) - ([a p/short? , b p/double? > p/double?] (Numeric/bitAnd a b)) - ([a p/char? , b (t/or p/byte? p/short?) > p/int?] (Numeric/bitAnd a b)) - ([a p/char? , b p/char? > p/char?] (Numeric/bitAnd a b)) - ([a p/char? , b p/int? > p/int?] (Numeric/bitAnd a b)) - ([a p/char? , b p/long? > p/long?] (Numeric/bitAnd a b)) - ([a p/char? , b p/float? > p/float?] (Numeric/bitAnd a b)) - ([a p/char? , b p/double? > p/double?] (Numeric/bitAnd a b)) - ([a p/int? , b (t/or p/byte? p/short? p/char? - p/int?) > p/int?] (Numeric/bitAnd a b)) - ([a p/int? , b p/long? > p/long?] (Numeric/bitAnd a b)) - ([a p/int? , b p/float? > p/float?] (Numeric/bitAnd a b)) - ([a p/int? , b p/double? > p/double?] (Numeric/bitAnd a b)) - ([a p/long? , b (t/or p/byte? p/short? p/char? - p/int? p/long?) > p/long?] (Numeric/bitAnd a b)) - ([a p/long? , b (t/or p/float? p/double?) > p/double?] (Numeric/bitAnd a b)) - ([a p/float? , b (t/or p/byte? p/short? p/char? - p/int? p/float?) > p/float?] (Numeric/bitAnd a b)) - ([a p/float? , b (t/or p/long? p/double?) > p/double?] (Numeric/bitAnd a b)) - ([a p/double? , b (t/- p/primitive? p/boolean?) > p/double?] (Numeric/bitAnd a b))] - :cljs [([a p/boolean?, b p/boolean? > p/boolean?] (core/and a b)) - ([a p/double? , b p/double? > (t/assume numerically-int?)] - (core/bit-and a b))])) + #_([a (t/- p/primitive? p/boolean?) + b (t/- p/primitive? p/boolean?) > ?] (Numeric/bitAnd a b)) + ( [a p/boolean?, b p/boolean? > p/boolean?] (Numeric/bitAnd a b)) + ( [a p/byte? , b p/byte? > p/byte?] (Numeric/bitAnd a b)) + ( [a p/byte? , b p/short? > p/short?] (Numeric/bitAnd a b)) + ( [a p/byte? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitAnd a b)) + ( [a p/byte? , b p/long? > p/long?] (Numeric/bitAnd a b)) + ( [a p/byte? , b p/float? > p/float?] (Numeric/bitAnd a b)) + ( [a p/byte? , b p/double? > p/double?] (Numeric/bitAnd a b)) + ( [a p/short? , b (t/or p/byte? p/short?) > p/short?] (Numeric/bitAnd a b)) + ( [a p/short? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitAnd a b)) + ( [a p/short? , b p/long? > p/long?] (Numeric/bitAnd a b)) + ( [a p/short? , b p/float? > p/float?] (Numeric/bitAnd a b)) + ( [a p/short? , b p/double? > p/double?] (Numeric/bitAnd a b)) + ( [a p/char? , b (t/or p/byte? p/short?) > p/int?] (Numeric/bitAnd a b)) + ( [a p/char? , b p/char? > p/char?] (Numeric/bitAnd a b)) + ( [a p/char? , b p/int? > p/int?] (Numeric/bitAnd a b)) + ( [a p/char? , b p/long? > p/long?] (Numeric/bitAnd a b)) + ( [a p/char? , b p/float? > p/float?] (Numeric/bitAnd a b)) + ( [a p/char? , b p/double? > p/double?] (Numeric/bitAnd a b)) + ( [a p/int? , b (t/or p/byte? p/short? p/char? + p/int?) > p/int?] (Numeric/bitAnd a b)) + ( [a p/int? , b p/long? > p/long?] (Numeric/bitAnd a b)) + ( [a p/int? , b p/float? > p/float?] (Numeric/bitAnd a b)) + ( [a p/int? , b p/double? > p/double?] (Numeric/bitAnd a b)) + ( [a p/long? , b (t/or p/byte? p/short? p/char? + p/int?) > p/long?] (Numeric/bitAnd a b)) + (^:in [a p/long? , b long? > p/long?] (Numbers/and a b)) + ( [a p/long? , b (t/or p/float? p/double?) > p/double?] (Numeric/bitAnd a b)) + ( [a p/float? , b (t/or p/byte? p/short? p/char? + p/int? p/float?) > p/float?] (Numeric/bitAnd a b)) + ( [a p/float? , b (t/or p/long? p/double?) > p/double?] (Numeric/bitAnd a b)) + ( [a p/double? , b (t/- p/primitive? p/boolean?) > p/double?] (Numeric/bitAnd a b))] + :cljs [( [a p/boolean?, b p/boolean? > p/boolean?] (core/and a b)) + ( [a p/double? , b p/double? > (t/assume numerically-int?)] + (core/bit-and a b))])) ;; TODO make variadic ;; TODO TYPED we can shorten this by having dependent types -(defnt ^:inline or +(t/defn ^:inline or "Bitwise `or`." + {:incorporated {'clojure.core/bit-or #inst "2018-10-11" + 'cljs.core/bit-or #inst "2018-10-11"}} #?@(:clj [#_([a p/boolean?, b p/boolean? > ?] (Numeric/bitOr a b)) - #_([a (t/- p/primitive? t/boolean?) - b (t/- p/primitive? t/boolean?) > ?] (Numeric/bitOr a b)) - ([a p/boolean?, b p/boolean? > p/boolean?] (Numeric/bitOr a b)) - ([a p/byte? , b p/byte? > p/byte?] (Numeric/bitOr a b)) - ([a p/byte? , b p/short? > p/short?] (Numeric/bitOr a b)) - ([a p/byte? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitOr a b)) - ([a p/byte? , b p/long? > p/long?] (Numeric/bitOr a b)) - ([a p/byte? , b p/float? > p/float?] (Numeric/bitOr a b)) - ([a p/byte? , b p/double? > p/double?] (Numeric/bitOr a b)) - ([a p/short? , b (t/or p/byte? p/short?) > p/short?] (Numeric/bitOr a b)) - ([a p/short? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitOr a b)) - ([a p/short? , b p/long? > p/long?] (Numeric/bitOr a b)) - ([a p/short? , b p/float? > p/float?] (Numeric/bitOr a b)) - ([a p/short? , b p/double? > p/double?] (Numeric/bitOr a b)) - ([a p/char? , b (t/or p/byte? p/short?) > p/int?] (Numeric/bitOr a b)) - ([a p/char? , b p/char? > p/char?] (Numeric/bitOr a b)) - ([a p/char? , b p/int? > p/int?] (Numeric/bitOr a b)) - ([a p/char? , b p/long? > p/long?] (Numeric/bitOr a b)) - ([a p/char? , b p/float? > p/float?] (Numeric/bitOr a b)) - ([a p/char? , b p/double? > p/double?] (Numeric/bitOr a b)) - ([a p/int? , b (t/or p/byte? p/short? p/char? - p/int?) > p/int?] (Numeric/bitOr a b)) - ([a p/int? , b p/long? > p/long?] (Numeric/bitOr a b)) - ([a p/int? , b p/float? > p/float?] (Numeric/bitOr a b)) - ([a p/int? , b p/double? > p/double?] (Numeric/bitOr a b)) - ([a p/long? , b (t/or p/byte? p/short? p/char? - p/int? p/long?) > p/long?] (Numeric/bitOr a b)) - ([a p/long? , b (t/or p/float? p/double?) > p/double?] (Numeric/bitOr a b)) - ([a p/float? , b (t/or p/byte? p/short? p/char? - p/int? p/float?) > p/float?] (Numeric/bitOr a b)) - ([a p/float? , b (t/or p/long? p/double?) > p/double?] (Numeric/bitOr a b)) - ([a p/double? , b (t/- p/primitive? p/boolean?) > p/double?] (Numeric/bitOr a b))] - :cljs [([a p/boolean?, b p/boolean? > p/boolean?] (core/or a b)) - ([a p/double? , b p/double? > (t/assume numerically-int?)] - (core/bit-or a b))])) + #_([a (t/- p/primitive? p/boolean?) + b (t/- p/primitive? p/boolean?) > ?] (Numeric/bitOr a b)) + ( [a p/boolean?, b p/boolean? > p/boolean?] (Numeric/bitOr a b)) + ( [a p/byte? , b p/byte? > p/byte?] (Numeric/bitOr a b)) + ( [a p/byte? , b p/short? > p/short?] (Numeric/bitOr a b)) + ( [a p/byte? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitOr a b)) + ( [a p/byte? , b p/long? > p/long?] (Numeric/bitOr a b)) + ( [a p/byte? , b p/float? > p/float?] (Numeric/bitOr a b)) + ( [a p/byte? , b p/double? > p/double?] (Numeric/bitOr a b)) + ( [a p/short? , b (t/or p/byte? p/short?) > p/short?] (Numeric/bitOr a b)) + ( [a p/short? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitOr a b)) + ( [a p/short? , b p/long? > p/long?] (Numeric/bitOr a b)) + ( [a p/short? , b p/float? > p/float?] (Numeric/bitOr a b)) + ( [a p/short? , b p/double? > p/double?] (Numeric/bitOr a b)) + ( [a p/char? , b (t/or p/byte? p/short?) > p/int?] (Numeric/bitOr a b)) + ( [a p/char? , b p/char? > p/char?] (Numeric/bitOr a b)) + ( [a p/char? , b p/int? > p/int?] (Numeric/bitOr a b)) + ( [a p/char? , b p/long? > p/long?] (Numeric/bitOr a b)) + ( [a p/char? , b p/float? > p/float?] (Numeric/bitOr a b)) + ( [a p/char? , b p/double? > p/double?] (Numeric/bitOr a b)) + ( [a p/int? , b (t/or p/byte? p/short? p/char? + p/int?) > p/int?] (Numeric/bitOr a b)) + ( [a p/int? , b p/long? > p/long?] (Numeric/bitOr a b)) + ( [a p/int? , b p/float? > p/float?] (Numeric/bitOr a b)) + ( [a p/int? , b p/double? > p/double?] (Numeric/bitOr a b)) + ( [a p/long? , b (t/or p/byte? p/short? p/char? + p/int?) > p/long?] (Numeric/bitOr a b)) + (^:in [a p/long? , b long? > p/long?] (Numbers/or a b)) + ( [a p/long? , b (t/or p/float? p/double?) > p/double?] (Numeric/bitOr a b)) + ( [a p/float? , b (t/or p/byte? p/short? p/char? + p/int? p/float?) > p/float?] (Numeric/bitOr a b)) + ( [a p/float? , b (t/or p/long? p/double?) > p/double?] (Numeric/bitOr a b)) + ( [a p/double? , b (t/- p/primitive? p/boolean?) > p/double?] (Numeric/bitOr a b))] + :cljs [( [a p/boolean?, b p/boolean? > p/boolean?] (core/or a b)) + ( [a p/double? , b p/double? > (t/assume numerically-int?)] + (core/bit-or a b))])) ;; TODO make variadic ;; TODO TYPED we can shorten this by having dependent types -(defnt ^:inline xor +(t/defn ^:inline xor "Bitwise `xor`." + {:incorporated {'clojure.core/bit-xor #inst "2018-10-11" + 'cljs.core/bit-xor #inst "2018-10-11"}} #?@(:clj [#_([a p/boolean?, b p/boolean? > ?] (Numeric/bitXOr a b)) - #_([a (t/- p/primitive? t/boolean?) - b (t/- p/primitive? t/boolean?) > ?] (Numeric/bitXOr a b)) - ([a p/boolean?, b p/boolean? > p/boolean?] (Numeric/bitXOr a b)) - ([a p/byte? , b p/byte? > p/byte?] (Numeric/bitXOr a b)) - ([a p/byte? , b p/short? > p/short?] (Numeric/bitXOr a b)) - ([a p/byte? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitXOr a b)) - ([a p/byte? , b p/long? > p/long?] (Numeric/bitXOr a b)) - ([a p/byte? , b p/float? > p/float?] (Numeric/bitXOr a b)) - ([a p/byte? , b p/double? > p/double?] (Numeric/bitXOr a b)) - ([a p/short? , b (t/or p/byte? p/short?) > p/short?] (Numeric/bitXOr a b)) - ([a p/short? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitXOr a b)) - ([a p/short? , b p/long? > p/long?] (Numeric/bitXOr a b)) - ([a p/short? , b p/float? > p/float?] (Numeric/bitXOr a b)) - ([a p/short? , b p/double? > p/double?] (Numeric/bitXOr a b)) - ([a p/char? , b (t/or p/byte? p/short?) > p/int?] (Numeric/bitXOr a b)) - ([a p/char? , b p/char? > p/char?] (Numeric/bitXOr a b)) - ([a p/char? , b p/int? > p/int?] (Numeric/bitXOr a b)) - ([a p/char? , b p/long? > p/long?] (Numeric/bitXOr a b)) - ([a p/char? , b p/float? > p/float?] (Numeric/bitXOr a b)) - ([a p/char? , b p/double? > p/double?] (Numeric/bitXOr a b)) - ([a p/int? , b (t/or p/byte? p/short? p/char? - p/int?) > p/int?] (Numeric/bitXOr a b)) - ([a p/int? , b p/long? > p/long?] (Numeric/bitXOr a b)) - ([a p/int? , b p/float? > p/float?] (Numeric/bitXOr a b)) - ([a p/int? , b p/double? > p/double?] (Numeric/bitXOr a b)) - ([a p/long? , b (t/or p/byte? p/short? p/char? - p/int? p/long?) > p/long?] (Numeric/bitXOr a b)) - ([a p/long? , b (t/or p/float? p/double?) > p/double?] (Numeric/bitXOr a b)) - ([a p/float? , b (t/or p/byte? p/short? p/char? - p/int? p/float?) > p/float?] (Numeric/bitXOr a b)) - ([a p/float? , b (t/or p/long? p/double?) > p/double?] (Numeric/bitXOr a b)) - ([a p/double? , b (t/- p/primitive? p/boolean?) > p/double?] (Numeric/bitXOr a b))] - :cljs [([a p/boolean?, b p/boolean? > p/boolean?] (js* "(~{} !=== ~{})" a b)) - ([a p/double? , b p/double? > (t/assume numerically-int?)] - (core/bit-xor a b))])) + #_([a (t/- p/primitive? p/boolean?) + b (t/- p/primitive? p/boolean?) > ?] (Numeric/bitXOr a b)) + ( [a p/boolean?, b p/boolean? > p/boolean?] (Numeric/bitXOr a b)) + ( [a p/byte? , b p/byte? > p/byte?] (Numeric/bitXOr a b)) + ( [a p/byte? , b p/short? > p/short?] (Numeric/bitXOr a b)) + ( [a p/byte? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitXOr a b)) + ( [a p/byte? , b p/long? > p/long?] (Numeric/bitXOr a b)) + ( [a p/byte? , b p/float? > p/float?] (Numeric/bitXOr a b)) + ( [a p/byte? , b p/double? > p/double?] (Numeric/bitXOr a b)) + ( [a p/short? , b (t/or p/byte? p/short?) > p/short?] (Numeric/bitXOr a b)) + ( [a p/short? , b (t/or p/char? p/int?) > p/int?] (Numeric/bitXOr a b)) + ( [a p/short? , b p/long? > p/long?] (Numeric/bitXOr a b)) + ( [a p/short? , b p/float? > p/float?] (Numeric/bitXOr a b)) + ( [a p/short? , b p/double? > p/double?] (Numeric/bitXOr a b)) + ( [a p/char? , b (t/or p/byte? p/short?) > p/int?] (Numeric/bitXOr a b)) + ( [a p/char? , b p/char? > p/char?] (Numeric/bitXOr a b)) + ( [a p/char? , b p/int? > p/int?] (Numeric/bitXOr a b)) + ( [a p/char? , b p/long? > p/long?] (Numeric/bitXOr a b)) + ( [a p/char? , b p/float? > p/float?] (Numeric/bitXOr a b)) + ( [a p/char? , b p/double? > p/double?] (Numeric/bitXOr a b)) + ( [a p/int? , b (t/or p/byte? p/short? p/char? + p/int?) > p/int?] (Numeric/bitXOr a b)) + ( [a p/int? , b p/long? > p/long?] (Numeric/bitXOr a b)) + ( [a p/int? , b p/float? > p/float?] (Numeric/bitXOr a b)) + ( [a p/int? , b p/double? > p/double?] (Numeric/bitXOr a b)) + ( [a p/long? , b (t/or p/byte? p/short? p/char? + p/int?) > p/long?] (Numeric/bitXOr a b)) + (^:in [a p/long? , b long? > p/long?] (Numbers/xor a b)) + ( [a p/long? , b (t/or p/float? p/double?) > p/double?] (Numeric/bitXOr a b)) + ( [a p/float? , b (t/or p/byte? p/short? p/char? + p/int? p/float?) > p/float?] (Numeric/bitXOr a b)) + ( [a p/float? , b (t/or p/long? p/double?) > p/double?] (Numeric/bitXOr a b)) + ( [a p/double? , b (t/- p/primitive? p/boolean?) > p/double?] (Numeric/bitXOr a b))] + :cljs [( [a p/boolean?, b p/boolean? > p/boolean?] + (js* "(~{} !== ~{})" a b)) + ( [a p/double? , b p/double? > (t/assume numerically-int?)] + (core/bit-xor a b))])) ;; ===== Bit-shifts ===== ;; ;; ----- Logical bit-shifts ---- ;; -(defnt ^:inline <<< +;; TODO make variadic +(t/defn ^:inline <<< "Unsigned (logical) bitwise shift left" +#?(:clj (^:in [x p/int? , n p/int? > (t/type x)] (Numbers/shiftRightInt x n))) +#?(:clj (^:in [x p/long?, n p/long? > (t/type x)] (Numbers/shiftRight x n))) #?(:clj ;; TODO implement the `char` op correctly because it likely isn't correct just to do ;; the straight bit op in Java - ([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] (Numeric/shiftLeft x n)) - :cljs ([x p/double?, n std-fixint? > (t/assume numerically-int?)] (core/bit-shift-left x n)))) - + ( [x (t/- p/primitive? p/boolean? p/int? p/long?), n p/integral? > (t/type x)] + (Numeric/shiftRight x n))) +#?(:clj ( [x p/int? , n (t/- p/integral? p/int?) > (t/type x)] (Numeric/shiftRight x n))) +#?(:clj ( [x p/long? , n (t/- p/integral? p/long?) > (t/type x)] (Numeric/shiftRight x n))) +#?(:cljs ( [x p/double?, n std-fixint? > (t/assume numerically-int?)] + (core/bit-shift-right x n)))) -(defnt ^:inline >>> - "Unsigned logical) bitwise shift right" +;; TODO make variadic +(t/defn ^:inline >>> + "Unsigned (logical) bitwise shift right" + {:incorporated {'clojure.core/unsigned-bit-shift-right #inst "2018-10-11" + 'cljs.core/unsigned-bit-shift-right #inst "2018-10-11"}} +#?(:clj (^:in [x p/int? , n p/int? > (t/type x)] (Numbers/unsignedShiftRightInt x n))) +#?(:clj (^:in [x p/long?, n p/long? > (t/type x)] (Numbers/unsignedShiftRight x n))) #?(:clj ;; TODO implement the `char` op correctly because it likely isn't correct just to do ;; the straight bit op in Java - ([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] (Numeric/uShiftRight a b)) - :cljs ([x p/double?, n std-fixint? > (t/assume numerically-int?)] + ( [x (t/- p/primitive? p/boolean? p/int? p/long?), n p/integral? > (t/type x)] + (Numeric/uShiftRight x n))) +#?(:clj ( [x p/int? , n (t/- p/integral? p/int?) > (t/type x)] (Numeric/uShiftRight x n))) +#?(:clj ( [x p/long? , n (t/- p/integral? p/long?) > (t/type x)] (Numeric/uShiftRight x n))) +#?(:cljs ([x p/double?, n std-fixint? > (t/assume numerically-int?)] (core/unsigned-bit-shift-right x n)))) ;; ----- Arithmetic bit-shifts ----- ;; -(defnt ^:inline << +;; TODO make variadic +(t/defn ^:inline << "Arithmetic bitwise shift left" + {:incorporated {'clojure.core/bit-shift-left #inst "2018-10-11" + 'cljs.core/bit-shift-left #inst "2018-10-11"}} +#?(:clj (^:in [x p/int? , n p/int? > (t/type x)] (Numbers/shiftLeftInt x n))) +#?(:clj (^:in [x p/long?, n p/long? > (t/type x)] (Numbers/shiftLeft x n))) #?(:clj ;; TODO implement the `char` op correctly because it likely isn't correct just to do ;; the straight bit op in Java - ([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] (Numeric/shiftLeft a b)) - :cljs ([x p/double?, n std-fixint? > (t/assume numerically-int?)] (core/bit-shift-left x n)))) + ( [x (t/- p/primitive? p/boolean? p/int? p/long?), n p/integral? > (t/type x)] + (Numeric/shiftLeft x n))) +#?(:clj ( [x p/int? , n (t/- p/integral? p/int?) > (t/type x)] (Numeric/shiftLeft x n))) +#?(:clj ( [x p/long? , n (t/- p/integral? p/long?) > (t/type x)] (Numeric/shiftLeft x n))) +#?(:cljs ( [x p/double?, n std-fixint? > (t/assume numerically-int?)] + (core/bit-shift-left x n)))) +;; TODO make variadic ;; TODO TYPED `t/numerically-int?` -(defnt ^:inline >> +(t/defn ^:inline >> "Arithmetic bitwise shift right" + {:incorporated {'clojure.core/bit-shift-right #inst "2018-10-11" + 'cljs.core/bit-shift-right #inst "2018-10-11"}} +#?(:clj (^:in [x p/int? , n p/int? > (t/type x)] (Numbers/shiftRightInt x n))) +#?(:clj (^:in [x p/long?, n p/long? > (t/type x)] (Numbers/shiftRight x n))) #?(:clj ;; TODO implement the `char` op correctly because it likely isn't correct just to do ;; the straight bit op in Java - ([x (t/- p/primitive? t/boolean?), n p/integral? > (t/type x)] (Numeric/shiftRight a b)) - :cljs ([x p/double?, n std-fixint? > (t/assume numerically-int?)] (core/bit-shift-right x n)))) + ( [x (t/- p/primitive? p/boolean? p/int? p/long?), n p/integral? > (t/type x)] + (Numeric/shiftRight x n))) +#?(:clj ( [x p/int? , n (t/- p/integral? p/int?) > (t/type x)] (Numeric/shiftRight x n))) +#?(:clj ( [x p/long? , n (t/- p/integral? p/long?) > (t/type x)] (Numeric/shiftRight x n))) +#?(:cljs ( [x p/double?, n std-fixint? > (t/assume numerically-int?)] + (core/bit-shift-right x n)))) ;; ===== Single-bit operations ===== ;; ;; TODO add bit operations with checked indices -(defnt ^:inline bit-set-false* +(t/defn ^:inline bit-set-false* "Makes the bit at the provided index ->`i` `bit-false`. Unchecked w.r.t. the bit index. Equivalent to `clojure.core/bit-clear`." {:todo #{"Extend index to non-longs"}} -#?(:clj ([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitClear x i)) +#?(:clj ([x (t/- p/primitive? p/boolean?), i p/long? > (t/type x)] (Numeric/bitClear x i)) :cljs ([x p/double?, i std-fixint? > (t/assume numerically-int?)] (core/bit-clear x i)))) -(defnt ^:inline bit-set-true* +(t/defn ^:inline bit-set-true* "Makes the bit at the provided index ->`i` `bit-true`. Unchecked w.r.t. the bit index. Equivalent to `clojure.core/bit-set`." {:todo #{"Extend index to non-longs"}} -#?(:clj ([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitSet x i)) +#?(:clj ([x (t/- p/primitive? p/boolean?), i p/long? > (t/type x)] (Numeric/bitSet x i)) :cljs ([x p/double?, i std/fixint? > (t/assume numerically-int?)] (core/bit-set x i)))) -(defnt ^:inline bit-not* +(t/defn ^:inline bit-not* "Applies `not` to the bit at the provided index ->`i`. Unchecked w.r.t. the bit index. Equivalent to `clojure.core/bit-flip`." {:todo #{"Extend index to non-longs"}} -#?(:clj ([x (t/- p/primitive? t/boolean?), i p/long? > (t/type x)] (Numeric/bitFlip x i)) +#?(:clj ([x (t/- p/primitive? p/boolean?), i p/long? > (t/type x)] (Numeric/bitFlip x i)) :cljs ([x p/double?, i std-fixint? > (t/assume numerically-int?)] (core/bit-flip x i)))) -(defnt ^:inline bit-true?* +(t/defn ^:inline bit-true?* "Outputs whether the bit at the provided index ->`i` is `bit-true`. Unchecked w.r.t. the bit index. Equivalent to `clojure.core/bit-test`." diff --git a/src/quantum/core/data/map.cljc b/src/quantum/core/data/map.cljc index d31b49b5..90e084e6 100644 --- a/src/quantum/core/data/map.cljc +++ b/src/quantum/core/data/map.cljc @@ -354,7 +354,7 @@ "Creates a persistent array map. If any keys are equal, they are handled as if by repeated applications of `assoc`." > +array-map? - ([] (. clojure.lang.PersistentArrayMap EMPTY)) + ([] ^:val (. clojure.lang.PersistentArrayMap EMPTY)) ;; TODO TYPED handle varargs #_([& kvs] (clojure.lang.PersistentArrayMap/createAsIfByAssoc (to-array kvs)))) @@ -488,7 +488,7 @@ `(->> pairs (apply concat) (apply >hash-map))` <~> `lodash/fromPairs`" > +hash-map? - ([] clojure.lang.PersistentHashMap/EMPTY) + ([] ^:val (. clojure.lang.PersistentHashMap EMPTY)) ;; TODO TYPED handle varargs #_([& kvs] (clojure.lang.PersistentHashMap/create kvs))) diff --git a/src/quantum/core/data/numeric.cljc b/src/quantum/core/data/numeric.cljc index 64a401cd..6ea5de9d 100644 --- a/src/quantum/core/data/numeric.cljc +++ b/src/quantum/core/data/numeric.cljc @@ -159,7 +159,6 @@ ;; ===== Likenesses ===== ;; - ;; TODO incorporate (defn ^boolean numerically-integer? "Returns true if n is a JavaScript number with no decimal part." @@ -180,7 +179,7 @@ (and numerically-integer? (>expr (c/fn [x] (c/<= -32768 x 32767))))) #_(def numerically-char? - (and numerically-integer? (>expr (c/fn [x] (c/<= 0 x 65535))))) + (and numerically-integer? (>expr (c/fn [x] (c/<= 0 x 65535))))) #_(def numerically-unsigned-short? numerically-char?) @@ -272,11 +271,51 @@ _ (doseq [s split] (when-not (every? #{\0 \1 \2 \3 \4 \5 \6 \7 \8 \9} s) (throw (ex-info "Number must have only numeric characters" {:num s})))) - integral (read-string integral-str) - decimal (read-string decimal-str) + integral (read-string integral-str) ; TODO we should just pass the raw string to the ratio + decimal (read-string decimal-str) ; TODO we should just pass the raw string to the ratio scale (if decimal (#?(:clj Math/pow :cljs js/Math.pow) 10 (count decimal-str)) 1)] (* (if (= minus-ct 1) -1 1) - (->ratio (+ (* scale integral) (or decimal 0)) - scale)))) + (>ratio (+ (* scale integral) (or decimal 0)) + scale)))) + +;; ===== Conversion ===== ;; + +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +#_(defnt ^:inline >byte > #?(:clj byte? :cljs numerically-byte?) + "Does not involve truncation or rounding." + ([x #?(:clj byte? :cljs numerically-byte?)] x) +#?(:clj ([x (t/and (t/- primitive? byte? boolean?) numerically-byte?)] (>byte* x)) + :cljs ([x (t/and double? numerically-byte?)] x)) + ([x boolean?] (if x #?(:clj (byte 1) :cljs 1) #?(:clj (byte 0) :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-byte?)] (>byte* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-byte?)] (.byteValue x))) +#?(:clj ([x (t/and dn/ratio? numerically-byte?)] (-> x .bigIntegerValue .byteValue)))) + + +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +#_(t/defn ^:inline >short > #?(:clj short? :cljs numerically-short?) + "Does not involve truncation or rounding." + ([x #?(:clj short? :cljs numerically-short?)] x) +#?(:clj ([x (t/and (t/- primitive? short? boolean?) numerically-short?)] (>short* x)) + :cljs ([x (t/and double? numerically-short?)] x)) + ([x boolean?] (if x #?(:clj (short 1) :cljs 1) #?(:clj (short 0) :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-short?)] (>short* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-short?)] (.shortValue x))) +#?(:clj ([x (t/and dn/ratio? numerically-short?)] (-> x .bigIntegerValue .shortValue)))) + +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +#_(t/defn ^:inline >char > #?(:clj char? :cljs numerically-char?) + "Does not involve truncation or rounding. + For CLJS, returns not a String of length 1 but a numerically-char Number." + ([x #?(:clj char? :cljs numerically-char?)] x) +#?(:clj ([x (t/and (t/- primitive? char? boolean?) numerically-char?)] (>char* x)) + :cljs ([x (t/and double? numerically-char?)] x)) + ([x boolean?] (if x #?(:clj (char 1) :cljs 1) #?(:clj (char 0) :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-char?)] (>char* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-char?)] (.charValue x))) +#?(:clj ([x (t/and dn/ratio? numerically-char?)] (-> x .bigIntegerValue .charValue)))) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 8f2221d7..2afbfb3b 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -5,13 +5,15 @@ #?(:cljs [com.gfredericks.goog.math.Integer :as int]) #?(:cljs goog.math.Integer) #?(:cljs goog.math.Long) + [quantum.core.compare.core :as ccomp] [quantum.core.type :as t] [quantum.untyped.core.type :as ut] ;; TODO TYPED excise reference [quantum.untyped.core.vars :as var :refer [defaliases]]) #?(:clj (:import - [java.nio ByteBuffer] + [clojure.lang Numbers Util] + [java.nio ByteBuffer] [quantum.core Numeric Primitive]))) (def nil? ut/nil?) @@ -113,6 +115,7 @@ (var/def boolean-bits "Implementationally might not be bit-manipulable but logically 1 bit" 1) (def byte-bits 8) (def short-bits 16) +(def char-bits 16) (def int-bits 32) (def long-bits 64) (def float-bits 32) @@ -121,36 +124,37 @@ ;; ===== Extreme magnitudes and values ===== ;; (t/defn ^:inline >min-magnitude - #?(:clj ([x byte? > byte?] (byte 0))) - #?(:clj ([x short? > short?] (short 0))) - #?(:clj ([x char? > char?] (char 0))) - #?(:clj ([x int? > int?] (int 0))) - #?(:clj ([x long? > long?] (long 0))) - #?(:clj ([x float? > float?] Float/MIN_VALUE)) - ([x double? > double?] #?(:clj Double/MIN_VALUE - :cljs js/Number.MIN_VALUE))) - -#?(:clj (def ^:private min-float (- Float/MAX_VALUE))) - (def ^:private min-double (- #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) + #?(:clj ([x byte? > (type x)] (byte 0))) + #?(:clj ([x short? > (type x)] (short 0))) + #?(:clj ([x char? > (type x)] (char 0))) + #?(:clj ([x int? > (type x)] (int 0))) + #?(:clj ([x long? > (type x)] (long 0))) + #?(:clj ([x float? > (type x)] Float/MIN_VALUE)) + ([x double? > (type x)] #?(:clj Double/MIN_VALUE + :cljs js/Number.MIN_VALUE))) + +;; TODO TYPED these are probably getting boxed +#?(:clj (var/def- min-float (Numeric/negate Float/MAX_VALUE))) + (var/def- min-double (- #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) ;; TODO TYPED for some reason it's not figuring out the type of `min-float` and `min-double` -#_(t/defn ^:inline >min-value - #?(:clj ([x byte? > byte?] Byte/MIN_VALUE)) - #?(:clj ([x short? > short?] Short/MIN_VALUE)) - #?(:clj ([x char? > char?] Character/MIN_VALUE)) - #?(:clj ([x int? > int?] Integer/MIN_VALUE)) - #?(:clj ([x long? > long?] Long/MIN_VALUE)) - #?(:clj ([x float? > float?] min-float)) - ([x double? > double?] min-double)) +(t/defn ^:inline >min-value + #?(:clj ([x byte? > (type x)] Byte/MIN_VALUE)) + #?(:clj ([x short? > (type x)] Short/MIN_VALUE)) + #?(:clj ([x char? > (type x)] Character/MIN_VALUE)) + #?(:clj ([x int? > (type x)] Integer/MIN_VALUE)) + #?(:clj ([x long? > (type x)] Long/MIN_VALUE)) + #?(:clj ([x float? > (type x)] min-float)) + ([x double? > (type x)] min-double)) (t/defn ^:inline >max-value - #?@(:clj [([x byte? > byte?] Byte/MAX_VALUE) - ([x short? > short?] Short/MAX_VALUE) - ([x char? > char?] Character/MAX_VALUE) - ([x int? > int?] Integer/MAX_VALUE) - ([x long? > long?] Long/MAX_VALUE) - ([x float? > float?] Float/MAX_VALUE)]) - ([x double? > double?] #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) + #?@(:clj [([x byte? > (type x)] Byte/MAX_VALUE) + ([x short? > (type x)] Short/MAX_VALUE) + ([x char? > (type x)] Character/MAX_VALUE) + ([x int? > (type x)] Integer/MAX_VALUE) + ([x long? > (type x)] Long/MAX_VALUE) + ([x float? > (type x)] Float/MAX_VALUE)]) + ([x double? > (type x)] #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) ;; ===== Primitive type properties ===== ;; @@ -165,205 +169,95 @@ ;; TODO TYPED `t/numerically-integer?` (t/defn ^:inline >bit-size ; > t/numerically-integer? - ([x (t/or boolean? (t/value #?(:clj Boolean :cljs js/Boolean)))] 1) ; kind of -#?@(:clj [([x (t/or byte? (t/value Byte))] 8) - ([x (t/or short? (t/value Short))] 16) - ([x (t/or char? (t/value Character))] 16) - ([x (t/or int? (t/value Integer))] 32) - ([x (t/or long? (t/value Long))] 64) - ([x (t/or float? (t/value Float))] 32)]) - ([x (t/or double? #?(:clj Double :cljs js/Number))] 64)) - -;; ===== Conversion ===== ;; - -;; ----- Boolean ----- ;; - -(t/defn ^:inline >boolean - "Converts input to a boolean. - Differs from asking whether something is truthy/falsey." - > boolean? - ([x boolean?] x) ;; For purposes of Clojure intrinsics - ([x (t/or long? double?)] (-> x clojure.lang.Numbers/isZero Numeric/not)) - ([x (t/- primitive? boolean? long? double?)] (-> x Numeric/isZero Numeric/not))) - -;; ----- Byte ----- ;; - -;; TODO figure out how to use with CLJS -#?(:clj -(t/defn ^:inline >byte* - "May involve non-out-of-range truncation." - > byte? - ([x byte?] x) - ([x (t/- primitive? byte? boolean?)] (Primitive/uncheckedByteCast x)))) - -;; TODO TYPED `numerically` -;; TODO figure out how to use with goog.math.Integer/Long -#_(defnt ^:inline >byte > #?(:clj byte? :cljs numerically-byte?) - "Does not involve truncation or rounding." - ([x #?(:clj byte? :cljs numerically-byte?)] x) -#?(:clj ([x (t/and (t/- primitive? byte? boolean?) numerically-byte?)] (>byte* x)) - :cljs ([x (t/and double? numerically-byte?)] x)) - ([x boolean?] (if x #?(:clj (byte 1) :cljs 1) #?(:clj (byte 0) :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-byte?)] (>byte* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-byte?)] (.byteValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-byte?)] (-> x .bigIntegerValue .byteValue)))) - -;; ----- Short ----- ;; - -;; TODO figure out how to use with CLJS -#?(:clj -(t/defn ^:inline >short* - "May involve non-out-of-range truncation." - > short? - ([x short?] x) - ([x (t/- primitive? short? boolean?)] (Primitive/uncheckedShortCast x)))) - -;; TODO TYPED `numerically` -;; TODO figure out how to use with goog.math.Integer/Long -#_(t/defn ^:inline >short > #?(:clj short? :cljs numerically-short?) - "Does not involve truncation or rounding." - ([x #?(:clj short? :cljs numerically-short?)] x) -#?(:clj ([x (t/and (t/- primitive? short? boolean?) numerically-short?)] (>short* x)) - :cljs ([x (t/and double? numerically-short?)] x)) - ([x boolean?] (if x #?(:clj (short 1) :cljs 1) #?(:clj (short 0) :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-short?)] (>short* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-short?)] (.shortValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-short?)] (-> x .bigIntegerValue .shortValue)))) - -;; ----- Char ----- ;; - -;; TODO figure out how to use with CLJS -#?(:clj -(t/defn ^:inline >char* - "May involve non-out-of-range truncation." - > char? - ([x char?] x) - ([x (t/- primitive? char? boolean?)] (Primitive/uncheckedCharCast x)))) - -;; TODO TYPED `numerically` -;; TODO figure out how to use with goog.math.Integer/Long -#_(t/defn ^:inline >char > #?(:clj char? :cljs numerically-char?) - "Does not involve truncation or rounding. - For CLJS, returns not a String of length 1 but a numerically-char Number." - ([x #?(:clj char? :cljs numerically-char?)] x) -#?(:clj ([x (t/and (t/- primitive? char? boolean?) numerically-char?)] (>char* x)) - :cljs ([x (t/and double? numerically-char?)] x)) - ([x boolean?] (if x #?(:clj (char 1) :cljs 1) #?(:clj (char 0) :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-char?)] (>char* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-char?)] (.charValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-char?)] (-> x .bigIntegerValue .charValue)))) - -;; ----- Int ----- ;; - -;; TODO figure out how to use with goog.math.Integer/Long -#?(:clj -(t/defn ^:inline >int* - "May involve non-out-of-range truncation." - > int? - ([x int?] x) ;; For purposes of Clojure intrinsics - ([x (t/- primitive? int? boolean?)] (clojure.lang.RT/uncheckedIntCast x)))) - -;; TODO TYPED `numerically` -;; TODO figure out how to use with goog.math.Integer/Long -#_(t/defn ^:inline >int - "Does not involve truncation or rounding." - > int? - ([x int?] x) -#?(:clj ([x (t/and (t/- primitive? int? boolean?) numerically-int?)] (>int* x)) - :cljs ([x (t/and double? numerically-int?)] x)) - ([x boolean?] (if x #?(:clj (int 1) :cljs 1) #?(:clj (int 0) :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-int?)] (>int* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-int?)] (.intValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-int?)] (-> x .bigIntegerValue .intValue)))) - -;; ----- Long ----- ;; - -;; TODO figure out how to use with CLJS, including goog.math.Integer/Long -#?(:clj -(t/defn ^:inline >long* - "May involve non-out-of-range truncation." - > long? - ([x long?] x) - ([x char?] (Primitive/uncheckedLongCast x)) ;; For purposes of Clojure intrinsics - ([x (t/- primitive? long? boolean? char?)] (clojure.lang.RT/uncheckedLongCast x)))) - -;; TODO TYPED `numerically` -;; TODO figure out how to use with goog.math.Integer/Long -#_(t/defn ^:inline >long - "Does not involve truncation or rounding." - > #?(:clj long? :cljs numerically-long?) - ([x #?(:clj long? :cljs numerically-long?)] x) -#?(:clj ([x (t/and (t/- primitive? long? boolean?) numerically-long?)] (>long* x)) - :cljs ([x (t/and double? numerically-long?)] x)) - ([x boolean?] (if x 1 0)) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) - numerically-long? - ;; TODO This might be faster than `numerically-long?` - #_(fnt [x ?] (nil? (.bipart x))))] (.lpart x))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) - numerically-long? - ;; TODO This might be faster than `numerically-long?` - #_(fnt [x ?] (< (.bitLength x) 64)))] (.longValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-long?)] (-> x .bigIntegerValue .longValue)))) - -;; ----- Float ----- ;; - -;; TODO figure out how to use with CLJS + ([x (t/or boolean? (t/value #?(:clj Boolean :cljs js/Boolean)))] boolean-bits) +#?@(:clj [([x (t/or byte? (t/value Byte))] byte-bits) + ([x (t/or short? (t/value Short))] short-bits) + ([x (t/or char? (t/value Character))] char-bits) + ([x (t/or int? (t/value Integer))] int-bits) + ([x (t/or long? (t/value Long))] long-bits) + ([x (t/or float? (t/value Float))] float-bits)]) + ([x (t/or double? #?(:clj Double :cljs js/Number))] double-bits)) + +;; ===== Extensions ===== ;; + #?(:clj -(t/defn ^:inline >float* - "May involve non-out-of-range truncation." - > float? - ([x float?] x) - ([x (t/- primitive? float? boolean?)] (Primitive/uncheckedFloatCast x)))) - -;; TODO TYPED `numerically` -;; TODO figure out how to use with goog.math.Integer/Long -#_(t/defn ^:inline >float > #?(:clj float? :cljs numerically-float?) - "Does not involve truncation or rounding." - ([x #?(:clj float? :cljs numerically-float?)] x) -#?(:clj ([x (t/and (t/- primitive? float? boolean?) numerically-float?)] (>float* x)) - :cljs ([x (t/and double? numerically-float?)] x)) - ([x boolean?] (if x #?(:clj (float 1) :cljs 1) #?(:clj (float 0) :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-float?)] (>float* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-float?)] (.floatValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-float?)] (-> x .bigIntegerValue .floatValue)))) - -;; ----- Double ----- ;; - -;; TODO figure out how to use with goog.math.Integer/Long -(t/defn ^:inline >double* - "May involve non-out-of-range truncation." - > double? - ([x double?] x) - ([x char?] (Primitive/uncheckedDoubleCast x)) ;; For purposes of Clojure intrinsics -#?(:clj ([x (t/- primitive? double? boolean? char?)] (clojure.lang.RT/uncheckedDoubleCast x)))) - -;; TODO TYPED `numerically` -;; TODO figure out how to use with goog.math.Integer/Long -#_(t/defn ^:inline >double > double? - "Does not involve truncation or rounding." - ([x double?] x) -#?(:clj ([x (t/and (t/- primitive? double? boolean?) numerically-double?)] (>double* x))) - ([x boolean?] (if x #?(:clj 1.0 :cljs 1) #?(:clj 1.0 :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-double?)] (>double* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-double?)] (.doubleValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-double?)] (-> x .bigIntegerValue .doubleValue)))) - -;; ===== Unsigned ===== ;; +(t/extend-defn! ccomp/== + (^:in [a boolean? , b boolean?] (Util/equiv a b)) + ( [a boolean? , b (t/- primitive? boolean?)] false) + ( [a (t/- primitive? boolean?) , b boolean?] false) + (^:in [a long? , b long?] (Numbers/equiv a b)) + ( [a long? , b (t/- numeric? long?)] (Numeric/eq a b)) + ( [a (t/- numeric? long?) , b long?] (Numeric/eq a b)) + (^:in [a double? , b double?] (Numbers/equiv a b)) + ( [a double? , b (t/- numeric? double?)] (Numeric/eq a b)) + ( [a (t/- numeric? double?) , b double?] (Numeric/eq a b)) + ( [a (t/- numeric? double? long?), b (t/- numeric? double? long?)] (Numeric/eq a b)))) #?(:clj -(t/defn >unsigned - {:adapted-from #{'ztellman/primitive-math 'gloss.data.primitives}} - ([x byte?] (Numeric/bitAnd (short 0xFF) x)) - ([x short?] (Numeric/bitAnd (int 0xFFFF) x)) - ([x int?] (Numeric/bitAnd (long 0xFFFFFFFF) x)) - ([x long?] (java.math.BigInteger. (int 1) - (-> ^:val (ByteBuffer/allocate (int 8)) - ^:val (.putLong x) - .array))))) - -;; TODO TYPED awaiting `>long` -#_(:clj (t/defn ubyte>byte [x long? > long?] (-> x >byte >long))) -#_(:clj (t/defn ushort>short [x long? > long?] (-> x >short >long))) -#_(:clj (t/defn uint>int [x long? > long?] (-> x >int >long))) -#_(:clj (t/defn ulong>long [x bigint? > long?] (-> x >bigint >long))) +(t/extend-defn! ccomp/not== + ([a boolean? , b boolean?] (Numbers/neq a b)) + ([a boolean? , b (t/- primitive? boolean?)] false) + ([a (t/- primitive? boolean?), b boolean?] false) + ([a numeric? , b numeric?] (Numeric/neq a b)))) + +(t/extend-defn! ccomp/= + ([a primitive?, b primitive?] (ccomp/== a b))) + +(t/extend-defn! ccomp/not= + ([a primitive?, b primitive?] (ccomp/not== a b))) + +(t/extend-defn! ccomp/< + ( [x numeric?] true) +#?(:clj (^:in [a long? , b long?] (Numbers/lt a b))) +#?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/lt a b))) +#?(:clj ( [a (t/- numeric? long?) , b long?] (Numeric/lt a b))) +#?(:clj (^:in [a double? , b double?] (Numbers/lt a b))) +#?(:clj ( [a double? , b (t/- numeric? double?)] (Numeric/lt a b))) +#?(:clj ( [a (t/- numeric? double?) , b double?] (Numeric/lt a b))) +#?(:clj ( [a (t/- numeric? double? long?), b (t/- numeric? double? long?)] (Numeric/lt a b))) +#?(:cljs ( [a numeric? , b numeric?] (cljs.core/< a b))) + ;; TODO rest of numbers, but not nil + ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) + ) + +(t/extend-defn! ccomp/<= + ( [x numeric?] true) +#?(:clj (^:in [a long? , b long?] (Numbers/lte a b))) +#?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/lte a b))) +#?(:clj ( [a (t/- numeric? long?) , b long?] (Numeric/lte a b))) +#?(:clj (^:in [a double? , b double?] (Numbers/lte a b))) +#?(:clj ( [a double? , b (t/- numeric? double?)] (Numeric/lte a b))) +#?(:clj ( [a (t/- numeric? double?) , b double?] (Numeric/lte a b))) +#?(:clj ( [a (t/- numeric? double? long?), b (t/- numeric? double? long?)] (Numeric/lte a b))) +#?(:cljs ( [a numeric? , b numeric?] (cljs.core/<= a b))) + ;; TODO rest of numbers, but not nil + ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) + ) + +(t/extend-defn! ccomp/> + ( [x numeric?] true) +#?(:clj (^:in [a long? , b long?] (Numbers/gt a b))) +#?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/gt a b))) +#?(:clj ( [a (t/- numeric? long?) , b long?] (Numeric/gt a b))) +#?(:clj (^:in [a double? , b double?] (Numbers/gt a b))) +#?(:clj ( [a double? , b (t/- numeric? double?)] (Numeric/gt a b))) +#?(:clj ( [a (t/- numeric? double?) , b double?] (Numeric/gt a b))) +#?(:clj ( [a (t/- numeric? double? long?), b (t/- numeric? double? long?)] (Numeric/gt a b))) +#?(:cljs ( [a numeric? , b numeric?] (cljs.core/> a b))) + ;; TODO rest of numbers, but not nil + ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) + ) + +(t/extend-defn! ccomp/>= + ( [x numeric?] true) +#?(:clj (^:in [a long? , b long?] (Numbers/gte a b))) +#?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/gte a b))) +#?(:clj ( [a (t/- numeric? long?) , b long?] (Numeric/gte a b))) +#?(:clj (^:in [a double? , b double?] (Numbers/gte a b))) +#?(:clj ( [a double? , b (t/- numeric? double?)] (Numeric/gte a b))) +#?(:clj ( [a (t/- numeric? double?) , b double?] (Numeric/gte a b))) +#?(:clj ( [a (t/- numeric? double? long?), b (t/- numeric? double? long?)] (Numeric/gte a b))) +#?(:cljs ( [a numeric? , b numeric?] (cljs.core/>= a b))) + ;; TODO rest of numbers, but not nil + ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) + ) diff --git a/src/quantum/core/primitive.cljc b/src/quantum/core/primitive.cljc new file mode 100644 index 00000000..453fdab5 --- /dev/null +++ b/src/quantum/core/primitive.cljc @@ -0,0 +1,199 @@ +(ns quantum.core.primitive + "Not merged into `quantum.core.data.primitive` because this namespace requires numeric ranges.") + +;; ===== Conversion ===== ;; + +;; ----- Boolean ----- ;; + +;; TODO CLJS +;; TODO rethink — is everything that's a 0 false and everything that's a 1 a true? Or is it just +;; 0's that are false? Etc. +(t/defn ^:inline >boolean + "Converts input to a boolean. + Differs from asking whether something is truthy/falsey." + > boolean? + ([x boolean?] x) ;; For purposes of Clojure intrinsics +#?(:clj ([x (t/or long? double?)] (-> x clojure.lang.Numbers/isZero Numeric/not))) +#?(:clj ([x (t/- primitive? boolean? long? double?)] (-> x Numeric/isZero Numeric/not)))) + +;; ----- Byte ----- ;; + +;; TODO figure out how to use with CLJS +#?(:clj +(t/defn ^:inline >byte* + "May involve non-out-of-range truncation." + > byte? + ([x byte?] x) + ([x (t/- primitive? byte? boolean?)] (Primitive/uncheckedByteCast x)))) + +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +#_(defnt ^:inline >byte > #?(:clj byte? :cljs numerically-byte?) + "Does not involve truncation or rounding." + ([x #?(:clj byte? :cljs numerically-byte?)] x) +#?(:clj ([x (t/and (t/- primitive? byte? boolean?) numerically-byte?)] (>byte* x)) + :cljs ([x (t/and double? numerically-byte?)] x)) + ([x boolean?] (if x #?(:clj (byte 1) :cljs 1) #?(:clj (byte 0) :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-byte?)] (>byte* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-byte?)] (.byteValue x))) +#?(:clj ([x (t/and dn/ratio? numerically-byte?)] (-> x .bigIntegerValue .byteValue)))) + +;; ----- Short ----- ;; + +;; TODO figure out how to use with CLJS +#?(:clj +(t/defn ^:inline >short* + "May involve non-out-of-range truncation." + > short? + ([x short?] x) + ([x (t/- primitive? short? boolean?)] (Primitive/uncheckedShortCast x)))) + +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +#_(t/defn ^:inline >short > #?(:clj short? :cljs numerically-short?) + "Does not involve truncation or rounding." + ([x #?(:clj short? :cljs numerically-short?)] x) +#?(:clj ([x (t/and (t/- primitive? short? boolean?) numerically-short?)] (>short* x)) + :cljs ([x (t/and double? numerically-short?)] x)) + ([x boolean?] (if x #?(:clj (short 1) :cljs 1) #?(:clj (short 0) :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-short?)] (>short* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-short?)] (.shortValue x))) +#?(:clj ([x (t/and dn/ratio? numerically-short?)] (-> x .bigIntegerValue .shortValue)))) + +;; ----- Char ----- ;; + +;; TODO figure out how to use with CLJS +#?(:clj +(t/defn ^:inline >char* + "May involve non-out-of-range truncation." + > char? + ([x char?] x) + ([x (t/- primitive? char? boolean?)] (Primitive/uncheckedCharCast x)))) + +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +#_(t/defn ^:inline >char > #?(:clj char? :cljs numerically-char?) + "Does not involve truncation or rounding. + For CLJS, returns not a String of length 1 but a numerically-char Number." + ([x #?(:clj char? :cljs numerically-char?)] x) +#?(:clj ([x (t/and (t/- primitive? char? boolean?) numerically-char?)] (>char* x)) + :cljs ([x (t/and double? numerically-char?)] x)) + ([x boolean?] (if x #?(:clj (char 1) :cljs 1) #?(:clj (char 0) :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-char?)] (>char* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-char?)] (.charValue x))) +#?(:clj ([x (t/and dn/ratio? numerically-char?)] (-> x .bigIntegerValue .charValue)))) + +;; ----- Int ----- ;; + +;; TODO figure out how to use with goog.math.Integer/Long +#?(:clj +(t/defn ^:inline >int* + "May involve non-out-of-range truncation." + > int? + ([x int?] x) ;; For purposes of Clojure intrinsics + ([x (t/- primitive? int? boolean?)] (clojure.lang.RT/uncheckedIntCast x)))) + +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +#_(t/defn ^:inline >int + "Does not involve truncation or rounding." + > int? + ([x int?] x) +#?(:clj ([x (t/and (t/- primitive? int? boolean?) numerically-int?)] (>int* x)) + :cljs ([x (t/and double? numerically-int?)] x)) + ([x boolean?] (if x #?(:clj (int 1) :cljs 1) #?(:clj (int 0) :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-int?)] (>int* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-int?)] (.intValue x))) +#?(:clj ([x (t/and dn/ratio? numerically-int?)] (-> x .bigIntegerValue .intValue)))) + +;; ----- Long ----- ;; + +;; TODO figure out how to use with CLJS, including goog.math.Integer/Long +#?(:clj +(t/defn ^:inline >long* + "May involve non-out-of-range truncation." + > long? + ([x long?] x) + ([x char?] (Primitive/uncheckedLongCast x)) ;; For purposes of Clojure intrinsics + ([x (t/- primitive? long? boolean? char?)] (clojure.lang.RT/uncheckedLongCast x)))) + +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +#_(t/defn ^:inline >long + "Does not involve truncation or rounding." + > #?(:clj long? :cljs numerically-long?) + ([x #?(:clj long? :cljs numerically-long?)] x) +#?(:clj ([x (t/and (t/- primitive? long? boolean?) numerically-long?)] (>long* x)) + :cljs ([x (t/and double? numerically-long?)] x)) + ([x boolean?] (if x 1 0)) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) + numerically-long? + ;; TODO This might be faster than `numerically-long?` + #_(fnt [x ?] (nil? (.bipart x))))] (.lpart x))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) + numerically-long? + ;; TODO This might be faster than `numerically-long?` + #_(fnt [x ?] (< (.bitLength x) 64)))] (.longValue x))) +#?(:clj ([x (t/and dn/ratio? numerically-long?)] (-> x .bigIntegerValue .longValue)))) + +;; ----- Float ----- ;; + +;; TODO figure out how to use with CLJS +#?(:clj +(t/defn ^:inline >float* + "May involve non-out-of-range truncation." + > float? + ([x float?] x) + ([x (t/- primitive? float? boolean?)] (Primitive/uncheckedFloatCast x)))) + +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +#_(t/defn ^:inline >float > #?(:clj float? :cljs numerically-float?) + "Does not involve truncation or rounding." + ([x #?(:clj float? :cljs numerically-float?)] x) +#?(:clj ([x (t/and (t/- primitive? float? boolean?) numerically-float?)] (>float* x)) + :cljs ([x (t/and double? numerically-float?)] x)) + ([x boolean?] (if x #?(:clj (float 1) :cljs 1) #?(:clj (float 0) :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-float?)] (>float* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-float?)] (.floatValue x))) +#?(:clj ([x (t/and dn/ratio? numerically-float?)] (-> x .bigIntegerValue .floatValue)))) + +;; ----- Double ----- ;; + +;; TODO figure out how to use with goog.math.Integer/Long +(t/defn ^:inline >double* + "May involve non-out-of-range truncation." + > double? + ([x double?] x) + ([x char?] (Primitive/uncheckedDoubleCast x)) ;; For purposes of Clojure intrinsics +#?(:clj ([x (t/- primitive? double? boolean? char?)] (clojure.lang.RT/uncheckedDoubleCast x)))) + +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +#_(t/defn ^:inline >double > double? + "Does not involve truncation or rounding." + ([x double?] x) +#?(:clj ([x (t/and (t/- primitive? double? boolean?) numerically-double?)] (>double* x))) + ([x boolean?] (if x #?(:clj 1.0 :cljs 1) #?(:clj 1.0 :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-double?)] (>double* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-double?)] (.doubleValue x))) +#?(:clj ([x (t/and dn/ratio? numerically-double?)] (-> x .bigIntegerValue .doubleValue)))) + +;; ===== Unsigned ===== ;; + +#?(:clj +(t/defn >unsigned + {:adapted-from #{'ztellman/primitive-math 'gloss.data.primitives}} + ([x byte?] (Numeric/bitAnd (short 0xFF) x)) + ([x short?] (Numeric/bitAnd (int 0xFFFF) x)) + ([x int?] (Numeric/bitAnd (long 0xFFFFFFFF) x)) + ([x long?] (java.math.BigInteger. (int 1) + (-> ^:val (ByteBuffer/allocate (int 8)) + ^:val (.putLong x) + .array))))) + +;; TODO TYPED awaiting `>long` +#_(:clj (t/defn ubyte>byte [x long? > long?] (-> x >byte >long))) +#_(:clj (t/defn ushort>short [x long? > long?] (-> x >short >long))) +#_(:clj (t/defn uint>int [x long? > long?] (-> x >int >long))) +#_(:clj (t/defn ulong>long [x bigint? > long?] (-> x >bigint >long))) diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index d054e19d..c54d2875 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -15,7 +15,7 @@ (defaliases ut type ;; Generators - ? * isa? + ? *, isa? isa?|direct ; fn ; TODO TYPED rename ftype value, unvalue From b8e0fcadd2cb1f9cde50a32213e431d2e5dd9990 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 11 Oct 2018 23:08:43 -0600 Subject: [PATCH 497/810] Add more notes to bit ops --- src/quantum/core/data/bits.cljc | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/src/quantum/core/data/bits.cljc b/src/quantum/core/data/bits.cljc index e0944af5..e477e292 100644 --- a/src/quantum/core/data/bits.cljc +++ b/src/quantum/core/data/bits.cljc @@ -269,16 +269,21 @@ "Makes the bit at the provided index ->`i` `bit-false`. Unchecked w.r.t. the bit index. Equivalent to `clojure.core/bit-clear`." - {:todo #{"Extend index to non-longs"}} + {:incorporated {'clojure.core/bit-clear #inst "2018-10-11" + 'cljs.core/bit-clear #inst "2018-10-11"} + :todo #{"Extend index to non-longs" + "Extend usage to non-primitives"}} #?(:clj ([x (t/- p/primitive? p/boolean?), i p/long? > (t/type x)] (Numeric/bitClear x i)) :cljs ([x p/double?, i std-fixint? > (t/assume numerically-int?)] (core/bit-clear x i)))) - (t/defn ^:inline bit-set-true* "Makes the bit at the provided index ->`i` `bit-true`. Unchecked w.r.t. the bit index. Equivalent to `clojure.core/bit-set`." - {:todo #{"Extend index to non-longs"}} + {:incorporated {'clojure.core/bit-set #inst "2018-10-11" + 'cljs.core/bit-set #inst "2018-10-11"} + :todo #{"Extend index to non-longs" + "Extend usage to non-primitives"}} #?(:clj ([x (t/- p/primitive? p/boolean?), i p/long? > (t/type x)] (Numeric/bitSet x i)) :cljs ([x p/double?, i std/fixint? > (t/assume numerically-int?)] (core/bit-set x i)))) @@ -286,7 +291,10 @@ "Applies `not` to the bit at the provided index ->`i`. Unchecked w.r.t. the bit index. Equivalent to `clojure.core/bit-flip`." - {:todo #{"Extend index to non-longs"}} + {:incorporated {'clojure.core/bit-flip #inst "2018-10-11" + 'cljs.core/bit-flip #inst "2018-10-11"} + :todo #{"Extend index to non-longs" + "Extend usage to non-primitives"}} #?(:clj ([x (t/- p/primitive? p/boolean?), i p/long? > (t/type x)] (Numeric/bitFlip x i)) :cljs ([x p/double?, i std-fixint? > (t/assume numerically-int?)] (core/bit-flip x i)))) @@ -294,7 +302,10 @@ "Outputs whether the bit at the provided index ->`i` is `bit-true`. Unchecked w.r.t. the bit index. Equivalent to `clojure.core/bit-test`." - {:todo #{"Extend index to non-longs"}} + {:incorporated {'clojure.core/bit-test #inst "2018-10-11" + 'cljs.core/bit-test #inst "2018-10-11"} + :todo #{"Extend index to non-longs" + "Extend usage to non-primitives"}} #?(:clj ([x (t/- p/primitive? p/boolean?), i p/long? > p/boolean?] (Numeric/bitTest x i)) :cljs ([x p/double? , i std-fixint? > p/boolean?] (core/bit-test x i)))) From f19d6716b46a09e38d2ac1de351e94267c612996 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 11 Oct 2018 23:09:00 -0600 Subject: [PATCH 498/810] `extend-defn!` is now quite viable! It's the next step --- resources-dev/defnt.cljc | 58 +++++++++--------- .../quantum/untyped/core/type/defnt.cljc | 5 +- .../quantum/test/untyped/core/type/defnt.cljc | 59 +++++++++++++++++++ 3 files changed, 91 insertions(+), 31 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 87e95280..26ce4278 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -59,7 +59,18 @@ TODO: Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - [1] - t/numerically : e.g. a double representing exactly what a float is able to represent + [1] - t/extend-defn! + - We could just recreate the dispatch every time, in the beginning. It would make for slower + compilation but faster execution for dynamic dispatch, and quicker time to use. So whenever + something extends a `t/defn`, the type overloads have to be put in the right place in the dispatch order. We could find the first place where the inputs are t/<. + - But then you have to trigger a recompilation of everything that depended on that `t/defn` + because your input-types and output-types have both gotten bigger. Maybe not on that overload + but still. + - This will be a more advanced feature. For now we just accept that we might have some odd behavior around extending `t/defn`s. + - When you overwrite a `reify` then it's fine as long as the interface class stays the same. + Of course, pending auto-recompilation, you'll have to manually recompile its dependents + for them to pick up on changes to its type. + [2] - t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. - t/numerically-integer? - In order to have this, you have to have comparisons in place @@ -76,28 +87,17 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` [ ] - (comp/t== x) - dependent type such that the passed input must be identical to x - [2] - t/input-type + [3] - t/input-type - `(t/input-type >namespace :?)` meaning the possible input types to the first input to `>namespace` - `(t/input-type reduce :_ :_ :?)` - This is pretty simple with the current dependent type system - Then if those fns ever get extended then it should trigger a chain-reaction of recompilations - [3] - t/output-type + [4] - t/output-type - This is pretty simple with the current dependent type system [ ] - Non-boxed `def`s: `(var/def- min-float (Numeric/negate Float/MAX_VALUE))` - [4] - t/extend-defn! - - We could just recreate the dispatch every time, in the beginning. It would make for slower - compilation but faster execution for dynamic dispatch, and quicker time to use. So whenever - something extends a `t/defn`, the type overloads have to be put in the right place in the dispatch order. We could find the first place where the inputs are t/<. - - But then you have to trigger a recompilation of everything that depended on that `t/defn` - because your input-types and output-types have both gotten bigger. Maybe not on that overload - but still. - - This will be a more advanced feature. For now we just accept that we might have some odd behavior around extending `t/defn`s. - - When you overwrite a `reify` then it's fine as long as the interface class stays the same. - Of course, pending auto-recompilation, you'll have to manually recompile its dependents - for them to pick up on changes to its type. - [6] - Direct dispatch needs to actually work correctly in `t/defn` - [7] - No trailing `>` means `> ?` + [5] - Direct dispatch needs to actually work correctly in `t/defn` + [6] - No trailing `>` means `> ?` - ? : type inference - use logic programming and variable unification e.g. `?1` `?2` ? - For this situation: `?` is `(t/- dc/counted?)` @@ -165,8 +165,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - t/ftype - conditionally optional arities etc. - t/declare - - declare-fnt (a way to do protocols/interfaces) - - extend-fnt! - ^:dyn - `(name (read ...))` fails at compile-time; we want it to at least try at runtime. So instead we annotate like `(name ^:dyn (read ...))`, meaning figure out at runtime what the out-type of @@ -186,7 +184,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative we do the `let*`-binding approach to typing vars? - should be able to be per-arity like so: (^:inline [] ...) - - ^:inline set on a function should propagate to all overloads, including ones added after the fact + - ^:inline set on a function should propagate to all overloads, including ones added via + `t/extend-defn!` - A good example of inlining: (t/def empty?|rf (fn/aritoid @@ -297,19 +296,19 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] biginteger - [ ] binding - [ ] binding-conveyor-fn - - [x .] bit-and + - [x x] bit-and - [! !] bit-and-not - - [x .] bit-clear + - [x x] bit-clear - [| ] bit-count - - [x .] bit-flip - - [x .] bit-not - - [x .] bit-or - - [x .] bit-set - - [x .] bit-shift-left - - [x .] bit-shift-right + - [x x] bit-flip + - [x x] bit-not + - [x x] bit-or + - [x x] bit-set + - [x x] bit-shift-left + - [x x] bit-shift-right - [| !] bit-shift-right-zero-fill - - [x .] bit-test - - [x .] bit-xor + - [x x] bit-test + - [x x] bit-xor - [x .] boolean - [x x] boolean? - [ ] boolean-array @@ -819,7 +818,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] special-symbol? - [| ] specify - [| ] specify! - - [ ] spread - [ ] spit - [ ] split-at - [ ] split-with diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 61988798..fdc965e3 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -595,4 +595,7 @@ even if that means alienating the mainstream CLJS-in-CLJ workflow." [& args] (fn|code :fn (ufeval/env-lang) args))) -#?(:clj (defmacro defn [& args] (fn|code :defn (ufeval/env-lang) args))) +#?(:clj +(defmacro defn + "A `defn` with an empty body is like using `declare`." + [& args] (fn|code :defn (ufeval/env-lang) args))) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 3e47997b..4677b219 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1788,3 +1788,62 @@ (s/fnt [x ?] (< x 0.1))) (t/or str? !str?)) y ?] (str x (name y))) ; uses the above-defined `name` + + +;; ===== `extend-defn!` tests ===== ;; + +(macroexpand + '(self/defn extensible + ([a t/double?]))) + +;; Code +(do ;; We could keep a global map of defn-symbol to mapping, but if someone deletes the namespace + ;; the `t/defn` is interned in, that mapping should go away too. + ;; We only show this mapping because testing/debug is on. Otherwise the macro would just + ;; `intern` the var and define it there rather than re-evaluating the types. + (def ~'extensible|__mapping + (atom [{:id 0 :arg-types [(t/isa? Double)] :out-type t/any?}])) + + (declare ~'extensible) + ;; TODO `mapping>arg-types` is `(apply *<> (:arg-types (get @extensible|__mapping 0)))` + (def ~'extensible|__0|types (mapping>arg-types ~'extensible|__mapping 0)) + (def ~'extensible|__0 (reify* [double>Object] (invoke [_0__ a] nil))) + + (intern 'quantum.test.untyped.core.type.defnt + (with-meta 'extensible + {:quantum.core.type/type + (apply t/ftype t/any? (self/mapping>ftype-signatures @extensible|__mapping))}) + (fn* ([~'x00__] + (ifs ((Array/get ~'extensible|__0|types 0) ~'x00__) + (. extensible|__0 invoke x00__) + (unsupported! `extensible [~'x00__] 0)))))) + +(testing "Insertion" + (self/extend-defn! extensible + ([a t/boolean?])) + + (do ;; We only show this mapping because testing/debug is on. Otherwise the macro would just + ;; `swap!` the mapping outside the code rather than re-evaluating the types. + ;; To find where to put the overload, we find the first place where the inputs are `t/<`. + ;; TODO test that when testing/debug mode is off, it doesn't emit this code + (reset! extensible|__mapping + [{:id 1 :arg-types [(t/isa? Boolean)] :out-type t/any?} + {:id 0 :arg-types [(t/isa? Double)] :out-type t/any?}]) + + ;; It's labeled as `extensible|__1` but internally that's not how it's ordered; it's just + ;; incrementing based on the size of the overload<->index mapping + ;; Currently we can't undefine overloads which I think is fine + (def ~'extensible|__1|types (mapping>arg-types extensible|__mapping 0)) + (def ~'extensible|__1 (reify* [boolean>Object] (invoke [_0__ a] nil))) + ;; The dynamic dispatch is currently redefined with every `extend-defn!` + ;; We expect that `t/defn` extension will take place in only one thread + (intern 'quantum.test.untyped.core.type.defnt + (with-meta 'extensible + {:quantum.core.type/type + (apply t/ftype t/any? (self/mapping>ftype-signatures @extensible|__mapping))}) + (fn* ([~'x00__] + (ifs ((Array/get ~'extensible|__1|types 0) ~'x00__) + (. extensible|__1 invoke x00__) + ((Array/get ~'extensible|__0|types 0) ~'x00__) + (. extensible|__0 invoke x00__) + (unsupported! `extensible [~'x00__] 0))))))) From 524104b993aaf6e353eddafabc1e44b52e639720 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 12 Oct 2018 13:12:39 -0600 Subject: [PATCH 499/810] `extend-defn!` is well underway! --- resources-dev/defnt.cljc | 9 +- .../quantum/untyped/core/type/defnt.cljc | 203 ++++++++++++------ src/quantum/core/collections/core.cljc | 16 +- src/quantum/core/data/bits.cljc | 6 +- src/quantum/core/primitive.cljc | 4 +- src/quantum/core/vars.cljc | 4 +- .../quantum/test/untyped/core/type/defnt.cljc | 74 +++---- 7 files changed, 188 insertions(+), 128 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 26ce4278..6f97bc5d 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -61,15 +61,11 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: [1] - t/extend-defn! - We could just recreate the dispatch every time, in the beginning. It would make for slower - compilation but faster execution for dynamic dispatch, and quicker time to use. So whenever - something extends a `t/defn`, the type overloads have to be put in the right place in the dispatch order. We could find the first place where the inputs are t/<. + compilation but faster execution for dynamic dispatch, and quicker time to use. - But then you have to trigger a recompilation of everything that depended on that `t/defn` because your input-types and output-types have both gotten bigger. Maybe not on that overload but still. - This will be a more advanced feature. For now we just accept that we might have some odd behavior around extending `t/defn`s. - - When you overwrite a `reify` then it's fine as long as the interface class stays the same. - Of course, pending auto-recompilation, you'll have to manually recompile its dependents - for them to pick up on changes to its type. [2] - t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. - t/numerically-integer? @@ -155,13 +151,14 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - We'll should make a special class or *something* like that to ensure that typed bindings are only bound within typed contexts. - `t/defn` declaration: `(t/defn >std-fixint > std-fixint?)` + - `t/defn` `|` (pre-types) - t/defrecord - t/def-concrete-type (i.e. `t/deftype`) - expressions (`quantum.untyped.core.analyze.expr`) - comparison of `t/fn`s is probably possible? - t/def - TODO what would this even look like? - - t/fnt (t/fn; current t/fn might transition to t/fn-spec or whatever?) + - t/fn - t/ftype - conditionally optional arities etc. - t/declare diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index fdc965e3..e92f6319 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -1,8 +1,8 @@ (ns quantum.untyped.core.type.defnt (:refer-clojure :exclude - [defn]) + [defn fn]) (:require - [clojure.core :as core] + [clojure.core :as c] [clojure.string :as str] ;; TODO excise this reference [quantum.core.type.core :as tcore] @@ -52,16 +52,45 @@ [quantum.core Numeric] [quantum.core.data Array])) +;; TODO move +(def index? #(and (integer? %) (>= % 0))) +(def count? index?) + +;; ===== `t/extend-defn!` specs ===== ;; + +(s/def :quantum.core.defnt/fn|extended-name qualified-symbol?) + +(s/def :quantum.core.defnt/extend-defn! + (s/and (s/spec + (s/cat :quantum.core.defnt/fn|extended-name :quantum.core.defnt/fn|extended-name + :quantum.core.defnt/overloads :quantum.core.defnt/overloads)) + (uss/fn-like|postchecks|gen :quantum.core.defnt/overloads) + :quantum.core.defnt/postchecks)) + +;; ===== End `t/extend-defn!` specs ===== ;; + (defonce *fn->type (atom {})) (defonce defnt-cache (atom {})) ; TODO For now — but maybe lock-free concurrent hash map to come (defonce *interfaces (atom {})) -;; Internal specs +;; ==== Internal specs ===== ;; (s/def ::lang #{:clj :cljs}) +(def ^:dynamic *compilation-mode* :normal) + +(s/def ::compilation-mode #{:normal :test}) + +(s/def ::kind #{:fn :defn :extend-defn!}) + +(s/def ::opts + (s/kv {:compilation-mode ::compilation-mode + :gen-gensym t/fn? + :lang ::lang + :kind ::kind})) + ;; "global" because they apply to the whole fnt (s/def ::fn|globals (s/kv {:fn|meta (s/nilable :quantum.core.specs/meta) @@ -70,10 +99,6 @@ :fn|output-type|form t/any? :fn|output-type t/type?})) -(s/def ::opts - (s/kv {:gen-gensym t/fn? - :lang ::lang})) - ;; Technically it's partially analyzed — its type definitions are analyzed (with the exception of ;; requests for type inference) while its body is not. (s/def ::unanalyzed-overload @@ -90,13 +115,13 @@ ;; One of these corresponds to one reify overload. (s/def ::overload (s/kv {:arg-classes (s/vec-of class?) - :arg-types (s/seq-of t/type?) + :arg-types (s/vec-of t/type?) :arglist-code|fn|hinted t/any? :arglist-code|reify|unhinted t/any? :body-form t/any? :output-class (s/nilable class?) :output-type t/type? - :positional-args-ct (s/and integer? #(>= % 0)) + :positional-args-ct count? ;; When present, varargs are considered to be of class Object :variadic? t/boolean?})) @@ -118,17 +143,18 @@ (s/kv {:form t/any? :direct-dispatch-data-seq (s/vec-of ::direct-dispatch-data)})) +(s/def ::types-decl-datum (s/kv {:id index? :arg-types (s/vec-of t/type?) :output-type t/type?})) + +(s/def ::types-decl (s/kv {:form t/any? :name simple-symbol?})) + #_(:clj -(core/defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] +(c/defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] (cond (not= k :spec) java.lang.Object; default class (symbol? spec) (pred->class lang spec)))) ;; TODO optimize such that `post-type|form` doesn't create a new type-validator wholesale every ;; time the function gets run; e.g. extern it -(core/defn >with-runtime-output-type [body output-type|form] `(t/validate ~body ~output-type|form)) - -;; TODO move -(def index? #(and (integer? %) (>= % 0))) +(c/defn >with-runtime-output-type [body output-type|form] `(t/validate ~body ~output-type|form)) ;; TODO simplify this class computation @@ -174,20 +200,20 @@ body-codelist|pre-analyze _] declared-output-type [:output-type _]} ::unanalyzed-overload - {:as fn|globals :keys [fn|name _, fn|type _, fn|output-type _]} ::fn|globals {:as opts :keys [lang _]} ::opts + {:as fn|globals :keys [fn|name _, fn|type _, fn|output-type _]} ::fn|globals > ::overload] (let [;; Not sure if `nil` is the right approach for the value recursive-ast-node-reference (uast/symbol {} fn|name nil fn|type) env (->> (zipmap arg-bindings arg-types) - (uc/map' (fn [[arg-binding arg-type]] + (uc/map' (c/fn [[arg-binding arg-type]] [arg-binding (uast/unbound nil arg-binding arg-type)])) ;; To support recursion (<- (assoc fn|name recursive-ast-node-reference))) arg-classes (->> arg-types (uc/map type>class)) body|pre-analyze|with-casts (->> arg-classes - (reducei (fn [body ^Class c i|arg] + (reducei (c/fn [body ^Class c i|arg] (if (.isPrimitive c) body (let [arg-sym (get arg-bindings i|arg)] @@ -195,7 +221,7 @@ ~body)))) (ufgen/?wrap-do body-codelist|pre-analyze))) body-node (uana/analyze env body|pre-analyze|with-casts) - hint-arg|fn (fn [i arg-binding] + hint-arg|fn (c/fn [i arg-binding] (ufth/with-type-hint arg-binding (ufth/>fn-arglist-tag (uc/get arg-classes i) @@ -270,7 +296,7 @@ (ur/join [(gen-gensym '_)] (->> arglist-code|reify|unhinted (uc/map-indexed - (fn [i|arg arg|form] + (c/fn [i|arg arg|form] (ufth/with-type-hint arg|form (-> arg-classes|reify (uc/get i|arg) ufth/>arglist-embeddable-tag)))))) reify-name (>symbol (str fn|name "|__" i|overload)) @@ -297,21 +323,21 @@ {:form form :name decl-name})) (defns >direct-dispatch - [{:as fn|globals :keys [fn|name _]} ::fn|globals - {:as opts :keys [gen-gensym _, lang _]} ::opts + [{:as opts :keys [gen-gensym _, lang _]} ::opts + {:as fn|globals :keys [fn|name _]} ::fn|globals overloads (s/vec-of ::overload) > ::direct-dispatch] (case lang :clj (let [direct-dispatch-data-seq (->> overloads (uc/map-indexed - (fn [i|overload {:as overload :keys [arg-types]}] + (c/fn [i|overload {:as overload :keys [arg-types]}] {:input-types-decl (>input-types-decl fn|globals arg-types i|overload) :reify (overload>reify overload opts fn|globals i|overload)}))) form (->> direct-dispatch-data-seq (uc/mapcat - (fn [{:as direct-dispatch-data :keys [input-types-decl]}] + (c/fn [{:as direct-dispatch-data :keys [input-types-decl]}] (list (:form input-types-decl) (-> direct-dispatch-data :reify :form)))))] (kw-map form direct-dispatch-data-seq)) @@ -332,13 +358,13 @@ [direct-dispatch-data-seq-for-arity (s/seq-of ::direct-dispatch-data) arglist (s/vec-of simple-symbol?)] (->> direct-dispatch-data-seq-for-arity - (uc/map+ (fn [{reify- :reify :keys [input-types-decl]}] + (uc/map+ (c/fn [{reify- :reify :keys [input-types-decl]}] [(>dynamic-dispatch|reify-call reify- arglist) (->> reify- :overload :arg-types (uc/map-indexed - (fn [i|arg arg-type] + (c/fn [i|arg arg-type] {:i i|arg :t arg-type :getf `((Array/get ~(:name input-types-decl) ~i|arg) @@ -353,32 +379,35 @@ (>dynamic-dispatch|reify-call (-> direct-dispatch-data-seq-for-arity first :reify) arglist) (let [*i|arg (atom 0) combinef - (fn ([] (transient [`ifs])) - ([ret] - (-> ret (conj! `(unsupported! '~(uid/qualify fn|name) ~arglist ~(deref *i|arg))) - persistent! - seq)) - ([ret getf x i] - (reset! *i|arg i) - (uc/conj! ret getf x)))] + (c/fn + ([] (transient [`ifs])) + ([ret] + (-> ret (conj! `(unsupported! '~(uid/qualify fn|name) ~arglist ~(deref *i|arg))) + persistent! + seq)) + ([ret getf x i] + (reset! *i|arg i) + (uc/conj! ret getf x)))] (uc/>combinatoric-tree (count arglist) - (fn [a b] (t/= (:t a) (:t b))) - (aritoid combinef combinef (fn [x [{:keys [getf i]} group]] (combinef x getf group i))) + (c/fn [a b] (t/= (:t a) (:t b))) + (aritoid combinef combinef (c/fn [x [{:keys [getf i]} group]] (combinef x getf group i))) uc/conj!|rf - (aritoid combinef combinef (fn [x [k [{:keys [getf i]}]]] (combinef x getf k i))) + (aritoid combinef combinef (c/fn [x [k [{:keys [getf i]}]]] (combinef x getf k i))) (>combinatoric-seq+ direct-dispatch-data-seq-for-arity arglist))))) (defns- >dynamic-dispatch-fn|form - [{:as fn|globals :keys [fn|meta _, fn|name _, fn|type _]} ::fn|globals - {:as opts :keys [gen-gensym _, lang _]} ::opts + [{:as opts :keys [gen-gensym _, lang _]} ::opts + {:as fn|globals :keys [fn|meta _, fn|name _, fn|output-type _]} ::fn|globals + types-decl ::types-decl direct-dispatch ::direct-dispatch] - `(core/defn ~fn|name - ~(assoc fn|meta :quantum.core.type/type (>form fn|type)) + `(c/defn ~fn|name + ~(assoc fn|meta :quantum.core.type/type + `(self/types-decl>ftype ~(:name types-decl) ~fn|output-type)) ~@(->> direct-dispatch :direct-dispatch-data-seq (group-by (fn-> :reify :overload :arg-types count)) (sort-by key) ; for purposes of reproducibility and organization - (map (fn [[arg-ct direct-dispatch-data-seq-for-arity]] + (map (c/fn [[arg-ct direct-dispatch-data-seq-for-arity]] (let [arglist (ufgen/gen-args 0 arg-ct "x" gen-gensym) body (>dynamic-dispatch|body-for-arity fn|name arglist direct-dispatch-data-seq-for-arity)] @@ -388,7 +417,7 @@ ;; ===== Arg type comparison ===== ;; -(core/defn compare-arg-types [t0 #_t/type?, t1 #_t/type? #_> #_ucomp/comparison?] +(c/defn compare-arg-types [t0 #_t/type?, t1 #_t/type? #_> #_ucomp/comparison?] (if-let [c0 (uana/sort-guide t0)] (if-let [c1 (uana/sort-guide t1)] (ifs (< c0 c1) -1 (> c0 c1) 1 0) @@ -397,11 +426,11 @@ 1 (uset/normalize-comparison (t/compare t0 t1))))) -(core/defn compare-args-types [arg-types0 #_(s/vec-of t/type?) arg-types1 #_(s/vec-of t/type?)] +(c/defn compare-args-types [arg-types0 #_(s/vec-of t/type?) arg-types1 #_(s/vec-of t/type?)] (let [ct-comparison (compare (count arg-types0) (count arg-types1))] (if (zero? ct-comparison) (reduce-2 - (core/fn [^long c t0 t1] + (c/fn [^long c t0 t1] (let [c' (long (compare-arg-types t0 t1))] (case c' -1 (case c 1 (reduced 0) c') @@ -413,7 +442,7 @@ ;; TODO spec ;; TODO use!! -(core/defn assert-monotonically-increasing-types! +(c/defn assert-monotonically-increasing-types! "Asserts that each type in an overload of the same arity and arg-position are in monotonically increasing order in terms of `t/compare`. @@ -426,7 +455,7 @@ (let [prev-overload (uc/last unanalyzed-overload-seq-accum) overload (uc/first unanalyzed-overload-seq)] (reducei-2 - (fn [_ arg|type|prev arg|type i|arg] + (c/fn [_ arg|type|prev arg|type i|arg] (when ;; NOTE could use `compare-arg-types` here instead of `t/compare` if we want a more ;; efficient combinatoric tree dispatch (= 1 (t/compare arg|type|prev arg|type)) @@ -452,7 +481,7 @@ > (s/seq-of ::unanalyzed-overload)] (when pre-type|form (TODO "Need to handle pre")) (when varargs (TODO "Need to handle varargs")) - (let [arg-types|form (->> args (mapv (fn [{[kind #_#{:any :spec}, t #_t/form?] :spec}] + (let [arg-types|form (->> args (mapv (c/fn [{[kind #_#{:any :spec}, t #_t/form?] :spec}] (case kind :any `t/any? :spec t)))) output-type|form (case output-type|form _ `t/any? @@ -462,7 +491,7 @@ output-type|form) arg-bindings (->> args - (mapv (fn [{[kind binding-] :binding-form}] + (mapv (c/fn [{[kind binding-] :binding-form}] ;; TODO this assertion is purely temporary until destructuring is ;; supported (assert kind :sym) @@ -474,7 +503,7 @@ (assert (-> varargs :binding-form first (= :sym)))) arg-types|expanded-seq ; split, primitivized, and sorted (->> (uana/analyze-arg-syms {} (zipmap arg-bindings arg-types|form) output-type|form) - (uc/map (fn [{:keys [env out-type-node]}] + (uc/map (c/fn [{:keys [env out-type-node]}] (let [output-type (:type out-type-node) arg-env (->> env :opts :arg-env deref) arg-types (->> arg-bindings (uc/map #(:type (get arg-env %))))] @@ -490,7 +519,7 @@ vec)] (uana/pr! arg-types|expanded-seq) ; TODO excise (->> arg-types|expanded-seq - (uc/map (fn [{:keys [arg-types output-type]}] + (uc/map (c/fn [{:keys [arg-types output-type]}] (kw-map arg-bindings varargs-binding arg-types|form arg-types output-type|form output-type @@ -504,32 +533,57 @@ (->> overloads-bases (uc/map+ #(overloads-basis>unanalyzed-overload-seq % fn|output-type|form fn|output-type)) (educei - (fn ([] []) - ([ret] ret) - ([ret unanalyzed-overload-seq i|overload-basis] - (assert-monotonically-increasing-types! ret unanalyzed-overload-seq i|overload-basis) - (ur/join ret unanalyzed-overload-seq)))))) - -(defns unanalyzed-overloads>fn|type - [unanalyzed-overloads (s/seq-of ::unanalyzed-overload), fn|output-type t/type? > utr/fn-type?] - (->> unanalyzed-overloads - (uc/lmap (fn [{:keys [arg-types pre-type output-type]}] + (c/fn + ([] []) + ([ret] ret) + ([ret unanalyzed-overload-seq i|overload-basis] + (assert-monotonically-increasing-types! ret unanalyzed-overload-seq i|overload-basis) + (ur/join ret unanalyzed-overload-seq)))))) + +(c/defn types-decl>ftype + [types-decl #_(atom-of (vec-of ...)), fn|output-type #_t/type? #_> #_(vec-of ...)] + (->> types-decl + deref + (uc/lmap (c/fn [{:keys [arg-types pre-type output-type]}] (cond-> arg-types pre-type (conj :| pre-type) output-type (conj :> output-type)))) (apply t/ftype fn|output-type))) -(defns fn|code [kind #{:fn :defn}, lang ::lang, args _] +(defns >types-decl + [opts ::opts, fn|globals ::fn|globals, overloads (s/seq-of ::overload) + > ::types-decl] + (let [types-sym (symbol (str (:fn|name fn|globals) "|__types-decl")) + types-decl-data + (if (= kind :extend-defn!) + ... + (->> overloads + (uc/map-indexed + (c/fn [i {:keys [arg-types output-type]}] + (kw-map i arg-types output-type)))))] + (if (-> opts :compilation-mode (= :test)) + {:name types-sym + :form (if (= kind :extend-defn!) + `(reset! ~(symbol (>name *ns*) (>name types-sym)) ~(>form types-decl-data)) + `(def ~types-sym (atom ~(>form types-decl-data))))} + (do (if (= kind :extend-defn!) + (reset! (var-get (ns-resolve *ns* types-sym)) types-decl-data) + (intern (>symbol *ns*) types-sym (atom types-decl-data))) + {:name types-sym :form nil})))) + +(defns fn|code [kind ::kind, lang ::lang, compilation-mode ::compilation-mode, args _] (let [{:as args' :keys [:quantum.core.specs/fn|name + :quantum.core.defnt/fn|extended-name :quantum.core.defnt/output-spec] overloads-bases :quantum.core.defnt/overloads fn|meta :quantum.core.specs/meta} - (s/validate args (case kind :defn :quantum.core.defnt/defnt - :fn :quantum.core.defnt/fnt)) + (s/validate args (case kind :defn :quantum.core.defnt/defnt + :fn :quantum.core.defnt/fnt + :extend-defn! :quantum.core.defnt/extend-defn!)) gen-gensym-base (ufgen/>reproducible-gensym|generator) - gen-gensym (fn [x] (symbol (str (gen-gensym-base x) "__"))) - opts (kw-map gen-gensym lang) + gen-gensym (c/fn [x] (symbol (str (gen-gensym-base x) "__"))) + opts (kw-map compilation-mode gen-gensym kind lang) inline? (s/validate (:inline fn|meta) (t/? t/boolean?)) fn|meta (if inline? (do (ulog/pr :warn "requested `:inline`; ignoring until feature is" @@ -543,14 +597,17 @@ overloads-bases fn|output-type|form fn|output-type) fn|type (unanalyzed-overloads>fn|type unanalyzed-overloads fn|output-type) fn|globals (kw-map fn|name fn|meta fn|type fn|output-type|form fn|output-type) + ;; Specifically overloads that were generated during this execution of this function overloads (->> unanalyzed-overloads - (uc/map #(unanalyzed-overload>overload % fn|globals opts))) - direct-dispatch (>direct-dispatch fn|globals opts overloads) + (uc/map #(unanalyzed-overload>overload % opts fn|globals))) + direct-dispatch (>direct-dispatch opts fn|globals overloads) + types-decl (>types-decl opts fn|globals overloads) fn-codelist (case lang :clj (->> `[(declare ~fn|name) ; for recursion + ~@(some-> (:form types-decl) vector) ~@(:form direct-dispatch) - ~(>dynamic-dispatch-fn|form fn|globals opts direct-dispatch)] + ~(>dynamic-dispatch-fn|form opts fn|globals types-decl direct-dispatch)] (remove nil?)) :cljs (TODO)) code (case kind @@ -559,7 +616,7 @@ code)) #?(:clj -(defmacro fnt +(defmacro fn "With `t/fn`, protocols, interfaces, and multimethods become unnecessary. The preferred method of dispatch becomes the function alone. @@ -593,9 +650,13 @@ `fnt` only works in languages in which the metalanguage (compiler language) is the same as the object language. As such, for CLJS, we choose to use only a CLJS-in-CLJS / bootstrapped compiler even if that means alienating the mainstream CLJS-in-CLJ workflow." - [& args] (fn|code :fn (ufeval/env-lang) args))) + [& args] (fn|code :fn (ufeval/env-lang) *compilation-mode* args))) #?(:clj (defmacro defn "A `defn` with an empty body is like using `declare`." - [& args] (fn|code :defn (ufeval/env-lang) args))) + [& args] (fn|code :defn (ufeval/env-lang) *compilation-mode* args))) + +#?(:clj +(defmacro extend-defn! + [& args] (fn|code :extend-defn! (ufeval/env-lang) *compilation-mode* args))) diff --git a/src/quantum/core/collections/core.cljc b/src/quantum/core/collections/core.cljc index 152d6eb4..c70d3824 100644 --- a/src/quantum/core/collections/core.cljc +++ b/src/quantum/core/collections/core.cljc @@ -114,15 +114,15 @@ [n (t/numerically p/int?), xs t/reducible? > t/reducible?] (let [n' (>int n)] (r/transformer xs - (fnt [rf r/rf?] + (t/fn [rf r/rf?] (let [buffer (java.util.ArrayDeque. n')] - (fnt ([] (rf)) - ([ret _, x _] - (let [ret' (if (identical? (.size buffer) n') - (rf ret (.pop buffer)) - ret)] - (.add buffer x) - ret'))))))))) + (t/fn ([] (rf)) + ([ret _, x _] + (let [ret' (if (identical? (.size buffer) n') + (rf ret (.pop buffer)) + ret)] + (.add buffer x) + ret'))))))))) #?(:clj (defn taker+ diff --git a/src/quantum/core/data/bits.cljc b/src/quantum/core/data/bits.cljc index e477e292..ccf90863 100644 --- a/src/quantum/core/data/bits.cljc +++ b/src/quantum/core/data/bits.cljc @@ -338,9 +338,9 @@ {:adapted-from 'gloss.data.primitives} [x , n length?] (->> (range n) - (mapv (fnt [] (if (pos? (and (<< 1 %) x)) - bit-true - bit-false))))) + (mapv (t/fn [] (if (pos? (and (<< 1 %) x)) + bit-true + bit-false))))) ;; TODO TYPED #_(defnt test*-coll diff --git a/src/quantum/core/primitive.cljc b/src/quantum/core/primitive.cljc index 453fdab5..0668fd83 100644 --- a/src/quantum/core/primitive.cljc +++ b/src/quantum/core/primitive.cljc @@ -129,11 +129,11 @@ #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-long? ;; TODO This might be faster than `numerically-long?` - #_(fnt [x ?] (nil? (.bipart x))))] (.lpart x))) + #_(t/fn [x ?] (nil? (.bipart x))))] (.lpart x))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-long? ;; TODO This might be faster than `numerically-long?` - #_(fnt [x ?] (< (.bitLength x) 64)))] (.longValue x))) + #_(t/fn [x ?] (< (.bitLength x) 64)))] (.longValue x))) #?(:clj ([x (t/and dn/ratio? numerically-long?)] (-> x .bigIntegerValue .longValue)))) ;; ----- Float ----- ;; diff --git a/src/quantum/core/vars.cljc b/src/quantum/core/vars.cljc index c4f1b313..6a4d0cf4 100644 --- a/src/quantum/core/vars.cljc +++ b/src/quantum/core/vars.cljc @@ -174,7 +174,7 @@ "Like `reset!` but for vars. Atomically sets the root binding of ->`var-` to ->`v`." {:attribution "alexandergunnarson"} [var-val var?, v t/ref? > var?] - (.alterRoot var-val (fnt [_] v)))) + (.alterRoot var-val (t/fn [_] v)))) ;; TODO TYPED — need to do `fnt`, `apply` #_(:clj @@ -185,7 +185,7 @@ var-)) ;; TODO we need to be able to conditionalize `f`'s arity based on the count of `args` ([var- f t/fn? & args (? t/seq?) > var?] - (do (.alterRoot var- (fnt [v' _] (apply f v' args))) + (do (.alterRoot var- (t/fn [v' _] (apply f v' args))) var-)))) ;; TODO TYPED — `doseq` diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 4677b219..828a29d7 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1096,15 +1096,15 @@ ([x (t/- tt/primitive? tt/boolean? tt/float? tt/double?)] (>long* x)) ([x (t/and (t/or tt/double? tt/float?) ;; TODO add this back in - #_(fnt [x (t/or t/double? t/float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] + #_(t/fn [x (t/or t/double? t/float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] (>long* x)) ([x (t/and (t/isa? clojure.lang.BigInt) ;; TODO add this back in - #_(fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] + #_(t/fn [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] (.lpart x)) ([x (t/and (t/isa? java.math.BigInteger) ;; TODO add this back in - #_(fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] + #_(t/fn [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] (.longValue x)) ([x tt/ratio?] (-> x >big-integer >long-checked)) ([x (t/value true)] 1) @@ -1151,12 +1151,12 @@ (.invoke >long*|__4 ~'x)))) #_[x (t/and (t/or double? float?) - (fnt [x (t/or double? float?)] + (t/fn [x (t/or double? float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] #_(def ~'>long|__5|input-types (*<> (t/and double? - (fnt [x (t/or double? float?)] + (t/fn [x (t/or double? float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE)))))) (def ~'>long|__5 (reify double>long @@ -1166,7 +1166,7 @@ #_(def ~'>long|__6|input-types (*<> (t/and t/float? - (fnt [x (t/or double? float?)] + (t/fn [x (t/or double? float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE)))))) (def ~'>long|__6 (reify float>long @@ -1175,22 +1175,22 @@ (.invoke >long*|__5 ~'x)))) #_[(t/and (t/isa? clojure.lang.BigInt) - (fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] + (t/fn [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] #_(def ~'>long|__7|input-types (*<> (t/and (t/isa? clojure.lang.BigInt) - (fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x)))))) + (t/fn [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x)))))) (def ~'>long|__7 (reify Object>long (~(L 'invoke) [_## ~(O 'x)] (let* [~(tag "clojure.lang.BigInt" 'x) ~'x] ~'(.lpart x))))) #_[x (t/and (t/isa? java.math.BigInteger) - (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] + (t/fn [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] #_(def ~'>long|__8|input-types (*<> (t/and (t/isa? java.math.BigInteger) - (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64))))) + (t/fn [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64))))) (def ~'>long|__8 (reify Object>long (~(L 'invoke) [_## ~(O 'x)] @@ -1266,12 +1266,12 @@ (t/fn [(t/- tt/boolean? tt/boolean? float? double?)] [(t/and (t/or t/double? t/float?) - (fnt [x (t/or double? float?)] + (t/fn [x (t/or double? float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] [(t/and (t/isa? clojure.lang.BigInt) - (fnt [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] + (t/fn [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] [(t/and (t/isa? java.math.BigInteger) - (fnt [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] + (t/fn [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] [ratio?] [(t/value true)] [(t/value false)] @@ -1792,31 +1792,33 @@ ;; ===== `extend-defn!` tests ===== ;; -(macroexpand - '(self/defn extensible - ([a t/double?]))) +(binding [self/*compilation-mode* :test] + (macroexpand + '(self/defn extensible + ([a t/double?])))) ;; Code -(do ;; We could keep a global map of defn-symbol to mapping, but if someone deletes the namespace +(do (declare ~'extensible) + + ;; We could keep a global map of defn-symbol to mapping, but if someone deletes the namespace ;; the `t/defn` is interned in, that mapping should go away too. ;; We only show this mapping because testing/debug is on. Otherwise the macro would just ;; `intern` the var and define it there rather than re-evaluating the types. - (def ~'extensible|__mapping - (atom [{:id 0 :arg-types [(t/isa? Double)] :out-type t/any?}])) + (def ~'extensible|__types-decl + (atom [{:id 0 :arg-types [(t/isa? Double)] :output-type t/any?}])) - (declare ~'extensible) - ;; TODO `mapping>arg-types` is `(apply *<> (:arg-types (get @extensible|__mapping 0)))` - (def ~'extensible|__0|types (mapping>arg-types ~'extensible|__mapping 0)) + ;; TODO `types-decl>arg-types` is `(apply *<> (:arg-types (get @extensible|__types 0)))` + (def ~'extensible|__0|types (self/types-decl>arg-types ~'extensible|__types-decl 0)) (def ~'extensible|__0 (reify* [double>Object] (invoke [_0__ a] nil))) - (intern 'quantum.test.untyped.core.type.defnt - (with-meta 'extensible - {:quantum.core.type/type - (apply t/ftype t/any? (self/mapping>ftype-signatures @extensible|__mapping))}) - (fn* ([~'x00__] - (ifs ((Array/get ~'extensible|__0|types 0) ~'x00__) - (. extensible|__0 invoke x00__) - (unsupported! `extensible [~'x00__] 0)))))) + ;; Could have done `intern`+`fn*` but JS needs some special things for it to work that may + ;; change over time + (defn extensible + {:quantum.core.type/type (self/types-decl>ftype extensible|__types-decl t/any?)} + ([~'x00__] + (ifs ((Array/get ~'extensible|__0|types 0) ~'x00__) + (. extensible|__0 invoke x00__) + (unsupported! `extensible [~'x00__] 0))))) (testing "Insertion" (self/extend-defn! extensible @@ -1826,21 +1828,21 @@ ;; `swap!` the mapping outside the code rather than re-evaluating the types. ;; To find where to put the overload, we find the first place where the inputs are `t/<`. ;; TODO test that when testing/debug mode is off, it doesn't emit this code - (reset! extensible|__mapping - [{:id 1 :arg-types [(t/isa? Boolean)] :out-type t/any?} - {:id 0 :arg-types [(t/isa? Double)] :out-type t/any?}]) + (reset! quantum.test.untyped.core.type.defnt/extensible|__types-decl + [{:id 1 :arg-types [(t/isa? Boolean)] :output-type t/any?} + {:id 0 :arg-types [(t/isa? Double)] :output-type t/any?}]) ;; It's labeled as `extensible|__1` but internally that's not how it's ordered; it's just ;; incrementing based on the size of the overload<->index mapping ;; Currently we can't undefine overloads which I think is fine - (def ~'extensible|__1|types (mapping>arg-types extensible|__mapping 0)) + (def ~'extensible|__1|types + (self/types-decl>arg-types quantum.test.untyped.core.type.defnt/extensible|__types-decl 0)) (def ~'extensible|__1 (reify* [boolean>Object] (invoke [_0__ a] nil))) ;; The dynamic dispatch is currently redefined with every `extend-defn!` ;; We expect that `t/defn` extension will take place in only one thread (intern 'quantum.test.untyped.core.type.defnt (with-meta 'extensible - {:quantum.core.type/type - (apply t/ftype t/any? (self/mapping>ftype-signatures @extensible|__mapping))}) + {:quantum.core.type/type (self/types-decl>ftype extensible|__types-decl t/any?)}) (fn* ([~'x00__] (ifs ((Array/get ~'extensible|__1|types 0) ~'x00__) (. extensible|__1 invoke x00__) From c124fa611b9bf442e35980d35fc46b114ffe968b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 12 Oct 2018 13:29:19 -0600 Subject: [PATCH 500/810] Get closer to extend-defn! --- .../quantum/untyped/core/type/defnt.cljc | 107 ++++++++++-------- .../quantum/test/untyped/core/type/defnt.cljc | 9 +- 2 files changed, 64 insertions(+), 52 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index e92f6319..fb5f65c7 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -125,7 +125,9 @@ ;; When present, varargs are considered to be of class Object :variadic? t/boolean?})) -(s/def ::input-types-decl +(s/def ::overload|id index?) + +(s/def ::overload-types-decl (s/kv {:form t/any? :name simple-symbol?})) @@ -136,8 +138,8 @@ :overload ::overload})) (s/def ::direct-dispatch-data - (s/kv {:input-types-decl ::input-types-decl - :reify ::reify})) + (s/kv {:overload-types-decl ::overload-types-decl + :reify ::reify})) (s/def ::direct-dispatch (s/kv {:form t/any? @@ -310,18 +312,60 @@ :name reify-name :overload overload}))) -;; ----- Direct dispatch: putting it all together ----- ;; +;; ----- Type declarations ----- ;; + +(defns >types-decl|name [fn|globals ::fn|globals > simple-symbol?] + (symbol (str (:fn|name fn|globals) "|__types-decl"))) + +(c/defn types-decl>arg-types + [types-decl #_(atom-of (vec-of ...)), overload-id #_::overload|id #_> #_(objects-of type?)] + (apply uarr/*<> (:arg-types (get @types-decl overload-id)))) + +(c/defn types-decl>ftype + [types-decl #_(atom-of (vec-of ...)), fn|output-type #_t/type? #_> #_(vec-of ...)] + (->> types-decl + deref + (uc/lmap (c/fn [{:keys [arg-types pre-type output-type]}] + (cond-> arg-types + pre-type (conj :| pre-type) + output-type (conj :> output-type)))) + (apply t/ftype fn|output-type))) + +(defns >types-decl + [{:as opts :keys [kind _]} ::opts, fn|globals ::fn|globals, overloads (s/seq-of ::overload) + > ::types-decl] + (let [types-sym (>types-decl|name fn|globals) + types-decl-data + (if (= kind :extend-defn!) + (TODO) + (->> overloads + (uc/map-indexed + (c/fn [i {:keys [arg-types output-type]}] + (kw-map i arg-types output-type)))))] + (if (-> opts :compilation-mode (= :test)) + {:name types-sym + :form (if (= kind :extend-defn!) + `(reset! ~(symbol (>name *ns*) (>name types-sym)) ~(>form types-decl-data)) + `(def ~types-sym (atom ~(>form types-decl-data))))} + ;; In non-test cases, it's far cheaper to not have to convert the types to a + ;; compiler-readable form and then re-evaluate them again + (do (if (= kind :extend-defn!) + (reset! (var-get (ns-resolve *ns* types-sym)) types-decl-data) + (intern (>symbol *ns*) types-sym (atom types-decl-data))) + {:name types-sym :form nil})))) -(defns >input-types-decl - "The evaluated `form` of each input-types-decl is an array of non-primitivized types that the +(defns >overload-types-decl + "The evaluated `form` of each overload-types-decl is an array of non-primitivized types that the dynamic dispatch uses to dispatch off input types." - [{:keys [fn|name _]} ::fn|globals, arg-types (s/vec-of t/type?), i|overload index? - > ::input-types-decl] + [{:as fn|globals :keys [fn|name _]} ::fn|globals arg-types (s/vec-of t/type?) + i|overload ::overload|id > ::overload-types-decl] (let [decl-name (>symbol (str fn|name "|__" i|overload "|types")) - form (list 'def (ufth/with-type-hint decl-name "[Ljava.lang.Object;") - (list* `uarr/*<> (uc/lmap >form arg-types)))] + form `(def ~(ufth/with-type-hint decl-name "[Ljava.lang.Object;") + (types-decl>arg-types ~(>types-decl|name fn|globals) ~i|overload))] {:form form :name decl-name})) +;; ----- Direct dispatch: putting it all together ----- ;; + (defns >direct-dispatch [{:as opts :keys [gen-gensym _, lang _]} ::opts {:as fn|globals :keys [fn|name _]} ::fn|globals @@ -332,13 +376,13 @@ (->> overloads (uc/map-indexed (c/fn [i|overload {:as overload :keys [arg-types]}] - {:input-types-decl - (>input-types-decl fn|globals arg-types i|overload) + {:overload-types-decl + (>overload-types-decl fn|globals arg-types i|overload) :reify (overload>reify overload opts fn|globals i|overload)}))) form (->> direct-dispatch-data-seq (uc/mapcat - (c/fn [{:as direct-dispatch-data :keys [input-types-decl]}] - (list (:form input-types-decl) + (c/fn [{:as direct-dispatch-data :keys [overload-types-decl]}] + (list (:form overload-types-decl) (-> direct-dispatch-data :reify :form)))))] (kw-map form direct-dispatch-data-seq)) :cljs (TODO))) @@ -358,7 +402,7 @@ [direct-dispatch-data-seq-for-arity (s/seq-of ::direct-dispatch-data) arglist (s/vec-of simple-symbol?)] (->> direct-dispatch-data-seq-for-arity - (uc/map+ (c/fn [{reify- :reify :keys [input-types-decl]}] + (uc/map+ (c/fn [{reify- :reify :keys [overload-types-decl]}] [(>dynamic-dispatch|reify-call reify- arglist) (->> reify- :overload @@ -367,7 +411,7 @@ (c/fn [i|arg arg-type] {:i i|arg :t arg-type - :getf `((Array/get ~(:name input-types-decl) ~i|arg) + :getf `((Array/get ~(:name overload-types-decl) ~i|arg) ~(get arglist i|arg))})))])))) (defns- >dynamic-dispatch|body-for-arity @@ -540,37 +584,6 @@ (assert-monotonically-increasing-types! ret unanalyzed-overload-seq i|overload-basis) (ur/join ret unanalyzed-overload-seq)))))) -(c/defn types-decl>ftype - [types-decl #_(atom-of (vec-of ...)), fn|output-type #_t/type? #_> #_(vec-of ...)] - (->> types-decl - deref - (uc/lmap (c/fn [{:keys [arg-types pre-type output-type]}] - (cond-> arg-types - pre-type (conj :| pre-type) - output-type (conj :> output-type)))) - (apply t/ftype fn|output-type))) - -(defns >types-decl - [opts ::opts, fn|globals ::fn|globals, overloads (s/seq-of ::overload) - > ::types-decl] - (let [types-sym (symbol (str (:fn|name fn|globals) "|__types-decl")) - types-decl-data - (if (= kind :extend-defn!) - ... - (->> overloads - (uc/map-indexed - (c/fn [i {:keys [arg-types output-type]}] - (kw-map i arg-types output-type)))))] - (if (-> opts :compilation-mode (= :test)) - {:name types-sym - :form (if (= kind :extend-defn!) - `(reset! ~(symbol (>name *ns*) (>name types-sym)) ~(>form types-decl-data)) - `(def ~types-sym (atom ~(>form types-decl-data))))} - (do (if (= kind :extend-defn!) - (reset! (var-get (ns-resolve *ns* types-sym)) types-decl-data) - (intern (>symbol *ns*) types-sym (atom types-decl-data))) - {:name types-sym :form nil})))) - (defns fn|code [kind ::kind, lang ::lang, compilation-mode ::compilation-mode, args _] (let [{:as args' :keys [:quantum.core.specs/fn|name diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 828a29d7..ac251caf 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1802,12 +1802,11 @@ ;; We could keep a global map of defn-symbol to mapping, but if someone deletes the namespace ;; the `t/defn` is interned in, that mapping should go away too. - ;; We only show this mapping because testing/debug is on. Otherwise the macro would just + ;; We only show this types decl because testing/debug is on. Otherwise the macro would just ;; `intern` the var and define it there rather than re-evaluating the types. (def ~'extensible|__types-decl (atom [{:id 0 :arg-types [(t/isa? Double)] :output-type t/any?}])) - ;; TODO `types-decl>arg-types` is `(apply *<> (:arg-types (get @extensible|__types 0)))` (def ~'extensible|__0|types (self/types-decl>arg-types ~'extensible|__types-decl 0)) (def ~'extensible|__0 (reify* [double>Object] (invoke [_0__ a] nil))) @@ -1824,8 +1823,8 @@ (self/extend-defn! extensible ([a t/boolean?])) - (do ;; We only show this mapping because testing/debug is on. Otherwise the macro would just - ;; `swap!` the mapping outside the code rather than re-evaluating the types. + (do ;; We only show this types decl because testing/debug is on. Otherwise the macro would just + ;; `swap!` the types decl outside the code rather than re-evaluating the types. ;; To find where to put the overload, we find the first place where the inputs are `t/<`. ;; TODO test that when testing/debug mode is off, it doesn't emit this code (reset! quantum.test.untyped.core.type.defnt/extensible|__types-decl @@ -1833,7 +1832,7 @@ {:id 0 :arg-types [(t/isa? Double)] :output-type t/any?}]) ;; It's labeled as `extensible|__1` but internally that's not how it's ordered; it's just - ;; incrementing based on the size of the overload<->index mapping + ;; incrementing based on the size of the types-decl ;; Currently we can't undefine overloads which I think is fine (def ~'extensible|__1|types (self/types-decl>arg-types quantum.test.untyped.core.type.defnt/extensible|__types-decl 0)) From ac45ab90cf79b6e09be817cce384ed4145450ebc Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 12 Oct 2018 17:40:53 -0600 Subject: [PATCH 501/810] `extend-defn!` works for the first time!! :D --- resources-dev/defnt.cljc | 13 +- src-untyped/quantum/untyped/core/form.cljc | 3 +- .../quantum/untyped/core/type/defnt.cljc | 331 ++++++++++++------ src/quantum/core/collections_typed.cljc | 1 + .../quantum/test/untyped/core/type/defnt.cljc | 21 +- 5 files changed, 241 insertions(+), 128 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 6f97bc5d..2135464f 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -60,12 +60,14 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: [1] - t/extend-defn! - - We could just recreate the dispatch every time, in the beginning. It would make for slower - compilation but faster execution for dynamic dispatch, and quicker time to use. + - We just recreate the dispatch every time, in the beginning. It makes for slower + compilation (?) but faster execution for dynamic dispatch, and quicker time to first use. - But then you have to trigger a recompilation of everything that depended on that `t/defn` because your input-types and output-types have both gotten bigger. Maybe not on that overload but still. - This will be a more advanced feature. For now we just accept that we might have some odd behavior around extending `t/defn`s. + - It should disallow creating another definition with the same input type combination. + - `assert-monotonically-increasing-types!` needs to be enforced [2] - t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. - t/numerically-integer? @@ -173,16 +175,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - Not just a private var for the dynamic dispatch, but needs to be private for purposes of the analyzer when doing direct dispatch. Should emit a warning, not just fail. - (t/and (t/or a b) c) should -> (t/or (t/and a c) (t/and b c)) for purposes of separating dispatches - - t/extend-defn! - - `(t/extend-defn! id/>name (^:inline [x namespace?] (-> x .getName id/>name)))` - ^:inline - - Applicable only if in a typed context and not used as a function - if you do (Numeric/bitAnd a b) inline then bitAnd needs to know the primitive type so maybe we do the `let*`-binding approach to typing vars? - - should be able to be per-arity like so: - (^:inline [] ...) - - ^:inline set on a function should propagate to all overloads, including ones added via - `t/extend-defn!` - A good example of inlining: (t/def empty?|rf (fn/aritoid diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index cd01bbd5..01e57750 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -36,7 +36,8 @@ nil (>form [x] nil) #?(:clj java.lang.Boolean :cljs boolean) (>form [x] x) - #?@(:clj [java.lang.Long (>form [x] x)]) + #?@(:clj [java.lang.Integer (>form [x] x) + java.lang.Long (>form [x] x)]) #?(:clj java.lang.Double :cljs number) (>form [x] x) #?(:clj java.lang.String diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index fb5f65c7..66b7f9c9 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -32,7 +32,7 @@ [quantum.untyped.core.form.generate :as ufgen] [quantum.untyped.core.form.type-hint :as ufth] [quantum.untyped.core.identifiers :as uid - :refer [>name >symbol]] + :refer [>name >?namespace >symbol]] [quantum.untyped.core.log :as ulog] [quantum.untyped.core.logic :as ul :refer [fn-or fn= ifs]] @@ -58,7 +58,7 @@ ;; ===== `t/extend-defn!` specs ===== ;; -(s/def :quantum.core.defnt/fn|extended-name qualified-symbol?) +(s/def :quantum.core.defnt/fn|extended-name symbol?) (s/def :quantum.core.defnt/extend-defn! (s/and (s/spec @@ -94,8 +94,10 @@ ;; "global" because they apply to the whole fnt (s/def ::fn|globals (s/kv {:fn|meta (s/nilable :quantum.core.specs/meta) + :fn|ns-name simple-symbol? :fn|name ::uss/fn|name :fn|type utr/fn-type? + :fn|types-decl-name simple-symbol? :fn|output-type|form t/any? :fn|output-type t/type?})) @@ -131,10 +133,12 @@ (s/kv {:form t/any? :name simple-symbol?})) +(s/def ::reify|name simple-symbol?) ; hinted with the interface name + (s/def ::reify (s/kv {:form t/any? :interface class? - :name simple-symbol? + :name ::reify|name :overload ::overload})) (s/def ::direct-dispatch-data @@ -145,9 +149,26 @@ (s/kv {:form t/any? :direct-dispatch-data-seq (s/vec-of ::direct-dispatch-data)})) -(s/def ::types-decl-datum (s/kv {:id index? :arg-types (s/vec-of t/type?) :output-type t/type?})) - -(s/def ::types-decl (s/kv {:form t/any? :name simple-symbol?})) +(s/def ::types-decl-datum + (s/kv {:id ::overload|id + :arg-types (s/vec-of t/type?) + :output-type t/type?})) + +(s/def ::indexed-types-decl-datum + (s/kv {:id ::overload|id + :arg-types (s/vec-of t/type?) + :output-type t/type? + :index index? ; overload-index (position in the overall types-decl) + :overload ::overload})) + +(s/def ::types-decl + (s/kv {:name simple-symbol? + :form t/any? + ;; Sorted by overload-index + :data (s/vec-of ::types-decl-datum) + ;; Sorted by overload-index + ;; 'Current' i.e. being created right now, not yet swapped into the types decl atom + :indexed-current-data (s/vec-of ::indexed-types-decl-datum)})) #_(:clj (c/defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] @@ -198,20 +219,23 @@ (defns- unanalyzed-overload>overload "Given an `::unanalyzed-overload`, performs type analysis on the body and computes a resulting `t/fn` overload, which is the foundation for one `reify`." - [{:keys [arg-bindings _, varargs-binding _, arg-types _, output-type|form _ + [{:as unanalyzed-overload + :keys [arg-bindings _, varargs-binding _, arg-types _, output-type|form _ body-codelist|pre-analyze _] declared-output-type [:output-type _]} ::unanalyzed-overload - {:as opts :keys [lang _]} ::opts + {:as opts :keys [lang _, kind _]} ::opts {:as fn|globals :keys [fn|name _, fn|type _, fn|output-type _]} ::fn|globals > ::overload] (let [;; Not sure if `nil` is the right approach for the value - recursive-ast-node-reference (uast/symbol {} fn|name nil fn|type) + recursive-ast-node-reference + (when-not (= kind :extend-defn!) (uast/symbol {} fn|name nil fn|type)) env (->> (zipmap arg-bindings arg-types) (uc/map' (c/fn [[arg-binding arg-type]] [arg-binding (uast/unbound nil arg-binding arg-type)])) ;; To support recursion - (<- (assoc fn|name recursive-ast-node-reference))) + (<- (cond-> (not= kind :extend-defn!) + (assoc fn|name recursive-ast-node-reference)))) arg-classes (->> arg-types (uc/map type>class)) body|pre-analyze|with-casts (->> arg-classes @@ -277,13 +301,20 @@ (map ufth/>interface-method-tag args-classes))] `(~'definterface ~interface-sym (~hinted-method-sym ~hinted-args)))) +(defns- >reify-name-unhinted + ([fn|name simple-symbol?, overload|id ::overload|id > simple-symbol?] + (symbol (str fn|name "|__" overload|id))) + ([fn|ns-name simple-symbol?, fn|name simple-symbol?, overload|id ::overload|id + > qualified-symbol?] + (symbol (name fn|ns-name) (str fn|name "|__" overload|id)))) + #?(:clj (defns overload>reify [{:as overload :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, output-class _]} ::overload {:as opts :keys [gen-gensym _]} ::opts {:keys [fn|name _]} ::fn|globals - i|overload index? + overload|id ::overload|id > ::reify] (let [arg-classes|reify (->> arg-classes (uc/map class>simplest-class)) output-class|reify (class>simplest-class output-class) @@ -301,97 +332,145 @@ (c/fn [i|arg arg|form] (ufth/with-type-hint arg|form (-> arg-classes|reify (uc/get i|arg) ufth/>arglist-embeddable-tag)))))) - reify-name (>symbol (str fn|name "|__" i|overload)) - form `(~'def ~reify-name + reify|name (-> (>reify-name-unhinted fn|name overload|id) + (ufth/with-type-hint (>name interface))) + form `(~'def ~reify|name (reify* [~(-> interface >name >symbol)] (~(ufth/with-type-hint reify-method-sym (ufth/>arglist-embeddable-tag output-class|reify)) ~arglist-code ~body-form)))] {:form form :interface interface - :name reify-name + :name reify|name :overload overload}))) ;; ----- Type declarations ----- ;; -(defns >types-decl|name [fn|globals ::fn|globals > simple-symbol?] - (symbol (str (:fn|name fn|globals) "|__types-decl"))) +(defns >types-decl-ref [{:keys [fn|ns-name _, fn|types-decl-name _]} ::fn|globals] + (var-get (resolve (symbol (name fn|ns-name) (name fn|types-decl-name))))) (c/defn types-decl>arg-types - [types-decl #_(atom-of (vec-of ...)), overload-id #_::overload|id #_> #_(objects-of type?)] - (apply uarr/*<> (:arg-types (get @types-decl overload-id)))) + [*types-decl #_(atom-of (vec-of ::types-decl-datum)), overload-index #_index? + #_> #_(objects-of type?)] + (apply uarr/*<> (:arg-types (get @*types-decl overload-index)))) (c/defn types-decl>ftype - [types-decl #_(atom-of (vec-of ...)), fn|output-type #_t/type? #_> #_(vec-of ...)] - (->> types-decl - deref + [*types-decl #_(atom-of (vec-of ::types-decl-datum)), fn|output-type #_t/type? #_> #_(vec-of ...)] + (->> @*types-decl (uc/lmap (c/fn [{:keys [arg-types pre-type output-type]}] (cond-> arg-types pre-type (conj :| pre-type) output-type (conj :> output-type)))) (apply t/ftype fn|output-type))) -(defns >types-decl - [{:as opts :keys [kind _]} ::opts, fn|globals ::fn|globals, overloads (s/seq-of ::overload) +(defns- >types-decl + [{:as opts :keys [kind _]} ::opts + {:as fn|globals :keys [fn|name _ fn|types-decl-name _]} ::fn|globals + overloads (s/vec-of ::overload) > ::types-decl] - (let [types-sym (>types-decl|name fn|globals) - types-decl-data + (let [types-decl-existing-data (when (= kind :extend-defn!) (deref (>types-decl-ref fn|globals))) + first-current-overload-id (if (= kind :extend-defn!) - (TODO) - (->> overloads + (count types-decl-existing-data) + 0) + types-decl-current-data ; i.e. being created right now, not swapped into the types decl atom + (->> overloads + (uc/map-indexed + (c/fn [i {:keys [arg-types output-type]}] + {:id (+ i first-current-overload-id) + :arg-types arg-types + :output-type output-type}))) + ;; We can't just concat the currently-being-created overloads' type-decl data with the + ;; existing type-decl data because we need to maintain the type-decl data's ordering by + ;; type-specificity so the dynamic dispatch works correctly. + types-decl-indexed-data + (when (= kind :extend-defn!) + (->> (ur/join types-decl-current-data types-decl-existing-data) + ;; So we can keep track of the original index + (uc/map-indexed + (c/fn [i {:as datum :keys [id]}] + (let [overload (get overloads (- id first-current-overload-id))] + (assoc datum :index i :overload overload)))) + ;; TODO here `extend-defn!` should: + ;; - Disallow creating another definition with the same input type combination + ;; - Use `assert-monotonically-increasing-types!` + (sort-by :arg-types compare-args-types))) + types-decl-indexed-current-data + (if (= kind :extend-defn!) + (->> types-decl-indexed-data + (c/filter (fn-> :id (>= first-current-overload-id)))) + (->> types-decl-current-data (uc/map-indexed - (c/fn [i {:keys [arg-types output-type]}] - (kw-map i arg-types output-type)))))] + (c/fn [i datum] (assoc datum :index i :overload (get overloads i)))))) + types-decl-data + (if (= kind :extend-defn!) + (->> types-decl-indexed-data (uc/map #(dissoc % :index :overload))) + types-decl-current-data)] (if (-> opts :compilation-mode (= :test)) - {:name types-sym + {:name fn|types-decl-name :form (if (= kind :extend-defn!) - `(reset! ~(symbol (>name *ns*) (>name types-sym)) ~(>form types-decl-data)) - `(def ~types-sym (atom ~(>form types-decl-data))))} + `(reset! ~(symbol (>name *ns*) (>name fn|types-decl-name)) + ~(>form types-decl-data)) + `(def ~fn|types-decl-name (atom ~(>form types-decl-data)))) + :data types-decl-data + :indexed-current-data types-decl-indexed-current-data} ;; In non-test cases, it's far cheaper to not have to convert the types to a ;; compiler-readable form and then re-evaluate them again (do (if (= kind :extend-defn!) - (reset! (var-get (ns-resolve *ns* types-sym)) types-decl-data) - (intern (>symbol *ns*) types-sym (atom types-decl-data))) - {:name types-sym :form nil})))) - -(defns >overload-types-decl + (reset! (>types-decl-ref fn|globals) types-decl-data) + (intern (>symbol *ns*) fn|types-decl-name (atom types-decl-data))) + {:name fn|types-decl-name + :form nil + :data types-decl-data + :indexed-current-data types-decl-indexed-current-data})))) + +(defns- >overload-types-decl|name + ([fn|name simple-symbol?, overload|id ::overload|id > simple-symbol?] + (symbol (str fn|name "|__" overload|id "|types"))) + ([fn|ns-name simple-symbol?, fn|name simple-symbol?, overload|id ::overload|id + > qualified-symbol?] + (symbol (name fn|ns-name) (str fn|name "|__" overload|id "|types")))) + +(defns- >overload-types-decl "The evaluated `form` of each overload-types-decl is an array of non-primitivized types that the dynamic dispatch uses to dispatch off input types." - [{:as fn|globals :keys [fn|name _]} ::fn|globals arg-types (s/vec-of t/type?) - i|overload ::overload|id > ::overload-types-decl] - (let [decl-name (>symbol (str fn|name "|__" i|overload "|types")) + [{:as fn|globals :keys [fn|name _, fn|types-decl-name _]} ::fn|globals + arg-types (s/vec-of t/type?), overload|id ::overload|id, overload-index index? + > ::overload-types-decl] + (let [decl-name (>overload-types-decl|name fn|name overload|id) form `(def ~(ufth/with-type-hint decl-name "[Ljava.lang.Object;") - (types-decl>arg-types ~(>types-decl|name fn|globals) ~i|overload))] + (types-decl>arg-types ~fn|types-decl-name ~overload-index))] {:form form :name decl-name})) ;; ----- Direct dispatch: putting it all together ----- ;; (defns >direct-dispatch - [{:as opts :keys [gen-gensym _, lang _]} ::opts + [{:as opts :keys [gen-gensym _, lang _, kind _]} ::opts {:as fn|globals :keys [fn|name _]} ::fn|globals overloads (s/vec-of ::overload) - > ::direct-dispatch] + types-decl ::types-decl > ::direct-dispatch] (case lang :clj (let [direct-dispatch-data-seq - (->> overloads - (uc/map-indexed - (c/fn [i|overload {:as overload :keys [arg-types]}] + (->> types-decl + :indexed-current-data + (uc/map + (c/fn [{:as indexed-type-decl-datum :keys [arg-types id index overload]}] {:overload-types-decl - (>overload-types-decl fn|globals arg-types i|overload) - :reify (overload>reify overload opts fn|globals i|overload)}))) + (>overload-types-decl fn|globals arg-types id index) + :reify (overload>reify overload opts fn|globals id)}))) form (->> direct-dispatch-data-seq (uc/mapcat (c/fn [{:as direct-dispatch-data :keys [overload-types-decl]}] - (list (:form overload-types-decl) - (-> direct-dispatch-data :reify :form)))))] + [(:form overload-types-decl) + (-> direct-dispatch-data :reify :form)])))] (kw-map form direct-dispatch-data-seq)) :cljs (TODO))) ;; ===== Dynamic dispatch ===== ;; -(defns- >dynamic-dispatch|reify-call [reify- ::reify, arglist (s/vec-of simple-symbol?)] - (let [hinted-reify-sym (-> reify- :name (ufth/with-type-hint (-> reify- :interface >name)))] - `(. ~hinted-reify-sym ~reify-method-sym ~@arglist))) +(defns- >dynamic-dispatch|reify-call + [reify|name|qualified qualified-symbol?, arglist (s/vec-of simple-symbol?)] + `(. ~reify|name|qualified ~reify-method-sym ~@arglist)) ;; TODO spec (defns unsupported! [name- _ #_t/qualified-symbol?, args _ #_indexed?, i index?] @@ -399,34 +478,38 @@ {:name name- :args args :arg-index i}))) (defns- >combinatoric-seq+ - [direct-dispatch-data-seq-for-arity (s/seq-of ::direct-dispatch-data) - arglist (s/vec-of simple-symbol?)] - (->> direct-dispatch-data-seq-for-arity - (uc/map+ (c/fn [{reify- :reify :keys [overload-types-decl]}] - [(>dynamic-dispatch|reify-call reify- arglist) - (->> reify- - :overload - :arg-types - (uc/map-indexed - (c/fn [i|arg arg-type] - {:i i|arg - :t arg-type - :getf `((Array/get ~(:name overload-types-decl) ~i|arg) - ~(get arglist i|arg))})))])))) + [{:as fn|globals :keys [fn|ns-name _ fn|name _]} ::fn|globals + types-decl-data-for-arity (s/vec-of ::types-decl-datum), arglist (s/vec-of simple-symbol?)] + (->> types-decl-data-for-arity + (uc/map+ + (c/fn [{:as types-decl-datum :keys [arg-types]}] + (let [overload|id (:id types-decl-datum) + overload-types-decl|name (>overload-types-decl|name fn|ns-name fn|name overload|id) + reify|name|qualified (>reify-name-unhinted fn|ns-name fn|name overload|id)] + [(>dynamic-dispatch|reify-call reify|name|qualified arglist) + (->> arg-types + (uc/map-indexed + (c/fn [i|arg arg-type] + {:i i|arg + :t arg-type + :getf `((Array/get ~overload-types-decl|name ~i|arg) + ~(get arglist i|arg))})))]))))) (defns- >dynamic-dispatch|body-for-arity - "Assumes the elements of `direct-dispatch-data-seq-for-arity` are ordered in increasing - generality of the input types of their respective `reify` declarations." - [fn|name ::uss/fn|name, arglist (s/vec-of simple-symbol?) - direct-dispatch-data-seq-for-arity (s/seq-of ::direct-dispatch-data)] + [{:as fn|globals :keys [fn|ns-name _, fn|name _]} ::fn|globals + arglist (s/vec-of simple-symbol?) + types-decl-data-for-arity (s/vec-of ::types-decl-datum)] (if (empty? arglist) - (>dynamic-dispatch|reify-call (-> direct-dispatch-data-seq-for-arity first :reify) arglist) + (let [overload|id (-> types-decl-data-for-arity first :id)] + (>dynamic-dispatch|reify-call + (>reify-name-unhinted fn|ns-name fn|name overload|id) arglist)) (let [*i|arg (atom 0) combinef (c/fn ([] (transient [`ifs])) ([ret] - (-> ret (conj! `(unsupported! '~(uid/qualify fn|name) ~arglist ~(deref *i|arg))) + (-> ret (conj! `(unsupported! '~(symbol (name fn|ns-name) (name fn|name)) + ~arglist ~(deref *i|arg))) persistent! seq)) ([ret getf x i] @@ -437,25 +520,32 @@ (aritoid combinef combinef (c/fn [x [{:keys [getf i]} group]] (combinef x getf group i))) uc/conj!|rf (aritoid combinef combinef (c/fn [x [k [{:keys [getf i]}]]] (combinef x getf k i))) - (>combinatoric-seq+ direct-dispatch-data-seq-for-arity arglist))))) + (>combinatoric-seq+ fn|globals types-decl-data-for-arity arglist))))) (defns- >dynamic-dispatch-fn|form - [{:as opts :keys [gen-gensym _, lang _]} ::opts - {:as fn|globals :keys [fn|meta _, fn|name _, fn|output-type _]} ::fn|globals - types-decl ::types-decl - direct-dispatch ::direct-dispatch] - `(c/defn ~fn|name - ~(assoc fn|meta :quantum.core.type/type - `(self/types-decl>ftype ~(:name types-decl) ~fn|output-type)) - ~@(->> direct-dispatch - :direct-dispatch-data-seq - (group-by (fn-> :reify :overload :arg-types count)) - (sort-by key) ; for purposes of reproducibility and organization - (map (c/fn [[arg-ct direct-dispatch-data-seq-for-arity]] - (let [arglist (ufgen/gen-args 0 arg-ct "x" gen-gensym) - body (>dynamic-dispatch|body-for-arity - fn|name arglist direct-dispatch-data-seq-for-arity)] - (list arglist body))))))) + [{:as opts :keys [gen-gensym _, lang _, kind _]} ::opts + {:as fn|globals :keys [fn|meta _, fn|ns-name _, fn|name _, fn|output-type _ + fn|types-decl-name _]} ::fn|globals + types-decl ::types-decl] + (let [overload-forms + (->> types-decl + :data + (group-by (fn-> :arg-types count)) + (sort-by key) ; for purposes of reproducibility and organization + (map (c/fn [[arg-ct types-decl-data-for-arity]] + (let [arglist (ufgen/gen-args 0 arg-ct "x" gen-gensym) + body (>dynamic-dispatch|body-for-arity + fn|globals arglist types-decl-data-for-arity)] + (list arglist body))))) + ftype-form `(self/types-decl>ftype ~fn|types-decl-name ~fn|output-type)] + (if (= kind :extend-defn!) + `(intern (quote ~fn|ns-name) + (with-meta (quote ~fn|name) + ;; TODO determine whether CLJS needs (update-in m [:jsdoc] conj "@param {...*} var_args") + (assoc (meta (var ~(symbol (>name fn|ns-name) (>name fn|name)))) + :quantum.core.type/type ~ftype-form)) + (fn* ~@overload-forms)) + `(c/defn ~fn|name ~(assoc fn|meta :quantum.core.type/type ftype-form) ~@overload-forms)))) ;; ===== End dynamic dispatch ===== ;; @@ -485,7 +575,6 @@ ct-comparison))) ;; TODO spec -;; TODO use!! (c/defn assert-monotonically-increasing-types! "Asserts that each type in an overload of the same arity and arg-position are in monotonically increasing order in terms of `t/compare`. @@ -520,6 +609,7 @@ pre-type|form [:pre _] [_ _, output-type|form _] [:post _]} [:arglist _] body-codelist|pre-analyze [:body _]} _ + kind ::kind fn|output-type|form _ ; TODO excise this var when we default `output-type|form` to `?` fn|output-type t/type? > (s/seq-of ::unanalyzed-overload)] @@ -545,7 +635,7 @@ ;; TODO this assertion is purely temporary until destructuring is ;; supported (assert (-> varargs :binding-form first (= :sym)))) - arg-types|expanded-seq ; split, primitivized, and sorted + arg-types|expanded-seq ; split, primitivized, and (if not `extend-defn!`) sorted (->> (uana/analyze-arg-syms {} (zipmap arg-bindings arg-types|form) output-type|form) (uc/map (c/fn [{:keys [env out-type-node]}] (let [output-type (:type out-type-node) @@ -559,9 +649,9 @@ "overall declared output type") (kw-map output-type fn|output-type))) (kw-map arg-types output-type)))) - (sort-by :arg-types compare-args-types) + ;; Not performed with `extend-defn!` because sorting happens later, in `>types-decl` + (<- (cond->> (not= kind :extend-defn!) (sort-by :arg-types compare-args-types))) vec)] - (uana/pr! arg-types|expanded-seq) ; TODO excise (->> arg-types|expanded-seq (uc/map (c/fn [{:keys [arg-types output-type]}] (kw-map arg-bindings varargs-binding @@ -571,17 +661,22 @@ (defns- overloads-bases>unanalyzed-overloads [overloads-bases _ #_:quantum.core.defnt/overloads + kind ::kind fn|output-type|form _ ; TODO excise this var when we default `output-type|form` to `?` fn|output-type t/type? > (s/seq-of ::unanalyzed-overload)] (->> overloads-bases - (uc/map+ #(overloads-basis>unanalyzed-overload-seq % fn|output-type|form fn|output-type)) + (uc/map+ + #(overloads-basis>unanalyzed-overload-seq % kind fn|output-type|form fn|output-type)) (educei (c/fn ([] []) ([ret] ret) ([ret unanalyzed-overload-seq i|overload-basis] - (assert-monotonically-increasing-types! ret unanalyzed-overload-seq i|overload-basis) + (when-not (= kind :extend-defn!) + ;; Because this assertion is performed later on in `>types-decl` + (assert-monotonically-increasing-types! + ret unanalyzed-overload-seq i|overload-basis)) (ur/join ret unanalyzed-overload-seq)))))) (defns fn|code [kind ::kind, lang ::lang, compilation-mode ::compilation-mode, args _] @@ -594,38 +689,50 @@ (s/validate args (case kind :defn :quantum.core.defnt/defnt :fn :quantum.core.defnt/fnt :extend-defn! :quantum.core.defnt/extend-defn!)) + fn|ns-name (if (= kind :extend-defn!) + (-> (uvar/resolve *ns* fn|extended-name) >?namespace symbol) + (>symbol *ns*)) + fn|name (if (= kind :extend-defn!) + (-> fn|extended-name >name symbol) + fn|name) gen-gensym-base (ufgen/>reproducible-gensym|generator) gen-gensym (c/fn [x] (symbol (str (gen-gensym-base x) "__"))) opts (kw-map compilation-mode gen-gensym kind lang) - inline? (s/validate (:inline fn|meta) (t/? t/boolean?)) + inline? (-> (if (= kind :extend-defn!) + (-> (uvar/resolve *ns* fn|extended-name) meta :inline) + (:inline fn|meta)) + (s/validate (t/? t/boolean?))) fn|meta (if inline? - (do (ulog/pr :warn "requested `:inline`; ignoring until feature is" - "implemented") + (do (ulog/pr :warn + "requested `:inline`; ignoring until feature is implemented") (dissoc fn|meta :inline)) fn|meta) fn|output-type|form (or (second output-spec) `t/any?) - ;; TODO this needs to be analyzed for dependent types referring tp local vars + ;; TODO this needs to be analyzed for dependent types referring to local vars fn|output-type (eval fn|output-type|form) unanalyzed-overloads (overloads-bases>unanalyzed-overloads - overloads-bases fn|output-type|form fn|output-type) + overloads-bases kind fn|output-type|form fn|output-type) fn|type (unanalyzed-overloads>fn|type unanalyzed-overloads fn|output-type) - fn|globals (kw-map fn|name fn|meta fn|type fn|output-type|form fn|output-type) + fn|types-decl-name (symbol (str fn|name "|__types-decl")) + fn|globals (kw-map fn|ns-name fn|name fn|meta fn|type fn|output-type|form + fn|output-type fn|types-decl-name) ;; Specifically overloads that were generated during this execution of this function overloads (->> unanalyzed-overloads (uc/map #(unanalyzed-overload>overload % opts fn|globals))) - direct-dispatch (>direct-dispatch opts fn|globals overloads) types-decl (>types-decl opts fn|globals overloads) + direct-dispatch (>direct-dispatch opts fn|globals overloads types-decl) + dynamic-dispatch (>dynamic-dispatch-fn|form opts fn|globals types-decl) fn-codelist (case lang :clj (->> `[(declare ~fn|name) ; for recursion ~@(some-> (:form types-decl) vector) ~@(:form direct-dispatch) - ~(>dynamic-dispatch-fn|form opts fn|globals types-decl direct-dispatch)] + ~dynamic-dispatch] (remove nil?)) :cljs (TODO)) code (case kind - :fn (TODO) - :defn `(~'do ~@fn-codelist))] + :fn (TODO) + (:defn :extend-defn!) `(~'do ~@fn-codelist))] code)) #?(:clj @@ -656,9 +763,15 @@ - When a typed function (or a typed object with function-like characteristics such as a `t/deftype`) is referenced outside of a typed context. - Metadata directives special to `t/fn` include: - - `:inline` : Applicable within the metadata of `t/fn` or `t/defn`. A directive to inline the - function if possible. + Metadata directives special to `t/fn`/`t/defn` include: + - `:inline` : If `true` and attached as metadata to the arglist of an overload, will cause that + overload to be inlined if possible. + - Example: `(t/defn abc (^:inline [] ...))` + If `true` and attached as metadata to the whole `t/defn` or `t/fn`, will cause + every one of its overloads to be inlined if possible. Overloads added to a `t/defn` + with `:inline` `true` will inherit this inline directive. + - Example: `(t/defn ^:inline abc ([] ...) ([...] ...))` + Note that inlining is possible only in typed contexts. `fnt` only works in languages in which the metalanguage (compiler language) is the same as the object language. As such, for CLJS, we choose to use only a CLJS-in-CLJS / bootstrapped compiler diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index c2407dd0..37388b70 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -20,6 +20,7 @@ [quantum.core.vars :as var])) #_" +- TODO be informed by https://www.researchgate.net/publication/313820944_Empirical_Study_of_Usage_and_Performance_of_Java_Collections - TODO incorporate FastUtil - FastUtil is the fastest collections library according to http://java-performance.info/hashmap-overview-jdk-fastutil-goldman-sachs-hppc-koloboke-trove-january-2015/ - TODO notify of changes to: diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index ac251caf..e041d470 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1793,9 +1793,9 @@ ;; ===== `extend-defn!` tests ===== ;; (binding [self/*compilation-mode* :test] - (macroexpand - '(self/defn extensible - ([a t/double?])))) + (macroexpand ' + (self/defn extensible + ([a t/double?])))) ;; Code (do (declare ~'extensible) @@ -1820,16 +1820,18 @@ (unsupported! `extensible [~'x00__] 0))))) (testing "Insertion" - (self/extend-defn! extensible - ([a t/boolean?])) + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/extend-defn! extensible + ([a t/boolean?])))) (do ;; We only show this types decl because testing/debug is on. Otherwise the macro would just - ;; `swap!` the types decl outside the code rather than re-evaluating the types. + ;; `reset!` the types decl outside the code rather than re-evaluating the types. ;; To find where to put the overload, we find the first place where the inputs are `t/<`. ;; TODO test that when testing/debug mode is off, it doesn't emit this code (reset! quantum.test.untyped.core.type.defnt/extensible|__types-decl - [{:id 1 :arg-types [(t/isa? Boolean)] :output-type t/any?} - {:id 0 :arg-types [(t/isa? Double)] :output-type t/any?}]) + [{:name ~(tag ... 'extensible|__1) :arg-types [(t/isa? Boolean)] :output-type t/any?} + {:name ~(tag ... 'extensible|__0) :arg-types [(t/isa? Double)] :output-type t/any?}]) ;; It's labeled as `extensible|__1` but internally that's not how it's ordered; it's just ;; incrementing based on the size of the types-decl @@ -1841,7 +1843,8 @@ ;; We expect that `t/defn` extension will take place in only one thread (intern 'quantum.test.untyped.core.type.defnt (with-meta 'extensible - {:quantum.core.type/type (self/types-decl>ftype extensible|__types-decl t/any?)}) + (assoc (meta (var quantum.test.untyped.core.type.defnt/extensible)) + :quantum.core.type/type (self/types-decl>ftype extensible|__types-decl t/any?))) (fn* ([~'x00__] (ifs ((Array/get ~'extensible|__1|types 0) ~'x00__) (. extensible|__1 invoke x00__) From 52dc49cade95cfa9155e26904684a6d50ef2719a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 13 Oct 2018 07:48:29 -0600 Subject: [PATCH 502/810] More tests pass! --- resources-dev/defnt.cljc | 17 +- .../quantum/untyped/core/identifiers.cljc | 6 +- .../quantum/untyped/core/type/defnt.cljc | 23 +- src/quantum/core/data/identifiers.cljc | 5 +- src/quantum/core/type.cljc | 3 +- .../quantum/test/untyped/core/type/defnt.cljc | 200 ++++++++++-------- 6 files changed, 136 insertions(+), 118 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 2135464f..b85685ba 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -59,15 +59,14 @@ TODO: Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - [1] - t/extend-defn! - - We just recreate the dispatch every time, in the beginning. It makes for slower - compilation (?) but faster execution for dynamic dispatch, and quicker time to first use. - - But then you have to trigger a recompilation of everything that depended on that `t/defn` - because your input-types and output-types have both gotten bigger. Maybe not on that overload - but still. - - This will be a more advanced feature. For now we just accept that we might have some odd behavior around extending `t/defn`s. - - It should disallow creating another definition with the same input type combination. - - `assert-monotonically-increasing-types!` needs to be enforced + - t/extend-defn! + [ ] Should we trigger a recompilation of everything that depended on that `t/defn` because the + input-types and output-types will have both gotten bigger? (Maybe not on that overload but + still.) + - This will be a more advanced feature. For now we just accept that we might have some odd + behavior around extending `t/defn`s. + [1a] It should disallow creating another definition with the same input type combination. + [1b] `assert-monotonically-increasing-types!` needs to be enforced [2] - t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. - t/numerically-integer? diff --git a/src-untyped/quantum/untyped/core/identifiers.cljc b/src-untyped/quantum/untyped/core/identifiers.cljc index a5d392ec..ea6a11f3 100644 --- a/src-untyped/quantum/untyped/core/identifiers.cljc +++ b/src-untyped/quantum/untyped/core/identifiers.cljc @@ -68,7 +68,11 @@ (defn qualify #?(:clj ([sym] (qualify *ns* sym))) - ([?ns sym] (symbol (?ns->name ?ns) (name sym)))) + ([ns-or-sym sym] + (let [qualifier (cond (symbol? ns-or-sym) (-> ns-or-sym name) + (namespace? ns-or-sym) (-> ns-or-sym ns-name name) + :else (uerr/not-supported! `qualify ns-or-sym))] + (symbol qualifier (name sym))))) (defn qualify|dot [sym ns-] (symbol (str (?ns->name ns-) "." (name sym)))) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 66b7f9c9..a529a09f 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -240,7 +240,7 @@ body|pre-analyze|with-casts (->> arg-classes (reducei (c/fn [body ^Class c i|arg] - (if (.isPrimitive c) + (if (or (.isPrimitive c) (= c java.lang.Object)) body (let [arg-sym (get arg-bindings i|arg)] `(let* [~(ufth/with-type-hint arg-sym (.getName c)) ~arg-sym] @@ -347,7 +347,7 @@ ;; ----- Type declarations ----- ;; (defns >types-decl-ref [{:keys [fn|ns-name _, fn|types-decl-name _]} ::fn|globals] - (var-get (resolve (symbol (name fn|ns-name) (name fn|types-decl-name))))) + (var-get (resolve (uid/qualify fn|ns-name fn|types-decl-name)))) (c/defn types-decl>arg-types [*types-decl #_(atom-of (vec-of ::types-decl-datum)), overload-index #_index? @@ -365,7 +365,7 @@ (defns- >types-decl [{:as opts :keys [kind _]} ::opts - {:as fn|globals :keys [fn|name _ fn|types-decl-name _]} ::fn|globals + {:as fn|globals :keys [fn|ns-name _, fn|name _ fn|types-decl-name _]} ::fn|globals overloads (s/vec-of ::overload) > ::types-decl] (let [types-decl-existing-data (when (= kind :extend-defn!) (deref (>types-decl-ref fn|globals))) @@ -409,8 +409,7 @@ (if (-> opts :compilation-mode (= :test)) {:name fn|types-decl-name :form (if (= kind :extend-defn!) - `(reset! ~(symbol (>name *ns*) (>name fn|types-decl-name)) - ~(>form types-decl-data)) + `(reset! ~(uid/qualify fn|ns-name fn|types-decl-name) ~(>form types-decl-data)) `(def ~fn|types-decl-name (atom ~(>form types-decl-data)))) :data types-decl-data :indexed-current-data types-decl-indexed-current-data} @@ -434,12 +433,13 @@ (defns- >overload-types-decl "The evaluated `form` of each overload-types-decl is an array of non-primitivized types that the dynamic dispatch uses to dispatch off input types." - [{:as fn|globals :keys [fn|name _, fn|types-decl-name _]} ::fn|globals + [{:as fn|globals :keys [fn|ns-name _, fn|name _, fn|types-decl-name _]} ::fn|globals arg-types (s/vec-of t/type?), overload|id ::overload|id, overload-index index? > ::overload-types-decl] (let [decl-name (>overload-types-decl|name fn|name overload|id) form `(def ~(ufth/with-type-hint decl-name "[Ljava.lang.Object;") - (types-decl>arg-types ~fn|types-decl-name ~overload-index))] + (types-decl>arg-types + ~(uid/qualify fn|ns-name fn|types-decl-name) ~overload-index))] {:form form :name decl-name})) ;; ----- Direct dispatch: putting it all together ----- ;; @@ -508,7 +508,7 @@ (c/fn ([] (transient [`ifs])) ([ret] - (-> ret (conj! `(unsupported! '~(symbol (name fn|ns-name) (name fn|name)) + (-> ret (conj! `(unsupported! '~(uid/qualify fn|ns-name fn|name) ~arglist ~(deref *i|arg))) persistent! seq)) @@ -537,12 +537,13 @@ body (>dynamic-dispatch|body-for-arity fn|globals arglist types-decl-data-for-arity)] (list arglist body))))) - ftype-form `(self/types-decl>ftype ~fn|types-decl-name ~fn|output-type)] + ftype-form `(types-decl>ftype ~(uid/qualify fn|ns-name fn|types-decl-name) + ~(>form fn|output-type))] (if (= kind :extend-defn!) `(intern (quote ~fn|ns-name) (with-meta (quote ~fn|name) ;; TODO determine whether CLJS needs (update-in m [:jsdoc] conj "@param {...*} var_args") - (assoc (meta (var ~(symbol (>name fn|ns-name) (>name fn|name)))) + (assoc (meta (var ~(uid/qualify fn|ns-name fn|name))) :quantum.core.type/type ~ftype-form)) (fn* ~@overload-forms)) `(c/defn ~fn|name ~(assoc fn|meta :quantum.core.type/type ftype-form) ~@overload-forms)))) @@ -713,7 +714,7 @@ unanalyzed-overloads (overloads-bases>unanalyzed-overloads overloads-bases kind fn|output-type|form fn|output-type) fn|type (unanalyzed-overloads>fn|type unanalyzed-overloads fn|output-type) - fn|types-decl-name (symbol (str fn|name "|__types-decl")) + fn|types-decl-name (symbol (str fn|name "|__types")) fn|globals (kw-map fn|ns-name fn|name fn|meta fn|type fn|output-type|form fn|output-type fn|types-decl-name) ;; Specifically overloads that were generated during this execution of this function diff --git a/src/quantum/core/data/identifiers.cljc b/src/quantum/core/data/identifiers.cljc index f7f9719f..8e497e94 100644 --- a/src/quantum/core/data/identifiers.cljc +++ b/src/quantum/core/data/identifiers.cljc @@ -60,8 +60,9 @@ ;; ===== Qualification ===== ;; (t/defn qualify > symbol? - #?(:clj ([sym symbol?] (qualify *ns* sym))) - ([?ns (t/? ??/namespace?) sym symbol?] (>symbol (?ns>name ?ns) (>name sym)))) +#?(:clj ([sym symbol?] (qualify *ns* sym))) + ([ns-sym symbol? sym symbol?] (>symbol (>name ns-sym) (>name sym))) +#?(:clj ([ns-val ??/namespace? sym symbol?] (>symbol (>name ns-val) (>name sym))))) (t/defn qualify|dot > symbol? [sym symbol? ns-val ??/namespace?] (>symbol (>str (?ns>name ns-val) "." (>name sym)))) diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index c54d2875..4bd8d723 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -9,8 +9,7 @@ [quantum.untyped.core.vars :refer [defalias defaliases]])) -(defalias udefnt/fnt) ; TODO TYPED rename -(defalias udefnt/defn) +(defaliases udefnt fn defn extend-defn!) (defaliases ut type diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index e041d470..ab510714 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -5,7 +5,7 @@ [clojure.core :as core] [quantum.test.untyped.core.type :as tt] [quantum.untyped.core.type.defnt :as self - :refer [fnt unsupported!]] + :refer [types-decl>arg-types types-decl>ftype unsupported!]] [quantum.untyped.core.data.array :refer [*<>]] [quantum.untyped.core.form @@ -52,24 +52,26 @@ #?(:clj (deftest test|pid (let [actual - (macroexpand ' - (self/defn pid|test [> (? t/string?)] - (->> ^:val (java.lang.management.ManagementFactory/getRuntimeMXBean) - (.getName)))) + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/defn pid|test [> (? t/string?)] + (->> ^:val (java.lang.management.ManagementFactory/getRuntimeMXBean) + (.getName))))) expected - ($ (do (declare ~'pid|test) - (def ~(O<> 'pid|test|__0|types) (quantum.untyped.core.data.array/*<>)) - (def ~'pid|test|__0 - (reify* [>Object] - (~(O 'invoke) [~'_0__] - ~(ST (list '. - (tag "java.lang.management.RuntimeMXBean" - '(. java.lang.management.ManagementFactory getRuntimeMXBean)) - 'getName))))) - (defn ~'pid|test - {:quantum.core.type/type - (t/ftype t/any? [:> (t/or (t/value nil) (t/isa? String))])} - ([] (. ~(tag (cstr `>Object) 'pid|test|__0) ~'invoke)))))] + ($ (do (declare ~'pid|test) + (def ~'pid|test|__types + (atom [{:id 0 :arg-types [] :output-type (t/or (t/value nil) (t/isa? String))}])) + (def ~(O<> 'pid|test|__0|types) (types-decl>arg-types pid|test|__types 0)) + (def ~(tag (cstr `>Object) 'pid|test|__0) + (reify* [>Object] + (~(O 'invoke) [~'_0__] + ~(ST (list '. + (tag "java.lang.management.RuntimeMXBean" + '(. java.lang.management.ManagementFactory getRuntimeMXBean)) + 'getName))))) + (defn ~'pid|test + {:quantum.core.type/type (types-decl>ftype pid|test|__types t/any?)} + ([] (. pid|test|__0 ~'invoke)))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) @@ -80,79 +82,91 @@ (deftest test|identity|uninlined (let [actual - (macroexpand ' - (self/defn identity|uninlined ([x t/any? > (t/type x)] x))) + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/defn identity|uninlined ([x t/any? > (t/type x)] x)))) expected (case (env-lang) :clj - ($ (do (declare ~'identity|uninlined) - - ;; [x t/any?] - - (def ~(O<> 'identity|uninlined|__0|types) (*<> (t/isa? Boolean))) - (def ~'identity|uninlined|__0 - (reify* [boolean>boolean] (~(B 'invoke) [~'_0__ ~(B 'x)] ~'x))) - (def ~(O<> 'identity|uninlined|__1|types) (*<> (t/isa? Byte))) - (def ~'identity|uninlined|__1 - (reify* [byte>byte] (~(Y 'invoke) [~'_1__ ~(Y 'x)] ~'x))) - (def ~(O<> 'identity|uninlined|__2|types) (*<> (t/isa? Short))) - (def ~'identity|uninlined|__2 - (reify* [short>short] (~(S 'invoke) [~'_2__ ~(S 'x)] ~'x))) - (def ~(O<> 'identity|uninlined|__3|types) (*<> (t/isa? Character))) - (def ~'identity|uninlined|__3 - (reify* [char>char] (~(C 'invoke) [~'_3__ ~(C 'x)] ~'x))) - (def ~(O<> 'identity|uninlined|__4|types) (*<> (t/isa? Integer))) - (def ~'identity|uninlined|__4 - (reify* [int>int] (~(I 'invoke) [~'_4__ ~(I 'x)] ~'x))) - (def ~(O<> 'identity|uninlined|__5|types) (*<> (t/isa? Long))) - (def ~'identity|uninlined|__5 - (reify* [long>long] (~(L 'invoke) [~'_5__ ~(L 'x)] ~'x))) - (def ~(O<> 'identity|uninlined|__6|types) (*<> (t/isa? Float))) - (def ~'identity|uninlined|__6 - (reify* [float>float] (~(F 'invoke) [~'_6__ ~(F 'x)] ~'x))) - (def ~(O<> 'identity|uninlined|__7|types) (*<> (t/isa? Double))) - (def ~'identity|uninlined|__7 - (reify* [double>double] (~(D 'invoke) [~'_7__ ~(D 'x)] ~'x))) - (def ~(O<> 'identity|uninlined|__8|types) (*<> t/any?)) - (def ~'identity|uninlined|__8 - (reify* [Object>Object] (~(O 'invoke) [~'_8__ ~(O 'x)] ~(O 'x)))) - - (defn ~'identity|uninlined - {:quantum.core.type/type - (t/ftype t/any? [(t/isa? Boolean) :> (t/isa? Boolean)] - [(t/isa? Byte) :> (t/isa? Byte)] - [(t/isa? Short) :> (t/isa? Short)] - [(t/isa? Character) :> (t/isa? Character)] - [(t/isa? Integer) :> (t/isa? Integer)] - [(t/isa? Long) :> (t/isa? Long)] - [(t/isa? Float) :> (t/isa? Float)] - [(t/isa? Double) :> (t/isa? Double)] - [t/any? :> t/any?])} - ([~'x00__] - (ifs - ((Array/get ~'identity|uninlined|__0|types 0) ~'x00__) - (. ~(tag (cstr `boolean>boolean) 'identity|uninlined|__0) ~'invoke ~'x00__) - ((Array/get ~'identity|uninlined|__1|types 0) ~'x00__) - (. ~(tag (cstr `byte>byte) 'identity|uninlined|__1) ~'invoke ~'x00__) - ((Array/get ~'identity|uninlined|__2|types 0) ~'x00__) - (. ~(tag (cstr `short>short) 'identity|uninlined|__2) ~'invoke ~'x00__) - ((Array/get ~'identity|uninlined|__3|types 0) ~'x00__) - (. ~(tag (cstr `char>char) 'identity|uninlined|__3) ~'invoke ~'x00__) - ((Array/get ~'identity|uninlined|__4|types 0) ~'x00__) - (. ~(tag (cstr `int>int) 'identity|uninlined|__4) ~'invoke ~'x00__) - ((Array/get ~'identity|uninlined|__5|types 0) ~'x00__) - (. ~(tag (cstr `long>long) 'identity|uninlined|__5) ~'invoke ~'x00__) - ((Array/get ~'identity|uninlined|__6|types 0) ~'x00__) - (. ~(tag (cstr `float>float) 'identity|uninlined|__6) ~'invoke ~'x00__) - ((Array/get ~'identity|uninlined|__7|types 0) ~'x00__) - (. ~(tag (cstr `double>double) 'identity|uninlined|__7) ~'invoke ~'x00__) - ((Array/get ~'identity|uninlined|__8|types 0) ~'x00__) - (. ~(tag (cstr `Object>Object) 'identity|uninlined|__8) ~'invoke ~'x00__) - ;; TODO no need for `unsupported!` because it will always get a valid branch - (unsupported! `identity|uninlined [~'x00__] 0)))))) + ($ (do (declare ~'identity|uninlined) + (def ~'identity|uninlined|__types + (atom [{:id 0 :arg-types [(t/isa? Boolean)] :output-type (t/isa? Boolean)} + {:id 1 :arg-types [(t/isa? Byte)] :output-type (t/isa? Byte)} + {:id 2 :arg-types [(t/isa? Short)] :output-type (t/isa? Short)} + {:id 3 :arg-types [(t/isa? Character)] :output-type (t/isa? Character)} + {:id 4 :arg-types [(t/isa? Integer)] :output-type (t/isa? Integer)} + {:id 5 :arg-types [(t/isa? Long)] :output-type (t/isa? Long)} + {:id 6 :arg-types [(t/isa? Float)] :output-type (t/isa? Float)} + {:id 7 :arg-types [(t/isa? Double)] :output-type (t/isa? Double)} + {:id 8 :arg-types [t/any?] :output-type t/any?}])) + + ;; [x t/any?] + + (def ~(O<> 'identity|uninlined|__0|types) + (types-decl>arg-types identity|uninlined|__types 0)) + (def ~(tag (cstr `boolean>boolean) 'identity|uninlined|__0) + (reify* [boolean>boolean] (~(B 'invoke) [~'_0__ ~(B 'x)] ~'x))) + (def ~(O<> 'identity|uninlined|__1|types) + (types-decl>arg-types identity|uninlined|__types 1)) + (def ~(tag (cstr `byte>byte) 'identity|uninlined|__1) + (reify* [byte>byte] (~(Y 'invoke) [~'_1__ ~(Y 'x)] ~'x))) + (def ~(O<> 'identity|uninlined|__2|types) + (types-decl>arg-types identity|uninlined|__types 2)) + (def ~(tag (cstr `short>short) 'identity|uninlined|__2) + (reify* [short>short] (~(S 'invoke) [~'_2__ ~(S 'x)] ~'x))) + (def ~(O<> 'identity|uninlined|__3|types) + (types-decl>arg-types identity|uninlined|__types 3)) + (def ~(tag (cstr `char>char) 'identity|uninlined|__3) + (reify* [char>char] (~(C 'invoke) [~'_3__ ~(C 'x)] ~'x))) + (def ~(O<> 'identity|uninlined|__4|types) + (types-decl>arg-types identity|uninlined|__types 4)) + (def ~(tag (cstr `int>int) 'identity|uninlined|__4) + (reify* [int>int] (~(I 'invoke) [~'_4__ ~(I 'x)] ~'x))) + (def ~(O<> 'identity|uninlined|__5|types) + (types-decl>arg-types identity|uninlined|__types 5)) + (def ~(tag (cstr `long>long) 'identity|uninlined|__5) + (reify* [long>long] (~(L 'invoke) [~'_5__ ~(L 'x)] ~'x))) + (def ~(O<> 'identity|uninlined|__6|types) + (types-decl>arg-types identity|uninlined|__types 6)) + (def ~(tag (cstr `float>float) 'identity|uninlined|__6) + (reify* [float>float] (~(F 'invoke) [~'_6__ ~(F 'x)] ~'x))) + (def ~(O<> 'identity|uninlined|__7|types) + (types-decl>arg-types identity|uninlined|__types 7)) + (def ~(tag (cstr `double>double) 'identity|uninlined|__7) + (reify* [double>double] (~(D 'invoke) [~'_7__ ~(D 'x)] ~'x))) + (def ~(O<> 'identity|uninlined|__8|types) + (types-decl>arg-types identity|uninlined|__types 8)) + (def ~(tag (cstr `Object>Object) 'identity|uninlined|__8) + (reify* [Object>Object] (~(O 'invoke) [~'_8__ ~(O 'x)] ~(O 'x)))) + + (defn ~'identity|uninlined + {:quantum.core.type/type + (self/types-decl>ftype identity|uninlined|__types t/any?)} + ([~'x00__] + (ifs + ((Array/get identity|uninlined|__0|types 0) ~'x00__) + (. identity|uninlined|__0 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__1|types 0) ~'x00__) + (. identity|uninlined|__1 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__2|types 0) ~'x00__) + (. identity|uninlined|__2 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__3|types 0) ~'x00__) + (. identity|uninlined|__3 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__4|types 0) ~'x00__) + (. identity|uninlined|__4 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__5|types 0) ~'x00__) + (. identity|uninlined|__5 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__6|types 0) ~'x00__) + (. identity|uninlined|__6 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__7|types 0) ~'x00__) + (. identity|uninlined|__7 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__8|types 0) ~'x00__) + (. identity|uninlined|__8 ~'invoke ~'x00__) + ;; TODO no need for `unsupported!` because it will always get a valid branch + (unsupported! `identity|uninlined [~'x00__] 0)))))) :cljs - ;; Direct dispatch will be simple functions, not `reify`s - ($ (do (defn ~'identity|uninlined [~'x] ~'x))))] + ;; Direct dispatch will be simple functions, not `reify`s + ($ (do (defn ~'identity|uninlined [~'x] ~'x))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) @@ -1804,16 +1818,16 @@ ;; the `t/defn` is interned in, that mapping should go away too. ;; We only show this types decl because testing/debug is on. Otherwise the macro would just ;; `intern` the var and define it there rather than re-evaluating the types. - (def ~'extensible|__types-decl + (def ~'extensible|__types (atom [{:id 0 :arg-types [(t/isa? Double)] :output-type t/any?}])) - (def ~'extensible|__0|types (self/types-decl>arg-types ~'extensible|__types-decl 0)) + (def ~'extensible|__0|types (self/types-decl>arg-types ~'extensible|__types 0)) (def ~'extensible|__0 (reify* [double>Object] (invoke [_0__ a] nil))) ;; Could have done `intern`+`fn*` but JS needs some special things for it to work that may ;; change over time (defn extensible - {:quantum.core.type/type (self/types-decl>ftype extensible|__types-decl t/any?)} + {:quantum.core.type/type (self/types-decl>ftype extensible|__types t/any?)} ([~'x00__] (ifs ((Array/get ~'extensible|__0|types 0) ~'x00__) (. extensible|__0 invoke x00__) @@ -1829,7 +1843,7 @@ ;; `reset!` the types decl outside the code rather than re-evaluating the types. ;; To find where to put the overload, we find the first place where the inputs are `t/<`. ;; TODO test that when testing/debug mode is off, it doesn't emit this code - (reset! quantum.test.untyped.core.type.defnt/extensible|__types-decl + (reset! quantum.test.untyped.core.type.defnt/extensible|__types [{:name ~(tag ... 'extensible|__1) :arg-types [(t/isa? Boolean)] :output-type t/any?} {:name ~(tag ... 'extensible|__0) :arg-types [(t/isa? Double)] :output-type t/any?}]) @@ -1837,14 +1851,14 @@ ;; incrementing based on the size of the types-decl ;; Currently we can't undefine overloads which I think is fine (def ~'extensible|__1|types - (self/types-decl>arg-types quantum.test.untyped.core.type.defnt/extensible|__types-decl 0)) + (self/types-decl>arg-types quantum.test.untyped.core.type.defnt/extensible|__types 0)) (def ~'extensible|__1 (reify* [boolean>Object] (invoke [_0__ a] nil))) ;; The dynamic dispatch is currently redefined with every `extend-defn!` ;; We expect that `t/defn` extension will take place in only one thread (intern 'quantum.test.untyped.core.type.defnt (with-meta 'extensible (assoc (meta (var quantum.test.untyped.core.type.defnt/extensible)) - :quantum.core.type/type (self/types-decl>ftype extensible|__types-decl t/any?))) + :quantum.core.type/type (self/types-decl>ftype extensible|__types t/any?))) (fn* ([~'x00__] (ifs ((Array/get ~'extensible|__1|types 0) ~'x00__) (. extensible|__1 invoke x00__) From 124c3e895b2acf5e423e7365e994cbbb183dd128 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 13 Oct 2018 08:11:47 -0600 Subject: [PATCH 503/810] Another test passes! --- .../quantum/untyped/core/type/defnt.cljc | 11 +- .../quantum/test/untyped/core/type/defnt.cljc | 190 +++++++++--------- 2 files changed, 94 insertions(+), 107 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index a529a09f..25dbb067 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -237,16 +237,7 @@ (<- (cond-> (not= kind :extend-defn!) (assoc fn|name recursive-ast-node-reference)))) arg-classes (->> arg-types (uc/map type>class)) - body|pre-analyze|with-casts - (->> arg-classes - (reducei (c/fn [body ^Class c i|arg] - (if (or (.isPrimitive c) (= c java.lang.Object)) - body - (let [arg-sym (get arg-bindings i|arg)] - `(let* [~(ufth/with-type-hint arg-sym (.getName c)) ~arg-sym] - ~body)))) - (ufgen/?wrap-do body-codelist|pre-analyze))) - body-node (uana/analyze env body|pre-analyze|with-casts) + body-node (uana/analyze env (ufgen/?wrap-do body-codelist|pre-analyze)) hint-arg|fn (c/fn [i arg-binding] (ufth/with-type-hint arg-binding (ufth/>fn-arglist-tag diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index ab510714..4eabe0e4 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -140,8 +140,7 @@ (reify* [Object>Object] (~(O 'invoke) [~'_8__ ~(O 'x)] ~(O 'x)))) (defn ~'identity|uninlined - {:quantum.core.type/type - (self/types-decl>ftype identity|uninlined|__types t/any?)} + {:quantum.core.type/type (types-decl>ftype identity|uninlined|__types t/any?)} ([~'x00__] (ifs ((Array/get identity|uninlined|__0|types 0) ~'x00__) @@ -175,48 +174,46 @@ (deftest test|name (let [actual - (macroexpand ' - (self/defn #_:inline name > t/string? - ([x t/string?] x) - #?(:clj ([x (t/isa? Named) > (t/* t/string?)] (.getName x)) - :cljs ([x (t/isa? INamed) > (t/* t/string?)] (-name x))))) + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/defn #_:inline name > t/string? + ([x t/string?] x) + #?(:clj ([x (t/isa? Named) > (t/* t/string?)] (.getName x)) + :cljs ([x (t/isa? INamed) > (t/* t/string?)] (-name x)))))) expected - (case (env-lang) - :clj - ($ (do (declare ~'name) + (case (env-lang) + :clj + ($ (do (declare ~'name) + (def ~'name|__types + (atom [{:id 0 :arg-types [(t/isa? String)] :output-type (t/isa? String)} + {:id 1 :arg-types [(t/isa? Named)] :output-type (t/* (t/isa? String))}])) - ;; [x t/string?] + ;; [x t/string?] - (def ~(O<> 'name|__0|types) (*<> (t/isa? java.lang.String))) - (def ~'name|__0 - (reify* [Object>Object] - (~(O 'invoke) [~'_0__ ~(O 'x)] ~(ST 'x)))) + (def ~(O<> 'name|__0|types) (types-decl>arg-types name|__types 0)) + (def ~(tag (cstr `Object>Object) 'name|__0) + (reify* [Object>Object] (~(O 'invoke) [~'_0__ ~(O 'x)] ~(ST 'x)))) - ;; [x (t/isa? Named)] > (t/* t/string?) + ;; [x (t/isa? Named)] > (t/* t/string?) - (def ~(O<> 'name|__1|types) (*<> (t/isa? Named))) - (def ~'name|__1 - (reify* [Object>Object] - (~(O 'invoke) [~'_1__ ~(O 'x)] - (t/validate ~(ST (list '. (tag "clojure.lang.Named" 'x) 'getName)) - ~'(t/* t/string?))))) + (def ~(O<> 'name|__1|types) (types-decl>arg-types name|__types 1)) + (def ~(tag (cstr `Object>Object) 'name|__1) + (reify* [Object>Object] + (~(O 'invoke) [~'_1__ ~(O 'x)] + (t/validate ~(ST (list '. (tag "clojure.lang.Named" 'x) 'getName)) + ~'(t/* t/string?))))) - (defn ~'name - {:quantum.core.type/type - (t/ftype (t/isa? String) - [(t/isa? String) :> (t/isa? String)] - [(t/isa? Named) :> (t/* (t/isa? String))])} - ([~'x00__] - (ifs ((Array/get ~'name|__0|types 0) ~'x00__) - (. ~(tag (cstr `Object>Object) 'name|__0) ~'invoke ~'x00__) - ((Array/get ~'name|__1|types 0) ~'x00__) - (. ~(tag (cstr `Object>Object) 'name|__1) ~'invoke ~'x00__) - (unsupported! `name [~'x00__] 0)))))) - :cljs - ($ (do (defn ~'name [~'x00__] - (ifs (t/string? x) x - (satisfies? INamed x) (-name x) - (unsupported! `name [~'x00__] 0))))))] + (defn ~'name + {:quantum.core.type/type (types-decl>ftype name|__types (t/isa? String))} + ([~'x00__] + (ifs ((Array/get name|__0|types 0) ~'x00__) (. name|__0 ~'invoke ~'x00__) + ((Array/get name|__1|types 0) ~'x00__) (. name|__1 ~'invoke ~'x00__) + (unsupported! `name [~'x00__] 0)))))) + :cljs + ($ (do (defn ~'name [~'x00__] + (ifs (t/string? x) x + (satisfies? INamed x) (-name x) + (unsupported! `name [~'x00__] 0))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) @@ -231,79 +228,78 @@ (deftest test|some? (let [actual - ;; Perhaps silly in ClojureScript, but avoids boxing in Clojure - (macroexpand ' - (self/defn #_:inline some? > t/boolean? - ([x t/nil?] false) - ;; Implicitly, `(- t/any? t/nil?)`, so `t/val?` - ([x t/any?] true))) + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/defn #_:inline some? > t/boolean? + ([x t/nil?] false) + ;; Implicitly, `(- t/any? t/nil?)`, so `t/val?` + ([x t/any?] true)))) expected (case (env-lang) :clj ($ (do (declare ~'some?) + (def ~'some?|__types + (atom [{:id 0 :arg-types [(t/value nil)] :output-type (t/value false)} + {:id 1 :arg-types [(t/isa? Boolean)] :output-type (t/value true)} + {:id 2 :arg-types [(t/isa? Byte)] :output-type (t/value true)} + {:id 3 :arg-types [(t/isa? Short)] :output-type (t/value true)} + {:id 4 :arg-types [(t/isa? Character)] :output-type (t/value true)} + {:id 5 :arg-types [(t/isa? Integer)] :output-type (t/value true)} + {:id 6 :arg-types [(t/isa? Long)] :output-type (t/value true)} + {:id 7 :arg-types [(t/isa? Float)] :output-type (t/value true)} + {:id 8 :arg-types [(t/isa? Double)] :output-type (t/value true)} + {:id 9 :arg-types [t/any?] :output-type (t/value true)}])) ;; [x t/nil?] - (def ~(O<> 'some?|__0|types) (*<> (t/value nil))) - (def ~'some?|__0 - (reify* [Object>boolean] (~(B 'invoke) [~'_0__ ~(O 'x)] false))) + (def ~(O<> 'some?|__0|types) (types-decl>arg-types some?|__types 0)) + (def ~(tag (cstr `Object>boolean) 'some?|__0) + (reify* [Object>boolean] (~(B 'invoke) [~'_0__ ~(O 'x)] false))) ;; [x t/any?] - (def ~(O<> 'some?|__1|types) (*<> (t/isa? Boolean))) - (def ~'some?|__1 (reify* [boolean>boolean] (~(B 'invoke) [~'_1__ ~(B 'x)] true))) - (def ~(O<> 'some?|__2|types) (*<> (t/isa? Byte))) - (def ~'some?|__2 (reify* [byte>boolean] (~(B 'invoke) [~'_2__ ~(Y 'x)] true))) - (def ~(O<> 'some?|__3|types) (*<> (t/isa? Short))) - (def ~'some?|__3 (reify* [short>boolean] (~(B 'invoke) [~'_3__ ~(S 'x)] true))) - (def ~(O<> 'some?|__4|types) (*<> (t/isa? Character))) - (def ~'some?|__4 (reify* [char>boolean] (~(B 'invoke) [~'_4__ ~(C 'x)] true))) - (def ~(O<> 'some?|__5|types) (*<> (t/isa? Integer))) - (def ~'some?|__5 (reify* [int>boolean] (~(B 'invoke) [~'_5__ ~(I 'x)] true))) - (def ~(O<> 'some?|__6|types) (*<> (t/isa? Long))) - (def ~'some?|__6 (reify* [long>boolean] (~(B 'invoke) [~'_6__ ~(L 'x)] true))) - (def ~(O<> 'some?|__7|types) (*<> (t/isa? Float))) - (def ~'some?|__7 (reify* [float>boolean] (~(B 'invoke) [~'_7__ ~(F 'x)] true))) - (def ~(O<> 'some?|__8|types) (*<> (t/isa? Double))) - (def ~'some?|__8 (reify* [double>boolean] (~(B 'invoke) [~'_8__ ~(D 'x)] true))) - (def ~(O<> 'some?|__9|types) (*<> t/any?)) - (def ~'some?|__9 (reify* [Object>boolean] (~(B 'invoke) [~'_9__ ~(O 'x)] true))) + (def ~(O<> 'some?|__1|types) (types-decl>arg-types some?|__types 1)) + (def ~(tag (cstr `boolean>boolean) 'some?|__1) + (reify* [boolean>boolean] (~(B 'invoke) [~'_1__ ~(B 'x)] true))) + (def ~(O<> 'some?|__2|types) (types-decl>arg-types some?|__types 2)) + (def ~(tag (cstr `byte>boolean) 'some?|__2) + (reify* [byte>boolean] (~(B 'invoke) [~'_2__ ~(Y 'x)] true))) + (def ~(O<> 'some?|__3|types) (types-decl>arg-types some?|__types 3)) + (def ~(tag (cstr `short>boolean) 'some?|__3) + (reify* [short>boolean] (~(B 'invoke) [~'_3__ ~(S 'x)] true))) + (def ~(O<> 'some?|__4|types) (types-decl>arg-types some?|__types 4)) + (def ~(tag (cstr `char>boolean) 'some?|__4) + (reify* [char>boolean] (~(B 'invoke) [~'_4__ ~(C 'x)] true))) + (def ~(O<> 'some?|__5|types) (types-decl>arg-types some?|__types 5)) + (def ~(tag (cstr `int>boolean) 'some?|__5) + (reify* [int>boolean] (~(B 'invoke) [~'_5__ ~(I 'x)] true))) + (def ~(O<> 'some?|__6|types) (types-decl>arg-types some?|__types 6)) + (def ~(tag (cstr `long>boolean) 'some?|__6) + (reify* [long>boolean] (~(B 'invoke) [~'_6__ ~(L 'x)] true))) + (def ~(O<> 'some?|__7|types) (types-decl>arg-types some?|__types 7)) + (def ~(tag (cstr `float>boolean) 'some?|__7) + (reify* [float>boolean] (~(B 'invoke) [~'_7__ ~(F 'x)] true))) + (def ~(O<> 'some?|__8|types) (types-decl>arg-types some?|__types 8)) + (def ~(tag (cstr `double>boolean) 'some?|__8) + (reify* [double>boolean] (~(B 'invoke) [~'_8__ ~(D 'x)] true))) + (def ~(O<> 'some?|__9|types) (types-decl>arg-types some?|__types 9)) + (def ~(tag (cstr `Object>boolean) 'some?|__9) + (reify* [Object>boolean] (~(B 'invoke) [~'_9__ ~(O 'x)] true))) (defn ~'some? - {:quantum.core.type/type - (t/ftype (t/isa? Boolean) - [(t/value nil) :> (t/isa? Boolean)] - [(t/isa? Boolean) :> (t/isa? Boolean)] - [(t/isa? Byte) :> (t/isa? Boolean)] - [(t/isa? Short) :> (t/isa? Boolean)] - [(t/isa? Character) :> (t/isa? Boolean)] - [(t/isa? Integer) :> (t/isa? Boolean)] - [(t/isa? Long) :> (t/isa? Boolean)] - [(t/isa? Float) :> (t/isa? Boolean)] - [(t/isa? Double) :> (t/isa? Boolean)] - [t/any? :> (t/isa? Boolean)])} + {:quantum.core.type/type (types-decl>ftype some?|__types (t/isa? Boolean))} ([~'x00__] - (ifs ((Array/get ~'some?|__0|types 0) ~'x00__) - (. ~(tag (cstr `Object>boolean) 'some?|__0) ~'invoke ~'x00__) + (ifs ((Array/get some?|__0|types 0) ~'x00__) (. some?|__0 ~'invoke ~'x00__) ;; TODO eliminate these checks below because they're not needed - ((Array/get ~'some?|__1|types 0) ~'x00__) - (. ~(tag (cstr `boolean>boolean) 'some?|__1) ~'invoke ~'x00__) - ((Array/get ~'some?|__2|types 0) ~'x00__) - (. ~(tag (cstr `byte>boolean) 'some?|__2) ~'invoke ~'x00__) - ((Array/get ~'some?|__3|types 0) ~'x00__) - (. ~(tag (cstr `short>boolean) 'some?|__3) ~'invoke ~'x00__) - ((Array/get ~'some?|__4|types 0) ~'x00__) - (. ~(tag (cstr `char>boolean) 'some?|__4) ~'invoke ~'x00__) - ((Array/get ~'some?|__5|types 0) ~'x00__) - (. ~(tag (cstr `int>boolean) 'some?|__5) ~'invoke ~'x00__) - ((Array/get ~'some?|__6|types 0) ~'x00__) - (. ~(tag (cstr `long>boolean) 'some?|__6) ~'invoke ~'x00__) - ((Array/get ~'some?|__7|types 0) ~'x00__) - (. ~(tag (cstr `float>boolean) 'some?|__7) ~'invoke ~'x00__) - ((Array/get ~'some?|__8|types 0) ~'x00__) - (. ~(tag (cstr `double>boolean) 'some?|__8) ~'invoke ~'x00__) - ((Array/get ~'some?|__9|types 0) ~'x00__) - (. ~(tag (cstr `Object>boolean) 'some?|__9) ~'invoke ~'x00__) + ((Array/get some?|__1|types 0) ~'x00__) (. some?|__1 ~'invoke ~'x00__) + ((Array/get some?|__2|types 0) ~'x00__) (. some?|__2 ~'invoke ~'x00__) + ((Array/get some?|__3|types 0) ~'x00__) (. some?|__3 ~'invoke ~'x00__) + ((Array/get some?|__4|types 0) ~'x00__) (. some?|__4 ~'invoke ~'x00__) + ((Array/get some?|__5|types 0) ~'x00__) (. some?|__5 ~'invoke ~'x00__) + ((Array/get some?|__6|types 0) ~'x00__) (. some?|__6 ~'invoke ~'x00__) + ((Array/get some?|__7|types 0) ~'x00__) (. some?|__7 ~'invoke ~'x00__) + ((Array/get some?|__8|types 0) ~'x00__) (. some?|__8 ~'invoke ~'x00__) + ((Array/get some?|__9|types 0) ~'x00__) (. some?|__9 ~'invoke ~'x00__) (unsupported! `some? [~'x00__] 0)))))) :cljs ($ (do (defn ~'some?| [~'x] From ec1528c4a045432f2d24bcf30f57815831e05808 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 13 Oct 2018 11:30:01 -0600 Subject: [PATCH 504/810] Fix a few bugs with `extend-defn!` --- resources-dev/defnt.cljc | 2 +- src-untyped/quantum/untyped/core/analyze.cljc | 17 ++-- .../quantum/untyped/core/type/compare.cljc | 48 +++------ .../quantum/untyped/core/type/defnt.cljc | 97 +++++++++++-------- src/quantum/core/data/primitive.cljc | 20 ++-- src/quantum/core/type.cljc | 3 + 6 files changed, 98 insertions(+), 89 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index b85685ba..0e237c02 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -65,7 +65,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative still.) - This will be a more advanced feature. For now we just accept that we might have some odd behavior around extending `t/defn`s. - [1a] It should disallow creating another definition with the same input type combination. + [1a] It should warn when creating another definition with the same input type combination. [1b] `assert-monotonically-increasing-types!` needs to be enforced [2] - t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 3f46cf14..e76d2a30 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -62,7 +62,9 @@ ;; TODO move? (defns- compare-class-specificity [c0 class?, c1 class?] - (case (utcomp/compare|class+class* c0 c1) + (case (utcomp/compare|class+class* + (or (t/unboxed-class->boxed-class c0) c0) + (or (t/unboxed-class->boxed-class c1) c1)) -1 -1 (0 2 3) 0 1 1)) @@ -305,10 +307,13 @@ args-ct (alength sample-arg-classes)] (->> (range args-ct) (reduce - (fn [call-sites' i] + (fn [call-sites' ^long i] (->> call-sites' - (uc/map+ (fn [{:keys [^"[Ljava.lang.Object;" arg-classes]}] (aget arg-classes i))) - (ucomp/comp-mins-of compare-class-specificity))) + (ucomp/comp-mins-of + (fn [x0 x1] + (let [^"[Ljava.lang.Object;" cs0 (:arg-classes x0) + ^"[Ljava.lang.Object;" cs1 (:arg-classes x1)] + (compare-class-specificity (aget cs0 i) (aget cs1 i))))))) call-sites)))) (defns- analyze-seq|method-or-constructor-call|incrementally-analyze @@ -337,7 +342,7 @@ (vec (concat (mapv :type args|analyzed) [arg|analyzed|type] (repeat (- (count args|form) - (count args|analyzed)) + (inc (count args|analyzed))) :unanalyzed)))}) (-> ret (assoc :call-sites call-sites') @@ -348,7 +353,7 @@ (err! (str "Multiple, equally specific " kinds-str " for class match the arg types") {:class target-class :form form - (keyword kinds-str) call-sites + (keyword kinds-str) (->> call-sites (uc/map #(update % :arg-classes vec))) :arg-types (mapv :type args|analyzed)}) ret))) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index bfce7e4b..fcce56bb 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -456,36 +456,20 @@ "Used in `t/compare|in` and `t/compare|out`. Might be used for other things too in the future. Commutative in the 2-ary arity." ([cs _ #_(seq-of uset/comparison?) > uset/comparison?] + ;; TODO it's possible to `reduced` early here depending (reduce (fn [c' c] (combine-comparisons c' c)) (first cs) (rest cs))) - ([^long c0 uset/comparison?, ^long c1 uset/comparison? > uset/comparison?] - (case c0 - -1 (case c1 - -1 ident) - 0 (case c1 - -1 ident - 2 >ident) - 1 (case c1 - -1 >ident - 1 >ident - 2 >ident) - 2 (case c1 - -1 >ident) - 3 (case c1 - -1 <>ident - 0 <>ident - 1 <>ident - 2 <>ident - 3 <>ident)))) + ([c0 uset/comparison?, c1 uset/comparison? > uset/comparison?] + (case (long c0) + -1 (case (long c1) -1 ident) + 0 (case (long c1) -1 ident, 2 >ident) + 1 (case (long c1) -1 >ident, 1 >ident, 2 >ident) + 2 (case (long c1) -1 >ident) + 3 (case (long c1) -1 <>ident, 0 <>ident, 1 <>ident, 2 <>ident, 3 <>ident)))) + +(defns compare-inputs + [arg-types0 _ #_(s/vec-of t/type?), arg-types1 _ #_(s/vec-of t/type?) > uset/comparison?] + (let [ct-comparison (c/compare (count arg-types0) (count arg-types1))] + (if (zero? ct-comparison) + ;; TODO can use educers here + (combine-comparisons (map compare arg-types0 arg-types1)) + class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] @@ -249,10 +252,7 @@ body-form (-> (:form body-node) (cond-> (-> actual-output-type meta :quantum.core.type/runtime?) - (>with-runtime-output-type output-type|form)) - (ufth/cast-bindings|code - (->> (uc/zipmap-into (umap/om) arg-bindings arg-classes) - (uc/remove-vals' (fn-or nil? (fn= java.lang.Object) t/primitive-class?)))))] + (>with-runtime-output-type output-type|form)))] {:arg-classes arg-classes :arg-types arg-types :arglist-code|fn|hinted (cond-> (->> arg-bindings (uc/map-indexed hint-arg|fn)) @@ -354,6 +354,24 @@ output-type (conj :> output-type)))) (apply t/ftype fn|output-type))) +(c/defn- dedupe-types-decl-data [fn|ns-name fn|name types-decl-data] + (reduce (let [*prev-datum (volatile! nil)] + (c/fn [data {:as datum :keys [arg-types]}] + (with-do + (ifs (nil? @*prev-datum) + (conj data datum) + (= uset/=ident (utcomp/compare-inputs + (:arg-types @*prev-datum) arg-types)) + (do (ulog/ppr :warn (str "Overwriting type overload for `" + (uid/qualify fn|ns-name fn|name) "`; arg types:") + arg-types) + (-> data pop (conj (assoc @*prev-datum :ns-sym (:ns-sym datum) + :overload (:overload datum))))) + (conj data datum)) + (vreset! *prev-datum datum)))) + [] + types-decl-data)) + (defns- >types-decl [{:as opts :keys [kind _]} ::opts {:as fn|globals :keys [fn|ns-name _, fn|name _ fn|types-decl-name _]} ::fn|globals @@ -369,27 +387,23 @@ (uc/map-indexed (c/fn [i {:keys [arg-types output-type]}] {:id (+ i first-current-overload-id) + :ns-sym (ns-name *ns*) :arg-types arg-types :output-type output-type}))) ;; We can't just concat the currently-being-created overloads' type-decl data with the ;; existing type-decl data because we need to maintain the type-decl data's ordering by ;; type-specificity so the dynamic dispatch works correctly. types-decl-indexed-data - (when (= kind :extend-defn!) - (->> (ur/join types-decl-current-data types-decl-existing-data) - ;; So we can keep track of the original index - (uc/map-indexed - (c/fn [i {:as datum :keys [id]}] - (let [overload (get overloads (- id first-current-overload-id))] - (assoc datum :index i :overload overload)))) - ;; TODO here `extend-defn!` should: - ;; - Disallow creating another definition with the same input type combination - ;; - Use `assert-monotonically-increasing-types!` - (sort-by :arg-types compare-args-types))) - types-decl-indexed-current-data (if (= kind :extend-defn!) - (->> types-decl-indexed-data - (c/filter (fn-> :id (>= first-current-overload-id)))) + (->> (ur/join types-decl-current-data types-decl-existing-data) + (uc/map + (c/fn [{:as datum :keys [id]}] + (assoc datum :overload (get overloads (- id first-current-overload-id))))) + ;; TODO here `extend-defn!` should probably: + ;; - Use `assert-monotonically-increasing-types!` + (sort-by :arg-types compare-args-types) + (dedupe-types-decl-data fn|ns-name fn|name) + (uc/map-indexed (c/fn [i datum] (assoc datum :index i)))) (->> types-decl-current-data (uc/map-indexed (c/fn [i datum] (assoc datum :index i :overload (get overloads i)))))) @@ -403,16 +417,16 @@ `(reset! ~(uid/qualify fn|ns-name fn|types-decl-name) ~(>form types-decl-data)) `(def ~fn|types-decl-name (atom ~(>form types-decl-data)))) :data types-decl-data - :indexed-current-data types-decl-indexed-current-data} + :indexed-data types-decl-indexed-data} ;; In non-test cases, it's far cheaper to not have to convert the types to a ;; compiler-readable form and then re-evaluate them again (do (if (= kind :extend-defn!) (reset! (>types-decl-ref fn|globals) types-decl-data) (intern (>symbol *ns*) fn|types-decl-name (atom types-decl-data))) - {:name fn|types-decl-name - :form nil - :data types-decl-data - :indexed-current-data types-decl-indexed-current-data})))) + {:name fn|types-decl-name + :form nil + :data types-decl-data + :indexed-data types-decl-indexed-data})))) (defns- >overload-types-decl|name ([fn|name simple-symbol?, overload|id ::overload|id > simple-symbol?] @@ -443,7 +457,8 @@ (case lang :clj (let [direct-dispatch-data-seq (->> types-decl - :indexed-current-data + :indexed-data + (uc/filter+ :overload) ; i.e. the "current" ones (uc/map (c/fn [{:as indexed-type-decl-datum :keys [arg-types id index overload]}] {:overload-types-decl @@ -470,13 +485,15 @@ (defns- >combinatoric-seq+ [{:as fn|globals :keys [fn|ns-name _ fn|name _]} ::fn|globals - types-decl-data-for-arity (s/vec-of ::types-decl-datum), arglist (s/vec-of simple-symbol?)] - (->> types-decl-data-for-arity + indexed-types-decl-data-for-arity (s/vec-of ::indexed-types-decl-datum) + arglist (s/vec-of simple-symbol?)] + (->> indexed-types-decl-data-for-arity (uc/map+ - (c/fn [{:as types-decl-datum :keys [arg-types]}] - (let [overload|id (:id types-decl-datum) - overload-types-decl|name (>overload-types-decl|name fn|ns-name fn|name overload|id) - reify|name|qualified (>reify-name-unhinted fn|ns-name fn|name overload|id)] + (c/fn [{:as types-decl-datum :keys [arg-types ns-sym overload]}] + (let [overload|id (:id types-decl-datum) + overload-types-decl|name + (>overload-types-decl|name ns-sym fn|name overload|id) + reify|name|qualified (>reify-name-unhinted ns-sym fn|name overload|id)] [(>dynamic-dispatch|reify-call reify|name|qualified arglist) (->> arg-types (uc/map-indexed @@ -488,10 +505,10 @@ (defns- >dynamic-dispatch|body-for-arity [{:as fn|globals :keys [fn|ns-name _, fn|name _]} ::fn|globals - arglist (s/vec-of simple-symbol?) - types-decl-data-for-arity (s/vec-of ::types-decl-datum)] + indexed-types-decl-data-for-arity (s/vec-of ::indexed-types-decl-datum) + arglist (s/vec-of simple-symbol?)] (if (empty? arglist) - (let [overload|id (-> types-decl-data-for-arity first :id)] + (let [overload|id (-> indexed-types-decl-data-for-arity first :id)] (>dynamic-dispatch|reify-call (>reify-name-unhinted fn|ns-name fn|name overload|id) arglist)) (let [*i|arg (atom 0) @@ -511,7 +528,7 @@ (aritoid combinef combinef (c/fn [x [{:keys [getf i]} group]] (combinef x getf group i))) uc/conj!|rf (aritoid combinef combinef (c/fn [x [k [{:keys [getf i]}]]] (combinef x getf k i))) - (>combinatoric-seq+ fn|globals types-decl-data-for-arity arglist))))) + (>combinatoric-seq+ fn|globals indexed-types-decl-data-for-arity arglist))))) (defns- >dynamic-dispatch-fn|form [{:as opts :keys [gen-gensym _, lang _, kind _]} ::opts @@ -520,13 +537,13 @@ types-decl ::types-decl] (let [overload-forms (->> types-decl - :data + :indexed-data (group-by (fn-> :arg-types count)) (sort-by key) ; for purposes of reproducibility and organization - (map (c/fn [[arg-ct types-decl-data-for-arity]] + (map (c/fn [[arg-ct indexed-types-decl-data-for-arity]] (let [arglist (ufgen/gen-args 0 arg-ct "x" gen-gensym) body (>dynamic-dispatch|body-for-arity - fn|globals arglist types-decl-data-for-arity)] + fn|globals indexed-types-decl-data-for-arity arglist)] (list arglist body))))) ftype-form `(types-decl>ftype ~(uid/qualify fn|ns-name fn|types-decl-name) ~(>form fn|output-type))] @@ -716,7 +733,7 @@ dynamic-dispatch (>dynamic-dispatch-fn|form opts fn|globals types-decl) fn-codelist (case lang - :clj (->> `[(declare ~fn|name) ; for recursion + :clj (->> `[~@(when (not= kind :extend-defn!) [`(declare ~fn|name)]) ; for recursion ~@(some-> (:form types-decl) vector) ~@(:form direct-dispatch) ~dynamic-dispatch] diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 2afbfb3b..e6637ea8 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -181,17 +181,17 @@ ;; ===== Extensions ===== ;; #?(:clj -(t/extend-defn! ccomp/== - (^:in [a boolean? , b boolean?] (Util/equiv a b)) +(macroexpand '(t/extend-defn! ccomp/== + #_(^:in [a boolean? , b boolean?] (Util/equiv a b)) ( [a boolean? , b (t/- primitive? boolean?)] false) - ( [a (t/- primitive? boolean?) , b boolean?] false) - (^:in [a long? , b long?] (Numbers/equiv a b)) - ( [a long? , b (t/- numeric? long?)] (Numeric/eq a b)) - ( [a (t/- numeric? long?) , b long?] (Numeric/eq a b)) - (^:in [a double? , b double?] (Numbers/equiv a b)) - ( [a double? , b (t/- numeric? double?)] (Numeric/eq a b)) - ( [a (t/- numeric? double?) , b double?] (Numeric/eq a b)) - ( [a (t/- numeric? double? long?), b (t/- numeric? double? long?)] (Numeric/eq a b)))) + #_( [a (t/- primitive? boolean?) , b boolean?] false) + #_(^:in [a long? , b long?] (Numbers/equiv a b)) + #_( [a long? , b (t/- numeric? long?)] (Numeric/eq a b)) + #_( [a (t/- numeric? long?) , b long?] (Numeric/eq a b)) + #_(^:in [a double? , b double?] (Numbers/equiv a b)) + #_( [a double? , b (t/- numeric? double?)] (Numeric/eq a b)) + #_( [a (t/- numeric? double?) , b double?] (Numeric/eq a b)) + #_( [a (t/- numeric? double? long?), b (t/- numeric? double? long?)] (Numeric/eq a b))))) #?(:clj (t/extend-defn! ccomp/not== diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index 4bd8d723..d5206bbe 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -9,6 +9,9 @@ [quantum.untyped.core.vars :refer [defalias defaliases]])) +;; TODO if we ever spec-instrument we need to be careful of these aliases as they'll no longer be +;; valid + (defaliases udefnt fn defn extend-defn!) (defaliases ut From 63c8fa3adf3984407620219786ccf0cc6fa8cc98 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 13 Oct 2018 11:51:55 -0600 Subject: [PATCH 505/810] Fix hinting --- .../quantum/untyped/core/analyze/ast.cljc | 2 +- .../quantum/untyped/core/type/defnt.cljc | 12 +++++++++-- src/quantum/core/data/primitive.cljc | 20 +++++++++---------- 3 files changed, 21 insertions(+), 13 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index f35e0c56..9fc0cdba 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -28,7 +28,7 @@ ;; TODO for now (uxp/iexpr? t)) nil - (let [cs (t/type>classes t)] + (let [cs (cond-> (t/type>classes t) (-> t meta :quantum.core.type/ref?) (conj nil))] (case (count cs) 1 (let [c (first cs)] (when-let [not-primitive? (not (contains? t/boxed-class->unboxed-symbol c))] diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 1ab1fa9d..8a5b78b0 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -401,7 +401,15 @@ (assoc datum :overload (get overloads (- id first-current-overload-id))))) ;; TODO here `extend-defn!` should probably: ;; - Use `assert-monotonically-increasing-types!` - (sort-by :arg-types compare-args-types) + (sort-by identity + (c/fn [datum0 datum1] + (let [c (compare-args-types (:arg-types datum0) (:arg-types datum1))] + ;; In order to make the earlier ID appear + (if (zero? c) + (if (:overload datum0) + (if (:overload datum1) c 1) + (if (:overload datum1) -1 c)) + c)))) (dedupe-types-decl-data fn|ns-name fn|name) (uc/map-indexed (c/fn [i datum] (assoc datum :index i)))) (->> types-decl-current-data @@ -449,7 +457,7 @@ ;; ----- Direct dispatch: putting it all together ----- ;; -(defns >direct-dispatch +(defns- >direct-dispatch [{:as opts :keys [gen-gensym _, lang _, kind _]} ::opts {:as fn|globals :keys [fn|name _]} ::fn|globals overloads (s/vec-of ::overload) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index e6637ea8..2afbfb3b 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -181,17 +181,17 @@ ;; ===== Extensions ===== ;; #?(:clj -(macroexpand '(t/extend-defn! ccomp/== - #_(^:in [a boolean? , b boolean?] (Util/equiv a b)) +(t/extend-defn! ccomp/== + (^:in [a boolean? , b boolean?] (Util/equiv a b)) ( [a boolean? , b (t/- primitive? boolean?)] false) - #_( [a (t/- primitive? boolean?) , b boolean?] false) - #_(^:in [a long? , b long?] (Numbers/equiv a b)) - #_( [a long? , b (t/- numeric? long?)] (Numeric/eq a b)) - #_( [a (t/- numeric? long?) , b long?] (Numeric/eq a b)) - #_(^:in [a double? , b double?] (Numbers/equiv a b)) - #_( [a double? , b (t/- numeric? double?)] (Numeric/eq a b)) - #_( [a (t/- numeric? double?) , b double?] (Numeric/eq a b)) - #_( [a (t/- numeric? double? long?), b (t/- numeric? double? long?)] (Numeric/eq a b))))) + ( [a (t/- primitive? boolean?) , b boolean?] false) + (^:in [a long? , b long?] (Numbers/equiv a b)) + ( [a long? , b (t/- numeric? long?)] (Numeric/eq a b)) + ( [a (t/- numeric? long?) , b long?] (Numeric/eq a b)) + (^:in [a double? , b double?] (Numbers/equiv a b)) + ( [a double? , b (t/- numeric? double?)] (Numeric/eq a b)) + ( [a (t/- numeric? double?) , b double?] (Numeric/eq a b)) + ( [a (t/- numeric? double? long?), b (t/- numeric? double? long?)] (Numeric/eq a b)))) #?(:clj (t/extend-defn! ccomp/not== From d983b610aaa0ff2dd57311f339610835ff9198bf Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 13 Oct 2018 12:09:01 -0600 Subject: [PATCH 506/810] Fix compilation --- src-untyped/quantum/untyped/core/print.cljc | 8 +- .../quantum/untyped/core/type/defnt.cljc | 130 +++++++++--------- src/quantum/core/compare/core.cljc | 24 ++-- src/quantum/core/data/primitive.cljc | 1 - 4 files changed, 83 insertions(+), 80 deletions(-) diff --git a/src-untyped/quantum/untyped/core/print.cljc b/src-untyped/quantum/untyped/core/print.cljc index 47d119ed..3b4d8e7f 100644 --- a/src-untyped/quantum/untyped/core/print.cljc +++ b/src-untyped/quantum/untyped/core/print.cljc @@ -39,10 +39,8 @@ (defn ppr-hints [x] (binding [*print-meta* true] (ppr x))) ; TODO this isn't right (defn ppr-error [x] - #?(:clj (let [pr-data-to-str? @uerr/*pr-data-to-str?] - (println (str "EXCEPTION" (when-not pr-data-to-str? " TRACE + MESSAGE") ":")) - (print (io.aviso.exception/format-exception x {:properties false})) - (when-not pr-data-to-str? + #?(:clj (do (println (str "EXCEPTION. TRACE + MESSAGE:")) + (print (io.aviso.exception/format-exception x {:properties false})) (let [e (>err x) e (or (:cause e) e)] (println "--------------------") @@ -51,7 +49,7 @@ (into (array-map)) not-empty)] (println "EXCEPTION DATA:") - (ppr e'))))) ; TODO fix so it doesn't print "empty: false" + (ppr e')))) ; TODO fix so it doesn't print "empty: false" :cljs (ppr x))) (defalias uerr/ppr-str) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 8a5b78b0..b3ea98ab 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -272,6 +272,58 @@ (err! "Class cannot contain pattern" {:class c :pattern illegal-pattern}) (-> c >name (str/replace "." "|")))))) +;; ===== Arg type comparison ===== ;; + +(c/defn compare-arg-types [t0 #_t/type?, t1 #_t/type? #_> #_ucomp/comparison?] + (if-let [c0 (uana/sort-guide t0)] + (if-let [c1 (uana/sort-guide t1)] + (ifs (< c0 c1) -1 (> c0 c1) 1 0) + -1) + (if-let [c1 (uana/sort-guide t1)] + 1 + (uset/normalize-comparison (t/compare t0 t1))))) + +(c/defn compare-args-types [arg-types0 #_(s/vec-of t/type?) arg-types1 #_(s/vec-of t/type?)] + (let [ct-comparison (compare (count arg-types0) (count arg-types1))] + (if (zero? ct-comparison) + (reduce-2 + (c/fn [^long c t0 t1] + (let [c' (long (compare-arg-types t0 t1))] + (case c' + -1 (case c 1 (reduced 0) c') + 0 c + 1 (case c -1 (reduced 0) c')))) + 0 + arg-types0 arg-types1) + ct-comparison))) + +;; TODO spec +(c/defn assert-monotonically-increasing-types! + "Asserts that each type in an overload of the same arity and arg-position are in monotonically + increasing order in terms of `t/compare`. + + Since its inputs are sorted via `compare-args-types`, this only need check the last overload of + `unanalyzed-overload-seq-accum` and the first overload of `unanalyzed-overload-seq`." + [unanalyzed-overload-seq-accum #_(s/seq-of ::unanalyzed-overload) + unanalyzed-overload-seq #_(s/seq-of ::unanalyzed-overload) + i|overload-basis #_index?] + (when-not (or (empty? unanalyzed-overload-seq-accum) (empty? unanalyzed-overload-seq)) + (let [prev-overload (uc/last unanalyzed-overload-seq-accum) + overload (uc/first unanalyzed-overload-seq)] + (reducei-2 + (c/fn [_ arg|type|prev arg|type i|arg] + (when ;; NOTE could use `compare-arg-types` here instead of `t/compare` if we want a more + ;; efficient combinatoric tree dispatch + (= 1 (t/compare arg|type|prev arg|type)) + ;; TODO provide code context, line number, etc. + (err! (istr "At overload ~{i|overload-basis}, arg ~{i|arg}: type is not in monotonically increasing order in terms of `t/compare`") + (umap/om :prev-overload prev-overload + :overload overload + :prev-type arg|type|prev + :type arg|type)))) + (:arg-types prev-overload) + (:arg-types overload))))) + ;; ===== Direct dispatch ===== ;; ;; ----- Direct dispatch: `reify` ---- ;; @@ -345,15 +397,18 @@ #_> #_(objects-of type?)] (apply uarr/*<> (:arg-types (get @*types-decl overload-index)))) -(c/defn types-decl>ftype - [*types-decl #_(atom-of (vec-of ::types-decl-datum)), fn|output-type #_t/type? #_> #_(vec-of ...)] - (->> @*types-decl +(c/defn type-data>ftype [type-data #_(vec-of ::types-decl-datum), fn|output-type #_t/type?] + (->> type-data (uc/lmap (c/fn [{:keys [arg-types pre-type output-type]}] - (cond-> arg-types - pre-type (conj :| pre-type) - output-type (conj :> output-type)))) + (cond-> arg-types + pre-type (conj :| pre-type) + output-type (conj :> output-type)))) (apply t/ftype fn|output-type))) +(c/defn types-decl>ftype + [*types-decl #_(atom-of (vec-of ::types-decl-datum)), fn|output-type #_t/type? #_> #_(vec-of ...)] + (type-data>ftype @*types-decl fn|output-type)) + (c/defn- dedupe-types-decl-data [fn|ns-name fn|name types-decl-data] (reduce (let [*prev-datum (volatile! nil)] (c/fn [data {:as datum :keys [arg-types]}] @@ -566,60 +621,6 @@ ;; ===== End dynamic dispatch ===== ;; -;; ===== Arg type comparison ===== ;; - -(c/defn compare-arg-types [t0 #_t/type?, t1 #_t/type? #_> #_ucomp/comparison?] - (if-let [c0 (uana/sort-guide t0)] - (if-let [c1 (uana/sort-guide t1)] - (ifs (< c0 c1) -1 (> c0 c1) 1 0) - -1) - (if-let [c1 (uana/sort-guide t1)] - 1 - (uset/normalize-comparison (t/compare t0 t1))))) - -(c/defn compare-args-types [arg-types0 #_(s/vec-of t/type?) arg-types1 #_(s/vec-of t/type?)] - (let [ct-comparison (compare (count arg-types0) (count arg-types1))] - (if (zero? ct-comparison) - (reduce-2 - (c/fn [^long c t0 t1] - (let [c' (long (compare-arg-types t0 t1))] - (case c' - -1 (case c 1 (reduced 0) c') - 0 c - 1 (case c -1 (reduced 0) c')))) - 0 - arg-types0 arg-types1) - ct-comparison))) - -;; TODO spec -(c/defn assert-monotonically-increasing-types! - "Asserts that each type in an overload of the same arity and arg-position are in monotonically - increasing order in terms of `t/compare`. - - Since its inputs are sorted via `compare-args-types`, this only need check the last overload of - `unanalyzed-overload-seq-accum` and the first overload of `unanalyzed-overload-seq`." - [unanalyzed-overload-seq-accum #_(s/seq-of ::unanalyzed-overload) - unanalyzed-overload-seq #_(s/seq-of ::unanalyzed-overload) - i|overload-basis #_index?] - (when-not (or (empty? unanalyzed-overload-seq-accum) (empty? unanalyzed-overload-seq)) - (let [prev-overload (uc/last unanalyzed-overload-seq-accum) - overload (uc/first unanalyzed-overload-seq)] - (reducei-2 - (c/fn [_ arg|type|prev arg|type i|arg] - (when ;; NOTE could use `compare-arg-types` here instead of `t/compare` if we want a more - ;; efficient combinatoric tree dispatch - (= 1 (t/compare arg|type|prev arg|type)) - ;; TODO provide code context, line number, etc. - (err! (istr "At overload ~{i|overload-basis}, arg ~{i|arg}: type is not in monotonically increasing order in terms of `t/compare`") - (umap/om :prev-overload prev-overload - :overload overload - :prev-type arg|type|prev - :type arg|type)))) - (:arg-types prev-overload) - (:arg-types overload))))) - -;; ===== End arg type comparison ===== ;; - (defns- overloads-basis>unanalyzed-overload-seq [{:as in {args [:args _] varargs [:varargs _] @@ -712,11 +713,16 @@ fn|name (if (= kind :extend-defn!) (-> fn|extended-name >name symbol) fn|name) + fn|var (when (= kind :extend-defn!) + (if-let [v (uvar/resolve *ns* fn|extended-name)] + v + (err! "Cannot extend a `t/defn` that has not been defined" + {:sym fn|extended-name}))) gen-gensym-base (ufgen/>reproducible-gensym|generator) gen-gensym (c/fn [x] (symbol (str (gen-gensym-base x) "__"))) opts (kw-map compilation-mode gen-gensym kind lang) inline? (-> (if (= kind :extend-defn!) - (-> (uvar/resolve *ns* fn|extended-name) meta :inline) + (-> fn|var meta :inline) (:inline fn|meta)) (s/validate (t/? t/boolean?))) fn|meta (if inline? @@ -729,7 +735,7 @@ fn|output-type (eval fn|output-type|form) unanalyzed-overloads (overloads-bases>unanalyzed-overloads overloads-bases kind fn|output-type|form fn|output-type) - fn|type (unanalyzed-overloads>fn|type unanalyzed-overloads fn|output-type) + fn|type (type-data>ftype unanalyzed-overloads fn|output-type) fn|types-decl-name (symbol (str fn|name "|__types")) fn|globals (kw-map fn|ns-name fn|name fn|meta fn|type fn|output-type|form fn|output-type fn|types-decl-name) diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index 46376249..632a2ee4 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -22,11 +22,11 @@ :refer [->num ->num&]] ;; TODO TYPED excise #_[quantum.core.data.numeric :as dn] - [quantum.core.data.primitive :as p] [quantum.core.type :as t] ;; TODO TYPED excise [quantum.untyped.core.logic - :refer [ifs]]) + :refer [ifs]] + [quantum.untyped.core.type :as ut]) #?(:clj (:import [quantum.core Numeric]))) @@ -51,7 +51,7 @@ {:incorporated '{clojure.lang.Util/identical "9/27/2018" clojure.core/identical? "9/27/2018" cljs.core/identical? "9/27/2018"}} - > p/boolean? + > ut/boolean? ([x t/any?] true) ; everything is self-identical #?(:clj ([a t/ref?, b t/ref?] (clojure.lang.Util/identical a b)) :cljs ([a t/any?, b t/any?] (cljs.core/identical? a b)))) @@ -59,8 +59,8 @@ ;; TODO add variadic arity (t/defn ^:inline not== "Tests identity-inequality." - > p/boolean? - ([x t/any?] false) ; everything is self-identical + > ut/boolean? + ([x t/any?] false) ; nothing is self-non-identical #?(:clj ([a t/ref?, b t/ref?] (Numeric/nonIdentical a b)) :cljs ([a t/any?, b t/any?] (js* "(~{} !== ~{})" a b)))) @@ -70,7 +70,7 @@ {:incorporated '{clojure.lang.Util/equiv "9/27/2018" clojure.core/= "9/27/2018" cljs.core/= "9/27/2018"}} - > p/boolean? + > ut/boolean? ([x t/any?] true)) ; everything is self-equal ;; TODO add variadic arity @@ -78,36 +78,36 @@ "Tests value-inequality." {:incorporated '{clojure.core/not= "9/27/2018" cljs.core/not= "9/27/2018"}} - > p/boolean? - ([x t/any?] false)) ; everything is self-equal + > ut/boolean? + ([x t/any?] false)) ; nothing is self-unequal ; ===== `<` ===== ; ;; TODO add variadic arity (t/defn ^:inline < "Numeric less-than comparison." - > p/boolean?) + > ut/boolean?) ; ===== `<=` ===== ; ;; TODO add variadic arity (t/defn ^:inline <= "Numeric less-than-or-value-equal comparison." - > p/boolean?) + > ut/boolean?) ; ===== `>` ===== ; ;; TODO add variadic arity (t/defn ^:inline > "Numeric greater-than comparison." - > p/boolean?) + > ut/boolean?) ; ===== `>=` ===== ; ;; TODO add variadic arity (t/defn ^:inline >= "Numeric greater-than-or-value-equal comparison." - > p/boolean?) + > ut/boolean?) ; ===== `compare` ===== ; diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 2afbfb3b..bd0051a1 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -137,7 +137,6 @@ #?(:clj (var/def- min-float (Numeric/negate Float/MAX_VALUE))) (var/def- min-double (- #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) -;; TODO TYPED for some reason it's not figuring out the type of `min-float` and `min-double` (t/defn ^:inline >min-value #?(:clj ([x byte? > (type x)] Byte/MIN_VALUE)) #?(:clj ([x short? > (type x)] Short/MIN_VALUE)) From e0fef5bca2d8912ccf4ab116d9412df6b38086d4 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 13 Oct 2018 12:40:12 -0600 Subject: [PATCH 507/810] Allows t/declare essentially --- resources-dev/defnt.cljc | 35 ++++++------ src-untyped/quantum/untyped/core/defnt.cljc | 2 +- src-untyped/quantum/untyped/core/specs.cljc | 29 +++++----- src-untyped/quantum/untyped/core/type.cljc | 3 +- .../quantum/untyped/core/type/defnt.cljc | 57 ++++++++++--------- src/quantum/core/compare/core.cljc | 47 +++------------ 6 files changed, 69 insertions(+), 104 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 0e237c02..daa07391 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -59,15 +59,7 @@ TODO: Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - - t/extend-defn! - [ ] Should we trigger a recompilation of everything that depended on that `t/defn` because the - input-types and output-types will have both gotten bigger? (Maybe not on that overload but - still.) - - This will be a more advanced feature. For now we just accept that we might have some odd - behavior around extending `t/defn`s. - [1a] It should warn when creating another definition with the same input type combination. - [1b] `assert-monotonically-increasing-types!` needs to be enforced - [2] - t/numerically : e.g. a double representing exactly what a float is able to represent + [1] - t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. - t/numerically-integer? - In order to have this, you have to have comparisons in place @@ -80,26 +72,26 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - numeric definitions - numeric ranges - numeric characteristics - [ ] - t/value-of - - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` - [ ] - (comp/t== x) - - dependent type such that the passed input must be identical to x - [3] - t/input-type + [2] - t/input-type - `(t/input-type >namespace :?)` meaning the possible input types to the first input to `>namespace` - `(t/input-type reduce :_ :_ :?)` - This is pretty simple with the current dependent type system - Then if those fns ever get extended then it should trigger a chain-reaction of recompilations - [4] - t/output-type + [3] - t/output-type - This is pretty simple with the current dependent type system - [ ] - Non-boxed `def`s: `(var/def- min-float (Numeric/negate Float/MAX_VALUE))` - [5] - Direct dispatch needs to actually work correctly in `t/defn` - [6] - No trailing `>` means `> ?` + [4] - Direct dispatch needs to actually work correctly in `t/defn` + [5] - No trailing `>` means `> ?` - ? : type inference - use logic programming and variable unification e.g. `?1` `?2` ? - For this situation: `?` is `(t/- dc/counted?)` ([n dn/std-integer?, xs dc/counted?] (count xs)) ([n dn/std-integer?, xs ?] ...) + [ ] - t/value-of + - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` + [ ] - (comp/t== x) + - dependent type such that the passed input must be identical to x + [ ] - Non-boxed `def`s: `(var/def- min-float (Numeric/negate Float/MAX_VALUE))` - `(t/validate x (t/* t/string?))` for `(t/* t/string?)` needs to be more performant - Don't re-create type on each call - Type Logic and Predicates @@ -198,11 +190,16 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - t/defmacro - t/deftype - t/dotyped + - t/extend-defn! + [ ] Should we trigger a recompilation of everything that depended on that `t/defn` because the + input-types and output-types will have both gotten bigger? (Maybe not on that overload but + still.) + - This will be a more advanced feature. For now we just accept that we might have some odd + behavior around extending `t/defn`s. - lazy compilation especially around `t/input-type` - equivalence of typed predicates (i.e. that which is `t/<=` `(t/fn [x t/any? :> p/boolean?])`) to types: - [xs (t/fn [x (t/isa? clojure.lang.Range)] ...)] - - No return value means that it should infer - NOTE on namespace organization: - The initial definition of conversion functions belongs in the namespace that their destination type belongs in, and it may be extended in every namespace in which there is a source type. diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index 8f5edeb5..44b5f5e1 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -146,7 +146,7 @@ :quantum.core.specs/docstring (s/? :quantum.core.specs/docstring) :quantum.core.specs/pre-meta :quantum.core.specs/pre-meta :quantum.core.defnt/output-spec :quantum.core.defnt/output-spec - :quantum.core.defnt/overloads :quantum.core.defnt/overloads)) + :quantum.core.defnt/overloads (s/? :quantum.core.defnt/overloads))) (uss/fn-like|postchecks|gen :quantum.core.defnt/overloads) :quantum.core.defnt/postchecks)) diff --git a/src-untyped/quantum/untyped/core/specs.cljc b/src-untyped/quantum/untyped/core/specs.cljc index 77211d59..ccf80e23 100644 --- a/src-untyped/quantum/untyped/core/specs.cljc +++ b/src-untyped/quantum/untyped/core/specs.cljc @@ -145,20 +145,21 @@ (defn fn-like|postchecks|gen [overloads-ident] (s/and (s/conformer (fn [v] - (let [[overloads-k overloads-v] (get v overloads-ident) - overloads - (-> (case overloads-k - :overload-1 {:overloads [overloads-v]} - :overload-n overloads-v) - (update :overloads - (fnl mapv - (fn1 update :body - (fn [[k v]] - (case k - :body {:body v} - :prepost+body v))))))] - (assoc v :quantum.core.specs/post-meta (:quantum.core.specs/post-meta overloads) - overloads-ident (get overloads :overloads))))) + (let [[overloads-k overloads-v :as overloads] (get v overloads-ident) + overloads' + (when overloads + (-> (case overloads-k + :overload-1 {:overloads [overloads-v]} + :overload-n overloads-v) + (update :overloads + (fnl mapv + (fn1 update :body + (fn [[k v]] + (case k + :body {:body v} + :prepost+body v)))))))] + (assoc v :quantum.core.specs/post-meta (:quantum.core.specs/post-meta overloads') + overloads-ident (get overloads' :overloads))))) :quantum.core.specs/fn|unique-doc :quantum.core.specs/fn|unique-meta ;; TODO validate metadata like return value etc. diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 863d42ad..d7959746 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -425,9 +425,8 @@ ;; ===== `t/ftype` ===== ;; -(defn ftype [out-type arity & arities] +(defn ftype [out-type & arities-form] (let [name- nil - arities-form (cons arity arities) arities (->> arities-form (uc/map+ (c/fn [arity-form] (-> (us/conform ::fn-type|arity arity-form) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index b3ea98ab..620a1c7a 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -718,9 +718,6 @@ v (err! "Cannot extend a `t/defn` that has not been defined" {:sym fn|extended-name}))) - gen-gensym-base (ufgen/>reproducible-gensym|generator) - gen-gensym (c/fn [x] (symbol (str (gen-gensym-base x) "__"))) - opts (kw-map compilation-mode gen-gensym kind lang) inline? (-> (if (= kind :extend-defn!) (-> fn|var meta :inline) (:inline fn|meta)) @@ -732,31 +729,35 @@ fn|meta) fn|output-type|form (or (second output-spec) `t/any?) ;; TODO this needs to be analyzed for dependent types referring to local vars - fn|output-type (eval fn|output-type|form) - unanalyzed-overloads (overloads-bases>unanalyzed-overloads - overloads-bases kind fn|output-type|form fn|output-type) - fn|type (type-data>ftype unanalyzed-overloads fn|output-type) - fn|types-decl-name (symbol (str fn|name "|__types")) - fn|globals (kw-map fn|ns-name fn|name fn|meta fn|type fn|output-type|form - fn|output-type fn|types-decl-name) - ;; Specifically overloads that were generated during this execution of this function - overloads (->> unanalyzed-overloads - (uc/map #(unanalyzed-overload>overload % opts fn|globals))) - types-decl (>types-decl opts fn|globals overloads) - direct-dispatch (>direct-dispatch opts fn|globals overloads types-decl) - dynamic-dispatch (>dynamic-dispatch-fn|form opts fn|globals types-decl) - fn-codelist - (case lang - :clj (->> `[~@(when (not= kind :extend-defn!) [`(declare ~fn|name)]) ; for recursion - ~@(some-> (:form types-decl) vector) - ~@(:form direct-dispatch) - ~dynamic-dispatch] - (remove nil?)) - :cljs (TODO)) - code (case kind - :fn (TODO) - (:defn :extend-defn!) `(~'do ~@fn-codelist))] - code)) + fn|output-type (eval fn|output-type|form)] + (println "overloads-bases" overloads-bases) + (if (empty? overloads-bases) + `(declare ~(with-meta fn|name + (assoc fn|meta :quantum.core.type/type `(t/ftype ~(>form fn|output-type))))) + (let [gen-gensym-base (ufgen/>reproducible-gensym|generator) + gen-gensym (c/fn [x] (symbol (str (gen-gensym-base x) "__"))) + opts (kw-map compilation-mode gen-gensym kind lang) + unanalyzed-overloads (overloads-bases>unanalyzed-overloads + overloads-bases kind fn|output-type|form fn|output-type) + fn|type (type-data>ftype unanalyzed-overloads fn|output-type) + fn|types-decl-name (symbol (str fn|name "|__types")) + fn|globals (kw-map fn|ns-name fn|name fn|meta fn|type fn|output-type|form + fn|output-type fn|types-decl-name) + ;; Specifically overloads that were generated during this execution of this function + overloads (->> unanalyzed-overloads + (uc/map #(unanalyzed-overload>overload % opts fn|globals))) + types-decl (>types-decl opts fn|globals overloads) + direct-dispatch (>direct-dispatch opts fn|globals overloads types-decl) + dynamic-dispatch (>dynamic-dispatch-fn|form opts fn|globals types-decl) + fn-codelist + (->> `[~@(when (not= kind :extend-defn!) [`(declare ~fn|name)]) ; For recursion + ~@(some-> (:form types-decl) vector) + ~@(:form direct-dispatch) + ~dynamic-dispatch] + (remove nil?))] + (case kind + :fn (TODO) + (:defn :extend-defn!) `(do ~@fn-codelist)))))) #?(:clj (defmacro fn diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index 632a2ee4..aa8e5e37 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -26,7 +26,9 @@ ;; TODO TYPED excise [quantum.untyped.core.logic :refer [ifs]] - [quantum.untyped.core.type :as ut]) + [quantum.untyped.core.type :as ut] + ;; TODO TYPED excise + [quantum.untyped.core.vars :as var]) #?(:clj (:import [quantum.core Numeric]))) @@ -115,9 +117,9 @@ "That which is comparable to its own 'concrete type' (i.e. class)." #?(:clj (t/isa? java.lang.Comparable) ;; TODO other things are comparable; really it depends on the two objects in question - :cljs (t/or p/nil? (t/isa? cljs.core/IComparable)))) + :cljs (t/or ut/nil? (t/isa? cljs.core/IComparable)))) -(def comparison? #?(:clj p/int? :cljs p/double?)) +(def comparison? #?(:clj ut/int? :cljs ut/double?)) (t/defn ^:inline compare "Logical (not numeric) comparison. @@ -168,6 +170,8 @@ static public int compare(Object k1, Object k2){ ; ----- `comp<` ----- ; #?(:clj (defnt' ^boolean comp<-bin + "Returns true if args are in monotonically increasing order according to `compare`, + otherwise false." ([^comparable? x] true) ([#{byte char short int long float double} x #{byte char short int long float double} y] (< x y)) @@ -179,12 +183,6 @@ static public int compare(Object k1, Object k2){ ) :cljs (defn comp<-bin ([x] true) ([x y] (< (compare x y) 0)))) -#?(:clj (variadic-predicate-proxy - ^{:doc "Returns true if args are in monotonically increasing order - according to `compare`, otherwise false."} - comp< comp<-bin)) -#?(:clj (variadic-predicate-proxy comp<& comp<-bin&)) - ; ----- `comp<=` ----- ; #?(:clj (defnt' ^boolean comp<=-bin @@ -207,17 +205,6 @@ static public int compare(Object k1, Object k2){ ; ===== `>` ===== ; -#?(:clj (defnt' ^boolean >-bin - ([#{byte char short int long float double} x] true) - ([#{byte char short int long float double} x - #{byte char short int long float double} y] (Numeric/gt x y)) - ; TODO numbers, but not nil - ) - :cljs (defn >-bin ([x] true) ([x y] (core/> x y)))) - -#?(:clj (variadic-predicate-proxy > >-bin)) -#?(:clj (variadic-predicate-proxy >& >-bin&)) - ; ----- `comp>` ----- ; #?(:clj (defnt' ^boolean comp>-bin @@ -333,26 +320,6 @@ static public int compare(Object k1, Object k2){ ^{:doc "Returns the greatest of the arguments according to `compare`, preferring later values."} comp-max comp-max-bin)) -#?(:clj (variadic-proxy comp-max& comp-max-bin&)) - -; ----- `comp-max` ----- ; - -; ===== PRIMITIVE `max`|`min` ===== ; - -#?(:clj (defnt' ^byte min-byte ([] Byte/MIN_VALUE ) ([^byte a] a) ([^byte a ^byte b] (min a b)))) -#?(:clj (defnt' ^byte max-byte ([] Byte/MAX_VALUE ) ([^byte a] a) ([^byte a ^byte b] (max a b)))) -#?(:clj (defnt' ^char min-char ([] Character/MIN_VALUE ) ([^char a] a) ([^char a ^char b] (min a b)))) -#?(:clj (defnt' ^char max-char ([] Character/MAX_VALUE ) ([^char a] a) ([^char a ^char b] (max a b)))) -#?(:clj (defnt' ^short min-short ([] Short/MIN_VALUE ) ([^short a] a) ([^short a ^short b] (min a b)))) -#?(:clj (defnt' ^short max-short ([] Short/MAX_VALUE ) ([^short a] a) ([^short a ^short b] (max a b)))) -#?(:clj (defnt' ^int min-int ([] Integer/MIN_VALUE ) ([^int a] a) ([^int a ^int b] (min a b)))) -#?(:clj (defnt' ^int max-int ([] Integer/MAX_VALUE ) ([^int a] a) ([^int a ^int b] (max a b)))) -#?(:clj (defnt' ^long min-long ([] Long/MIN_VALUE ) ([^long a] a) ([^long a ^long b] (min a b)))) -#?(:clj (defnt' ^long max-long ([] Long/MAX_VALUE ) ([^long a] a) ([^long a ^long b] (max a b)))) -#?(:clj (defnt' ^float min-float ([] Float/NEGATIVE_INFINITY ) ([^float a] a) ([^float a ^float b] (min a b)))) -#?(:clj (defnt' ^float max-float ([] Float/POSITIVE_INFINITY ) ([^float a] a) ([^float a ^float b] (max a b)))) -#?(:clj (defnt' ^double min-double ([] Double/NEGATIVE_INFINITY) ([^double a] a) ([^double a ^double b] (min a b)))) -#?(:clj (defnt' ^double max-double ([] Double/POSITIVE_INFINITY) ([^double a] a) ([^double a ^double b] (max a b)))) ; ===== extreme-`key` ===== ; From 519151e003162c5d59aac77d57825131a52eb073 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 13 Oct 2018 12:53:13 -0600 Subject: [PATCH 508/810] All of `quantum.core.data.primitive` compiles! --- resources-dev/defnt.cljc | 4 ++-- src-untyped/quantum/untyped/core/type/defnt.cljc | 15 ++++++++------- src-untyped/quantum/untyped/core/vars.cljc | 8 ++++++++ src/quantum/core/data/primitive.cljc | 2 +- src/quantum/core/vars.cljc | 2 +- 5 files changed, 20 insertions(+), 11 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index daa07391..e76bf535 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -150,11 +150,11 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - expressions (`quantum.untyped.core.analyze.expr`) - comparison of `t/fn`s is probably possible? - t/def - - TODO what would this even look like? + - TODO what would this even look like? I guess it would just declare the sym, meta, and type + - Without an argument, it would work like `declare` - t/fn - t/ftype - conditionally optional arities etc. - - t/declare - ^:dyn - `(name (read ...))` fails at compile-time; we want it to at least try at runtime. So instead we annotate like `(name ^:dyn (read ...))`, meaning figure out at runtime what the out-type of diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 620a1c7a..844a1066 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -478,14 +478,14 @@ {:name fn|types-decl-name :form (if (= kind :extend-defn!) `(reset! ~(uid/qualify fn|ns-name fn|types-decl-name) ~(>form types-decl-data)) - `(def ~fn|types-decl-name (atom ~(>form types-decl-data)))) + `(defonce ~fn|types-decl-name (atom ~(>form types-decl-data)))) :data types-decl-data :indexed-data types-decl-indexed-data} ;; In non-test cases, it's far cheaper to not have to convert the types to a ;; compiler-readable form and then re-evaluate them again (do (if (= kind :extend-defn!) (reset! (>types-decl-ref fn|globals) types-decl-data) - (intern (>symbol *ns*) fn|types-decl-name (atom types-decl-data))) + (uvar/intern-once! fn|ns-name fn|types-decl-name (atom types-decl-data))) {:name fn|types-decl-name :form nil :data types-decl-data @@ -729,18 +729,19 @@ fn|meta) fn|output-type|form (or (second output-spec) `t/any?) ;; TODO this needs to be analyzed for dependent types referring to local vars - fn|output-type (eval fn|output-type|form)] - (println "overloads-bases" overloads-bases) + fn|output-type (eval fn|output-type|form) + fn|types-decl-name (symbol (str fn|name "|__types"))] (if (empty? overloads-bases) - `(declare ~(with-meta fn|name - (assoc fn|meta :quantum.core.type/type `(t/ftype ~(>form fn|output-type))))) + `(do (declare + ~(with-meta fn|name + (assoc fn|meta :quantum.core.type/type `(t/ftype ~(>form fn|output-type))))) + (defonce ~fn|types-decl-name (atom []))) (let [gen-gensym-base (ufgen/>reproducible-gensym|generator) gen-gensym (c/fn [x] (symbol (str (gen-gensym-base x) "__"))) opts (kw-map compilation-mode gen-gensym kind lang) unanalyzed-overloads (overloads-bases>unanalyzed-overloads overloads-bases kind fn|output-type|form fn|output-type) fn|type (type-data>ftype unanalyzed-overloads fn|output-type) - fn|types-decl-name (symbol (str fn|name "|__types")) fn|globals (kw-map fn|ns-name fn|name fn|meta fn|type fn|output-type|form fn|output-type fn|types-decl-name) ;; Specifically overloads that were generated during this execution of this function diff --git a/src-untyped/quantum/untyped/core/vars.cljc b/src-untyped/quantum/untyped/core/vars.cljc index a67400c0..f53ca368 100644 --- a/src-untyped/quantum/untyped/core/vars.cljc +++ b/src-untyped/quantum/untyped/core/vars.cljc @@ -132,3 +132,11 @@ (= sym 'in-ns) #'core/in-ns :else (.getMapping ^clojure.lang.Namespace ns-val sym))))))) + +(def intern! intern) + +(defn intern-once! + "Interns a var corresponding to ->`sym` only if the var does not have a value." + ([ns-sym #_symbol?, sym #_symbol?, v #_t/ref?] + (or (resolve (find-ns ns-sym) sym) + (intern! ns-sym sym v)))) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index bd0051a1..bc76e056 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -194,7 +194,7 @@ #?(:clj (t/extend-defn! ccomp/not== - ([a boolean? , b boolean?] (Numbers/neq a b)) + ([a boolean? , b boolean?] (Numeric/neq a b)) ([a boolean? , b (t/- primitive? boolean?)] false) ([a (t/- primitive? boolean?), b boolean?] false) ([a numeric? , b numeric?] (Numeric/neq a b)))) diff --git a/src/quantum/core/vars.cljc b/src/quantum/core/vars.cljc index 6a4d0cf4..2d443145 100644 --- a/src/quantum/core/vars.cljc +++ b/src/quantum/core/vars.cljc @@ -282,4 +282,4 @@ #?(:clj (defaliases uns ns>alias ns-name>alias clear-ns-interns! search-var ns-exclude with-ns with-temp-ns import-static - load-ns load-nss loaded-libs load-lib! load-package! load-dep! assert-ns-aliased ?resolve)) + load-ns load-nss loaded-libs load-lib! load-package! load-dep! assert-ns-aliased ?resolve intern! intern-once!)) From d2376c964ec64dee189c7e221b8abd00298b0217 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 13 Oct 2018 12:59:13 -0600 Subject: [PATCH 509/810] `defonce` should not happen --- resources-dev/defnt.cljc | 1 + src-untyped/quantum/untyped/core/type/defnt.cljc | 6 +++--- src/quantum/core/data/primitive.cljc | 4 ++-- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index e76bf535..5b15bfaa 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -59,6 +59,7 @@ TODO: Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: + [0] - Reflection warning, /Users/alexander/Code/quantum/src/quantum/core/data/primitive.cljc:250:1 - call to method invoke on quantum.core.compare.core.byte>boolean can't be resolved (no such method). [1] - t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. - t/numerically-integer? diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 844a1066..39e17f6f 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -478,14 +478,14 @@ {:name fn|types-decl-name :form (if (= kind :extend-defn!) `(reset! ~(uid/qualify fn|ns-name fn|types-decl-name) ~(>form types-decl-data)) - `(defonce ~fn|types-decl-name (atom ~(>form types-decl-data)))) + `(def ~fn|types-decl-name (atom ~(>form types-decl-data)))) :data types-decl-data :indexed-data types-decl-indexed-data} ;; In non-test cases, it's far cheaper to not have to convert the types to a ;; compiler-readable form and then re-evaluate them again (do (if (= kind :extend-defn!) (reset! (>types-decl-ref fn|globals) types-decl-data) - (uvar/intern-once! fn|ns-name fn|types-decl-name (atom types-decl-data))) + (intern fn|ns-name fn|types-decl-name (atom types-decl-data))) {:name fn|types-decl-name :form nil :data types-decl-data @@ -735,7 +735,7 @@ `(do (declare ~(with-meta fn|name (assoc fn|meta :quantum.core.type/type `(t/ftype ~(>form fn|output-type))))) - (defonce ~fn|types-decl-name (atom []))) + (def ~fn|types-decl-name (atom []))) (let [gen-gensym-base (ufgen/>reproducible-gensym|generator) gen-gensym (c/fn [x] (symbol (str (gen-gensym-base x) "__"))) opts (kw-map compilation-mode gen-gensym kind lang) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index bc76e056..337e65d1 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -247,7 +247,7 @@ ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) ) -(t/extend-defn! ccomp/>= +(macroexpand '(t/extend-defn! ccomp/>= ( [x numeric?] true) #?(:clj (^:in [a long? , b long?] (Numbers/gte a b))) #?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/gte a b))) @@ -259,4 +259,4 @@ #?(:cljs ( [a numeric? , b numeric?] (cljs.core/>= a b))) ;; TODO rest of numbers, but not nil ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) - ) + )) From 81bb1be9cdb473f54a6b1eae8d5f112d79b678ea Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 13 Oct 2018 14:03:15 -0600 Subject: [PATCH 510/810] Ensure no duplicate overloads get defined --- .../quantum/untyped/core/type/compare.cljc | 4 +- .../quantum/untyped/core/type/defnt.cljc | 166 ++++++++---------- .../quantum/test/untyped/core/type/defnt.cljc | 2 +- 3 files changed, 78 insertions(+), 94 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index fcce56bb..95b48d15 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -457,7 +457,9 @@ Commutative in the 2-ary arity." ([cs _ #_(seq-of uset/comparison?) > uset/comparison?] ;; TODO it's possible to `reduced` early here depending - (reduce (fn [c' c] (combine-comparisons c' c)) (first cs) (rest cs))) + (if (empty? cs) + =ident + (reduce (fn [c' c] (combine-comparisons c' c)) (first cs) (rest cs)))) ([c0 uset/comparison?, c1 uset/comparison? > uset/comparison?] (case (long c0) -1 (case (long c1) -1 ident) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 39e17f6f..04b8a6d1 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -150,6 +150,11 @@ (s/kv {:form t/any? :direct-dispatch-data-seq (s/vec-of ::direct-dispatch-data)})) +(s/def ::type-datum + (s/kv {:arg-types (s/vec-of t/type?) + :pre-type t/type? + :output-type t/type?})) + (s/def ::types-decl-datum (s/kv {:id ::overload|id :ns-sym simple-symbol? @@ -170,8 +175,7 @@ ;; Sorted by overload-index :data (s/vec-of ::types-decl-datum) ;; Sorted by overload-index - :indexed-data (s/vec-of ::indexed-types-decl-datum) - :first-current-overload-id ::overload|id})) + :indexed-data (s/vec-of ::indexed-types-decl-datum)})) #_(:clj (c/defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] @@ -297,32 +301,18 @@ arg-types0 arg-types1) ct-comparison))) -;; TODO spec -(c/defn assert-monotonically-increasing-types! - "Asserts that each type in an overload of the same arity and arg-position are in monotonically - increasing order in terms of `t/compare`. - - Since its inputs are sorted via `compare-args-types`, this only need check the last overload of - `unanalyzed-overload-seq-accum` and the first overload of `unanalyzed-overload-seq`." - [unanalyzed-overload-seq-accum #_(s/seq-of ::unanalyzed-overload) - unanalyzed-overload-seq #_(s/seq-of ::unanalyzed-overload) - i|overload-basis #_index?] - (when-not (or (empty? unanalyzed-overload-seq-accum) (empty? unanalyzed-overload-seq)) - (let [prev-overload (uc/last unanalyzed-overload-seq-accum) - overload (uc/first unanalyzed-overload-seq)] - (reducei-2 - (c/fn [_ arg|type|prev arg|type i|arg] - (when ;; NOTE could use `compare-arg-types` here instead of `t/compare` if we want a more - ;; efficient combinatoric tree dispatch - (= 1 (t/compare arg|type|prev arg|type)) - ;; TODO provide code context, line number, etc. - (err! (istr "At overload ~{i|overload-basis}, arg ~{i|arg}: type is not in monotonically increasing order in terms of `t/compare`") - (umap/om :prev-overload prev-overload - :overload overload - :prev-type arg|type|prev - :type arg|type)))) - (:arg-types prev-overload) - (:arg-types overload))))) +(c/defn- dedupe-type-data [on-dupe #_fn?, type-data #_(vec-of ::types-decl-datum)] + (reduce (let [*prev-datum (volatile! nil)] + (c/fn [data {:as datum :keys [arg-types]}] + (with-do + (ifs (nil? @*prev-datum) + (conj data datum) + (= uset/=ident (utcomp/compare-inputs (:arg-types @*prev-datum) arg-types)) + (on-dupe data @*prev-datum datum) + (conj data datum)) + (vreset! *prev-datum datum)))) + [] + type-data)) ;; ===== Direct dispatch ===== ;; @@ -397,12 +387,12 @@ #_> #_(objects-of type?)] (apply uarr/*<> (:arg-types (get @*types-decl overload-index)))) -(c/defn type-data>ftype [type-data #_(vec-of ::types-decl-datum), fn|output-type #_t/type?] +(c/defn type-data>ftype [type-data #_(vec-of ::type-datum), fn|output-type #_t/type?] (->> type-data (uc/lmap (c/fn [{:keys [arg-types pre-type output-type]}] - (cond-> arg-types - pre-type (conj :| pre-type) - output-type (conj :> output-type)))) + (cond-> arg-types + pre-type (conj :| pre-type) + output-type (conj :> output-type)))) (apply t/ftype fn|output-type))) (c/defn types-decl>ftype @@ -410,22 +400,14 @@ (type-data>ftype @*types-decl fn|output-type)) (c/defn- dedupe-types-decl-data [fn|ns-name fn|name types-decl-data] - (reduce (let [*prev-datum (volatile! nil)] - (c/fn [data {:as datum :keys [arg-types]}] - (with-do - (ifs (nil? @*prev-datum) - (conj data datum) - (= uset/=ident (utcomp/compare-inputs - (:arg-types @*prev-datum) arg-types)) - (do (ulog/ppr :warn (str "Overwriting type overload for `" - (uid/qualify fn|ns-name fn|name) "`; arg types:") - arg-types) - (-> data pop (conj (assoc @*prev-datum :ns-sym (:ns-sym datum) - :overload (:overload datum))))) - (conj data datum)) - (vreset! *prev-datum datum)))) - [] - types-decl-data)) + (->> types-decl-data + (dedupe-type-data + (c/fn [data prev-datum datum] + (ulog/ppr :warn + (str "Overwriting type overload for `" (uid/qualify fn|ns-name fn|name) "`") + {:arg-types-prev (:arg-types prev-datum) :arg-types (:arg-types datum)}) + (-> data pop + (conj (assoc prev-datum :ns-sym (:ns-sym datum) :overload (:overload datum)))))))) (defns- >types-decl [{:as opts :keys [kind _]} ::opts @@ -454,8 +436,6 @@ (uc/map (c/fn [{:as datum :keys [id]}] (assoc datum :overload (get overloads (- id first-current-overload-id))))) - ;; TODO here `extend-defn!` should probably: - ;; - Use `assert-monotonically-increasing-types!` (sort-by identity (c/fn [datum0 datum1] (let [c (compare-args-types (:arg-types datum0) (:arg-types datum1))] @@ -477,8 +457,10 @@ (if (-> opts :compilation-mode (= :test)) {:name fn|types-decl-name :form (if (= kind :extend-defn!) - `(reset! ~(uid/qualify fn|ns-name fn|types-decl-name) ~(>form types-decl-data)) - `(def ~fn|types-decl-name (atom ~(>form types-decl-data)))) + `(reset! ~(uid/qualify fn|ns-name fn|types-decl-name) + ~(->> types-decl-data (uc/map #(dissoc % :ns-sym)) >form)) + `(def ~fn|types-decl-name + (atom ~(->> types-decl-data (uc/map #(dissoc % :ns-sym)) >form)))) :data types-decl-data :indexed-data types-decl-indexed-data} ;; In non-test cases, it's far cheaper to not have to convert the types to a @@ -653,49 +635,48 @@ ;; TODO this assertion is purely temporary until destructuring is ;; supported (assert (-> varargs :binding-form first (= :sym)))) - arg-types|expanded-seq ; split, primitivized, and (if not `extend-defn!`) sorted + arg-types|expanded-seq+ ; split and primitivized; not yet sorted (->> (uana/analyze-arg-syms {} (zipmap arg-bindings arg-types|form) output-type|form) - (uc/map (c/fn [{:keys [env out-type-node]}] - (let [output-type (:type out-type-node) - arg-env (->> env :opts :arg-env deref) - arg-types (->> arg-bindings (uc/map #(:type (get arg-env %))))] - - (when (and ;; TODO excise clause when we default `output-type|form` to `?` - (not (identical? output-type|form fn|output-type|form)) - (not (t/<= output-type fn|output-type))) - (err! (str "Overload's declared output type does not satisfy function's" - "overall declared output type") - (kw-map output-type fn|output-type))) - (kw-map arg-types output-type)))) - ;; Not performed with `extend-defn!` because sorting happens later, in `>types-decl` - (<- (cond->> (not= kind :extend-defn!) (sort-by :arg-types compare-args-types))) - vec)] - (->> arg-types|expanded-seq + (uc/map+ + (c/fn [{:keys [env out-type-node]}] + (let [output-type (:type out-type-node) + arg-env (->> env :opts :arg-env deref) + arg-types (->> arg-bindings (uc/map #(:type (get arg-env %))))] + + (when (and ;; TODO excise clause when we default `output-type|form` to `?` + (not (identical? output-type|form fn|output-type|form)) + (not (t/<= output-type fn|output-type))) + (err! (str "Overload's declared output type does not satisfy function's" + "overall declared output type") + (kw-map output-type fn|output-type))) + (kw-map arg-types output-type)))))] + (->> arg-types|expanded-seq+ (uc/map (c/fn [{:keys [arg-types output-type]}] (kw-map arg-bindings varargs-binding arg-types|form arg-types output-type|form output-type body-codelist|pre-analyze)))))) -(defns- overloads-bases>unanalyzed-overloads - [overloads-bases _ #_:quantum.core.defnt/overloads - kind ::kind - fn|output-type|form _ ; TODO excise this var when we default `output-type|form` to `?` - fn|output-type t/type? - > (s/seq-of ::unanalyzed-overload)] - (->> overloads-bases - (uc/map+ - #(overloads-basis>unanalyzed-overload-seq % kind fn|output-type|form fn|output-type)) - (educei - (c/fn - ([] []) - ([ret] ret) - ([ret unanalyzed-overload-seq i|overload-basis] - (when-not (= kind :extend-defn!) - ;; Because this assertion is performed later on in `>types-decl` - (assert-monotonically-increasing-types! - ret unanalyzed-overload-seq i|overload-basis)) - (ur/join ret unanalyzed-overload-seq)))))) +(defns- unanalyzed-overloads>overloads + "This is of `O(n•log(n))` time complexity where n is the total number of generated/analyzed + overloads. + This is because once we must sort (`O(n•log(n))`) the overloads by comparing their arg types and + then if we find any duplicates in a linear scan (`O(n)`), we throw an error." + [unanalyzed-overloads (s/vec-of ::unanalyzed-overload), opts ::opts, fn|globals ::fn|globals + > (s/vec-of ::overload)] + (->> unanalyzed-overloads + ;; We have to analyze everything in order to figure out all the types (or at least, analyze + ;; in order to figure out body-dependent input types) before we can compare them against + ;; each other + (uc/map #(unanalyzed-overload>overload % opts fn|globals)) + (sort-by :arg-types compare-args-types) + (dedupe-type-data + (c/fn [overloads prev-overload overload] + (err! "Duplicate input types for overload" + {:arg-types-0 (:arg-types prev-overload) + :body-0 (:body-form prev-overload) + :arg-types-1 (:arg-types overload) + :body-1 (:body-form overload)}))))) (defns fn|code [kind ::kind, lang ::lang, compilation-mode ::compilation-mode, args _] (let [{:as args' @@ -739,14 +720,15 @@ (let [gen-gensym-base (ufgen/>reproducible-gensym|generator) gen-gensym (c/fn [x] (symbol (str (gen-gensym-base x) "__"))) opts (kw-map compilation-mode gen-gensym kind lang) - unanalyzed-overloads (overloads-bases>unanalyzed-overloads - overloads-bases kind fn|output-type|form fn|output-type) + unanalyzed-overloads (->> overloads-bases + (uc/mapcat #(overloads-basis>unanalyzed-overload-seq + % kind fn|output-type|form fn|output-type))) fn|type (type-data>ftype unanalyzed-overloads fn|output-type) fn|globals (kw-map fn|ns-name fn|name fn|meta fn|type fn|output-type|form fn|output-type fn|types-decl-name) ;; Specifically overloads that were generated during this execution of this function - overloads (->> unanalyzed-overloads - (uc/map #(unanalyzed-overload>overload % opts fn|globals))) + overloads (unanalyzed-overloads>overloads + unanalyzed-overloads opts fn|globals) types-decl (>types-decl opts fn|globals overloads) direct-dispatch (>direct-dispatch opts fn|globals overloads types-decl) dynamic-dispatch (>dynamic-dispatch-fn|form opts fn|globals types-decl) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 4eabe0e4..eb9a1a17 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -47,7 +47,7 @@ (defn cstr [x] (if (-> x resolve class?) (str x) - (str (namespace x) "." (name x)))) + (str (core/namespace x) "." (core/name x)))) #?(:clj (deftest test|pid From f75d7f35c12b3cd9dc4cbf74eb8c13661b1e5172 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 13 Oct 2018 14:21:11 -0600 Subject: [PATCH 511/810] Better reporting means we can fix this! --- .../quantum/untyped/core/type/defnt.cljc | 46 +++++++++++-------- src/quantum/core/data/primitive.cljc | 14 +++--- 2 files changed, 34 insertions(+), 26 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 04b8a6d1..1a593ae7 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -105,13 +105,14 @@ ;; Technically it's partially analyzed — its type definitions are analyzed (with the exception of ;; requests for type inference) while its body is not. (s/def ::unanalyzed-overload - (s/kv {:arg-bindings (s/vec-of t/any?) - :varargs-binding t/any? - :arg-types|form (s/vec-of t/any?) - :arg-types (s/vec-of t/type?) - :output-type|form t/any? - :output-type t/type? - :body-codelist|pre-analyze t/any?})) + (s/kv {:arglist-form|unanalyzed t/any? + :arg-bindings (s/vec-of t/any?) + :varargs-binding t/any? + :arg-types|form (s/vec-of t/any?) + :arg-types (s/vec-of t/type?) + :output-type|form t/any? + :output-type t/type? + :body-codelist|unanalyzed t/any?})) ;; This is the overload after the input specs are split by their respective `t/or` constituents, ;; and after primitivization, but before readiness for incorporation into a `reify`. @@ -119,6 +120,7 @@ (s/def ::overload (s/kv {:arg-classes (s/vec-of class?) :arg-types (s/vec-of t/type?) + :arglist-form|unanalyzed t/any? :arglist-code|fn|hinted t/any? :arglist-code|reify|unhinted t/any? :body-form t/any? @@ -227,8 +229,8 @@ "Given an `::unanalyzed-overload`, performs type analysis on the body and computes a resulting `t/fn` overload, which is the foundation for one `reify`." [{:as unanalyzed-overload - :keys [arg-bindings _, varargs-binding _, arg-types _, output-type|form _ - body-codelist|pre-analyze _] + :keys [arglist-form|unanalyzed _, arg-bindings _, varargs-binding _, arg-types _, + output-type|form _, body-codelist|unanalyzed _] declared-output-type [:output-type _]} ::unanalyzed-overload {:as opts :keys [lang _, kind _]} ::opts @@ -244,7 +246,7 @@ (<- (cond-> (not= kind :extend-defn!) (assoc fn|name recursive-ast-node-reference)))) arg-classes (->> arg-types (uc/map type>class)) - body-node (uana/analyze env (ufgen/?wrap-do body-codelist|pre-analyze)) + body-node (uana/analyze env (ufgen/?wrap-do body-codelist|unanalyzed)) hint-arg|fn (c/fn [i arg-binding] (ufth/with-type-hint arg-binding (ufth/>fn-arglist-tag @@ -257,7 +259,8 @@ (-> (:form body-node) (cond-> (-> actual-output-type meta :quantum.core.type/runtime?) (>with-runtime-output-type output-type|form)))] - {:arg-classes arg-classes + {:arglist-form|unanalyzed arglist-form|unanalyzed + :arg-classes arg-classes :arg-types arg-types :arglist-code|fn|hinted (cond-> (->> arg-bindings (uc/map-indexed hint-arg|fn)) varargs-binding (conj '& varargs-binding)) @@ -608,14 +611,17 @@ varargs [:varargs _] pre-type|form [:pre _] [_ _, output-type|form _] [:post _]} [:arglist _] - body-codelist|pre-analyze [:body _]} _ + body-codelist|unanalyzed [:body _]} _ kind ::kind fn|output-type|form _ ; TODO excise this var when we default `output-type|form` to `?` fn|output-type t/type? > (s/seq-of ::unanalyzed-overload)] (when pre-type|form (TODO "Need to handle pre")) (when varargs (TODO "Need to handle varargs")) - (let [arg-types|form (->> args (mapv (c/fn [{[kind #_#{:any :spec}, t #_t/form?] :spec}] + (let [arglist-form|unanalyzed (cond-> args varargs (conj '& varargs) + pre-type|form (conj '| pre-type|form) + output-type|form (conj '> output-type|form)) + arg-types|form (->> args (mapv (c/fn [{[kind #_#{:any :spec}, t #_t/form?] :spec}] (case kind :any `t/any? :spec t)))) output-type|form (case output-type|form _ `t/any? @@ -652,10 +658,10 @@ (kw-map arg-types output-type)))))] (->> arg-types|expanded-seq+ (uc/map (c/fn [{:keys [arg-types output-type]}] - (kw-map arg-bindings varargs-binding + (kw-map arglist-form|unanalyzed arg-bindings varargs-binding arg-types|form arg-types output-type|form output-type - body-codelist|pre-analyze)))))) + body-codelist|unanalyzed)))))) (defns- unanalyzed-overloads>overloads "This is of `O(n•log(n))` time complexity where n is the total number of generated/analyzed @@ -673,10 +679,12 @@ (dedupe-type-data (c/fn [overloads prev-overload overload] (err! "Duplicate input types for overload" - {:arg-types-0 (:arg-types prev-overload) - :body-0 (:body-form prev-overload) - :arg-types-1 (:arg-types overload) - :body-1 (:body-form overload)}))))) + (umap/om :arglist-form-0 (:arglist-form|unanalyzed prev-overload) + :arg-types-0 (:arg-types prev-overload) + :body-0 (:body-form prev-overload) + :arglist-form-1 (:arglist-form|unanalyzed overload) + :arg-types-1 (:arg-types overload) + :body-1 (:body-form overload))))))) (defns fn|code [kind ::kind, lang ::lang, compilation-mode ::compilation-mode, args _] (let [{:as args' diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 337e65d1..f35ec02b 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -188,7 +188,7 @@ ( [a long? , b (t/- numeric? long?)] (Numeric/eq a b)) ( [a (t/- numeric? long?) , b long?] (Numeric/eq a b)) (^:in [a double? , b double?] (Numbers/equiv a b)) - ( [a double? , b (t/- numeric? double?)] (Numeric/eq a b)) + ( [a double? , b (t/- numeric? double? long?)] (Numeric/eq a b)) ( [a (t/- numeric? double?) , b double?] (Numeric/eq a b)) ( [a (t/- numeric? double? long?), b (t/- numeric? double? long?)] (Numeric/eq a b)))) @@ -211,7 +211,7 @@ #?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/lt a b))) #?(:clj ( [a (t/- numeric? long?) , b long?] (Numeric/lt a b))) #?(:clj (^:in [a double? , b double?] (Numbers/lt a b))) -#?(:clj ( [a double? , b (t/- numeric? double?)] (Numeric/lt a b))) +#?(:clj ( [a double? , b (t/- numeric? double? long?)] (Numeric/lt a b))) #?(:clj ( [a (t/- numeric? double?) , b double?] (Numeric/lt a b))) #?(:clj ( [a (t/- numeric? double? long?), b (t/- numeric? double? long?)] (Numeric/lt a b))) #?(:cljs ( [a numeric? , b numeric?] (cljs.core/< a b))) @@ -225,7 +225,7 @@ #?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/lte a b))) #?(:clj ( [a (t/- numeric? long?) , b long?] (Numeric/lte a b))) #?(:clj (^:in [a double? , b double?] (Numbers/lte a b))) -#?(:clj ( [a double? , b (t/- numeric? double?)] (Numeric/lte a b))) +#?(:clj ( [a double? , b (t/- numeric? double? long?)] (Numeric/lte a b))) #?(:clj ( [a (t/- numeric? double?) , b double?] (Numeric/lte a b))) #?(:clj ( [a (t/- numeric? double? long?), b (t/- numeric? double? long?)] (Numeric/lte a b))) #?(:cljs ( [a numeric? , b numeric?] (cljs.core/<= a b))) @@ -239,7 +239,7 @@ #?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/gt a b))) #?(:clj ( [a (t/- numeric? long?) , b long?] (Numeric/gt a b))) #?(:clj (^:in [a double? , b double?] (Numbers/gt a b))) -#?(:clj ( [a double? , b (t/- numeric? double?)] (Numeric/gt a b))) +#?(:clj ( [a double? , b (t/- numeric? double? long?)] (Numeric/gt a b))) #?(:clj ( [a (t/- numeric? double?) , b double?] (Numeric/gt a b))) #?(:clj ( [a (t/- numeric? double? long?), b (t/- numeric? double? long?)] (Numeric/gt a b))) #?(:cljs ( [a numeric? , b numeric?] (cljs.core/> a b))) @@ -247,16 +247,16 @@ ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) ) -(macroexpand '(t/extend-defn! ccomp/>= +(t/extend-defn! ccomp/>= ( [x numeric?] true) #?(:clj (^:in [a long? , b long?] (Numbers/gte a b))) #?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/gte a b))) #?(:clj ( [a (t/- numeric? long?) , b long?] (Numeric/gte a b))) #?(:clj (^:in [a double? , b double?] (Numbers/gte a b))) -#?(:clj ( [a double? , b (t/- numeric? double?)] (Numeric/gte a b))) +#?(:clj ( [a double? , b (t/- numeric? double? long?)] (Numeric/gte a b))) #?(:clj ( [a (t/- numeric? double?) , b double?] (Numeric/gte a b))) #?(:clj ( [a (t/- numeric? double? long?), b (t/- numeric? double? long?)] (Numeric/gte a b))) #?(:cljs ( [a numeric? , b numeric?] (cljs.core/>= a b))) ;; TODO rest of numbers, but not nil ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) - )) + ) From d30e73ac4bcd5dcfecf21d490339676a574845ab Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 13 Oct 2018 14:43:12 -0600 Subject: [PATCH 512/810] Move primitive conversions into the correct places --- resources-dev/defnt.cljc | 8 +- src/quantum/core/compare/core.cljc | 2 +- src/quantum/core/data/numeric.cljc | 174 +++++++++++++++++++++-- src/quantum/core/data/primitive.cljc | 18 +++ src/quantum/core/primitive.cljc | 199 --------------------------- 5 files changed, 181 insertions(+), 220 deletions(-) delete mode 100644 src/quantum/core/primitive.cljc diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 5b15bfaa..0d386728 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -63,12 +63,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative [1] - t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. - t/numerically-integer? - - In order to have this, you have to have comparisons in place - - In order for comparisons to be in place you need primitives to compare by - - For primitive conversions you need comparisons and `numerically` to determine ranges - - This is why we can have core.data.primitive and core.primitive - - core.data.primitive - - just type definitions and characteristics + - Primitive conversions not requiring checks can go in data.primitive - core.data.numeric (requires data.primitive) - numeric definitions - numeric ranges @@ -192,6 +187,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - t/deftype - t/dotyped - t/extend-defn! + [ ] Ability to add output type restriction after the fact? [ ] Should we trigger a recompilation of everything that depended on that `t/defn` because the input-types and output-types will have both gotten bigger? (Maybe not on that overload but still.) diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index aa8e5e37..ecb53a42 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -122,7 +122,7 @@ (def comparison? #?(:clj ut/int? :cljs ut/double?)) (t/defn ^:inline compare - "Logical (not numeric) comparison. + "Logical (not exclusively numeric) comparison. When ->`a` is logically 'less than' ->`b`, outputs a negative number. When ->`a` is logically 'equal to' ->`b`, outputs zero. diff --git a/src/quantum/core/data/numeric.cljc b/src/quantum/core/data/numeric.cljc index 6ea5de9d..715f22fd 100644 --- a/src/quantum/core/data/numeric.cljc +++ b/src/quantum/core/data/numeric.cljc @@ -15,7 +15,7 @@ `ratio?` for CLJS: - Fraction.js is the best contender as of 9/27/2018. https://github.com/infusion/Fraction.js" - (:refer-clojure :exclude + #_(:refer-clojure :exclude ; otherwise `Unable to resolve symbol: eval` [decimal? denominator integer? number? numerator ratio?]) (:require [clojure.core :as core] @@ -281,23 +281,67 @@ scale)))) ;; ===== Conversion ===== ;; +;; Note that numeric-primitive conversions go here because they take as inputs and produce outputs +;; things that are within a numeric range. + +;; ----- Byte ----- ;; + +;; TODO figure out how to use with CLJS +#?(:clj +(t/defn ^:inline >byte* + "May involve non-out-of-range truncation." + > byte? + ([x byte?] x) + ([x (t/- primitive? byte? boolean?)] (Primitive/uncheckedByteCast x)))) ;; TODO TYPED `numerically` ;; TODO figure out how to use with goog.math.Integer/Long -#_(defnt ^:inline >byte > #?(:clj byte? :cljs numerically-byte?) +(t/defn ^:inline >byte > #?(:clj byte? :cljs numerically-byte?) "Does not involve truncation or rounding." ([x #?(:clj byte? :cljs numerically-byte?)] x) #?(:clj ([x (t/and (t/- primitive? byte? boolean?) numerically-byte?)] (>byte* x)) :cljs ([x (t/and double? numerically-byte?)] x)) - ([x boolean?] (if x #?(:clj (byte 1) :cljs 1) #?(:clj (byte 0) :cljs 0))) + #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-byte?)] (>byte* (.lpart x)))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-byte?)] (.byteValue x))) #?(:clj ([x (t/and dn/ratio? numerically-byte?)] (-> x .bigIntegerValue .byteValue)))) +;; ----- Char ----- ;; + +;; TODO figure out how to use with CLJS +#?(:clj +(t/defn ^:inline >char* + "May involve non-out-of-range truncation." + > char? + ([x char?] x) + ([x (t/- primitive? char? boolean?)] (Primitive/uncheckedCharCast x)))) ;; TODO TYPED `numerically` ;; TODO figure out how to use with goog.math.Integer/Long -#_(t/defn ^:inline >short > #?(:clj short? :cljs numerically-short?) +(t/defn ^:inline >char > #?(:clj char? :cljs numerically-char?) + "Does not involve truncation or rounding. + For CLJS, returns not a String of length 1 but a numerically-char Number." + ([x #?(:clj char? :cljs numerically-char?)] x) +#?(:clj ([x (t/and (t/- primitive? char? boolean?) numerically-char?)] (>char* x)) + :cljs ([x (t/and double? numerically-char?)] x)) + ([x boolean?] (if x #?(:clj (char 1) :cljs 1) #?(:clj (char 0) :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-char?)] (>char* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-char?)] (.charValue x))) +#?(:clj ([x (t/and dn/ratio? numerically-char?)] (-> x .bigIntegerValue .charValue)))) + +;; ----- Short ----- ;; + +;; TODO figure out how to use with CLJS +#?(:clj +(t/defn ^:inline >short* + "May involve non-out-of-range truncation." + > short? + ([x short?] x) + ([x (t/- primitive? short? boolean?)] (Primitive/uncheckedShortCast x)))) + +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +(t/defn ^:inline >short > #?(:clj short? :cljs numerically-short?) "Does not involve truncation or rounding." ([x #?(:clj short? :cljs numerically-short?)] x) #?(:clj ([x (t/and (t/- primitive? short? boolean?) numerically-short?)] (>short* x)) @@ -307,15 +351,117 @@ #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-short?)] (.shortValue x))) #?(:clj ([x (t/and dn/ratio? numerically-short?)] (-> x .bigIntegerValue .shortValue)))) +;; ----- Int ----- ;; + +;; TODO figure out how to use with goog.math.Integer/Long +#?(:clj +(t/defn ^:inline >int* + "May involve non-out-of-range truncation." + > int? + ([x int?] x) ;; For purposes of Clojure intrinsics + ([x (t/- primitive? int? boolean?)] (clojure.lang.RT/uncheckedIntCast x)))) + ;; TODO TYPED `numerically` ;; TODO figure out how to use with goog.math.Integer/Long -#_(t/defn ^:inline >char > #?(:clj char? :cljs numerically-char?) - "Does not involve truncation or rounding. - For CLJS, returns not a String of length 1 but a numerically-char Number." - ([x #?(:clj char? :cljs numerically-char?)] x) -#?(:clj ([x (t/and (t/- primitive? char? boolean?) numerically-char?)] (>char* x)) - :cljs ([x (t/and double? numerically-char?)] x)) - ([x boolean?] (if x #?(:clj (char 1) :cljs 1) #?(:clj (char 0) :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-char?)] (>char* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-char?)] (.charValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-char?)] (-> x .bigIntegerValue .charValue)))) +(t/defn ^:inline >int + "Does not involve truncation or rounding." + > int? + ([x int?] x) +#?(:clj ([x (t/and (t/- primitive? int? boolean?) numerically-int?)] (>int* x)) + :cljs ([x (t/and double? numerically-int?)] x)) + ([x boolean?] (if x #?(:clj (int 1) :cljs 1) #?(:clj (int 0) :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-int?)] (>int* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-int?)] (.intValue x))) +#?(:clj ([x (t/and dn/ratio? numerically-int?)] (-> x .bigIntegerValue .intValue)))) + +;; ----- Long ----- ;; + +;; TODO figure out how to use with CLJS, including goog.math.Integer/Long +#?(:clj +(t/defn ^:inline >long* + "May involve non-out-of-range truncation." + > long? + ([x long?] x) + ([x char?] (Primitive/uncheckedLongCast x)) ;; For purposes of Clojure intrinsics + ([x (t/- primitive? long? boolean? char?)] (clojure.lang.RT/uncheckedLongCast x)))) + +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +(t/defn ^:inline >long + "Does not involve truncation or rounding." + > #?(:clj long? :cljs numerically-long?) + ([x #?(:clj long? :cljs numerically-long?)] x) +#?(:clj ([x (t/and (t/- primitive? long? boolean?) numerically-long?)] (>long* x)) + :cljs ([x (t/and double? numerically-long?)] x)) + ([x boolean?] (if x 1 0)) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) + numerically-long? + ;; TODO This might be faster than `numerically-long?` + #_(t/fn [x ?] (nil? (.bipart x))))] (.lpart x))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) + numerically-long? + ;; TODO This might be faster than `numerically-long?` + #_(t/fn [x ?] (< (.bitLength x) 64)))] (.longValue x))) +#?(:clj ([x (t/and dn/ratio? numerically-long?)] (-> x .bigIntegerValue .longValue)))) + +;; ----- Float ----- ;; + +;; TODO figure out how to use with CLJS +#?(:clj +(t/defn ^:inline >float* + "May involve non-out-of-range truncation." + > float? + ([x float?] x) + ([x (t/- primitive? float? boolean?)] (Primitive/uncheckedFloatCast x)))) + +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +(t/defn ^:inline >float > #?(:clj float? :cljs numerically-float?) + "Does not involve truncation or rounding." + ([x #?(:clj float? :cljs numerically-float?)] x) +#?(:clj ([x (t/and (t/- primitive? float? boolean?) numerically-float?)] (>float* x)) + :cljs ([x (t/and double? numerically-float?)] x)) + ([x boolean?] (if x #?(:clj (float 1) :cljs 1) #?(:clj (float 0) :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-float?)] (>float* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-float?)] (.floatValue x))) +#?(:clj ([x (t/and dn/ratio? numerically-float?)] (-> x .bigIntegerValue .floatValue)))) + +;; ----- Double ----- ;; + +;; TODO figure out how to use with goog.math.Integer/Long +(t/defn ^:inline >double* + "May involve non-out-of-range truncation." + > double? + ([x double?] x) + ([x char?] (Primitive/uncheckedDoubleCast x)) ;; For purposes of Clojure intrinsics +#?(:clj ([x (t/- primitive? double? boolean? char?)] (clojure.lang.RT/uncheckedDoubleCast x)))) + +;; TODO TYPED `numerically` +;; TODO figure out how to use with goog.math.Integer/Long +(t/defn ^:inline >double > double? + "Does not involve truncation or rounding." + ([x double?] x) +#?(:clj ([x (t/and (t/- primitive? double? boolean?) numerically-double?)] (>double* x))) + ([x boolean?] (if x #?(:clj 1.0 :cljs 1) #?(:clj 1.0 :cljs 0))) +#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-double?)] (>double* (.lpart x)))) +#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-double?)] (.doubleValue x))) +#?(:clj ([x (t/and dn/ratio? numerically-double?)] (-> x .bigIntegerValue .doubleValue)))) + +;; ===== Unsigned ===== ;; + +#?(:clj +(t/defn >unsigned + {:adapted-from #{'ztellman/primitive-math 'gloss.data.primitives}} + ([x byte?] (Numeric/bitAnd (short 0xFF) x)) + ([x short?] (Numeric/bitAnd (int 0xFFFF) x)) + ([x int?] (Numeric/bitAnd (long 0xFFFFFFFF) x)) + ([x long?] (java.math.BigInteger. (int 1) + (-> ^:val (ByteBuffer/allocate (int 8)) + ^:val (.putLong x) + .array))))) + +;; TODO TYPED awaiting `>long` +#_(:clj (t/defn ubyte>byte [x long? > long?] (-> x >byte >long))) +#_(:clj (t/defn ushort>short [x long? > long?] (-> x >short >long))) +#_(:clj (t/defn uint>int [x long? > long?] (-> x >int >long))) +#_(:clj (t/defn ulong>long [x bigint? > long?] (-> x >bigint >long))) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index f35ec02b..7f8aaee3 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -177,6 +177,24 @@ ([x (t/or float? (t/value Float))] float-bits)]) ([x (t/or double? #?(:clj Double :cljs js/Number))] double-bits)) +;; ===== Conversion ===== ;; +;; Note that numeric-primitive conversions do not go here (but may be found in +;; `quantum.core.data.numeric`) because they take as inputs and produce outputs things that are +;; within a numeric range. + +;; ----- Boolean ----- ;; + +;; TODO CLJS +;; TODO rethink — is everything that's a 0 false and everything that's a 1 a true? Or is it just +;; 0's that are false? Etc. +(t/defn ^:inline >boolean + "Converts input to a boolean. + Differs from asking whether something is truthy/falsey." + > boolean? + ([x boolean?] x) ;; For purposes of Clojure intrinsics +#?(:clj ([x (t/or long? double?)] (-> x clojure.lang.Numbers/isZero Numeric/not))) +#?(:clj ([x (t/- primitive? boolean? long? double?)] (-> x Numeric/isZero Numeric/not)))) + ;; ===== Extensions ===== ;; #?(:clj diff --git a/src/quantum/core/primitive.cljc b/src/quantum/core/primitive.cljc deleted file mode 100644 index 0668fd83..00000000 --- a/src/quantum/core/primitive.cljc +++ /dev/null @@ -1,199 +0,0 @@ -(ns quantum.core.primitive - "Not merged into `quantum.core.data.primitive` because this namespace requires numeric ranges.") - -;; ===== Conversion ===== ;; - -;; ----- Boolean ----- ;; - -;; TODO CLJS -;; TODO rethink — is everything that's a 0 false and everything that's a 1 a true? Or is it just -;; 0's that are false? Etc. -(t/defn ^:inline >boolean - "Converts input to a boolean. - Differs from asking whether something is truthy/falsey." - > boolean? - ([x boolean?] x) ;; For purposes of Clojure intrinsics -#?(:clj ([x (t/or long? double?)] (-> x clojure.lang.Numbers/isZero Numeric/not))) -#?(:clj ([x (t/- primitive? boolean? long? double?)] (-> x Numeric/isZero Numeric/not)))) - -;; ----- Byte ----- ;; - -;; TODO figure out how to use with CLJS -#?(:clj -(t/defn ^:inline >byte* - "May involve non-out-of-range truncation." - > byte? - ([x byte?] x) - ([x (t/- primitive? byte? boolean?)] (Primitive/uncheckedByteCast x)))) - -;; TODO TYPED `numerically` -;; TODO figure out how to use with goog.math.Integer/Long -#_(defnt ^:inline >byte > #?(:clj byte? :cljs numerically-byte?) - "Does not involve truncation or rounding." - ([x #?(:clj byte? :cljs numerically-byte?)] x) -#?(:clj ([x (t/and (t/- primitive? byte? boolean?) numerically-byte?)] (>byte* x)) - :cljs ([x (t/and double? numerically-byte?)] x)) - ([x boolean?] (if x #?(:clj (byte 1) :cljs 1) #?(:clj (byte 0) :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-byte?)] (>byte* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-byte?)] (.byteValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-byte?)] (-> x .bigIntegerValue .byteValue)))) - -;; ----- Short ----- ;; - -;; TODO figure out how to use with CLJS -#?(:clj -(t/defn ^:inline >short* - "May involve non-out-of-range truncation." - > short? - ([x short?] x) - ([x (t/- primitive? short? boolean?)] (Primitive/uncheckedShortCast x)))) - -;; TODO TYPED `numerically` -;; TODO figure out how to use with goog.math.Integer/Long -#_(t/defn ^:inline >short > #?(:clj short? :cljs numerically-short?) - "Does not involve truncation or rounding." - ([x #?(:clj short? :cljs numerically-short?)] x) -#?(:clj ([x (t/and (t/- primitive? short? boolean?) numerically-short?)] (>short* x)) - :cljs ([x (t/and double? numerically-short?)] x)) - ([x boolean?] (if x #?(:clj (short 1) :cljs 1) #?(:clj (short 0) :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-short?)] (>short* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-short?)] (.shortValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-short?)] (-> x .bigIntegerValue .shortValue)))) - -;; ----- Char ----- ;; - -;; TODO figure out how to use with CLJS -#?(:clj -(t/defn ^:inline >char* - "May involve non-out-of-range truncation." - > char? - ([x char?] x) - ([x (t/- primitive? char? boolean?)] (Primitive/uncheckedCharCast x)))) - -;; TODO TYPED `numerically` -;; TODO figure out how to use with goog.math.Integer/Long -#_(t/defn ^:inline >char > #?(:clj char? :cljs numerically-char?) - "Does not involve truncation or rounding. - For CLJS, returns not a String of length 1 but a numerically-char Number." - ([x #?(:clj char? :cljs numerically-char?)] x) -#?(:clj ([x (t/and (t/- primitive? char? boolean?) numerically-char?)] (>char* x)) - :cljs ([x (t/and double? numerically-char?)] x)) - ([x boolean?] (if x #?(:clj (char 1) :cljs 1) #?(:clj (char 0) :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-char?)] (>char* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-char?)] (.charValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-char?)] (-> x .bigIntegerValue .charValue)))) - -;; ----- Int ----- ;; - -;; TODO figure out how to use with goog.math.Integer/Long -#?(:clj -(t/defn ^:inline >int* - "May involve non-out-of-range truncation." - > int? - ([x int?] x) ;; For purposes of Clojure intrinsics - ([x (t/- primitive? int? boolean?)] (clojure.lang.RT/uncheckedIntCast x)))) - -;; TODO TYPED `numerically` -;; TODO figure out how to use with goog.math.Integer/Long -#_(t/defn ^:inline >int - "Does not involve truncation or rounding." - > int? - ([x int?] x) -#?(:clj ([x (t/and (t/- primitive? int? boolean?) numerically-int?)] (>int* x)) - :cljs ([x (t/and double? numerically-int?)] x)) - ([x boolean?] (if x #?(:clj (int 1) :cljs 1) #?(:clj (int 0) :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-int?)] (>int* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-int?)] (.intValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-int?)] (-> x .bigIntegerValue .intValue)))) - -;; ----- Long ----- ;; - -;; TODO figure out how to use with CLJS, including goog.math.Integer/Long -#?(:clj -(t/defn ^:inline >long* - "May involve non-out-of-range truncation." - > long? - ([x long?] x) - ([x char?] (Primitive/uncheckedLongCast x)) ;; For purposes of Clojure intrinsics - ([x (t/- primitive? long? boolean? char?)] (clojure.lang.RT/uncheckedLongCast x)))) - -;; TODO TYPED `numerically` -;; TODO figure out how to use with goog.math.Integer/Long -#_(t/defn ^:inline >long - "Does not involve truncation or rounding." - > #?(:clj long? :cljs numerically-long?) - ([x #?(:clj long? :cljs numerically-long?)] x) -#?(:clj ([x (t/and (t/- primitive? long? boolean?) numerically-long?)] (>long* x)) - :cljs ([x (t/and double? numerically-long?)] x)) - ([x boolean?] (if x 1 0)) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) - numerically-long? - ;; TODO This might be faster than `numerically-long?` - #_(t/fn [x ?] (nil? (.bipart x))))] (.lpart x))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) - numerically-long? - ;; TODO This might be faster than `numerically-long?` - #_(t/fn [x ?] (< (.bitLength x) 64)))] (.longValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-long?)] (-> x .bigIntegerValue .longValue)))) - -;; ----- Float ----- ;; - -;; TODO figure out how to use with CLJS -#?(:clj -(t/defn ^:inline >float* - "May involve non-out-of-range truncation." - > float? - ([x float?] x) - ([x (t/- primitive? float? boolean?)] (Primitive/uncheckedFloatCast x)))) - -;; TODO TYPED `numerically` -;; TODO figure out how to use with goog.math.Integer/Long -#_(t/defn ^:inline >float > #?(:clj float? :cljs numerically-float?) - "Does not involve truncation or rounding." - ([x #?(:clj float? :cljs numerically-float?)] x) -#?(:clj ([x (t/and (t/- primitive? float? boolean?) numerically-float?)] (>float* x)) - :cljs ([x (t/and double? numerically-float?)] x)) - ([x boolean?] (if x #?(:clj (float 1) :cljs 1) #?(:clj (float 0) :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-float?)] (>float* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-float?)] (.floatValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-float?)] (-> x .bigIntegerValue .floatValue)))) - -;; ----- Double ----- ;; - -;; TODO figure out how to use with goog.math.Integer/Long -(t/defn ^:inline >double* - "May involve non-out-of-range truncation." - > double? - ([x double?] x) - ([x char?] (Primitive/uncheckedDoubleCast x)) ;; For purposes of Clojure intrinsics -#?(:clj ([x (t/- primitive? double? boolean? char?)] (clojure.lang.RT/uncheckedDoubleCast x)))) - -;; TODO TYPED `numerically` -;; TODO figure out how to use with goog.math.Integer/Long -#_(t/defn ^:inline >double > double? - "Does not involve truncation or rounding." - ([x double?] x) -#?(:clj ([x (t/and (t/- primitive? double? boolean?) numerically-double?)] (>double* x))) - ([x boolean?] (if x #?(:clj 1.0 :cljs 1) #?(:clj 1.0 :cljs 0))) -#?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-double?)] (>double* (.lpart x)))) -#?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-double?)] (.doubleValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-double?)] (-> x .bigIntegerValue .doubleValue)))) - -;; ===== Unsigned ===== ;; - -#?(:clj -(t/defn >unsigned - {:adapted-from #{'ztellman/primitive-math 'gloss.data.primitives}} - ([x byte?] (Numeric/bitAnd (short 0xFF) x)) - ([x short?] (Numeric/bitAnd (int 0xFFFF) x)) - ([x int?] (Numeric/bitAnd (long 0xFFFFFFFF) x)) - ([x long?] (java.math.BigInteger. (int 1) - (-> ^:val (ByteBuffer/allocate (int 8)) - ^:val (.putLong x) - .array))))) - -;; TODO TYPED awaiting `>long` -#_(:clj (t/defn ubyte>byte [x long? > long?] (-> x >byte >long))) -#_(:clj (t/defn ushort>short [x long? > long?] (-> x >short >long))) -#_(:clj (t/defn uint>int [x long? > long?] (-> x >int >long))) -#_(:clj (t/defn ulong>long [x bigint? > long?] (-> x >bigint >long))) From 5a0b9d8677cb5237979a63714f755de11203c46a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 13 Oct 2018 15:02:06 -0600 Subject: [PATCH 513/810] Handle weird issue --- src-untyped/quantum/untyped/core/analyze.cljc | 10 +++-- src/quantum/core/data/primitive.cljc | 44 +++++++++---------- 2 files changed, 29 insertions(+), 25 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index e76d2a30..e876c045 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -357,7 +357,7 @@ :arg-types (mapv :type args|analyzed)}) ret))) -(defns- analyze-seq|dot|method-call|incrementally-analyze +(defns- |method-call|incrementally-analyze [env ::env, form _, target uast/node?, target-class class?, method-form _ args|form _ methods-for-ct-and-kind (s/seq-of t/any?) > uast/method-call?] (let [{:keys [args|analyzed call-sites]} @@ -422,12 +422,16 @@ (first cs') (err! "Found more than one class" cs)))) -;; TODO type these arguments; e.g. check that ?method||field, if present, is an unqualified symbol (defns- analyze-seq|dot [env ::env, [_ _, target-form _, ?method-or-field _ & ?args _ :as form] _] (let [target (analyze* env target-form) method-or-field (if (symbol? ?method-or-field) ?method-or-field (first ?method-or-field)) - args-forms (if (symbol? ?method-or-field) ?args (rest ?method-or-field))] + ;; To get around a weird behavior in Clojure, at least in 1.9 + method-or-field (if (and (= target-form 'clojure.lang.RT) + (= method-or-field 'clojure.core/longCast)) + 'longCast + method-or-field) + args-forms (if (symbol? ?method-or-field) ?args (rest ?method-or-field))] (if (t/= (:type target) t/nil?) (err! "Cannot use the dot operator on a target of nil type." {:form form}) (let [;; `nilable?` because technically any non-primitive in Java is nilable and we can't diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 7f8aaee3..9ceec219 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -124,36 +124,36 @@ ;; ===== Extreme magnitudes and values ===== ;; (t/defn ^:inline >min-magnitude - #?(:clj ([x byte? > (type x)] (byte 0))) - #?(:clj ([x short? > (type x)] (short 0))) - #?(:clj ([x char? > (type x)] (char 0))) - #?(:clj ([x int? > (type x)] (int 0))) - #?(:clj ([x long? > (type x)] (long 0))) - #?(:clj ([x float? > (type x)] Float/MIN_VALUE)) - ([x double? > (type x)] #?(:clj Double/MIN_VALUE - :cljs js/Number.MIN_VALUE))) + #?(:clj ([x byte? > (t/type x)] (byte 0))) + #?(:clj ([x short? > (t/type x)] (short 0))) + #?(:clj ([x char? > (t/type x)] (char 0))) + #?(:clj ([x int? > (t/type x)] (int 0))) + #?(:clj ([x long? > (t/type x)] (long 0))) + #?(:clj ([x float? > (t/type x)] Float/MIN_VALUE)) + ([x double? > (t/type x)] #?(:clj Double/MIN_VALUE + :cljs js/Number.MIN_VALUE))) ;; TODO TYPED these are probably getting boxed #?(:clj (var/def- min-float (Numeric/negate Float/MAX_VALUE))) (var/def- min-double (- #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) (t/defn ^:inline >min-value - #?(:clj ([x byte? > (type x)] Byte/MIN_VALUE)) - #?(:clj ([x short? > (type x)] Short/MIN_VALUE)) - #?(:clj ([x char? > (type x)] Character/MIN_VALUE)) - #?(:clj ([x int? > (type x)] Integer/MIN_VALUE)) - #?(:clj ([x long? > (type x)] Long/MIN_VALUE)) - #?(:clj ([x float? > (type x)] min-float)) - ([x double? > (type x)] min-double)) + #?(:clj ([x byte? > (t/type x)] Byte/MIN_VALUE)) + #?(:clj ([x short? > (t/type x)] Short/MIN_VALUE)) + #?(:clj ([x char? > (t/type x)] Character/MIN_VALUE)) + #?(:clj ([x int? > (t/type x)] Integer/MIN_VALUE)) + #?(:clj ([x long? > (t/type x)] Long/MIN_VALUE)) + #?(:clj ([x float? > (t/type x)] min-float)) + ([x double? > (t/type x)] min-double)) (t/defn ^:inline >max-value - #?@(:clj [([x byte? > (type x)] Byte/MAX_VALUE) - ([x short? > (type x)] Short/MAX_VALUE) - ([x char? > (type x)] Character/MAX_VALUE) - ([x int? > (type x)] Integer/MAX_VALUE) - ([x long? > (type x)] Long/MAX_VALUE) - ([x float? > (type x)] Float/MAX_VALUE)]) - ([x double? > (type x)] #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) + #?@(:clj [([x byte? > (t/type x)] Byte/MAX_VALUE) + ([x short? > (t/type x)] Short/MAX_VALUE) + ([x char? > (t/type x)] Character/MAX_VALUE) + ([x int? > (t/type x)] Integer/MAX_VALUE) + ([x long? > (t/type x)] Long/MAX_VALUE) + ([x float? > (t/type x)] Float/MAX_VALUE)]) + ([x double? > (t/type x)] #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) ;; ===== Primitive type properties ===== ;; From a270422cb91fd3c9bd4e1a887922d1abfa7839a1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 14 Oct 2018 01:08:07 -0600 Subject: [PATCH 514/810] Reorganize data.numeric; incorporate numeric.predicates and some ops --- resources-dev/clojure-lang-numbers-temp.java | 128 ------ resources-dev/defnt.cljc | 91 ++-- src-untyped/quantum/untyped/core/numeric.cljc | 5 +- src/quantum/core/compare/core.cljc | 8 +- src/quantum/core/data/numeric.cljc | 403 +++++++++++------- src/quantum/core/numeric/predicates.cljc | 60 --- .../quantum/test/untyped/core/type/defnt.cljc | 1 + 7 files changed, 300 insertions(+), 396 deletions(-) delete mode 100644 src/quantum/core/numeric/predicates.cljc diff --git a/resources-dev/clojure-lang-numbers-temp.java b/resources-dev/clojure-lang-numbers-temp.java index 036c0823..35fae98f 100644 --- a/resources-dev/clojure-lang-numbers-temp.java +++ b/resources-dev/clojure-lang-numbers-temp.java @@ -47,18 +47,6 @@ public Number unchecked_dec(Number x){ } -static public boolean isZero(Object x){ - return ops(x).isZero((Number)x); -} - -static public boolean isPos(Object x){ - return ops(x).isPos((Number)x); -} - -static public boolean isNeg(Object x){ - return ops(x).isNeg((Number)x); -} - static public Number minus(Object x){ return ops(x).negate((Number)x); } @@ -368,18 +356,6 @@ final public Ops opsWith(BigDecimalOps x){ return BIGDECIMAL_OPS; } - public boolean isZero(Number x){ - return x.longValue() == 0; - } - - public boolean isPos(Number x){ - return x.longValue() > 0; - } - - public boolean isNeg(Number x){ - return x.longValue() < 0; - } - final public Number add(Number x, Number y){ return num(Numbers.add(x.longValue(),y.longValue())); } @@ -545,18 +521,6 @@ final public Ops opsWith(BigDecimalOps x){ return this; } - public boolean isZero(Number x){ - return x.doubleValue() == 0; - } - - public boolean isPos(Number x){ - return x.doubleValue() > 0; - } - - public boolean isNeg(Number x){ - return x.doubleValue() < 0; - } - final public Number add(Number x, Number y){ return Double.valueOf(x.doubleValue() + y.doubleValue()); } @@ -632,21 +596,6 @@ final public Ops opsWith(BigDecimalOps x){ return BIGDECIMAL_OPS; } - public boolean isZero(Number x){ - Ratio r = (Ratio) x; - return r.numerator.signum() == 0; - } - - public boolean isPos(Number x){ - Ratio r = (Ratio) x; - return r.numerator.signum() > 0; - } - - public boolean isNeg(Number x){ - Ratio r = (Ratio) x; - return r.numerator.signum() < 0; - } - static Number normalizeRet(Number ret, Number x, Number y){ // if(ret instanceof BigInteger && !(x instanceof BigInteger || y instanceof BigInteger)) // { @@ -763,27 +712,6 @@ final public Ops opsWith(BigDecimalOps x){ return BIGDECIMAL_OPS; } - public boolean isZero(Number x){ - BigInt bx = toBigInt(x); - if(bx.bipart == null) - return bx.lpart == 0; - return bx.bipart.signum() == 0; - } - - public boolean isPos(Number x){ - BigInt bx = toBigInt(x); - if(bx.bipart == null) - return bx.lpart > 0; - return bx.bipart.signum() > 0; - } - - public boolean isNeg(Number x){ - BigInt bx = toBigInt(x); - if(bx.bipart == null) - return bx.lpart < 0; - return bx.bipart.signum() < 0; - } - final public Number add(Number x, Number y){ return toBigInt(x).add(toBigInt(y)); } @@ -864,21 +792,6 @@ final public Ops opsWith(BigDecimalOps x){ return this; } - public boolean isZero(Number x){ - BigDecimal bx = (BigDecimal) x; - return bx.signum() == 0; - } - - public boolean isPos(Number x){ - BigDecimal bx = (BigDecimal) x; - return bx.signum() > 0; - } - - public boolean isNeg(Number x){ - BigDecimal bx = (BigDecimal) x; - return bx.signum() < 0; - } - final public Number add(Number x, Number y){ MathContext mc = (MathContext) MATH_CONTEXT.deref(); return mc == null @@ -1439,18 +1352,6 @@ static public double divide(double x, double y){ return x / y; } -static public boolean isPos(double x){ - return x > 0; -} - -static public boolean isNeg(double x){ - return x < 0; -} - -static public boolean isZero(double x){ - return x == 0; -} - static int throwIntOverflow(){ throw new ArithmeticException("integer overflow"); } @@ -1639,18 +1540,6 @@ static public int unchecked_int_remainder(int x, int y){ // return x >= y; //} -//static public boolean isPos(int x){ -// return x > 0; -//} - -//static public boolean isNeg(int x){ -// return x < 0; -//} - -//static public boolean isZero(int x){ -// return x == 0; -//} - static public Number num(long x){ return Long.valueOf(x); } @@ -1820,18 +1709,6 @@ static public long remainder(long x, long y){ return x % y; } -static public boolean isPos(long x){ - return x > 0; -} - -static public boolean isNeg(long x){ - return x < 0; -} - -static public boolean isZero(long x){ - return x == 0; -} - //overload resolution //* @@ -2087,11 +1964,6 @@ static public boolean equiv(Object x, double y){ return ((Number)x).doubleValue() == y; } -static boolean isNaN(Object x){ - return (x instanceof Double) && ((Double)x).isNaN() - || (x instanceof Float) && ((Float)x).isNaN(); -} - static public double max(double x, double y){ return Math.max(x, y); } diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 0d386728..817fc612 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -94,6 +94,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - We should probably have a 'normal form' so we can correctly hash if we do spec lookup - t/- : fix - (t/- (t/isa? java.util.Queue) (t/or ?!+queue? !!queue?)) + - (t/- t/any? p/float? p/double?); (t/- number? p/primitive?) - dc/of - (dc/of number?) ; implicitly the container is a `reducible?` - (dc/of map/+map? symbol? dstr/string?) @@ -506,7 +507,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x ] inc - [x ] inc' - [x x] indexed? - - [| ] infinite? + - [| x] infinite? - [ ] inst? - [ ] inst-ms - [ ] instance? — NOTE CLJS has macro @@ -607,7 +608,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x ] namespace? - [! |] nary-inline - [ ] nat-int? - - [ ] neg? + - [x x] neg? - [ ] neg-int? - [ ] newline - [x ] next @@ -655,7 +656,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x ] pop - [ ] pop! - [ ] pop-thread-bindings - - [ ] pos? + - [x x] pos? - [ ] pos-int? - [ ] pr - [ ] pr-on @@ -914,7 +915,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] with-redefs-fn - [| !] write-all - [ ] xml-seq - - [x ] zero? + - [x x] zero? - [ ] zipmap - [.] Intrinsics https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/Intrinsics.java @@ -928,12 +929,12 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x] Numbers.gt(double,double) - [x] Numbers.gte(long,long) - [x] Numbers.gte(double,double) - - [ ] Numbers.isPos(long) - - [ ] Numbers.isPos(double) - - [ ] Numbers.isNeg(long) - - [ ] Numbers.isNeg(double) - - [ ] Numbers.isZero(double) - - [ ] Numbers.isZero(long) + - [x] Numbers.isPos(long) + - [x] Numbers.isPos(double) + - [x] Numbers.isNeg(long) + - [x] Numbers.isNeg(double) + - [x] Numbers.isZero(long) + - [x] Numbers.isZero(double) - [x] Numbers.lt(long,long) - [x] Numbers.lt(double,double) - [x] Numbers.lte(long,long) @@ -991,35 +992,35 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] RT.alength(short[]) - [ ] RT.alength(boolean[]) - [ ] RT.alength(double[]) - - [ ] RT.doubleCast(long) - - [ ] RT.doubleCast(double) - - [ ] RT.doubleCast(float) - - [ ] RT.doubleCast(int) - - [ ] RT.doubleCast(short) - - [ ] RT.doubleCast(byte) - - [ ] RT.uncheckedDoubleCast(double) - - [ ] RT.uncheckedDoubleCast(float) - - [ ] RT.uncheckedDoubleCast(long) - - [ ] RT.uncheckedDoubleCast(int) - - [ ] RT.uncheckedDoubleCast(short) - - [ ] RT.uncheckedDoubleCast(byte) - - [ ] RT.longCast(long) - - [ ] RT.longCast(short) - [ ] RT.longCast(byte) + - [ ] RT.longCast(short) - [ ] RT.longCast(int) - - [ ] RT.uncheckedIntCast(long) - - [ ] RT.uncheckedIntCast(double) - - [ ] RT.uncheckedIntCast(byte) - - [ ] RT.uncheckedIntCast(short) - - [ ] RT.uncheckedIntCast(char) - - [ ] RT.uncheckedIntCast(int) - - [ ] RT.uncheckedIntCast(float) - - [ ] RT.uncheckedLongCast(short) - - [ ] RT.uncheckedLongCast(float) - - [ ] RT.uncheckedLongCast(double) - - [ ] RT.uncheckedLongCast(byte) - - [ ] RT.uncheckedLongCast(long) - - [ ] RT.uncheckedLongCast(int) + - [!] RT.longCast(long) + - [ ] RT.doubleCast(byte) + - [ ] RT.doubleCast(short) + - [ ] RT.doubleCast(int) + - [ ] RT.doubleCast(long) + - [ ] RT.doubleCast(float) + - [!] RT.doubleCast(double) + - [x] RT.uncheckedIntCast(byte) + - [x] RT.uncheckedIntCast(short) + - [x] RT.uncheckedIntCast(char) + - [!] RT.uncheckedIntCast(int) + - [x] RT.uncheckedIntCast(long) + - [x] RT.uncheckedIntCast(float) + - [x] RT.uncheckedIntCast(double) + - [x] RT.uncheckedLongCast(byte) + - [x] RT.uncheckedLongCast(short) + - [x] RT.uncheckedLongCast(int) + - [!] RT.uncheckedLongCast(long) + - [x] RT.uncheckedLongCast(float) + - [x] RT.uncheckedLongCast(double) + - [x] RT.uncheckedDoubleCast(byte) + - [x] RT.uncheckedDoubleCast(short) + - [x] RT.uncheckedDoubleCast(int) + - [x] RT.uncheckedDoubleCast(long) + - [x] RT.uncheckedDoubleCast(float) + - [!] RT.uncheckedDoubleCast(double) - [!] Util.equiv(long,long) - [x] Util.equiv(boolean,boolean) - [!] Util.equiv(double,double) @@ -1530,10 +1531,10 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] incP - [ ] int_array - [ ] ints - - [ ] isNaN - - [ ] isNeg - - [ ] isPos - - [ ] isZero + - [x] isNaN + - [x] isNeg + - [x] isPos + - [x] isZero - [ ] long_array - [ ] longs - [ ] lt @@ -1641,7 +1642,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x] quantum.core.data.time - [.] quantum.core.compare.core - [.] quantum.core.data.numeric - - [.] quantum.core.numeric.predicates + - [x] quantum.core.numeric.predicates - [.] quantum.core.numeric.convert - [.] quantum.core.numeric.exponents - [.] quantum.core.numeric.misc @@ -1707,13 +1708,13 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] (logical) not - [x] lt - [x] lte - - [ ] gt - - [ ] gte + - [x] gt + - [x] gte - [x] eq - [x] neq - [ ] inc - [ ] dec - - [ ] isZero + - [x] isZero - [ ] isNeg - [ ] isPos - [x] add diff --git a/src-untyped/quantum/untyped/core/numeric.cljc b/src-untyped/quantum/untyped/core/numeric.cljc index d2a225e5..bfe40c95 100644 --- a/src-untyped/quantum/untyped/core/numeric.cljc +++ b/src-untyped/quantum/untyped/core/numeric.cljc @@ -18,8 +18,9 @@ :cljs (defalias core/pos-int?)) (defn integer-value? - {:adapted-from '#{com.google.common.math.DoubleMath/isMathematicalInteger - "https://stackoverflow.com/questions/1078953/check-if-bigdecimal-is-integer-value"}} + {:adapted-from + '#{com.google.common.math.DoubleMath/isMathematicalInteger + "https://stackoverflow.com/questions/1078953/check-if-bigdecimal-is-integer-value"}} [x] (cond #?@(:clj [(or (double? x) (float? x)) (let [x (double x)] diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index ecb53a42..9163eafe 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -54,7 +54,7 @@ clojure.core/identical? "9/27/2018" cljs.core/identical? "9/27/2018"}} > ut/boolean? - ([x t/any?] true) ; everything is self-identical + ([x t/any?] true) ; everything is self-identical (except NaN and Infinity...) #?(:clj ([a t/ref?, b t/ref?] (clojure.lang.Util/identical a b)) :cljs ([a t/any?, b t/any?] (cljs.core/identical? a b)))) @@ -62,7 +62,7 @@ (t/defn ^:inline not== "Tests identity-inequality." > ut/boolean? - ([x t/any?] false) ; nothing is self-non-identical + ([x t/any?] false) ; nothing is self-non-identical (except NaN and Infinity...) #?(:clj ([a t/ref?, b t/ref?] (Numeric/nonIdentical a b)) :cljs ([a t/any?, b t/any?] (js* "(~{} !== ~{})" a b)))) @@ -73,7 +73,7 @@ clojure.core/= "9/27/2018" cljs.core/= "9/27/2018"}} > ut/boolean? - ([x t/any?] true)) ; everything is self-equal + ([x t/any?] true)) ; everything is self-equal (except NaN and Infinity...) ;; TODO add variadic arity (t/defn ^:inline not= @@ -81,7 +81,7 @@ {:incorporated '{clojure.core/not= "9/27/2018" cljs.core/not= "9/27/2018"}} > ut/boolean? - ([x t/any?] false)) ; nothing is self-unequal + ([x t/any?] false)) ; nothing is self-unequal (except NaN and Infinity...) ; ===== `<` ===== ; diff --git a/src/quantum/core/data/numeric.cljc b/src/quantum/core/data/numeric.cljc index 715f22fd..433e4399 100644 --- a/src/quantum/core/data/numeric.cljc +++ b/src/quantum/core/data/numeric.cljc @@ -16,7 +16,7 @@ `ratio?` for CLJS: - Fraction.js is the best contender as of 9/27/2018. https://github.com/infusion/Fraction.js" #_(:refer-clojure :exclude ; otherwise `Unable to resolve symbol: eval` - [decimal? denominator integer? number? numerator ratio?]) + [decimal? denominator integer? number? numerator ratio? zero?]) (:require [clojure.core :as core] [clojure.string :as str] @@ -28,9 +28,13 @@ [quantum.core.type :as t] ;; TODO TYPED excise reference [quantum.untyped.core.vars :as var - :refer [defalias]])) + :refer [defalias]]) +#?(:clj (:import + [quantum.core Numeric Primitive]))) -;; ===== Integers ===== ;; +;; ===== Types ===== ;; + +;; ----- Integers ----- ;; ;; Incorporated `clojure.core/int?` ;; Incorporated `cljs.core/int?` @@ -51,21 +55,18 @@ ;; Incorporated `cljs.core/integer?` (def integer? (t/or fixint? bigint?)) -;; TODO TYPED `>long` -#_(:clj -(t/defn >java-bigint > java-bigint? - ([x java-bigint?] x) - ([x clj-bigint? > (t/assume java-bigint?)] (.toBigInteger x)) - ([;; TODO TYPED `(- number? BigInteger BigInt)` - x (t/or p/short? p/int? p/long?) > (t/assume java-bigint?)] ; TODO BigDecimal - (-> x p/>long BigInteger/valueOf)))) - -#?(:cljs -(t/defn >bigint > bigint? - ([x bigint?] x) - ([x p/double?] (-> x (.toString) >bigint)))) +;; ----- Decimals ----- ;; -;; ===== Decimals ===== ;; +(t/defn ^:inline nan? + "`Float/NaN`, `Double/NaN`, and `js/NaN` are all non-self-identical. `js/NaN` is not a + `js/Number` (sensibly so), but `Float/NaN` is a `Float` and `Double/NaN` is a `Double`." + > p/boolean? + #?(:cljs ([x t/any? > (t/assume p/boolean?)] (js/isNaN x))) + #?(:clj ([x p/float?] (Float/isNaN x))) + #?(:clj ([x p/double?] (Double/isNaN x))) + ;; TODO TYPED `(t/- t/any? p/float? p/double?)` + #?(:clj ([x (t/- p/primitive? p/float? p/double?)] false)) + #?(:clj ([x t/ref?] false))) ;; Incorporated `clojure.core/float?` ;; Incorporated `cljs.core/float?` @@ -81,7 +82,7 @@ (def decimal? (t/or fixdec? bigdec?)) -;; ===== Precision ===== ;; +;; ----- Precision ----- ;; (var/def fixnum? "The set of all fixed-precision numbers." (t/or fixint? fixdec?)) @@ -89,88 +90,119 @@ (var/def bignum? "The set of all 'big' (arbitrary-precision) numbers." (t/or fixint? fixdec?)) -;; ===== Ratios ===== ;; +;; ----- Ratios ----- ;; (def ratio? #?(:clj (t/isa? clojure.lang.Ratio) ;; TODO bring in implementation per the ns docstring :cljs t/none?)) -;; TODO TYPED >double -#_(:clj -(t/defn rationalize - "Outputs the rational value of `n`." - {:incorporated {'clojure.lang.Numbers/rationalize "9/2018"}} - > (t/isa? java.lang.Number) - ([x (t/or p/float? p/double?)] - (rationalize (BigDecimal/valueOf (p/>double x)))) - ([x (t/isa? BigDecimal)] - (let [bv (.unscaledValue x) - scale (.scale x)] - (if (< scale 0) - (BigInt/fromBigInteger (.multiply bv (.pow BigInteger.TEN (- scale)))) - (Numbers/divide bv (.pow BigInteger.TEN scale))))) - ([x (t/isa? java.lang.Number)] x))) - -;; TODO TYPED finish -#_(t/defn >ratio > ratio? - #?(:clj ([x ??] (>ratio x 1))) - #?(:clj ([x ??, y ??] - (whenf (rationalize (/ x y)) - (fn-not core/ratio?) - #(clojure.lang.Ratio. (->big-integer %) java.math.BigInteger/ONE))))) +;; ----- General ----- ;; -;; ===== General ===== ;; +(def number? (t/or #?@(:clj [(t/isa? java.lang.Number)] + :cljs [integer? decimal? ratio?]))) (t/defn ^:inline >zero-of-type #_> #_zero? - ([x p/byte? > (t/type x)] Numeric/byte0) - ([x p/short? > (t/type x)] Numeric/short0) - ([x p/char? > (t/type x)] Numeric/char0) - ([x p/int? > #?(:clj (type x) :cljs (t/assume (t/type x)))] +#?(:clj ([x p/byte? > (t/type x)] Numeric/byte0)) +#?(:clj ([x p/short? > (t/type x)] Numeric/short0)) +#?(:clj ([x p/char? > (t/type x)] Numeric/char0)) + ([x p/int? > #?(:clj (t/type x) :cljs (t/assume (t/type x)))] #?(:clj Numeric/int0 :cljs goog.math.Integer/ZERO)) - ([x p/long? > #?(:clj (type x) :cljs (t/assume (t/type x)))] + ([x p/long? > #?(:clj (t/type x) :cljs (t/assume (t/type x)))] #?(:clj 0 :cljs goog.math.Long/ZERO)) - ([x p/float? > (t/type x)] Numeric/float0) - ([x p/double? > (t/type x)] 0.0) -#?(:clj ([x p/java-bigint? > (t/type x)] java.math.BigInteger/ZERO)) -#?(:clj ([x p/clj-bigint? > (t/type x)] clojure.lang.BigInt/ZERO))) +#?(:clj ([x p/float? > (t/type x)] Numeric/float0)) + ([x p/double? > (t/type x)] 0.0) +#?(:clj ([x java-bigint? > (t/assume (t/type x))] java.math.BigInteger/ZERO)) +#?(:clj ([x clj-bigint? > (t/assume (t/type x))] clojure.lang.BigInt/ZERO)) +#?(:clj ([x bigdec? > (t/assume (t/type x))] java.math.BigDecimal/ZERO))) + +(t/defn ^:inline zero? > p/boolean? +#?(:clj (^:int [x (t/or p/long? p/double?)] (Numbers/isZero x))) +#?(:clj ( [x (t/- p/numeric? p/long? p/double?)] (Numeric/isZero x))) +#?(:clj ( [x clj-bigint?] (if (?/nil? (.-bipart x)) + (-> x .-lpart zero?) + (-> x .-bipart zero?)))) +#?(:clj ( [x (t/or java-bigint? bigdec?)] (-> x .signum zero?))) +#?(:clj ( [x ratio?] (-> x .-numerator zero?))) + ( [x #?(:clj (t/ref number?) :clj number?)] (?/= x 0))) (t/defn ^:inline >one-of-type #_> #_one? - ([x p/byte? > (t/type x)] Numeric/byte1) - ([x p/short? > (t/type x)] Numeric/short1) - ([x p/char? > (t/type x)] Numeric/char1) - ([x p/int? > #?(:clj (type x) :cljs (t/assume (t/type x)))] +#?(:clj ([x p/byte? > (t/type x)] Numeric/byte1)) +#?(:clj ([x p/short? > (t/type x)] Numeric/short1)) +#?(:clj ([x p/char? > (t/type x)] Numeric/char1)) + ([x p/int? > #?(:clj (type x) :cljs (t/assume (t/type x)))] #?(:clj Numeric/int1 :cljs goog.math.Integer/ONE)) - ([x p/long? > #?(:clj (type x) :cljs (t/assume (t/type x)))] + ([x p/long? > #?(:clj (type x) :cljs (t/assume (t/type x)))] #?(:clj 1 :cljs goog.math.Long/ONE)) - ([x p/float? > (t/type x)] Numeric/float1) - ([x p/double? > (t/type x)] 1.0) -#?(:clj ([x p/java-bigint? > (t/type x)] java.math.BigInteger/ONE)) -#?(:clj ([x p/clj-bigint? > (t/type x)] clojure.lang.BigInt/ONE))) - -(t/defn >one-of-type) - -(t/defn ^:inline numerator > numerically-integer? - ([x numerically-integer? > (t/type x)] x) -#?(:clj ([x ratio? > (t/assume java-bigint?)] (.numerator x)))) - -(t/defn ^:inline denominator > numerically-integer? - ([x numerically-integer? > (t/type x)] (>one-of-type x)) -#?(:clj ([x ratio? > (t/assume java-bigint?)] (.denominator x)))) +#?(:clj ([x p/float? > (t/type x)] Numeric/float1)) + ([x p/double? > (t/type x)] 1.0) +#?(:clj ([x java-bigint? > (t/assume (t/type x))] java.math.BigInteger/ONE)) +#?(:clj ([x clj-bigint? > (t/assume (t/type x))] clojure.lang.BigInt/ONE)) +#?(:clj ([x bigdec? > (t/assume (t/type x))] java.math.BigDecimal/ONE))) + +(t/defn ^:inline one? > p/boolean? +#?(:clj ([x p/numeric?] (?/= x (>one-of-type x)))) + ([x #?(:clj (t/ref number?) :clj number?)] (?/= x 1))) + +(t/defn ^:inline neg? > p/boolean? +#?(:clj (^:int [x (t/or p/long? p/double?)] (Numbers/isNeg x))) +#?(:clj ( [x (t/- p/numeric? p/long? p/double?)] (Numeric/isNeg x))) +#?(:clj ( [x clj-bigint?] (if (?/nil? (.-bipart x)) + (-> x .-lpart neg?) + (-> x .-bipart neg?)))) +#?(:clj ( [x (t/or java-bigint? bigdec?)] (-> x .signum neg?))) +#?(:clj ( [x ratio?] (-> x .-numerator neg?))) + ( [x #?(:clj (t/ref number?) :clj number?)] (?/< x 0))) + +(t/defn nneg? > p/boolean? [x number?] (FIXME)) + +(t/defn ^:inline pos? > p/boolean? +#?(:clj (^:int [x (t/or p/long? p/double?)] (Numbers/isPos x))) +#?(:clj ( [x (t/- p/numeric? p/long? p/double?)] (Numeric/isPos x))) +#?(:clj ( [x clj-bigint?] (if (?/nil? (.-bipart x)) + (-> x .-lpart pos?) + (-> x .-bipart pos?)))) +#?(:clj ( [x (t/or java-bigint? bigdec?)] (-> x .signum pos?))) +#?(:clj ( [x ratio?] (-> x .-numerator pos?))) + ( [x #?(:clj (t/ref number?) :clj number?)] (?/> x 0))) + +(t/defn npos? > p/boolean? [x number?] (FIXME))) + +(def pos-int? (fn/and integer? pos?)) +(def neg-int? (fn/and integer? neg?)) +(def npos-int? (fn/and integer? npos?)) +(def nneg-int? (fn/and integer? nneg?)) + +(t/defn exact? > p/boolean? [x p/numeric?] (TODO)) + +(t/defn ^:inline infinite? + "`Float/NEGATIVE_INFINITY`, `Float/POSITIVE_INFINITY`, `Double/NEGATIVE_INFINITY`, and + `Double/POSITIVE_INFINITY` are all non-self-identical. `js/Number.NEGATIVE_INFINITY` and + `js/Number.POSITIVE_INFINITY` are self-identical, but neither of them are `js/Number`s. By + contrast, the `Float` and `Double` infinities are instances of `Float` and `Double`, + respectively." +#?(:cljs ([x t/any? > (t/assume p/boolean?)] (??/not (js/isFinite x)))) +#?(:clj ([x p/float?] (Float/isInfinite x))) +#?(:clj ([x p/double?] (Double/isInfinite x))) +#?(:clj ([x (t/- p/primitive? p/float? p/double?)] false)) + ;; This leaves room for other numbers to be infinite +#?(:clj ([x (t/ref number?)] false))) ;; ===== Likenesses ===== ;; -;; TODO incorporate -(defn ^boolean numerically-integer? - "Returns true if n is a JavaScript number with no decimal part." - [n] - (and (number? n) - (not ^boolean (js/isNaN n)) - (not (identical? n js/Infinity)) - (== (js/parseFloat n) (js/parseInt n 10)))) - -#_(def numerically-integer? (or integer? (and decimal? (>expr unum/integer-value?)))) - -#_(def numeric-primitive? (and primitive? (not boolean?))) +(t/defn integer-value? ; TODO this is the same as `numerically-integer?` but we need to turn it into a predicate + {:adapted-from + '#{com.google.common.math.DoubleMath/isMathematicalInteger + "https://stackoverflow.com/questions/1078953/check-if-bigdecimal-is-integer-value"}} + > p/boolean? + ( [x integer?] true) +#?(:cljs (^:int [x p/double? > (t/assume p/boolean?)] (js/Number.isInteger x))) +#?(:clj ( [x (t/or p/float? p/double?)] (c?/= x (>long* x)))) +#?(:clj ( [x bigdec?] (or (zero? (.signum x)) + (-> x .scale npos?) + (-> x .stripTrailingZeros .scale npos?)))) +#?(:clj ( [x (t/ref number?)] x))) + +(def numerically-integer? (t/or integer? (t/and decimal? (>expr unum/integer-value?)))) #_(def numerically-byte? (and numerically-integer? (>expr (c/fn [x] (c/<= -128 x 127))))) @@ -216,10 +248,8 @@ ;;"java.lang.Double" numerically-double? (err! "Could not find numerical range type for class" {:c c})))) -(def number? (t/or #?@(:clj [(t/isa? java.lang.Number)] - :cljs [integer? decimal? ratio?]))) -(def primitive-number? (t/or #?@(:clj [p/short? t/int? t/long? t/float?]) t/double?)) +(def primitive-number? (t/or #?@(:clj [p/short? p/int? p/long? p/float?]) p/double?)) (var/def numeric? "Something 'numeric' is something that may be treated as a number but may not actually *be* one." @@ -237,48 +267,7 @@ ;; TODO excise? (def std-integer? (t/or integer? #?(:cljs numerically-integer-double?))) -(def std-fixint? #?(:clj long? :cljs numerically-integer-double?)) - -(t/defn >std-fixint - "Converts input to a `std-fixint?` in a way that may involve truncation or rounding." - > std-fixint? -#?(:cljs ([x double? > (t/assume std-fixint?)] (js/Math.round x)))) - -;; TODO TYPED -(t/defn read-rational - "Create cross-platform literal rational numbers from decimal, without intermediate inexact - (e.g. float/double) representation. - - Example: - #r 2.712 -> (rationalize 2.712M)" - {:todo #{"Support exponent notation e.g. 2.313E7 | 2.313e7"}} - [r string?] - (let [r-str (cond (string? r) - r - (symbol? r) - (do (assert (-> r namespace nil?)) - (assert (-> r name first (= \r))) - (->> r name rest (apply str)))) - minus-ct (->> r-str (filter #(= % \-)) count) - _ (assert (#{0 1} minus-ct)) - r-str (case minus-ct - 0 r-str - 1 (do (assert (-> r-str first (= \-))) - (->> r-str rest (apply str)))) - [integral-str decimal-str :as split] (str/split r-str #"\.") - _ (when (-> split count (> 2)) - (throw (ex-info "Number cannot have more than one decimal point" {:num r-str}))) - _ (doseq [s split] - (when-not (every? #{\0 \1 \2 \3 \4 \5 \6 \7 \8 \9} s) - (throw (ex-info "Number must have only numeric characters" {:num s})))) - integral (read-string integral-str) ; TODO we should just pass the raw string to the ratio - decimal (read-string decimal-str) ; TODO we should just pass the raw string to the ratio - scale (if decimal - (#?(:clj Math/pow :cljs js/Math.pow) 10 (count decimal-str)) - 1)] - (* (if (= minus-ct 1) -1 1) - (>ratio (+ (* scale integral) (or decimal 0)) - scale)))) +(def std-fixint? #?(:clj p/long? :cljs numerically-integer-double?)) ;; ===== Conversion ===== ;; ;; Note that numeric-primitive conversions go here because they take as inputs and produce outputs @@ -290,21 +279,20 @@ #?(:clj (t/defn ^:inline >byte* "May involve non-out-of-range truncation." - > byte? - ([x byte?] x) - ([x (t/- primitive? byte? boolean?)] (Primitive/uncheckedByteCast x)))) + > p/byte? + ([x p/byte?] x) + ([x (t/- p/primitive? p/byte? p/boolean?)] (Primitive/uncheckedByteCast x)))) ;; TODO TYPED `numerically` ;; TODO figure out how to use with goog.math.Integer/Long -(t/defn ^:inline >byte > #?(:clj byte? :cljs numerically-byte?) +(t/defn ^:inline >byte > #?(:clj p/byte? :cljs numerically-byte?) "Does not involve truncation or rounding." - ([x #?(:clj byte? :cljs numerically-byte?)] x) -#?(:clj ([x (t/and (t/- primitive? byte? boolean?) numerically-byte?)] (>byte* x)) - :cljs ([x (t/and double? numerically-byte?)] x)) - + ([x #?(:clj p/byte? :cljs numerically-byte?)] x) +#?(:clj ([x (t/and (t/- p/primitive? p/byte? p/boolean?) numerically-byte?)] (>byte* x)) + :cljs ([x (t/and p/double? numerically-byte?)] x)) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-byte?)] (>byte* (.lpart x)))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-byte?)] (.byteValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-byte?)] (-> x .bigIntegerValue .byteValue)))) +#?(:clj ([x (t/and ratio? numerically-byte?)] (-> x .bigIntegerValue .byteValue)))) ;; ----- Char ----- ;; @@ -327,7 +315,7 @@ ([x boolean?] (if x #?(:clj (char 1) :cljs 1) #?(:clj (char 0) :cljs 0))) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-char?)] (>char* (.lpart x)))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-char?)] (.charValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-char?)] (-> x .bigIntegerValue .charValue)))) +#?(:clj ([x (t/and ratio? numerically-char?)] (-> x .bigIntegerValue .charValue)))) ;; ----- Short ----- ;; @@ -349,7 +337,7 @@ ([x boolean?] (if x #?(:clj (short 1) :cljs 1) #?(:clj (short 0) :cljs 0))) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-short?)] (>short* (.lpart x)))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-short?)] (.shortValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-short?)] (-> x .bigIntegerValue .shortValue)))) +#?(:clj ([x (t/and ratio? numerically-short?)] (-> x .bigIntegerValue .shortValue)))) ;; ----- Int ----- ;; @@ -358,8 +346,8 @@ (t/defn ^:inline >int* "May involve non-out-of-range truncation." > int? - ([x int?] x) ;; For purposes of Clojure intrinsics - ([x (t/- primitive? int? boolean?)] (clojure.lang.RT/uncheckedIntCast x)))) + ( [x int?] x) + (^:int [x (t/- primitive? int? boolean?)] (clojure.lang.RT/uncheckedIntCast x)))) ;; TODO TYPED `numerically` ;; TODO figure out how to use with goog.math.Integer/Long @@ -372,7 +360,7 @@ ([x boolean?] (if x #?(:clj (int 1) :cljs 1) #?(:clj (int 0) :cljs 0))) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-int?)] (>int* (.lpart x)))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-int?)] (.intValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-int?)] (-> x .bigIntegerValue .intValue)))) +#?(:clj ([x (t/and ratio? numerically-int?)] (-> x .bigIntegerValue .intValue)))) ;; ----- Long ----- ;; @@ -381,9 +369,10 @@ (t/defn ^:inline >long* "May involve non-out-of-range truncation." > long? - ([x long?] x) - ([x char?] (Primitive/uncheckedLongCast x)) ;; For purposes of Clojure intrinsics - ([x (t/- primitive? long? boolean? char?)] (clojure.lang.RT/uncheckedLongCast x)))) + ( [x long?] x) + ( [x char?] (Primitive/uncheckedLongCast x)) + (^:int [x (t/- primitive? long? boolean? char?)] (clojure.lang.RT/uncheckedLongCast x)) + ( [x (t/ref number?)] (.longValue x)))) ;; TODO TYPED `numerically` ;; TODO figure out how to use with goog.math.Integer/Long @@ -402,7 +391,7 @@ numerically-long? ;; TODO This might be faster than `numerically-long?` #_(t/fn [x ?] (< (.bitLength x) 64)))] (.longValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-long?)] (-> x .bigIntegerValue .longValue)))) +#?(:clj ([x (t/and ratio? numerically-long?)] (-> x .bigIntegerValue .longValue)))) ;; ----- Float ----- ;; @@ -424,17 +413,18 @@ ([x boolean?] (if x #?(:clj (float 1) :cljs 1) #?(:clj (float 0) :cljs 0))) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-float?)] (>float* (.lpart x)))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-float?)] (.floatValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-float?)] (-> x .bigIntegerValue .floatValue)))) +#?(:clj ([x (t/and ratio? numerically-float?)] (-> x .bigIntegerValue .floatValue)))) ;; ----- Double ----- ;; ;; TODO figure out how to use with goog.math.Integer/Long (t/defn ^:inline >double* "May involve non-out-of-range truncation." - > double? - ([x double?] x) - ([x char?] (Primitive/uncheckedDoubleCast x)) ;; For purposes of Clojure intrinsics -#?(:clj ([x (t/- primitive? double? boolean? char?)] (clojure.lang.RT/uncheckedDoubleCast x)))) + > p/double? + ( [x p/double?] x) + ( [x p/char?] (Primitive/uncheckedDoubleCast x)) +#?(:clj (^:int [x (t/- p/primitive? p/boolean? p/char? p/double?)] + (clojure.lang.RT/uncheckedDoubleCast x)))) ;; TODO TYPED `numerically` ;; TODO figure out how to use with goog.math.Integer/Long @@ -445,17 +435,17 @@ ([x boolean?] (if x #?(:clj 1.0 :cljs 1) #?(:clj 1.0 :cljs 0))) #?(:clj ([x (t/and (t/isa? clojure.lang.BigInt) numerically-double?)] (>double* (.lpart x)))) #?(:clj ([x (t/and (t/isa? java.math.BigInteger) numerically-double?)] (.doubleValue x))) -#?(:clj ([x (t/and dn/ratio? numerically-double?)] (-> x .bigIntegerValue .doubleValue)))) +#?(:clj ([x (t/and ratio? numerically-double?)] (-> x .bigIntegerValue .doubleValue)))) -;; ===== Unsigned ===== ;; +;; ----- Unsigned ----- ;; #?(:clj (t/defn >unsigned {:adapted-from #{'ztellman/primitive-math 'gloss.data.primitives}} - ([x byte?] (Numeric/bitAnd (short 0xFF) x)) - ([x short?] (Numeric/bitAnd (int 0xFFFF) x)) - ([x int?] (Numeric/bitAnd (long 0xFFFFFFFF) x)) - ([x long?] (java.math.BigInteger. (int 1) + ([x p/byte?] (Numeric/bitAnd (short 0xFF) x)) + ([x p/short?] (Numeric/bitAnd (int 0xFFFF) x)) + ([x p/int?] (Numeric/bitAnd (long 0xFFFFFFFF) x)) + ([x p/long?] (java.math.BigInteger. (int 1) (-> ^:val (ByteBuffer/allocate (int 8)) ^:val (.putLong x) .array))))) @@ -465,3 +455,102 @@ #_(:clj (t/defn ushort>short [x long? > long?] (-> x >short >long))) #_(:clj (t/defn uint>int [x long? > long?] (-> x >int >long))) #_(:clj (t/defn ulong>long [x bigint? > long?] (-> x >bigint >long))) + +;; ----- Integers ----- ;; + +#?(:cljs +(t/defn >bigint > bigint? + ([x bigint?] x) + ([x p/double?] (-> x (.toString) >bigint)))) + +;; ----- Decimals ----- ;; + +;; TODO TYPED `>long` +#_(:clj +(t/defn >java-bigint > java-bigint? + ([x java-bigint?] x) + ([x clj-bigint? > (t/assume java-bigint?)] (.toBigInteger x)) + ([;; TODO TYPED `(- number? BigInteger BigInt)` + x (t/or p/short? p/int? p/long?) > (t/assume java-bigint?)] ; TODO BigDecimal + (-> x p/>long BigInteger/valueOf)))) + +;; ----- Ratios ----- ;; + +;; TODO TYPED >double +#_(:clj +(t/defn rationalize + "Outputs the rational value of `n`." + {:incorporated {'clojure.lang.Numbers/rationalize "9/2018"}} + > (t/isa? java.lang.Number) + ([x (t/or p/float? p/double?)] + (rationalize (BigDecimal/valueOf (p/>double x)))) + ([x (t/isa? BigDecimal)] + (let [bv (.unscaledValue x) + scale (.scale x)] + (if (< scale 0) + (BigInt/fromBigInteger (.multiply bv (.pow BigInteger.TEN (- scale)))) + (Numbers/divide bv (.pow BigInteger.TEN scale))))) + ([x (t/isa? java.lang.Number)] x))) + +;; TODO TYPED finish +#_(t/defn >ratio > ratio? + #?(:clj ([x ??] (>ratio x 1))) + #?(:clj ([x ??, y ??] + (whenf (rationalize (/ x y)) + (fn-not core/ratio?) + #(clojure.lang.Ratio. (->big-integer %) java.math.BigInteger/ONE))))) + + +;; ===== General ===== ;; + +(t/defn ^:inline numerator > numerically-integer? + ([x numerically-integer? > (t/type x)] x) +#?(:clj ([x ratio? > (t/assume java-bigint?)] (.numerator x)))) + +(t/defn ^:inline denominator > numerically-integer? + ([x numerically-integer? > (t/type x)] (>one-of-type x)) +#?(:clj ([x ratio? > (t/assume java-bigint?)] (.denominator x)))) + + + + +(t/defn >std-fixint + "Converts input to a `std-fixint?` in a way that may involve truncation or rounding." + > std-fixint? +#?(:cljs ([x double? > (t/assume std-fixint?)] (js/Math.round x)))) + +;; TODO TYPED +(t/defn read-rational + "Create cross-platform literal rational numbers from decimal, without intermediate inexact + (e.g. float/double) representation. + + Example: + #r 2.712 -> (rationalize 2.712M)" + {:todo #{"Support exponent notation e.g. 2.313E7 | 2.313e7"}} + [r string?] + (let [r-str (cond (string? r) + r + (symbol? r) + (do (assert (-> r namespace nil?)) + (assert (-> r name first (= \r))) + (->> r name rest (apply str)))) + minus-ct (->> r-str (filter #(= % \-)) count) + _ (assert (#{0 1} minus-ct)) + r-str (case minus-ct + 0 r-str + 1 (do (assert (-> r-str first (= \-))) + (->> r-str rest (apply str)))) + [integral-str decimal-str :as split] (str/split r-str #"\.") + _ (when (-> split count (> 2)) + (throw (ex-info "Number cannot have more than one decimal point" {:num r-str}))) + _ (doseq [s split] + (when-not (every? #{\0 \1 \2 \3 \4 \5 \6 \7 \8 \9} s) + (throw (ex-info "Number must have only numeric characters" {:num s})))) + integral (read-string integral-str) ; TODO we should just pass the raw string to the ratio + decimal (read-string decimal-str) ; TODO we should just pass the raw string to the ratio + scale (if decimal + (#?(:clj Math/pow :cljs js/Math.pow) 10 (count decimal-str)) + 1)] + (* (if (= minus-ct 1) -1 1) + (>ratio (+ (* scale integral) (or decimal 0)) + scale)))) diff --git a/src/quantum/core/numeric/predicates.cljc b/src/quantum/core/numeric/predicates.cljc deleted file mode 100644 index 4663cbd4..00000000 --- a/src/quantum/core/numeric/predicates.cljc +++ /dev/null @@ -1,60 +0,0 @@ -(ns quantum.core.numeric.predicates - (:refer-clojure :exclude - [neg? pos? pos-int? zero?]) - (:require - #?(:cljs [com.gfredericks.goog.math.Integer :as int]) - [quantum.core.compare.core :as comp] - [quantum.core.data.numeric :as dn - :refer [bigdec? bigint? clj-bigint? java-bigint? numeric-primitive?]] - [quantum.core.data.primitive :as p] - [quantum.core.logic :as l] - [quantum.core.type :as t] - ;; TODO TYPED excise reference - [quantum.core.untyped.error - :refer [TODO]]) -#?(:clj (:import - [quantum.core Numeric]))) - - ;; TODO TYPED - (t/defn ^:inline neg? > p/boolean? - ([x numeric-primitive?] #?(:clj (Numeric/isNeg x) :cljs (comp/< x 0))) -#?(:clj ([x (t/or java-bigint? bigdec?)] (-> x .signum neg?))) -#?(:clj ([x clj-bigint?] (if (-> x .bipart p/nil?) - (-> x .lpart neg?) - (-> x .bipart .signum neg?)))) -#?(:cljs ([x bigint?] (.isNegative x))) -#?(:clj ([x dn/ratio?] (-> x .numerator .signum neg?)))) - - ;; TODO TYPED - (t/defn ^:inline pos? > p/boolean? - ([x numeric-primitive?] #?(:clj (Numeric/isPos x) :cljs (comp/> x 0))) -#?(:clj ([x (t/or java-bigint? bigdec?)] (-> x .signum pos?))) -#?(:clj ([x clj-bigint?] (if (-> x .bipart p/nil?) - (-> x .lpart pos?) - (-> x .bipart .signum pos?)))) -#?(:cljs ([x bigint?] (l/not (.isNegative x)))) -#?(:clj ([x dn/ratio?] (-> x .numerator .signum pos?)))) - - ;; TODO TYPED - (t/defn ^:inline zero? > p/boolean? - ([x numeric-primitive?] #?(:clj (Numeric/isZero x) :cljs (comp/== x 0))) -#?(:clj ([x (t/or java-bigint? bigdec?)] (-> x .signum zero?))) -#?(:clj ([x clj-bigint?] (if (-> x .bipart p/nil?) - (-> x .lpart zero?) - (-> x .bipart .signum zero?)))) -#?(:cljs ([x bigint?] (.isZero x))) -#?(:clj ([x dn/ratio?] (-> x .numerator .signum zero?)))) - - (t/defnt ^:inline nan? > p/boolean? -#?(:clj ([x p/float?] (Float/isNaN x))) - ([x p/double?] (#?(:clj Double/isNaN :cljs js/Number.isNaN) x)) - ([x t/any?] false)) - -(def npos? (l/fn-not pos?)) -(def nneg? (l/fn-not neg?)) -(def pos-int? (l/fn-and dn/integer? pos?)) -(def neg-int? (l/fn-and dn/integer? neg?)) -(def npos-int? (l/fn-and dn/integer? npos?)) -(def nneg-int? (l/fn-and dn/integer? nneg?)) - -(t/defn exact? > p/boolean? [x p/numeric?] (TODO)) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index eb9a1a17..da5fa568 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -30,6 +30,7 @@ ;; Just in case (clojure.spec.test.alpha/unstrument) (do (require '[orchestra.spec.test :as st]) + (orchestra.spec.test/unstrument) (orchestra.spec.test/instrument)) (defn B [form] (tag "boolean" form)) From 48fbd9994e903cfe694a40828ba4f2fdc9112050 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 14 Oct 2018 10:45:43 -0600 Subject: [PATCH 515/810] Working more on comparisons --- resources-dev/clojure-lang-util-temp.java | 13 -------- resources-dev/defnt.cljc | 7 +++- src/quantum/core/compare.cljc | 39 ++++++++++++----------- src/quantum/core/compare/core.cljc | 22 +++++++++++-- src/quantum/core/data/numeric.cljc | 34 +++++++++++++------- src/quantum/core/data/primitive.cljc | 24 +++++++------- 6 files changed, 81 insertions(+), 58 deletions(-) diff --git a/resources-dev/clojure-lang-util-temp.java b/resources-dev/clojure-lang-util-temp.java index 0adecfab..1715d7e7 100644 --- a/resources-dev/clojure-lang-util-temp.java +++ b/resources-dev/clojure-lang-util-temp.java @@ -1,17 +1,4 @@ public class Util{ -static public boolean equiv(Object k1, Object k2){ - if(k1 == k2) - return true; - if(k1 != null) - { - if(k1 instanceof Number && k2 instanceof Number) - return Numbers.equal((Number)k1, (Number)k2); - else if(k1 instanceof IPersistentCollection || k2 instanceof IPersistentCollection) - return pcequiv(k1,k2); - return k1.equals(k2); - } - return false; -} public interface EquivPred{ boolean equiv(Object k1, Object k2); diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 817fc612..0a9f8ac5 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -102,6 +102,10 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - dc/map-of - dc/seq-of - Analysis + - `(p/nil? ...)` should probably be inlined to `(?/== ... nil)` rather than using the overhead of the + deftype + - This should realize that we're negating a `<` and change the operator to `<=` + - `(t/def nneg? (fn/comp ?/not neg?))` - Better analysis of compound literals - Literal vectors need to be analyzed — (t/finite-of t/built-in-vector? a-type b-type ...) - Literal sets need to be analyzed — (t/finite-of t/built-in-set? a-type b-type ...) @@ -148,6 +152,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - comparison of `t/fn`s is probably possible? - t/def - TODO what would this even look like? I guess it would just declare the sym, meta, and type + - It would also have the benefit of creating a typed context - Without an argument, it would work like `declare` - t/fn - t/ftype @@ -214,7 +219,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [! !] .. - [x x] < - [x x] <= - - [. .] = — look at coercive-= + - [x .] = — look at coercive-= - [x x] == - [x x] > - [x x] >= diff --git a/src/quantum/core/compare.cljc b/src/quantum/core/compare.cljc index 8dcc7e8a..3d72c04d 100644 --- a/src/quantum/core/compare.cljc +++ b/src/quantum/core/compare.cljc @@ -39,13 +39,27 @@ (:import clojure.lang.BigInt quantum.core.Numeric))) -;; TODO incorporate (CLJS) -(defn ^boolean = - ([x y] - (if (nil? x) - (nil? y) - (or (identical? x y) - ^boolean (-equiv x y))))) +(def compare ccomp/compare) + +;; TODO TYPED define variadic arity +(t/extend-defn! compare +#?(:cljs ([a js/Date , b js/Date] (compare (dtime/date>value a) (dtime/date>value b)))) + ([a arr/array-1d?, b arr/array-1d?] (compare-1d-arrays-lexicographically a b))) + +;; TODO TYPED define variadic arity +;; TODO move this to the appropriate place +(t/extend-defn! = +#?(:cljs ([a js/Date , b js/Date] (= (dtime/date>value o) (dtime/date>value other)))) +#?(:cljs ([a js/Date , b t/any?] false)) +#?(:cljs ([a ??/array? , b ??/array?] (TODO))) +#?(:cljs ([a ??/array? , b t/any?] false)) + ;; We intentionally ignore the case of `new String(...)`. +#?(:cljs ([a ??/string?, b ??/string?] (== a b))) +#?(:cljs ([a ??/string?, b t/any?] false)) +#?(:clj ([a (t/isa? IPersistentCollection) b t/any?] (TODO Util.pcequiv))) +#?(:clj ([a t/any? b (t/isa? IPersistentCollection)] (TODO Util.pcequiv))) +) + ;; TODO TYPED; also incorporate `core/fn->comparator` (defn fn->comparator [f] @@ -70,17 +84,6 @@ (recur (core/inc i)) x)))))))) -(def compare ccomp/compare) - -;; TODO TYPED define variadic arity -(t/extend-defn! compare -#?(:cljs ([a js/Date , b js/Date] (compare (dtime/date>value a) (dtime/date>value b)))) - ([a arr/array-1d?, b arr/array-1d?] (compare-1d-arrays-lexicographically a b))) - -;; TODO TYPED define variadic arity -(t/extend-defn! = -#?(:cljs ([a js/Date, b js/Date] (== (dtime/date>value o) (dtime/date>value other))))) - (defaliases ccomp min-key first-min-key second-min-key max-key first-max-key second-max-key diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index 9163eafe..e711742e 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -41,7 +41,6 @@ ;; TODO comp< vs. <; comp< should include arrays ;; `=` <- `==`, `=`: permissive ;; `='` <- `=`: strict like `core/=` with numbers -;; `==` <- `identical?` ;; TODO `hash=` ;; TODO .equals vs. .equiv vs. all the others? @@ -68,12 +67,29 @@ ;; TODO add variadic arity (t/defn ^:inline = - "Tests value-equality." + "Tests value-equality. Same as Java's `x.equals(y)` except it also works for nil, and compares + numbers and collections in a type-independent manner. For numbers, works like `core/==`" {:incorporated '{clojure.lang.Util/equiv "9/27/2018" clojure.core/= "9/27/2018" cljs.core/= "9/27/2018"}} > ut/boolean? - ([x t/any?] true)) ; everything is self-equal (except NaN and Infinity...) + ([x t/any?] true) ; everything is self-equal (except NaN and Infinity...) + ([a t/nil? , b t/nil?] true) + ([a t/nil? , b (t/ref t/val?)] false) + ([a (t/ref t/val?), b t/nil?] false) + ;; The fallback overload; collections (in CLJ) and protocol-native objects (in CLJS) will have a + ;; more specific equivalence check as defined later on + ([a (t/ref t/val?), b (t/ref t/val?)] + (or (== a b) + #?(:clj (.equals a b) + :cljs (-equiv ^non-native a b))))) + +(defn ^boolean = + ([x y] + (if (nil? x) + (nil? y) + (or (identical? x y) + ^boolean (-equiv x y))))) ;; TODO add variadic arity (t/defn ^:inline not= diff --git a/src/quantum/core/data/numeric.cljc b/src/quantum/core/data/numeric.cljc index 433e4399..2e617816 100644 --- a/src/quantum/core/data/numeric.cljc +++ b/src/quantum/core/data/numeric.cljc @@ -15,13 +15,14 @@ `ratio?` for CLJS: - Fraction.js is the best contender as of 9/27/2018. https://github.com/infusion/Fraction.js" - #_(:refer-clojure :exclude ; otherwise `Unable to resolve symbol: eval` + (:refer-clojure :exclude ; otherwise `Unable to resolve symbol: eval` [decimal? denominator integer? number? numerator ratio? zero?]) (:require [clojure.core :as core] [clojure.string :as str] #?(:cljs goog.math.Integer) #?(:cljs goog.math.Long) + [quantum.core.compare.core :as c?] [quantum.core.data.primitive :as p] #_[quantum.core.logic :refer [whenf fn-not fn=]] @@ -30,6 +31,7 @@ [quantum.untyped.core.vars :as var :refer [defalias]]) #?(:clj (:import + [clojure.lang Numbers] [quantum.core Numeric Primitive]))) ;; ===== Types ===== ;; @@ -98,9 +100,17 @@ ;; ----- General ----- ;; +(def exact? (t/or integer? ratio?)) + (def number? (t/or #?@(:clj [(t/isa? java.lang.Number)] :cljs [integer? decimal? ratio?]))) +;; ===== Comparison extensions ===== ;; + +;; TODO primitive with non-primitive +(t/extend-defn! c?/= + FIXME) + (t/defn ^:inline >zero-of-type #_> #_zero? #?(:clj ([x p/byte? > (t/type x)] Numeric/byte0)) #?(:clj ([x p/short? > (t/type x)] Numeric/short0)) @@ -118,7 +128,7 @@ (t/defn ^:inline zero? > p/boolean? #?(:clj (^:int [x (t/or p/long? p/double?)] (Numbers/isZero x))) #?(:clj ( [x (t/- p/numeric? p/long? p/double?)] (Numeric/isZero x))) -#?(:clj ( [x clj-bigint?] (if (?/nil? (.-bipart x)) +#?(:clj ( [x clj-bigint?] (if (p/nil? (.-bipart x)) (-> x .-lpart zero?) (-> x .-bipart zero?)))) #?(:clj ( [x (t/or java-bigint? bigdec?)] (-> x .signum zero?))) @@ -140,8 +150,8 @@ #?(:clj ([x bigdec? > (t/assume (t/type x))] java.math.BigDecimal/ONE))) (t/defn ^:inline one? > p/boolean? -#?(:clj ([x p/numeric?] (?/= x (>one-of-type x)))) - ([x #?(:clj (t/ref number?) :clj number?)] (?/= x 1))) +#?(:clj ([x p/numeric?] (c?/= x (>one-of-type x)))) + ([x #?(:clj (t/ref number?) :clj number?)] (c?/= x 1))) (t/defn ^:inline neg? > p/boolean? #?(:clj (^:int [x (t/or p/long? p/double?)] (Numbers/isNeg x))) @@ -153,7 +163,8 @@ #?(:clj ( [x ratio?] (-> x .-numerator neg?))) ( [x #?(:clj (t/ref number?) :clj number?)] (?/< x 0))) -(t/defn nneg? > p/boolean? [x number?] (FIXME)) +;; TODO TYPED this should realize that we're negating a `<` and change the operator to `<=` +(t/def nneg? (fn/comp ?/not neg?)) (t/defn ^:inline pos? > p/boolean? #?(:clj (^:int [x (t/or p/long? p/double?)] (Numbers/isPos x))) @@ -165,14 +176,13 @@ #?(:clj ( [x ratio?] (-> x .-numerator pos?))) ( [x #?(:clj (t/ref number?) :clj number?)] (?/> x 0))) -(t/defn npos? > p/boolean? [x number?] (FIXME))) - -(def pos-int? (fn/and integer? pos?)) -(def neg-int? (fn/and integer? neg?)) -(def npos-int? (fn/and integer? npos?)) -(def nneg-int? (fn/and integer? nneg?)) +;; TODO TYPED this should realize that we're negating a `<` and change the operator to `<=` +(t/def npos? (fn/comp ?/not pos?)) -(t/defn exact? > p/boolean? [x p/numeric?] (TODO)) +(t/def pos-int? (fn/and integer? pos?)) +(t/def neg-int? (fn/and integer? neg?)) +(t/def npos-int? (fn/and integer? npos?)) +(t/def nneg-int? (fn/and integer? nneg?)) (t/defn ^:inline infinite? "`Float/NEGATIVE_INFINITY`, `Float/POSITIVE_INFINITY`, `Double/NEGATIVE_INFINITY`, and diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 9ceec219..3c5ba61d 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -5,7 +5,7 @@ #?(:cljs [com.gfredericks.goog.math.Integer :as int]) #?(:cljs goog.math.Integer) #?(:cljs goog.math.Long) - [quantum.core.compare.core :as ccomp] + [quantum.core.compare.core :as c?] [quantum.core.type :as t] [quantum.untyped.core.type :as ut] ;; TODO TYPED excise reference @@ -16,6 +16,7 @@ [java.nio ByteBuffer] [quantum.core Numeric Primitive]))) +;; TODO for CLJS nil/val, we need to check via `js/==` not `js/===` (def nil? ut/nil?) (def val? ut/val?) @@ -198,7 +199,7 @@ ;; ===== Extensions ===== ;; #?(:clj -(t/extend-defn! ccomp/== +(t/extend-defn! c?/== (^:in [a boolean? , b boolean?] (Util/equiv a b)) ( [a boolean? , b (t/- primitive? boolean?)] false) ( [a (t/- primitive? boolean?) , b boolean?] false) @@ -211,19 +212,20 @@ ( [a (t/- numeric? double? long?), b (t/- numeric? double? long?)] (Numeric/eq a b)))) #?(:clj -(t/extend-defn! ccomp/not== +(t/extend-defn! c?/not== ([a boolean? , b boolean?] (Numeric/neq a b)) ([a boolean? , b (t/- primitive? boolean?)] false) ([a (t/- primitive? boolean?), b boolean?] false) ([a numeric? , b numeric?] (Numeric/neq a b)))) -(t/extend-defn! ccomp/= - ([a primitive?, b primitive?] (ccomp/== a b))) +(t/extend-defn! c?/= + ([a primitive?, b primitive?] (c?/== a b)) +#?(:cljs ([a primitive?, b t/any?] false))) -(t/extend-defn! ccomp/not= - ([a primitive?, b primitive?] (ccomp/not== a b))) +(t/extend-defn! c?/not= + ([a primitive?, b primitive?] (c?/not== a b))) -(t/extend-defn! ccomp/< +(t/extend-defn! c?/< ( [x numeric?] true) #?(:clj (^:in [a long? , b long?] (Numbers/lt a b))) #?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/lt a b))) @@ -237,7 +239,7 @@ ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) ) -(t/extend-defn! ccomp/<= +(t/extend-defn! c?/<= ( [x numeric?] true) #?(:clj (^:in [a long? , b long?] (Numbers/lte a b))) #?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/lte a b))) @@ -251,7 +253,7 @@ ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) ) -(t/extend-defn! ccomp/> +(t/extend-defn! c?/> ( [x numeric?] true) #?(:clj (^:in [a long? , b long?] (Numbers/gt a b))) #?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/gt a b))) @@ -265,7 +267,7 @@ ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) ) -(t/extend-defn! ccomp/>= +(t/extend-defn! c?/>= ( [x numeric?] true) #?(:clj (^:in [a long? , b long?] (Numbers/gte a b))) #?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/gte a b))) From b9df299bd7b928ed4c70aa7263333dddd8b95374 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 15 Oct 2018 10:37:52 -0600 Subject: [PATCH 516/810] Non-`compare` comparisons complete --- resources-dev/clojure-lang-numbers-temp.java | 314 ------------------ resources-dev/clojure-lang-rt-temp.java | 13 - resources-dev/defnt.cljc | 74 ++++- src-untyped/quantum/untyped/core/analyze.cljc | 39 ++- .../quantum/untyped/core/analyze/ast.cljc | 30 +- .../quantum/untyped/core/collections.cljc | 3 +- .../quantum/untyped/core/identifiers.cljc | 2 +- src-untyped/quantum/untyped/core/loops.cljc | 19 +- src-untyped/quantum/untyped/core/type.cljc | 19 +- .../quantum/untyped/core/type/defnt.cljc | 14 +- .../untyped/core/type/reifications.cljc | 40 ++- src/quantum/core/compare/core.cljc | 93 +++--- src/quantum/core/data/collections.cljc | 5 +- src/quantum/core/data/numeric.cljc | 292 +++++++++++----- src/quantum/core/data/primitive.cljc | 8 +- src/quantum/core/data/string.cljc | 23 +- src/quantum/core/numeric/convert.cljc | 69 ---- test/quantum/test/untyped/core/type.cljc | 27 ++ 18 files changed, 492 insertions(+), 592 deletions(-) delete mode 100644 src/quantum/core/numeric/convert.cljc diff --git a/resources-dev/clojure-lang-numbers-temp.java b/resources-dev/clojure-lang-numbers-temp.java index 35fae98f..97277209 100644 --- a/resources-dev/clojure-lang-numbers-temp.java +++ b/resources-dev/clojure-lang-numbers-temp.java @@ -156,108 +156,6 @@ static public double remainder(double n, double d){ } } -static public boolean equiv(Object x, Object y){ - return equiv((Number) x, (Number) y); -} - -static public boolean equiv(Number x, Number y){ - return ops(x).combine(ops(y)).equiv(x, y); -} - -static public boolean equal(Number x, Number y){ - return category(x) == category(y) - && ops(x).combine(ops(y)).equiv(x, y); -} - -static public boolean lt(Object x, Object y){ - return ops(x).combine(ops(y)).lt((Number)x, (Number)y); -} - -static public boolean lte(Object x, Object y){ - return ops(x).combine(ops(y)).lte((Number)x, (Number)y); -} - -static public boolean gt(Object x, Object y){ - return ops(x).combine(ops(y)).lt((Number)y, (Number)x); -} - -static public boolean gte(Object x, Object y){ - return ops(x).combine(ops(y)).gte((Number)x, (Number)y); -} - -static public int compare(Number x, Number y){ - Ops ops = ops(x).combine(ops(y)); - if(ops.lt(x, y)) - return -1; - else if(ops.lt(y, x)) - return 1; - return 0; -} - -@WarnBoxedMath(false) -static BigInt toBigInt(Object x){ - if(x instanceof BigInt) - return (BigInt) x; - if(x instanceof BigInteger) - return BigInt.fromBigInteger((BigInteger) x); - else - return BigInt.fromLong(((Number) x).longValue()); -} - -@WarnBoxedMath(false) -static BigInteger toBigInteger(Object x){ - if(x instanceof BigInteger) - return (BigInteger) x; - else if(x instanceof BigInt) - return ((BigInt) x).toBigInteger(); - else - return BigInteger.valueOf(((Number) x).longValue()); -} - -@WarnBoxedMath(false) -static BigDecimal toBigDecimal(Object x){ - if(x instanceof BigDecimal) - return (BigDecimal) x; - else if(x instanceof BigInt) - { - BigInt bi = (BigInt) x; - if(bi.bipart == null) - return BigDecimal.valueOf(bi.lpart); - else - return new BigDecimal(bi.bipart); - } - else if(x instanceof BigInteger) - return new BigDecimal((BigInteger) x); - else if(x instanceof Double) - return new BigDecimal(((Number) x).doubleValue()); - else if(x instanceof Float) - return new BigDecimal(((Number) x).doubleValue()); - else if(x instanceof Ratio) - { - Ratio r = (Ratio)x; - return (BigDecimal)divide(new BigDecimal(r.numerator), r.denominator); - } - else - return BigDecimal.valueOf(((Number) x).longValue()); -} - -@WarnBoxedMath(false) -static public Ratio toRatio(Object x){ - if(x instanceof Ratio) - return (Ratio) x; - else if(x instanceof BigDecimal) - { - BigDecimal bx = (BigDecimal) x; - BigInteger bv = bx.unscaledValue(); - int scale = bx.scale(); - if(scale < 0) - return new Ratio(bv.multiply(BigInteger.TEN.pow(-scale)), BigInteger.ONE); - else - return new Ratio(bv, BigInteger.TEN.pow(scale)); - } - return new Ratio(toBigInteger(x), BigInteger.ONE); -} - @WarnBoxedMath(false) static public Number rationalize(Number x){ if(x instanceof Float || x instanceof Double) @@ -427,22 +325,6 @@ public Number remainder(Number x, Number y){ return num(x.longValue() % y.longValue()); } - public boolean equiv(Number x, Number y){ - return x.longValue() == y.longValue(); - } - - public boolean lt(Number x, Number y){ - return x.longValue() < y.longValue(); - } - - public boolean lte(Number x, Number y){ - return x.longValue() <= y.longValue(); - } - - public boolean gte(Number x, Number y){ - return x.longValue() >= y.longValue(); - } - //public Number subtract(Number x, Number y); final public Number negate(Number x){ long val = x.longValue(); @@ -541,22 +423,6 @@ public Number remainder(Number x, Number y){ return Numbers.remainder(x.doubleValue(), y.doubleValue()); } - public boolean equiv(Number x, Number y){ - return x.doubleValue() == y.doubleValue(); - } - - public boolean lt(Number x, Number y){ - return x.doubleValue() < y.doubleValue(); - } - - public boolean lte(Number x, Number y){ - return x.doubleValue() <= y.doubleValue(); - } - - public boolean gte(Number x, Number y){ - return x.doubleValue() >= y.doubleValue(); - } - //public Number subtract(Number x, Number y); final public Number negate(Number x){ return Double.valueOf(-x.doubleValue()); @@ -646,31 +512,6 @@ public Number remainder(Number x, Number y){ return normalizeRet(ret, x, y); } - public boolean equiv(Number x, Number y){ - Ratio rx = toRatio(x); - Ratio ry = toRatio(y); - return rx.numerator.equals(ry.numerator) - && rx.denominator.equals(ry.denominator); - } - - public boolean lt(Number x, Number y){ - Ratio rx = toRatio(x); - Ratio ry = toRatio(y); - return Numbers.lt(rx.numerator.multiply(ry.denominator), ry.numerator.multiply(rx.denominator)); - } - - public boolean lte(Number x, Number y){ - Ratio rx = toRatio(x); - Ratio ry = toRatio(y); - return Numbers.lte(rx.numerator.multiply(ry.denominator), ry.numerator.multiply(rx.denominator)); - } - - public boolean gte(Number x, Number y){ - Ratio rx = toRatio(x); - Ratio ry = toRatio(y); - return Numbers.gte(rx.numerator.multiply(ry.denominator), ry.numerator.multiply(rx.denominator)); - } - //public Number subtract(Number x, Number y); final public Number negate(Number x){ Ratio r = (Ratio) x; @@ -732,22 +573,6 @@ public Number remainder(Number x, Number y){ return toBigInt(x).remainder(toBigInt(y)); } - public boolean equiv(Number x, Number y){ - return toBigInt(x).equals(toBigInt(y)); - } - - public boolean lt(Number x, Number y){ - return toBigInt(x).lt(toBigInt(y)); - } - - public boolean lte(Number x, Number y){ - return toBigInteger(x).compareTo(toBigInteger(y)) <= 0; - } - - public boolean gte(Number x, Number y){ - return toBigInteger(x).compareTo(toBigInteger(y)) >= 0; - } - //public Number subtract(Number x, Number y); final public Number negate(Number x){ return BigInt.fromBigInteger(toBigInteger(x).negate()); @@ -827,22 +652,6 @@ public Number remainder(Number x, Number y){ : toBigDecimal(x).remainder(toBigDecimal(y), mc); } - public boolean equiv(Number x, Number y){ - return toBigDecimal(x).compareTo(toBigDecimal(y)) == 0; - } - - public boolean lt(Number x, Number y){ - return toBigDecimal(x).compareTo(toBigDecimal(y)) < 0; - } - - public boolean lte(Number x, Number y){ - return toBigDecimal(x).compareTo(toBigDecimal(y)) <= 0; - } - - public boolean gte(Number x, Number y){ - return toBigDecimal(x).compareTo(toBigDecimal(y)) >= 0; - } - //public Number subtract(Number x, Number y); final public Number negate(Number x){ MathContext mc = (MathContext) MATH_CONTEXT.deref(); @@ -874,8 +683,6 @@ public Number dec(Number x){ static final BigIntOps BIGINT_OPS = new BigIntOps(); static final BigDecimalOps BIGDECIMAL_OPS = new BigDecimalOps(); -static public enum Category {INTEGER, FLOATING, DECIMAL, RATIO}; - static Ops ops(Object x){ Class xc = x.getClass(); @@ -951,27 +758,6 @@ static int hasheq(Number x){ return hasheqFrom(x, xc); } -static Category category(Object x){ - Class xc = x.getClass(); - - if(xc == Integer.class) - return Category.INTEGER; - else if(xc == Double.class) - return Category.FLOATING; - else if(xc == Long.class) - return Category.INTEGER; - else if(xc == Float.class) - return Category.FLOATING; - else if(xc == BigInt.class) - return Category.INTEGER; - else if(xc == Ratio.class) - return Category.RATIO; - else if(xc == BigDecimal.class) - return Category.DECIMAL; - else - return Category.INTEGER; -} - static long bitOpsCast(Object x){ Class xc = x.getClass(); @@ -1520,26 +1306,6 @@ static public int unchecked_int_remainder(int x, int y){ return x % y; } -//static public boolean equiv(int x, int y){ -// return x == y; -//} - -//static public boolean lt(int x, int y){ -// return x < y; -//} - -//static public boolean lte(int x, int y){ -// return x <= y; -//} - -//static public boolean gt(int x, int y){ -// return x > y; -//} - -//static public boolean gte(int x, int y){ -// return x >= y; -//} - static public Number num(long x){ return Long.valueOf(x); } @@ -1884,86 +1650,6 @@ static public Number divide(long x, long y){ return divide((Number)x, (Number)y); } -static public boolean lt(long x, Object y){ - return lt((Object)x,y); -} - -static public boolean lt(Object x, long y){ - return lt(x,(Object)y); -} - -static public boolean lt(double x, Object y){ - return x < ((Number)y).doubleValue(); -} - -static public boolean lt(Object x, double y){ - return ((Number)x).doubleValue() < y; -} - -static public boolean lte(long x, Object y){ - return lte((Object)x,y); -} - -static public boolean lte(Object x, long y){ - return lte(x,(Object)y); -} - -static public boolean lte(double x, Object y){ - return x <= ((Number)y).doubleValue(); -} - -static public boolean lte(Object x, double y){ - return ((Number)x).doubleValue() <= y; -} - -static public boolean gt(long x, Object y){ - return gt((Object)x,y); -} - -static public boolean gt(Object x, long y){ - return gt(x,(Object)y); -} - -static public boolean gt(double x, Object y){ - return x > ((Number)y).doubleValue(); -} - -static public boolean gt(Object x, double y){ - return ((Number)x).doubleValue() > y; -} - -static public boolean gte(long x, Object y){ - return gte((Object)x,y); -} - -static public boolean gte(Object x, long y){ - return gte(x,(Object)y); -} - -static public boolean gte(double x, Object y){ - return x >= ((Number)y).doubleValue(); -} - -static public boolean gte(Object x, double y){ - return ((Number)x).doubleValue() >= y; -} - -static public boolean equiv(long x, Object y){ - return equiv((Object)x,y); -} - -static public boolean equiv(Object x, long y){ - return equiv(x,(Object)y); -} - -static public boolean equiv(double x, Object y){ - return x == ((Number)y).doubleValue(); -} - -static public boolean equiv(Object x, double y){ - return ((Number)x).doubleValue() == y; -} - static public double max(double x, double y){ return Math.max(x, y); } diff --git a/resources-dev/clojure-lang-rt-temp.java b/resources-dev/clojure-lang-rt-temp.java index ddd2cb37..1c69d24e 100644 --- a/resources-dev/clojure-lang-rt-temp.java +++ b/resources-dev/clojure-lang-rt-temp.java @@ -20,19 +20,6 @@ public class RT{ static public final Object[] EMPTY_ARRAY = new Object[]{}; -static public final Comparator DEFAULT_COMPARATOR = new DefaultComparator(); - -private static final class DefaultComparator implements Comparator, Serializable { - public int compare(Object o1, Object o2){ - return Util.compare(o1, o2); - } - - private Object readResolve() throws ObjectStreamException { - // ensures that we aren't hanging onto a new default comparator for every - // sorted set, etc., we deserialize - return DEFAULT_COMPARATOR; - } -} static AtomicInteger id = new AtomicInteger(1); diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 0a9f8ac5..b16a5c81 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -96,11 +96,52 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - (t/- (t/isa? java.util.Queue) (t/or ?!+queue? !!queue?)) - (t/- t/any? p/float? p/double?); (t/- number? p/primitive?) - dc/of - - (dc/of number?) ; implicitly the container is a `reducible?` + - (dc/of number?) ; implicitly the container is a `reducible?`, because that's now the + fundamental traversal operation + - Maybe we should replace or supplement with: + - `(dc/* number?)` for any collection containing zero or more `number?`s + - `(dc/+ number?)` for any collection containing at least one `number?`s + - Equivalent to `(t/and (dc/* number?) (fn-> count (>= 1)))` + - `(t/and vector? (dc/* number?))` for any collection containing zero or more `number?`s, which satisfies `vector?` + - `t/finite` (reminiscent of `s/tuple`+`s/kv` but with different behavior) + - This is for when we don't want a 'pattern' but rather want the actual thing + - Instead of `(dc/* number?)` we might have `(t/finite number? (t/value 1) map?)`. The order + of inputs to `t/finite` only matters if it's `t/and`ed with a collection type for which + order matters (`(t/or dc/sequential? dc/sorted?)`): + - (t/and vector? (t/finite (t/value :a) (t/value :b))) + - must match `[:a :b]`, in that order + - (t/and set? (t/finite (t/value :a) (t/value :b))) + - must match `#{:a :b}`, not necessarily in that order + - (t/and map? (t/finite (t/finite (t/value :a) (t/value :b)) + (t/finite (t/value :c) (t/value :d)))) + - must match `{:a :b :c :d}`, not necessarily in that kv-order + - (t/and map? (t/finite (t/and map-entry? (t/finite (t/value :a) (t/value :b))) + (t/and vector? (t/finite (t/value :c) (t/value :d))))) + - must match `{:a :b :c :d}`, not necessarily in that kv-order + - (t/and map? (t/finite (t/value :a) (t/value :b))) + - impossible since not all inputs satisfy `map-entry-like?` + - (t/finite (t/value :a) (t/value :b)) + - is satisfied by e.g. [:a :b], (list :a :b), (!list :a :b), (<> :a :b), #{:a :b} + - (t/finite (t/finite (t/value :a) (t/value :b))) + - is satisfied by e.g. [[:a :b]], [(list :a :b)], (list [:a :b]), (!list [:a :b]), + (<> [:a :b]), (<> (<> :a :b)), #{[:a :b]}, {:a :b}, (sorted-map :a :b) - (dc/of map/+map? symbol? dstr/string?) - (dc/of t/seq? namespace?) - dc/map-of - dc/seq-of + - If we assert: + - [:a :b :c] is equally representable as: + - (t/seq vector? [ (t/value :a) (t/value :b) (t/value :c)]) + - (t/kv vector? {0 (t/value :a) 1 (t/value :b) 2 (t/value :c)}) + - and (sorted-map 0 :a 1 :b 2 :c) as: + - (t/kv sorted-map? { 0 (t/value :a) 1 (t/value :b) 2 (t/value :c)}) + - (t/seq sorted-map? [[0 (t/value :a)] [1 (t/value :b)] [2 (t/value :c)]]) + - then we would have to assert (absurdly) that the following are equivalent representations: + - (t/seq vector? [ (t/value :a) (t/value :b) (t/value :c)]) + - (t/kv vector? { 0 (t/value :a) 1 (t/value :b) 2 (t/value :c)}) + - (t/seq vector? [ [0 (t/value :a)] [1 (t/value :b)] [2 (t/value :c)]]) + - (t/kv vector? { 0 [0 (t/value :a)] 1 [1 (t/value :b)] 2 [2 (t/value :c)]}) + - and so on ad infinitum. Therefore we reserve `t/kv` for `(t/and t/lookup? (t/not indexed?))`. - Analysis - `(p/nil? ...)` should probably be inlined to `(?/== ... nil)` rather than using the overhead of the deftype @@ -109,7 +150,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - Better analysis of compound literals - Literal vectors need to be analyzed — (t/finite-of t/built-in-vector? a-type b-type ...) - Literal sets need to be analyzed — (t/finite-of t/built-in-set? a-type b-type ...) - - Literal maps need to be better analyzed — (t/finite-of t/built-in-map? [ak-type av-type] ...) - Literal seqs need to be better analyzed — (t/finite-of t/built-in-list? [ak-type av-type] ...) - Peformance analysis (this comes very much later) - We should be able to do complexity analysis. Similarly to how we can combine and manipulate @@ -282,9 +322,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] await1 - [ ] await-for - [ ] bases - - [ ] bigdec - - [ ] bigint - - [ ] biginteger + - [x -] bigdec + - [x -] bigint + - [x -] biginteger - [ ] binding - [ ] binding-conveyor-fn - [x x] bit-and @@ -1113,8 +1153,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] java.util.Arrays.copyOfRange(objects, int, int, Class) > objects - [ ] java.util.Arrays.equals(chars, chars) > boolean - [ ] java.util.ArraysSupport.vectorizedMismatch(Object, long, Object, long, int, int) > int - - [ ] .compareTo(String) > int - - [ ] .equals(Object) > boolean + - [x] .compareTo(String) > int + - [x] .equals(Object) > boolean - [ ] .indexOf(String) > int - [ ] sun.reflect.Reflection.getCallerClass() > Class - [ ] sun.reflect.Reflection.getClassAccessFlags(Class) > int @@ -1523,13 +1563,13 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] divide - [ ] double_array - [ ] doubles - - [ ] equal + - [x] equal - [ ] equiv - [ ] flipBit - [ ] float_array - [ ] floats - - [ ] gt - - [ ] gte + - [x] gt + - [x] gte - [ ] hasheq - [ ] hasheqFrom - [ ] inc @@ -1542,8 +1582,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [x] isZero - [ ] long_array - [ ] longs - - [ ] lt - - [ ] lte + - [x] lt + - [x] lte - [ ] max - [ ] min - [ ] minus @@ -1566,9 +1606,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] shorts - [ ] setBit - [ ] testBit - - [ ] toBigDecimal - - [ ] toBigInt - - [ ] toBigInteger + - [x] toBigDecimal + - [x] toBigInt + - [x] toBigInteger - [ ] toRatio - [ ] unchecked_add - [ ] unchecked_dec @@ -1720,8 +1760,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] inc - [ ] dec - [x] isZero - - [ ] isNeg - - [ ] isPos + - [x] isNeg + - [x] isPos - [x] add - [ ] subtract - [ ] negate diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index e876c045..3857689e 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -212,26 +212,36 @@ [env ::env, form _, empty-form _, rf _] (-> (reducei (fn [accum form' i] (rf accum (analyze* (:env accum) form') i)) - {:env env :form (transient empty-form) :body (transient [])} + {:env env :form (transient empty-form) :body (transient [])} form) (update :form (fn-> persistent! (add-file-context-from form))) (update :body persistent!))) (defns- analyze-map - {:todo #{"If the map is bound to a variable, preserve type info for it such that lookups - can start out with a guarantee of a certain type."}} + {:todo #{"Should we differentiate between array map and hash map here depen. on ct of inputs?"}} [env ::env, form _] - (TODO "analyze-map") - #_(->> form - (reduce-kv (fn [{env' :env forms :form} form'k form'v] - (let [ast-node-k (analyze* env' form'k) - ast-node-v (analyze* env' form'v)] - (->expr-info {:env env' - :form (assoc! forms (:form ast-node-k) (:form ast-node-v)) - ;; TODO fix; we want the types of the keys and vals to be deduced - :type-info nil}))) - (->expr-info {:env env :form (transient {})})) - (persistent!-and-add-file-context-from form))) + (let [{:keys [all-values? m]} + (->> form + (uc/map+ (fn [[form-k form-v]] [(analyze* env form-k) (analyze* env form-v)])) + (educe (fn [{:as ret :keys [all-values? m]} [k v]] + (-> ret + (cond-> (and all-values? + (-> k :type utr/value-type?) + (-> v :type utr/value-type?)) + (assoc :all-values? true)) + (update :m assoc k v))) + {:all-values? true :m {}})) + t (if all-values? + (->> m (uc/map+ (fn [[k v]] [(-> k :type t/unvalue) (-> v :type t/unvalue)])) + (join {}) + t/value) + (t/and t/+map|built-in? (t/finite (seq m))))] + (uast/map-node {:env env + :unanalyzed-form form + :form (->> m (uc/map+ (fn [[k v]] [(:form k) (:form v)])) + (join {}) + (<- (add-file-context-from form))) + :type t}))) (defns- analyze-seq|do [env ::env, [_ _ & body|form _ :as form] _ > uast/do?] (if (empty? body|form) @@ -860,6 +870,7 @@ (uast/literal env form (t/>type form)) (or (vector? form) (set? form)) + ;; TODO use `uast/vector-node` and `uast/set-node` (analyze-non-map-seqable env form (empty form) (fn stop [& [a b :as args]] (prl! args) (err! "STOP"))) (map? form) (analyze-map env form) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 9fc0cdba..ae8557ac 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -90,11 +90,31 @@ (defn literal? [x] (instance? Literal x)) -(defrecord ClassValue - [env #_::env - form #_simple-symbol? - value #_t/class? - type #_(t/value value)] +(defrecord VectorNode [env #_::env, unanalyzed-form #_::t/form, form #_::t/form, type #_t/type?] + INode + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (list `vector-node (std-print-structure this)))) + +(defn vector-node [m] (map->VectorNode m)) + +(defrecord MapNode [env #_::env, unanalyzed-form #_::t/form, form #_::t/form, type #_t/type?] + INode + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (list `map-node (std-print-structure this)))) + +(defn map-node [m] (map->MapNode m)) + +(defrecord SetNode [env #_::env, unanalyzed-form #_::t/form, form #_::t/form, type #_t/type?] + INode + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (list `set-node (std-print-structure this)))) + +(defn set-node [m] (map->SetNode m)) + +(defrecord ClassValue [env #_::env, form #_simple-symbol?, value #_t/class?, type #_(t/value value)] INode fipp.ednize/IOverride fipp.ednize/IEdn diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index 8877367e..26bad8d2 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -182,7 +182,8 @@ (def mergev (partial mergev-with (fn [i v0 v1] v1))) -(defn zipmap-into [x ks vs] (reduce-2 assoc x ks vs true)) +(defn zipmap-into [x ks vs] + (reduce-2 assoc x ks vs (fn [_ _] (throw (ex-info "Seqs' count is not the same"))))) (defn zipmap [ks vs] (zipmap-into {} ks vs)) diff --git a/src-untyped/quantum/untyped/core/identifiers.cljc b/src-untyped/quantum/untyped/core/identifiers.cljc index ea6a11f3..f4865b1c 100644 --- a/src-untyped/quantum/untyped/core/identifiers.cljc +++ b/src-untyped/quantum/untyped/core/identifiers.cljc @@ -123,7 +123,7 @@ (-> x class .getName clojure.lang.Compiler/demunge recur)) :cljs (when-not (-> x .-name str/blank?) (-> x .-name demunge-str recur))) - :else (-> x str recur))) + :else (-> x str >symbol))) #?(:clj (eval `(defalias ~(if (resolve `fcore/ident?) `fcore/ident? diff --git a/src-untyped/quantum/untyped/core/loops.cljc b/src-untyped/quantum/untyped/core/loops.cljc index 70e89d67..fd52a025 100644 --- a/src-untyped/quantum/untyped/core/loops.cljc +++ b/src-untyped/quantum/untyped/core/loops.cljc @@ -6,19 +6,20 @@ (ucore/log-this-ns) +(defn default-on-different-count [xs0 xs1] nil) + (defn reduce-2 "Reduces over two seqables at a time." ([f xs0 xs1] (reduce-2 f nil xs0 xs1)) - ([f init xs0 xs1] (reduce-2 f init xs0 xs1 false)) - ([f init xs0 xs1 assert-same-count?] + ([f init xs0 xs1] (reduce-2 f init xs0 xs1 default-on-different-count)) + ([f init xs0 xs1 on-different-count] (loop [ret init xs0' xs0 xs1' xs1] (cond (reduced? ret) @ret (or (empty? xs0') (empty? xs1')) - (do (when (and assert-same-count? - (or (and (empty? xs0') (seq xs1')) - (and (seq xs0') (empty? xs1')))) - (throw (ex-info "Seqables are not the same count" {}))) + (if (or (and (empty? xs0') (seq xs1')) + (and (seq xs0') (empty? xs1'))) + (on-different-count xs0 xs1) ret) :else (recur (f ret (first xs0') (first xs1')) (next xs0') @@ -27,11 +28,11 @@ (defn reducei-2 "Reduces over two seqables at a time, maintaining an index." ([f xs0 xs1] (reducei-2 f nil xs0 xs1)) - ([f init xs0 xs1] (reducei-2 f init xs0 xs1 false)) - ([f init xs0 xs1 assert-same-count?] + ([f init xs0 xs1] (reducei-2 f init xs0 xs1 default-on-different-count)) + ([f init xs0 xs1 on-different-count] (let [f' (let [*i (volatile! -1)] (fn [ret x0 x1] (f ret x0 x1 (vreset! *i (unchecked-inc (long @*i))))))] - (reduce-2 f' init xs0 xs1 assert-same-count?)))) + (reduce-2 f' init xs0 xs1 on-different-count)))) ;; TODO incorporate into `quantum.core.loops` #?(:clj diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index d7959746..328a5e1f 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -68,7 +68,7 @@ [quantum.untyped.core.type.reifications UniversalSetType EmptySetType NotType OrType AndType - ProtocolType ClassType + ProtocolType ClassType FiniteType ValueType FnType]))) @@ -163,6 +163,21 @@ (defns- isa?|class [c #?(:clj c/class? :cljs c/fn?)] (ClassType. uhash/default uhash/default nil c nil)) +;; ----- FiniteType ----- ;; + +(defns finite + ([> utr/finite-type?] (finite [])) + ([data _ > utr/finite-type?] + (let [data' (if (type? data) + [data] + (if-not (sequential? data) + (err! "Finite type info must be sequential" {:type (c/type data)}) + (if-not (seq-and type? data) + (err! "Not every element of finite type data is a type" {}) + data)))] + (FiniteType. uhash/default uhash/default nil data' nil))) + ([datum _ & data _ > utr/finite-type?] (finite (cons datum data)))) + ;; ----- ValueType ----- ;; (defns value @@ -542,6 +557,8 @@ (utr/or-type? t) (reduce (c/fn [classes' t'] (-type>classes t' classes')) classes (utr/or-type>args t)) + (c/= val?) + (-type>classes val|by-class? classes) :else (err! "Not sure how to handle type" t))) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 1a593ae7..6913a7aa 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -37,7 +37,7 @@ [quantum.untyped.core.logic :as ul :refer [fn-or fn= ifs]] [quantum.untyped.core.loops - :refer [reduce-2 reducei-2]] + :refer [reduce-2]] [quantum.untyped.core.numeric.combinatorics :as ucombo] [quantum.untyped.core.reducers :as ur :refer [educe educei reducei]] @@ -696,17 +696,17 @@ (s/validate args (case kind :defn :quantum.core.defnt/defnt :fn :quantum.core.defnt/fnt :extend-defn! :quantum.core.defnt/extend-defn!)) + fn|var (when (= kind :extend-defn!) + (or (uvar/resolve *ns* fn|extended-name) + (err! "Could not resolve fn name to extend" + {:sym fn|extended-name}))) fn|ns-name (if (= kind :extend-defn!) - (-> (uvar/resolve *ns* fn|extended-name) >?namespace symbol) + (-> fn|var >?namespace >symbol) (>symbol *ns*)) fn|name (if (= kind :extend-defn!) (-> fn|extended-name >name symbol) fn|name) - fn|var (when (= kind :extend-defn!) - (if-let [v (uvar/resolve *ns* fn|extended-name)] - v - (err! "Cannot extend a `t/defn` that has not been defined" - {:sym fn|extended-name}))) + inline? (-> (if (= kind :extend-defn!) (-> fn|var meta :inline) (:inline fn|meta)) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 7d4ea16c..9a27a03e 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -18,6 +18,8 @@ [quantum.untyped.core.form :as uform :refer [>form]] [quantum.untyped.core.form.generate.deftype :as udt] + [quantum.untyped.core.loops + :refer [reduce-2]] [quantum.untyped.core.spec :as us]) #?(:clj (:import [quantum.untyped.core.analyze.expr Expression]))) @@ -239,7 +241,7 @@ (udt/deftype ClassType [#?(:clj ^int ^:unsynchronized-mutable hash :cljs ^number ^:mutable hash) #?(:clj ^int ^:unsynchronized-mutable hash-code :cljs ^number ^:mutable hash-code) - meta #_(t/? ::meta) + meta #_meta/meta? ^Class c #_t/class? name #_(t/? symbol?)] {PType nil @@ -263,6 +265,42 @@ (defns class-type>class [t class-type?] (.-c ^ClassType t)) +;; ----- FiniteType ----- ;; + +(udt/deftype FiniteType + [#?(:clj ^int ^:unsynchronized-mutable hash :cljs ^number ^:mutable hash) + #?(:clj ^int ^:unsynchronized-mutable hash-code :cljs ^number ^:mutable hash-code) + meta #_meta/meta? + data #_dc/sequential? + name #_(t/? symbol?)] + {PType nil + ;; TODO this is probably not quite right + ?Fn {invoke ([_ xs] (if (seqable? xs) + (reduce-2 ;; Similar to `seq-and` + (fn [ret t x] (if (t x) true (reduced false))) + true ; vacuously + (sequence data) (sequence xs) + (fn [_ _] false)) + false))} + ?Meta {meta ([this] meta) + with-meta ([this meta'] (FiniteType. hash hash-code meta' data name))} + ?Hash {hash ([this] (uhash/caching-set-ordered! hash FiniteType data))} + ?Object {hash-code ([this] (uhash/caching-set-code! hash-code FiniteType data)) + equals ([this that #_any?] + (or (== this that) + (and (instance? FiniteType that) + (= data (.-data ^FiniteType that)))))} + uform/PGenForm {>form ([this] (-> (list 'quantum.untyped.core.type/finite (>form data)) + (accounting-for-meta meta)))} + fedn/IOverride nil + fedn/IEdn {-edn ([this] (if name + (-> name (accounting-for-meta meta)) + (>form this)))}}) + +(defn finite-type? [x] (instance? FiniteType x)) + +(defns finite-type>data [t finite-type?] (.-data ^FiniteType t)) + ;; ----- ValueType ----- ;; (udt/deftype ValueType diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index e711742e..8f4b8e0c 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -9,7 +9,6 @@ ;; TODO TYPED remove #_[= not= < > <= >= max min max-key min-key neg? pos? zero? - -' + inc compare]) (:require - ;; TODO TYPED excise [clojure.core :as core] ;; TODO TYPED excise #_[quantum.core.numeric.operators :as op @@ -53,7 +52,8 @@ clojure.core/identical? "9/27/2018" cljs.core/identical? "9/27/2018"}} > ut/boolean? - ([x t/any?] true) ; everything is self-identical (except NaN and Infinity...) + ;; Everything is self-identical (except, implementationally, NaN and Infinity) + ([x t/any?] true) #?(:clj ([a t/ref?, b t/ref?] (clojure.lang.Util/identical a b)) :cljs ([a t/any?, b t/any?] (cljs.core/identical? a b)))) @@ -61,19 +61,23 @@ (t/defn ^:inline not== "Tests identity-inequality." > ut/boolean? - ([x t/any?] false) ; nothing is self-non-identical (except NaN and Infinity...) + ;; Nothing is self-non-identical (except, implementationally, NaN and Infinity) + ([x t/any?] false) #?(:clj ([a t/ref?, b t/ref?] (Numeric/nonIdentical a b)) :cljs ([a t/any?, b t/any?] (js* "(~{} !== ~{})" a b)))) ;; TODO add variadic arity (t/defn ^:inline = - "Tests value-equality. Same as Java's `x.equals(y)` except it also works for nil, and compares - numbers and collections in a type-independent manner. For numbers, works like `core/==`" - {:incorporated '{clojure.lang.Util/equiv "9/27/2018" - clojure.core/= "9/27/2018" - cljs.core/= "9/27/2018"}} + "Tests value-equality. Same as Java's `x.equals(y)`, except it also works for nil, and compares + numbers and collections in a type-independent manner. For numbers, it works like `core/==`." + {:incorporated '{clojure.lang.Numbers/equals "10/14/2018" + clojure.lang.Numbers/equiv "10/14/2018" + clojure.lang.Util/equiv "9/27/2018" + clojure.core/= "9/27/2018" + cljs.core/= "9/27/2018"}} > ut/boolean? - ([x t/any?] true) ; everything is self-equal (except NaN and Infinity...) + ;; Everything is self-equal (except, implementationally, NaN and Infinity) + ([x t/any?] true) ([a t/nil? , b t/nil?] true) ([a t/nil? , b (t/ref t/val?)] false) ([a (t/ref t/val?), b t/nil?] false) @@ -84,26 +88,23 @@ #?(:clj (.equals a b) :cljs (-equiv ^non-native a b))))) -(defn ^boolean = - ([x y] - (if (nil? x) - (nil? y) - (or (identical? x y) - ^boolean (-equiv x y))))) - ;; TODO add variadic arity (t/defn ^:inline not= "Tests value-inequality." {:incorporated '{clojure.core/not= "9/27/2018" cljs.core/not= "9/27/2018"}} > ut/boolean? - ([x t/any?] false)) ; nothing is self-unequal (except NaN and Infinity...) + ;; Nothing is self-unequal (except, implementationally, NaN and Infinity) + ([x t/any?] false)) ; ===== `<` ===== ; ;; TODO add variadic arity (t/defn ^:inline < "Numeric less-than comparison." + {:incorporated '{clojure.lang.Numbers/lt "10/14/2018" + clojure.core/< "10/14/2018" + cljs.core/< "10/14/2018"}} > ut/boolean?) ; ===== `<=` ===== ; @@ -111,6 +112,9 @@ ;; TODO add variadic arity (t/defn ^:inline <= "Numeric less-than-or-value-equal comparison." + {:incorporated '{clojure.lang.Numbers/lte "10/14/2018" + clojure.core/<= "10/14/2018" + cljs.core/<= "10/14/2018"}} > ut/boolean?) ; ===== `>` ===== ; @@ -118,6 +122,9 @@ ;; TODO add variadic arity (t/defn ^:inline > "Numeric greater-than comparison." + {:incorporated '{clojure.lang.Numbers/gt "10/14/2018" + clojure.core/> "10/14/2018" + cljs.core/> "10/14/2018"}} > ut/boolean?) ; ===== `>=` ===== ; @@ -125,15 +132,18 @@ ;; TODO add variadic arity (t/defn ^:inline >= "Numeric greater-than-or-value-equal comparison." + {:incorporated '{clojure.lang.Numbers/gte "10/14/2018" + clojure.core/>= "10/14/2018" + cljs.core/>= "10/14/2018"}} > ut/boolean?) ; ===== `compare` ===== ; (var/def icomparable? - "That which is comparable to its own 'concrete type' (i.e. class)." - #?(:clj (t/isa? java.lang.Comparable) - ;; TODO other things are comparable; really it depends on the two objects in question - :cljs (t/or ut/nil? (t/isa? cljs.core/IComparable)))) + "That which implements the interface marking comparability to its own 'concrete type' (i.e. + class)." + #?(:clj (t/isa? java.lang.Comparable) + :cljs (t/isa|direct? cljs.core/IComparable))) (def comparison? #?(:clj ut/int? :cljs ut/double?)) @@ -147,37 +157,28 @@ clojure.core/compare "9/27/2018" cljs.core/compare "9/27/2018"}} > comparison? - ;; TODO TYPED should we use `>int` here? - ([a p/nil? , b p/val?] (int -1)) - ;; TODO TYPED should we use `>int` here? - ([a p/val? , b p/nil?] (int 1)) - ([a p/primitive?, b p/primitive?] - (ifs (> a b) (int 1) - (< a b) (int -1) - (int 0))) - ([^Comparable a ^Comparable b] (.compareTo a b)) - ([^Comparable a ^prim? b] (.compareTo a b)) - ([^prim? a ^Comparable b] (int (.compareTo (p/box a) b)))) - -static public int compare(Object k1, Object k2){ - if(k1 == k2) - return 0; - - if(k1 instanceof Number) - return Numbers.compare((Number) k1, (Number) k2); - return ((Comparable) k1).compareTo(k2); -} + ([a ut/nil? , b ut/nil?] (int 0)) + ([a ut/nil? , b ut/val?] (int -1)) + ([a ut/val? , b ut/nil?] (int 1)) + ;; Fallbacks + ([a (t/ref icomparable?), b (t/ref icomparable?)] + (if (== a b) + (int 0) + #?(:clj (.compareTo a b) :cljs (core/-compare ^not-native a b)))) + ([a t/ref?, b t/ref?] + (if (== a b) + (int 0) + (throw (ex-info "Cannot compare incomparable values" {:type0 (type a) :type1 (type b)}))))) (defn ^number compare [x y] (cond - (identical? x y) 0 - - (satisfies? IComparable x) - (-compare x y) + (number? x) (if (number? y) + (garray/defaultCompare x y) + (throw (js/Error. (str "Cannot compare " x " to " y)))) :else - (if (and (or (string? x) (array? x) (boolean? x)) + (if (and (or (string? x) (array? x) (true? x) (false? x)) (identical? (type x) (type y))) (garray/defaultCompare x y) (throw (js/Error. (str "Cannot compare " x " to " y)))))) diff --git a/src/quantum/core/data/collections.cljc b/src/quantum/core/data/collections.cljc index 99b35a97..9688394b 100644 --- a/src/quantum/core/data/collections.cljc +++ b/src/quantum/core/data/collections.cljc @@ -105,7 +105,10 @@ (def iindexed? (t/isa?|direct #?(:clj clojure.lang.Indexed :cljs cljs.core/IIndexed))) -;; Indicates efficient lookup by (integer) index (via `get`) +;; Indicates efficient lookup by (`dn/integer?`) index (via `get`), and that its indices are dense. +;; An `indexed?` is distinct from a non-`indexed?` `lookup?` whose keys densely satisfy `integer?` +;; in that when traversed sequentially, the former will behave as sequence of (unindexed) elements +;; while the latter will behave as a sequence of key-value pairs. (def indexed? (t/or iindexed? ;; Doesn't guarantee `java.util.List` is implemented, except by convention diff --git a/src/quantum/core/data/numeric.cljc b/src/quantum/core/data/numeric.cljc index 2e617816..1de107a0 100644 --- a/src/quantum/core/data/numeric.cljc +++ b/src/quantum/core/data/numeric.cljc @@ -31,7 +31,8 @@ [quantum.untyped.core.vars :as var :refer [defalias]]) #?(:clj (:import - [clojure.lang Numbers] + [clojure.lang BigInt Numbers Ratio] + [java.math BigInteger] [quantum.core Numeric Primitive]))) ;; ===== Types ===== ;; @@ -105,11 +106,162 @@ (def number? (t/or #?@(:clj [(t/isa? java.lang.Number)] :cljs [integer? decimal? ratio?]))) +(var/def numeric? + "Something 'numeric' is something that may be treated as a number but may not actually *be* one." + (t/or number? #?(:clj p/char?))) + +;; ===== Arbitrary-precision conversions (needed for comparisons) ===== ;; + +;; Forward declaration so bigint conversions can use it +;; TODO figure out how to use with CLJS, including goog.math.Integer/Long +#?(:clj +(t/defn ^:inline >long* + "May involve non-out-of-range truncation." + > p/long? + ( [x p/long?] x) + ( [x p/char?] (Primitive/uncheckedLongCast x)) + (^:in [x (t/- p/primitive? p/long? p/boolean? p/char?)] (clojure.lang.RT/uncheckedLongCast x)) + ( [x (t/ref number?)] (.longValue x)))) + +;; TODO figure out how to use with goog.math.Integer/Long +(t/defn ^:inline >double* + "May involve non-out-of-range truncation." + > p/double? + ( [x p/double?] x) + ( [x p/char?] (Primitive/uncheckedDoubleCast x)) +#?(:clj (^:in [x (t/- p/primitive? p/boolean? p/char? p/double?)] + (clojure.lang.RT/uncheckedDoubleCast x)))) + +#?(:clj +(t/defn ^:inline >java-bigint > java-bigint? + ([x fixnum? > (t/assume java-bigint?)] (-> x >long* BigInteger/valueOf)) + ([x java-bigint?] x) + ([x clj-bigint? > (t/assume java-bigint?)] (.toBigInteger x)) + ;; Truncates the decimal portion + ;; TODO should this overload be part of `>java-bigint*`? + ([x bigdec? > (t/assume java-bigint?)] (.toBigInteger x)) + ;; Truncates the decimal portion + ;; TODO should this overload be part of `>java-bigint*`? + ([x ratio? > (t/assume java-bigint?)] (.bigIntegerValue x))) + +#?(:clj +(t/defn ^:inline >clj-bigint > clj-bigint? + ([x fixnum? > (t/assume clj-bigint?)] (-> x >long* BigInt/fromLong)) + ([x java-bigint? > (t/assume clj-bigint?)] (BigInt/fromBigInteger x)) + ([x clj-bigint?] x) + ;; Truncates the decimal portion + ;; TODO should this overload be part of `>clj-bigint*`? + ([x bigdec?] (-> x >java-bigint >clj-bigint)) + ;; Truncates the decimal portion + ;; TODO should this overload be part of `>clj-bigint*`? + ([x ratio?] (-> x >java-bigint >clj-bigint)))) + +#?(:clj +(t/defn ^:inline >bigdec > bigdec? + ([x fixint? > (t/assume bigdec?)] (-> x >long* BigDecimal/valueOf)) + ([x fixdec? > (t/assume bigdec?)] (-> x >double* BigDecimal/valueOf)) + ([x java-bigint?] (BigDecimal. x)) + ([x clj-bigint? > (t/assume bigdec?)] (.toBigDecimal x)) + ([x bigdec?] x) + ([x ratio? > (t/assume bigdec?)] (.divide (-> x ^:val (.numerator) >bigdec) + (-> x ^:val (.denominator) >bigdec))))) + +#?(:clj +(t/defn ^:inline >ratio > ratio? + ([x (t/or fixnum? bigint?)] (Ratio. (>java-bigint x) BigInteger/ONE)) + ([x bigdec?] (let [v ^:val (.unscaledValue x) + scale (.scale x)] + (if (c?/< scale 0) + (Ratio. (.multiply v (.pow ^:val (. BigInteger TEN) + (Numbers/unchecked_int_negate scale))) + ^:val (. BigInteger ONE)) + (Ratio. v (.pow ^:val (. BigInteger TEN) scale))))) + ([x ratio?] x))) + ;; ===== Comparison extensions ===== ;; ;; TODO primitive with non-primitive (t/extend-defn! c?/= - FIXME) + ;; `.equals` takes into account precision even if they're numerically equivalent + ;; `core/=` uses `.equals` for `BigDecimal`s +#?(:clj ([a bigdec? , b bigdec?] (c?/comp= a b))) +#?(:clj ([a bigdec? , b numeric?] (c?/= a (>bigdec b)))) +#?(:clj ([a numeric? , b bigdec?] (c?/= (>bigdec a) b))) +#?(:clj ([a java-bigint?, b java-bigint?] (.equals a b))) +#?(:clj ([a java-bigint?, b numeric?] (c?/= a (>java-bigint b)))) +#?(:clj ([a numeric? , b java-bigint?] (c?/= (>java-bigint a) b))) +#?(:clj ([a clj-bigint? , b clj-bigint?] (.equals a b))) +#?(:clj ([a clj-bigint? , b numeric?] (c?/= a (>clj-bigint b)))) +#?(:clj ([a numeric? , b clj-bigint?] (c?/= (>clj-bigint a) b))) +#?(:clj ([a ratio? , b ratio?] (and (c?/= (.numerator a) (.numerator b)) + (c?/= (.denominator a) (.denominator b))))) +#?(:clj ([a ratio? , b numeric?] (c?/= a (>ratio b)))) +#?(:clj ([a numeric? , b ratio?] (c?/= (>ratio a) b)))) + +;; TODO primitive with non-primitive +(t/extend-defn! c?/< + ([x numeric?] true) +#?(:clj ([a bigdec? , b bigdec?] (c?/comp< a b))) +#?(:clj ([a bigdec? , b numeric?] (c?/< a (>bigdec b)))) +#?(:clj ([a numeric? , b bigdec?] (c?/< (>bigdec a) b))) +#?(:clj ([a java-bigint?, b java-bigint?] (c?/comp< a b))) +#?(:clj ([a java-bigint?, b numeric?] (c?/< a (>java-bigint b)))) +#?(:clj ([a numeric? , b java-bigint?] (c?/< (>java-bigint a) b))) +#?(:clj ([a clj-bigint?, b clj-bigint?] + (if (and (p/nil? (.bipart a)) (p/nil? (.bipart b))) + (c?/< (.lpart a) (.lpart b)) + (c?/comp< (>java-bigint a) (>java-bigint b))))) +#?(:clj ([a clj-bigint? , b numeric?] (c?/< a (>clj-bigint b)))) +#?(:clj ([a numeric? , b clj-bigint?] (c?/< (>clj-bigint a) b))) +#?(:clj ([a ratio? , b ratio?] + (c?/< (.multiply (.numerator a) (.numerator b)) + (.multiply (.denominator a) (.denominator b))))) +#?(:clj ([a ratio? , b numeric?] (c?/< a (>ratio b)))) +#?(:clj ([a numeric? , b ratio?] (c?/< (>ratio a) b)))) + +;; TODO primitive with non-primitive +(t/extend-defn! c?/<= + ([x numeric?] true) +#?(:clj ([a bigdec? , b bigdec?] (c?/comp<= a b))) +#?(:clj ([a bigdec? , b numeric?] (c?/<= a (>bigdec b)))) +#?(:clj ([a numeric? , b bigdec?] (c?/<= (>bigdec a) b))) +#?(:clj ([a clj-bigint?, b clj-bigint?] + (if (and (p/nil? (.bipart a)) (p/nil? (.bipart b))) + (c?/<= (.lpart a) (.lpart b)) + (c?/comp<= (>java-bigint a) (>java-bigint b))))) +#?(:clj ([a ratio? , b ratio?] + (c?/<= (.multiply (.numerator a) (.numerator b)) + (.multiply (.denominator a) (.denominator b)))))) + +;; TODO primitive with non-primitive +(t/extend-defn! c?/> + ([x numeric?] true) +#?(:clj ([a bigdec? , b bigdec?] (c?/comp> a b))) +#?(:clj ([a bigdec? , b numeric?] (c?/> a (>bigdec b)))) +#?(:clj ([a numeric? , b bigdec?] (c?/> (>bigdec a) b))) +#?(:clj ([a clj-bigint?, b clj-bigint?] + (if (and (p/nil? (.bipart a)) (p/nil? (.bipart b))) + (c?/> (.lpart a) (.lpart b)) + (c?/comp> (>java-bigint a) (>java-bigint b))))) +#?(:clj ([a ratio? , b ratio?] + (c?/> (.multiply (.numerator a) (.numerator b)) + (.multiply (.denominator a) (.denominator b)))))) + +;; TODO primitive with non-primitive +(t/extend-defn! c?/>= + ([x numeric?] true) +#?(:clj ([a bigdec? , b bigdec?] (c?/comp>= a b))) +#?(:clj ([a bigdec? , b numeric?] (c?/>= a (>bigdec b)))) +#?(:clj ([a numeric? , b bigdec?] (c?/>= (>bigdec a) b))) +#?(:clj ([a clj-bigint?, b clj-bigint?] + (if (and (p/nil? (.bipart a)) (p/nil? (.bipart b))) + (c?/>= (.lpart a) (.lpart b)) + (c?/comp>= (>java-bigint a) (>java-bigint b))))) +#?(:clj ([a ratio? , b ratio?] + (c?/>= (.multiply (.numerator a) (.numerator b)) + (.multiply (.denominator a) (.denominator b)))))) + +;; ===== Comparisons to constants (e.g. to 0 or 1) ===== ;; (t/defn ^:inline >zero-of-type #_> #_zero? #?(:clj ([x p/byte? > (t/type x)] Numeric/byte0)) @@ -126,14 +278,14 @@ #?(:clj ([x bigdec? > (t/assume (t/type x))] java.math.BigDecimal/ZERO))) (t/defn ^:inline zero? > p/boolean? -#?(:clj (^:int [x (t/or p/long? p/double?)] (Numbers/isZero x))) -#?(:clj ( [x (t/- p/numeric? p/long? p/double?)] (Numeric/isZero x))) -#?(:clj ( [x clj-bigint?] (if (p/nil? (.-bipart x)) - (-> x .-lpart zero?) - (-> x .-bipart zero?)))) -#?(:clj ( [x (t/or java-bigint? bigdec?)] (-> x .signum zero?))) -#?(:clj ( [x ratio?] (-> x .-numerator zero?))) - ( [x #?(:clj (t/ref number?) :clj number?)] (?/= x 0))) +#?(:clj (^:in [x (t/or p/long? p/double?)] (Numbers/isZero x))) +#?(:clj ( [x (t/- p/numeric? p/long? p/double?)] (Numeric/isZero x))) +#?(:clj ( [x clj-bigint?] (if (p/nil? (.bipart x)) + (-> x .lpart zero?) + (-> x .bipart zero?)))) +#?(:clj ( [x (t/or java-bigint? bigdec?)] (-> x .signum zero?))) +#?(:clj ( [x ratio?] (-> x .numerator zero?))) + ( [x #?(:clj (t/ref number?) :cljs numeric?)] (?/= x 0))) (t/defn ^:inline >one-of-type #_> #_one? #?(:clj ([x p/byte? > (t/type x)] Numeric/byte1)) @@ -151,30 +303,30 @@ (t/defn ^:inline one? > p/boolean? #?(:clj ([x p/numeric?] (c?/= x (>one-of-type x)))) - ([x #?(:clj (t/ref number?) :clj number?)] (c?/= x 1))) + ([x #?(:clj (t/ref number?) :cljs numeric?)] (c?/= x 1))) (t/defn ^:inline neg? > p/boolean? -#?(:clj (^:int [x (t/or p/long? p/double?)] (Numbers/isNeg x))) -#?(:clj ( [x (t/- p/numeric? p/long? p/double?)] (Numeric/isNeg x))) -#?(:clj ( [x clj-bigint?] (if (?/nil? (.-bipart x)) - (-> x .-lpart neg?) - (-> x .-bipart neg?)))) -#?(:clj ( [x (t/or java-bigint? bigdec?)] (-> x .signum neg?))) -#?(:clj ( [x ratio?] (-> x .-numerator neg?))) - ( [x #?(:clj (t/ref number?) :clj number?)] (?/< x 0))) +#?(:clj (^:in [x (t/or p/long? p/double?)] (Numbers/isNeg x))) +#?(:clj ( [x (t/- p/numeric? p/long? p/double?)] (Numeric/isNeg x))) +#?(:clj ( [x clj-bigint?] (if (?/nil? (.bipart x)) + (-> x .lpart neg?) + (-> x .bipart neg?)))) +#?(:clj ( [x (t/or java-bigint? bigdec?)] (-> x .signum neg?))) +#?(:clj ( [x ratio?] (-> x .numerator neg?))) + ( [x #?(:clj (t/ref number?) :clj numeric?)] (?/< x 0))) ;; TODO TYPED this should realize that we're negating a `<` and change the operator to `<=` (t/def nneg? (fn/comp ?/not neg?)) (t/defn ^:inline pos? > p/boolean? -#?(:clj (^:int [x (t/or p/long? p/double?)] (Numbers/isPos x))) -#?(:clj ( [x (t/- p/numeric? p/long? p/double?)] (Numeric/isPos x))) -#?(:clj ( [x clj-bigint?] (if (?/nil? (.-bipart x)) - (-> x .-lpart pos?) - (-> x .-bipart pos?)))) -#?(:clj ( [x (t/or java-bigint? bigdec?)] (-> x .signum pos?))) -#?(:clj ( [x ratio?] (-> x .-numerator pos?))) - ( [x #?(:clj (t/ref number?) :clj number?)] (?/> x 0))) +#?(:clj (^:in [x (t/or p/long? p/double?)] (Numbers/isPos x))) +#?(:clj ( [x (t/- p/numeric? p/long? p/double?)] (Numeric/isPos x))) +#?(:clj ( [x clj-bigint?] (if (?/nil? (.bipart x)) + (-> x .lpart pos?) + (-> x .bipart pos?)))) +#?(:clj ( [x (t/or java-bigint? bigdec?)] (-> x .signum pos?))) +#?(:clj ( [x ratio?] (-> x .numerator pos?))) + ( [x #?(:clj (t/ref number?) :clj numeric?)] (c?/> x 0))) ;; TODO TYPED this should realize that we're negating a `<` and change the operator to `<=` (t/def npos? (fn/comp ?/not pos?)) @@ -190,12 +342,12 @@ `js/Number.POSITIVE_INFINITY` are self-identical, but neither of them are `js/Number`s. By contrast, the `Float` and `Double` infinities are instances of `Float` and `Double`, respectively." -#?(:cljs ([x t/any? > (t/assume p/boolean?)] (??/not (js/isFinite x)))) -#?(:clj ([x p/float?] (Float/isInfinite x))) -#?(:clj ([x p/double?] (Double/isInfinite x))) -#?(:clj ([x (t/- p/primitive? p/float? p/double?)] false)) +#?(:cljs ([x t/any? > (t/assume p/boolean?)] (??/not (js/isFinite x)))) +#?(:clj ([x p/float?] (Float/isInfinite x))) +#?(:clj ([x p/double?] (Double/isInfinite x))) +#?(:clj ([x (t/- p/numeric? p/float? p/double?)] false)) ;; This leaves room for other numbers to be infinite -#?(:clj ([x (t/ref number?)] false))) +#?(:clj ([x (t/ref number?)] false))) ;; ===== Likenesses ===== ;; @@ -204,13 +356,13 @@ '#{com.google.common.math.DoubleMath/isMathematicalInteger "https://stackoverflow.com/questions/1078953/check-if-bigdecimal-is-integer-value"}} > p/boolean? - ( [x integer?] true) -#?(:cljs (^:int [x p/double? > (t/assume p/boolean?)] (js/Number.isInteger x))) -#?(:clj ( [x (t/or p/float? p/double?)] (c?/= x (>long* x)))) -#?(:clj ( [x bigdec?] (or (zero? (.signum x)) - (-> x .scale npos?) - (-> x .stripTrailingZeros .scale npos?)))) -#?(:clj ( [x (t/ref number?)] x))) + ( [x integer?] true) +#?(:cljs (^:in [x p/double? > (t/assume p/boolean?)] (js/Number.isInteger x))) +#?(:clj ( [x (t/or p/float? p/double?)] (c?/= x (>long* x)))) +#?(:clj ( [x bigdec?] (or (zero? (.signum x)) + (-> x .scale npos?) + (-> x .stripTrailingZeros .scale npos?)))) +#?(:clj ( [x (t/ref number?)] x))) (def numerically-integer? (t/or integer? (t/and decimal? (>expr unum/integer-value?)))) @@ -261,10 +413,6 @@ (def primitive-number? (t/or #?@(:clj [p/short? p/int? p/long? p/float?]) p/double?)) -(var/def numeric? - "Something 'numeric' is something that may be treated as a number but may not actually *be* one." - (t/or number? #?(:clj p/char?))) - (def numeric-primitive? p/numeric?) (def numerically-integer-double? (t/and p/double? numerically-integer?)) @@ -283,6 +431,24 @@ ;; Note that numeric-primitive conversions go here because they take as inputs and produce outputs ;; things that are within a numeric range. +;; TODO evaluate +(defnt ->num + (^long [^boolean x] (if x 1 0)) + ([#{number? byte char} x] x)) + +;; TODO evaluate +(defn ->boolean-num [x] (if x 1 0)) + +;; TODO evaluate +#?(:clj +(defnt exactly + ([#{decimal?} x] + (-> x rationalize exactly)) + ([#{int? long?} x] (->bigint x)) + ([#{bigint? ratio?} x] x))) + + + ;; ----- Byte ----- ;; ;; TODO figure out how to use with CLJS @@ -356,8 +522,8 @@ (t/defn ^:inline >int* "May involve non-out-of-range truncation." > int? - ( [x int?] x) - (^:int [x (t/- primitive? int? boolean?)] (clojure.lang.RT/uncheckedIntCast x)))) + ( [x int?] x) + (^:in [x (t/- primitive? int? boolean?)] (clojure.lang.RT/uncheckedIntCast x)))) ;; TODO TYPED `numerically` ;; TODO figure out how to use with goog.math.Integer/Long @@ -374,16 +540,6 @@ ;; ----- Long ----- ;; -;; TODO figure out how to use with CLJS, including goog.math.Integer/Long -#?(:clj -(t/defn ^:inline >long* - "May involve non-out-of-range truncation." - > long? - ( [x long?] x) - ( [x char?] (Primitive/uncheckedLongCast x)) - (^:int [x (t/- primitive? long? boolean? char?)] (clojure.lang.RT/uncheckedLongCast x)) - ( [x (t/ref number?)] (.longValue x)))) - ;; TODO TYPED `numerically` ;; TODO figure out how to use with goog.math.Integer/Long (t/defn ^:inline >long @@ -427,15 +583,6 @@ ;; ----- Double ----- ;; -;; TODO figure out how to use with goog.math.Integer/Long -(t/defn ^:inline >double* - "May involve non-out-of-range truncation." - > p/double? - ( [x p/double?] x) - ( [x p/char?] (Primitive/uncheckedDoubleCast x)) -#?(:clj (^:int [x (t/- p/primitive? p/boolean? p/char? p/double?)] - (clojure.lang.RT/uncheckedDoubleCast x)))) - ;; TODO TYPED `numerically` ;; TODO figure out how to use with goog.math.Integer/Long (t/defn ^:inline >double > double? @@ -466,23 +613,6 @@ #_(:clj (t/defn uint>int [x long? > long?] (-> x >int >long))) #_(:clj (t/defn ulong>long [x bigint? > long?] (-> x >bigint >long))) -;; ----- Integers ----- ;; - -#?(:cljs -(t/defn >bigint > bigint? - ([x bigint?] x) - ([x p/double?] (-> x (.toString) >bigint)))) - -;; ----- Decimals ----- ;; - -;; TODO TYPED `>long` -#_(:clj -(t/defn >java-bigint > java-bigint? - ([x java-bigint?] x) - ([x clj-bigint? > (t/assume java-bigint?)] (.toBigInteger x)) - ([;; TODO TYPED `(- number? BigInteger BigInt)` - x (t/or p/short? p/int? p/long?) > (t/assume java-bigint?)] ; TODO BigDecimal - (-> x p/>long BigInteger/valueOf)))) ;; ----- Ratios ----- ;; diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 3c5ba61d..a4b28fab 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -226,7 +226,6 @@ ([a primitive?, b primitive?] (c?/not== a b))) (t/extend-defn! c?/< - ( [x numeric?] true) #?(:clj (^:in [a long? , b long?] (Numbers/lt a b))) #?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/lt a b))) #?(:clj ( [a (t/- numeric? long?) , b long?] (Numeric/lt a b))) @@ -240,7 +239,6 @@ ) (t/extend-defn! c?/<= - ( [x numeric?] true) #?(:clj (^:in [a long? , b long?] (Numbers/lte a b))) #?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/lte a b))) #?(:clj ( [a (t/- numeric? long?) , b long?] (Numeric/lte a b))) @@ -254,7 +252,6 @@ ) (t/extend-defn! c?/> - ( [x numeric?] true) #?(:clj (^:in [a long? , b long?] (Numbers/gt a b))) #?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/gt a b))) #?(:clj ( [a (t/- numeric? long?) , b long?] (Numeric/gt a b))) @@ -268,7 +265,6 @@ ) (t/extend-defn! c?/>= - ( [x numeric?] true) #?(:clj (^:in [a long? , b long?] (Numbers/gte a b))) #?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/gte a b))) #?(:clj ( [a (t/- numeric? long?) , b long?] (Numeric/gte a b))) @@ -280,3 +276,7 @@ ;; TODO rest of numbers, but not nil ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) ) + +(t/extend-defn! c?/compare +#?(:clj ([a c?/icomparable?, b primitive?] (.compareTo a b))) + ([a primitive? , b c?/icomparable?] (.compareTo (box a) b))) diff --git a/src/quantum/core/data/string.cljc b/src/quantum/core/data/string.cljc index 65ad42df..42e4bdcd 100644 --- a/src/quantum/core/data/string.cljc +++ b/src/quantum/core/data/string.cljc @@ -3,8 +3,9 @@ (:refer-clojure :exclude [string?]) (:require + [quantum.core.compare.core :as c?] [quantum.core.data.meta :as meta] - [quantum.core.data.numeric :as num] + [quantum.core.data.numeric :as dn] [quantum.core.data.primitive :as p] [quantum.core.type :as t] ;; TODO TYPED excise @@ -148,11 +149,17 @@ (t/fn [x integer?] (comp/<= #?(:clj Character/MIN_RADIX :cljs 2) x #?(:clj Character/MAX_RADIX :cljs 36)))) -(t/extend-defn! p/>boolean +(t/extend-defn! ?c/compare +#?(:clj (^:in [a string?, b string?] (.compareTo a b)))) + +(t/extend-defn! ?c/= +#?(:clj (^:in [a string?, b string?] (.equals a b)))) + +(t/extend-defn! dn/>boolean ([x (t/value "true")] true) ([x (t/value "false")] false)) -(t/extend-defn! p/>byte +(t/extend-defn! dn/>byte ([x string?] #?(:clj (Byte/parseByte x) ;; NOTE could use `js/parseInt` but it's very 'unsafe' @@ -164,7 +171,7 @@ ;; TODO implement based on `Byte/parseByte` :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) -(t/extend-defn! p/>short +(t/extend-defn! dn/>short ([x string?] #?(:clj (Short/parseShort x) ;; NOTE could use `js/parseInt` but it's very 'unsafe' @@ -176,7 +183,7 @@ ;; TODO implement based on `Short/parseShort` :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) -(t/extend-defn! p/>int +(t/extend-defn! dn/>int ([x string?] #?(:clj (Integer/parseInteger x) ;; NOTE could use `js/parseInt` but it's very 'unsafe' @@ -188,7 +195,7 @@ ;; TODO implement based on `Integer/parseInteger` :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) -(t/extend-defn! p/>long +(t/extend-defn! dn/>long ([x string?] #?(:clj (Long/parseLong x) ;; NOTE could use `js/parseInt` but it's very 'unsafe' @@ -200,14 +207,14 @@ ;; TODO implement based on `Long/parseLong` :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) -(t/extend-defn! p/>float +(t/extend-defn! dn/>float ([x string?] #?(:clj (Float/parseFloat x) ;; NOTE could use `js/parseFloat` but it's very 'unsafe' ;; TODO implement based on `Float/parseFloat` :cljs (throw (ex-info "Parsing not implemented" {:string x}))))) -(t/extend-defn! p/>double +(t/extend-defn! dn/>double ([x string?] #?(:clj (Double/parseDouble x) ;; NOTE could use `js/parseFloat` but it's very 'unsafe' diff --git a/src/quantum/core/numeric/convert.cljc b/src/quantum/core/numeric/convert.cljc deleted file mode 100644 index 374f7de0..00000000 --- a/src/quantum/core/numeric/convert.cljc +++ /dev/null @@ -1,69 +0,0 @@ -(ns quantum.core.numeric.convert - (:refer-clojure :exclude [bigdec]) - (:require - [clojure.core :as core] - [quantum.core.data.numeric :as dn] - [quantum.core.error :as err - :refer [TODO]] - [quantum.core.macros - :refer [defnt #?@(:clj [defnt'])]] - [quantum.core.vars - :refer [defalias]]) -#?(:cljs - (:require-macros - [quantum.core.numeric.convert :as self])) -#?(:clj - (:import - java.math.BigInteger - clojure.lang.BigInt))) - -(defnt ->num - (^long [^boolean x] (if x 1 0)) - ([#{number? byte char} x] x)) - -(defn ->boolean-num [x] (if x 1 0)) - -#?(:clj (defalias ->big-integer dn/->big-integer)) - -#?(:clj (defnt' ^BigInt ->bigint - ([^BigInt x] x) - ([^BigInteger x] (BigInt/fromBigInteger x)) - ([^long x] (-> x BigInt/fromLong)) - ([^string? x radix] (->bigint (BigInteger. x (int radix)))) - ([#{double? Number} x] (-> x BigInteger/valueOf ->bigint))) - :cljs (defalias ->bigint dn/->bigint)) - -#?(:clj (doto (defalias ->bigdec core/bigdec) (alter-meta! assoc :tag BigDecimal)) - #_(defnt' ^BigDecimal ->bigdec - ([^java.math.BigDecimal x] x) - ([^BigInt x] - (if (-> x (.bipart) nil? ) - (-> x (.lpart ) BigDecimal/valueOf) - (-> x (.bipart) (BigDecimal.) ))) - ([^BigInteger x] (BigDecimal. x)) - ([#{(- decimal? :curr)} x] (BigDecimal. x)) - ([^Ratio x] (/ (BigDecimal. (.numerator x)) (.denominator x))) - ([#{(- number? :curr)} x] (BigDecimal/valueOf x))) - :cljs (defn ->bigdec [x] (TODO))) - -#?(:clj (defalias ->ratio dn/->ratio) - #_(defnt ^clojure.lang.Ratio ->ratio - ([^clojure.lang.Ratio x] x) - ([^java.math.BigDecimal x] - (let [^BigInteger bv (.unscaledValue x) - ^int scale (.scale x)] ; technically int - (if (neg? scale) - (Ratio. (->> (neg scale) - (.pow BigInteger/TEN) - (.multiply bv)) - BigInteger/ONE) - (Ratio. bv (-> BigInteger/TEN (.pow scale)))))) - ([^Object x] (-> x ->big-integer (Ratio. BigInteger/ONE)))) - :cljs (defalias ->ratio dn/->ratio)) - -#?(:clj -(defnt exactly - ([#{decimal?} x] - (-> x rationalize exactly)) - ([#{int? long?} x] (->bigint x)) - ([#{bigint? ratio?} x] x))) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 343d300a..a6fe35bb 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -396,6 +396,33 @@ (test-equality #(t/isa? I)) (test-equality #(t/isa? P))) +(deftest test|finite + (is= true ((t/finite []) nil)) + (is= true ((t/finite []) [])) + (is= true ((t/finite []) #{})) + (is= true ((t/finite []) {})) + (is= true ((t/finite) nil)) + (is= true ((t/finite) [])) + (is= true ((t/finite) #{})) + (is= true ((t/finite) {})) + (is= false ((t/finite [boolean?]) nil)) + (is= false ((t/finite [boolean?]) [])) + (is= false ((t/finite [boolean?]) #{})) + (is= false ((t/finite [boolean?]) {})) + (is= true ((t/finite [boolean?]) [true])) + (is= true ((t/finite [boolean?]) #{true})) + (is= false ((t/finite [boolean?]) {true true})) + (is= false ((t/finite boolean?) nil)) + (is= false ((t/finite boolean?) [])) + (is= false ((t/finite boolean?) #{})) + (is= false ((t/finite boolean?) {})) + (is= true ((t/finite boolean?) [true])) + (is= true ((t/finite boolean?) #{true})) + (is= false ((t/finite boolean?) {true true})) + (is= true ((t/finite [(t/finite boolean? boolean?)]) {true true})) + (is= true ((t/finite (t/finite boolean? boolean?)) {true true})) + ) + (deftest test|value (test-equality #(t/value 1)) (testing "hash equality" From 1dc14a3b7789ca61cbe98cb24196638b0ebf02b2 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 15 Oct 2018 13:45:09 -0600 Subject: [PATCH 517/810] `t/finite` -> `t/ordered`, `t/unordered` --- test/quantum/test/untyped/core/type.cljc | 133 ++++++++++++++---- .../test/untyped/core/type/compare.cljc | 2 + 2 files changed, 109 insertions(+), 26 deletions(-) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index a6fe35bb..95c114b7 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -3,6 +3,7 @@ [boolean? char? double? float? int? ratio? string?]) (:require [clojure.core :as core] + [quantum.untyped.core.data.map :as umap] [quantum.untyped.core.test :refer [deftest testing is is= throws]] [quantum.untyped.core.type :as t @@ -396,32 +397,112 @@ (test-equality #(t/isa? I)) (test-equality #(t/isa? P))) -(deftest test|finite - (is= true ((t/finite []) nil)) - (is= true ((t/finite []) [])) - (is= true ((t/finite []) #{})) - (is= true ((t/finite []) {})) - (is= true ((t/finite) nil)) - (is= true ((t/finite) [])) - (is= true ((t/finite) #{})) - (is= true ((t/finite) {})) - (is= false ((t/finite [boolean?]) nil)) - (is= false ((t/finite [boolean?]) [])) - (is= false ((t/finite [boolean?]) #{})) - (is= false ((t/finite [boolean?]) {})) - (is= true ((t/finite [boolean?]) [true])) - (is= true ((t/finite [boolean?]) #{true})) - (is= false ((t/finite [boolean?]) {true true})) - (is= false ((t/finite boolean?) nil)) - (is= false ((t/finite boolean?) [])) - (is= false ((t/finite boolean?) #{})) - (is= false ((t/finite boolean?) {})) - (is= true ((t/finite boolean?) [true])) - (is= true ((t/finite boolean?) #{true})) - (is= false ((t/finite boolean?) {true true})) - (is= true ((t/finite [(t/finite boolean? boolean?)]) {true true})) - (is= true ((t/finite (t/finite boolean? boolean?)) {true true})) - ) +(defn- test-basic-finite [f] + (is= true ((f []) nil)) + (is= true ((f []) [])) + (is= true ((f []) #{})) + (is= true ((f []) {})) + (is= true ((f) nil)) + (is= true ((f) [])) + (is= true ((f) #{})) + (is= true ((f) {})) + (is= false ((f [boolean?]) nil)) + (is= false ((f [boolean?]) [])) + (is= false ((f [boolean?]) #{})) + (is= false ((f [boolean?]) {})) + (is= true ((f [boolean?]) [true])) + (is= true ((f [boolean?]) #{true})) + (is= false ((f [boolean?]) {true true})) + (is= false ((f boolean?) nil)) + (is= false ((f boolean?) [])) + (is= false ((f boolean?) #{})) + (is= false ((f boolean?) {})) + (is= true ((f boolean?) [true])) + (is= true ((f boolean?) #{true})) + (is= false ((f boolean?) {true true})) + (is= true ((f [(t/ordered boolean? boolean?)]) {true true})) + (is= true ((f (t/ordered boolean? boolean?)) {true true})) + (is= true ((f [(t/ordered boolean? boolean?)]) [[true true]])) + (is= true ((f (t/ordered boolean? boolean?)) [[true true]])) + (testing "`indexed?` is treated distinctly from `lookup?` with `integer?` keys" + (is= true ((f [(t/ordered long? boolean?)]) [[0 true]])) + (is= true ((f (t/ordered long? boolean?)) [[0 true]])) + (is= false ((f [(t/ordered long? boolean?)]) [true])) + (is= false ((f (t/ordered long? boolean?)) [true])) + (is= true ((f [(t/ordered long? boolean?)]) {0 true})) + (is= true ((f (t/ordered long? boolean?)) {0 true})))) + +(deftest test|unordered + (test-basic-finite) + (testing "Order should not matter; only frequency" + (is= true ((t/unordered (t/value 1) (t/value 2) (t/value 3) (t/value 4) (t/value 5) (t/value 6)) + [1 2 3 4 5 6])) + (dotimes [i 100] + (is= true ((t/unordered (t/value 1) (t/value 2) (t/value 3) (t/value 4)(t/value 5)(t/value 6)) + (shuffle [1 2 3 4 5 6])))) + (is= true ((t/unordered (t/value 1) (t/value 2) (t/value 3) (t/value 4) (t/value 5) (t/value 6)) + #{1 2 3 4 5 6})) + (is= true ((t/unordered (t/ordered (t/value :a) (t/value :b)) + (t/ordered (t/value :c) (t/value :d)) + (t/ordered (t/value :e) (t/value :f)) + (t/ordered (t/value :g) (t/value :h)) + (t/ordered (t/value :i) (t/value :j))) + {:a :b :c :d :e :f :g :h :i :j})) + (let [t (t/unordered (t/unordered (t/value :a) (t/value :b)) + (t/unordered (t/value :c) (t/value :d)) + (t/unordered (t/value :e) (t/value :f)) + (t/unordered (t/value :g) (t/value :h)) + (t/unordered (t/value :i) (t/value :j)))] + (is= true (t (->> {:a :b :c :d :e :f :g :h :i :j} (map shuffle) (into {})))))) + (testing "Internally should sort types deterministically" + (let [ts (->> (range 15) (map t/value)) + t (t/unordered ts)] + (dotimes [i 100] + (is= t (t/unordered (shuffle ts)))))) + (testing "Combinatoric equality between `t/ordered` and `t/unordered`" + (test-comparison =ident + (t/unordered (t/value 1) (t/value 2)) + (t/or (t/ordered (t/value 1) (t/value 2)) + (t/ordered (t/value 2) (t/value 1)))) + (test-comparison =ident + (t/unordered (t/unordered (t/value 1) (t/value 2)) + (t/unordered (t/value 1) (t/value 2))) + (t/or (t/ordered (t/ordered (t/value 1) (t/value 2)) + (t/ordered (t/value 1) (t/value 2))) + (t/ordered (t/ordered (t/value 1) (t/value 2)) + (t/ordered (t/value 2) (t/value 1))) + (t/ordered (t/ordered (t/value 2) (t/value 1)) + (t/ordered (t/value 1) (t/value 2))) + (t/ordered (t/ordered (t/value 2) (t/value 1)) + (t/ordered (t/value 2) (t/value 1))))))) + +(deftest test|ordered + (test-basic-finite) + (testing "Order should matter" + (is= true ((t/ordered (t/value 1) (t/value 2) (t/value 3) (t/value 4) (t/value 5) (t/value 6)) + [1 2 3 4 5 6])) + (is= false ((t/ordered (t/value 1) (t/value 2) (t/value 3) (t/value 4) (t/value 5) (t/value 6)) + #{1 2 3 4 5 6})) + (let [t (t/ordered (t/ordered (t/value :a) (t/value :b)) + (t/ordered (t/value :c) (t/value :d)) + (t/ordered (t/value :e) (t/value :f)) + (t/ordered (t/value :g) (t/value :h)) + (t/ordered (t/value :i) (t/value :j)))] + (is= false (t { :a :b :c :d :e :f :g :h :i :j})) + (is= true (t (umap/om :a :b :c :d :e :f :g :h :i :j))) + (is= true (t (sorted-map :a :b :c :d :e :f :g :h :i :j)))) + (let [t (t/ordered (t/unordered (t/value :a) (t/value :b)) + (t/unordered (t/value :c) (t/value :d)) + (t/unordered (t/value :e) (t/value :f)) + (t/unordered (t/value :g) (t/value :h)) + (t/unordered (t/value :i) (t/value :j)))] + (dotimes [i 100] + (is= false (t (->> { :a :b :c :d :e :f :g :h :i :j} + (map shuffle) (into {})))) + (is= true (t (->> (umap/om :a :b :c :d :e :f :g :h :i :j) + (map shuffle) (into umap/om)))) + (is= true (t (->> (sorted-map :a :b :c :d :e :f :g :h :i :j) + (map shuffle) (apply sorted-map)))))))) (deftest test|value (test-equality #(t/value 1)) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index c593ecfe..33c8ea18 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -479,6 +479,8 @@ (test-comparison > nilabled: #{<>}" (test-comparison <>ident t/long? (t/? t/string?))))) + (testing "+ UnorderedType") + (testing "+ OrderedType") (testing "+ ValueType" (testing "arg <" (testing "+ arg <") From c8ef1170a38c3d485310d9b9bcb232ae39a501f8 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 15 Oct 2018 15:23:14 -0600 Subject: [PATCH 518/810] `ordered?`: seq, sequential, list, sorted, indexed cleared up --- src/quantum/core/data/collections.cljc | 102 +++++++++++++++-------- test/quantum/test/untyped/core/type.cljc | 16 +++- 2 files changed, 81 insertions(+), 37 deletions(-) diff --git a/src/quantum/core/data/collections.cljc b/src/quantum/core/data/collections.cljc index 9688394b..6ef4c934 100644 --- a/src/quantum/core/data/collections.cljc +++ b/src/quantum/core/data/collections.cljc @@ -16,6 +16,9 @@ ;; TODO move to `quantum.core.data.sequence` ;; ===== Sequences and sequence-wrappers ===== ;; ;; Sequential (generally not efficient Lookup / RandomAccess) +;; Note that lists and seqs are not fundamentally different and so we don't distinguish between them +;; here. + (def iseqable? (t/isa?|direct #?(:clj clojure.lang.Seqable :cljs cljs.core/ISeqable))) @@ -69,71 +72,104 @@ ;; TODO excise — this is used later on elsewhere (def misc-seq? (t/or chunked-seq? indexed-seq? key-seq? val-seq?)) -;; ----- Lists ----- ;; Not extremely different from Sequences ; TODO clean this up - -(def cdlist? t/none? #_(:clj (t/or (t/isa? clojure.data.finger_tree.CountedDoubleList) - (t/isa? quantum.core.data.finger_tree.CountedDoubleList)) - :cljs (t/isa? quantum.core.data.finger-tree/CountedDoubleList))) -(def dlist? t/none? #_(:clj (t/or (t/isa? clojure.data.finger_tree.CountedDoubleList) - (t/isa? quantum.core.data.finger_tree.CountedDoubleList)) - :cljs (t/isa? quantum.core.data.finger-tree/CountedDoubleList))) - (var/defalias ut/+list|built-in?) +(def cdseq? t/none? #_(:clj (t/or (t/isa? clojure.data.finger_tree.CountedDoubleList) + (t/isa? quantum.core.data.finger_tree.CountedDoubleList)) + :cljs (t/isa? quantum.core.data.finger-tree/CountedDoubleList))) +(def dseq? t/none? #_(:clj (t/or (t/isa? clojure.data.finger_tree.CountedDoubleList) + (t/isa? quantum.core.data.finger_tree.CountedDoubleList)) + :cljs (t/isa? quantum.core.data.finger-tree/CountedDoubleList))) + (def +list? (t/isa? #?(:clj clojure.lang.IPersistentList :cljs cljs.core/IList))) -(def !list? #?(:clj (t/isa? java.util.LinkedList) :cljs t/none?)) -(def list? #?(:clj (t/isa? java.util.List) :cljs +list?)) +(def !seq? #?(:clj (t/isa? java.util.LinkedList) :cljs t/none?)) ;; ===== End sequences ===== ;; (def record? (t/isa?|direct #?(:clj clojure.lang.IRecord :cljs cljs.core/IRecord))) -(def sorted? +(var/def comparator-ordered? + "Something that guarantees the invariant that its elements will always be ordered by some + comparator." (t/or (t/isa?|direct #?(:clj clojure.lang.Sorted :cljs cljs.core/ISorted)) #?@(:clj [(t/isa? java.util.SortedMap) (t/isa? java.util.SortedSet)] - :cljs [(t/isa? goog.structs.AvlTree)]) - ; TODO implement — monotonically <, <=, =, >=, > - #_(t/>expr monotonic?))) + :cljs [(t/isa? goog.structs.AvlTree)]))) + +(var/def sorted? + "Something that is either (necessarily) `comparator-ordered?` or contingently comparator-ordered + (i.e. whose elements happen to be in monotonically decreasing or increasing order by `compare`)." + (t/or comparator-ordered? + ; TODO implement — it means monotonically <= or >= + monotonic?)) -(def transient? (t/isa? #?(:clj clojure.lang.ITransientCollection - :cljs cljs.core/ITransientCollection))) +(def transient? (t/isa?|direct #?(:clj clojure.lang.ITransientCollection + :cljs cljs.core/ITransientCollection))) -(def editable? (t/isa? #?(:clj clojure.lang.IEditableCollection - :cljs cljs.core/IEditableCollection))) +(def editable? (t/isa?|direct #?(:clj clojure.lang.IEditableCollection + :cljs cljs.core/IEditableCollection))) (def iindexed? (t/isa?|direct #?(:clj clojure.lang.Indexed :cljs cljs.core/IIndexed))) -;; Indicates efficient lookup by (`dn/integer?`) index (via `get`), and that its indices are dense. -;; An `indexed?` is distinct from a non-`indexed?` `lookup?` whose keys densely satisfy `integer?` -;; in that when traversed sequentially, the former will behave as sequence of (unindexed) elements -;; while the latter will behave as a sequence of key-value pairs. -(def indexed? +(var/def indexed? + "Indicates efficient lookup by (`dn/integer?`) index (via `get`), and that its indices are dense. + An `indexed?` is distinct from a non-`indexed?` `lookup?` whose keys densely satisfy `integer?` + in that when traversed sequentially, the former will behave as sequence of (unindexed) elements + while the latter will behave as a sequence of key-value pairs." (t/or iindexed? ;; Doesn't guarantee `java.util.List` is implemented, except by convention #?(:clj (t/isa? java.util.RandomAccess)) #?(:clj dstr/char-seq? :cljs dstr/string?) arr/array?)) +(var/def insertion-ordered? + "Collections whose elements are ordered, whether in forward or reverse direction, by their + insertion." + ...) + +(var/def sequentially-ordered? + "Collections defined by the fact that their elements must appear in a particular order, + specifically due to the criterion of 'nextness' rather than e.g. a value-comparator or insertion + order." + (t/or (t/isa|direct? #?(:clj clojure.lang.Sequential :cljs cljs.core/ISequential)) + iseq? + #?(:clj (t/isa? java.util.List)) + +list? + indexed?)) + +(var/def ordered? + "Collections defined by the fact that their elements must appear in a particular order. Note: + - `sequentially-ordered?` (even if non-`indexed?`) implies `ordered?`, as the ordering criterion + can be thought of as each element's implicit sequential designator / index. + - `indexed?` implies `ordered?`, as the ordering criterion can be thought of as each element's + explicit sequential designator / index. + - `comparator-ordered?` implies `ordered?` while `sorted?` does not necessarily, as while a + collection may happen to be sorted, this does not imply that order is one of its defining + aspects. + - `insertion-ordered?` implies `ordered`, as the ordering criterion can be thought of as the + designator / index of each element's insertion. + - While all good hashing algorithms are deterministic, order is not (generally) guaranteed for + hash-ordered collections." + (t/or sequentially-ordered? + comparator-ordered? + insertion-ordered?)) + (def +associative? (t/isa?|direct #?(:clj clojure.lang.Associative :cljs cljs.core/IAssociative))) (def !+associative? (t/isa?|direct #?(:clj clojure.lang.ITransientAssociative :cljs cljs.core/ITransientAssociative))) -;; Indicates whether `assoc?!` is supported -(def associative? (t/or +associative? !+associative? (t/or map/map? indexed?))) - -(def sequential? - (t/or (t/isa? #?(:clj clojure.lang.Sequential :cljs cljs.core/ISequential)) - list? indexed?)) +(var/def associative? + "Indicates whether `assoc?!` is supported." + (t/or +associative? !+associative? (t/or map/map? indexed?))) (def icounted? (t/isa?|direct #?(:clj clojure.lang.Counted :cljs cljs.core/ICounted))) -;; If something is `counted?`, it is supposed to implement a constant-time `count` -;; `nil` is counted but this type ignores that -(def counted? +(var/def counted? + "Objects guaranteed to implement a constant-time `count`. `nil` is technically counted but this + type ignores that." (t/or icounted? ;; It's not guaranteed that `char-seq?`s have constant-time `.length`/`count` but it's very ;; reasonable to assume. diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 95c114b7..7e0b4e29 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -432,8 +432,7 @@ (is= true ((f [(t/ordered long? boolean?)]) {0 true})) (is= true ((f (t/ordered long? boolean?)) {0 true})))) -(deftest test|unordered - (test-basic-finite) +(defn- test-basic-unordered [t] (testing "Order should not matter; only frequency" (is= true ((t/unordered (t/value 1) (t/value 2) (t/value 3) (t/value 4) (t/value 5) (t/value 6)) [1 2 3 4 5 6])) @@ -458,7 +457,11 @@ (let [ts (->> (range 15) (map t/value)) t (t/unordered ts)] (dotimes [i 100] - (is= t (t/unordered (shuffle ts)))))) + (is= t (t/unordered (shuffle ts))))))) + +(deftest test|unordered + (test-basic-finite t/unordered) + (test-basic-unordered t/unordered) (testing "Combinatoric equality between `t/ordered` and `t/unordered`" (test-comparison =ident (t/unordered (t/value 1) (t/value 2)) @@ -476,8 +479,13 @@ (t/ordered (t/ordered (t/value 2) (t/value 1)) (t/ordered (t/value 2) (t/value 1))))))) +(deftest test|set ; i.e. as `unique-unordered` + (test-basic-finite t/set) + (test-basic-unordered t/set) + (testing "Order and frequency should not matter")) + (deftest test|ordered - (test-basic-finite) + (test-basic-finite t/ordered) (testing "Order should matter" (is= true ((t/ordered (t/value 1) (t/value 2) (t/value 3) (t/value 4) (t/value 5) (t/value 6)) [1 2 3 4 5 6])) From 2d77879f4599a6af1e0dd61c8a3b76f446152450 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 15 Oct 2018 16:13:54 -0600 Subject: [PATCH 519/810] add `lookup?`; remove `insertion-ordered?` --- src/quantum/core/data/collections.cljc | 36 +++++++++++++++----------- 1 file changed, 21 insertions(+), 15 deletions(-) diff --git a/src/quantum/core/data/collections.cljc b/src/quantum/core/data/collections.cljc index 6ef4c934..9137a1f6 100644 --- a/src/quantum/core/data/collections.cljc +++ b/src/quantum/core/data/collections.cljc @@ -87,6 +87,12 @@ ;; ===== End sequences ===== ;; +(def transient? (t/isa?|direct #?(:clj clojure.lang.ITransientCollection + :cljs cljs.core/ITransientCollection))) + +(def editable? (t/isa?|direct #?(:clj clojure.lang.IEditableCollection + :cljs cljs.core/IEditableCollection))) + (def record? (t/isa?|direct #?(:clj clojure.lang.IRecord :cljs cljs.core/IRecord))) (var/def comparator-ordered? @@ -104,12 +110,6 @@ ; TODO implement — it means monotonically <= or >= monotonic?)) -(def transient? (t/isa?|direct #?(:clj clojure.lang.ITransientCollection - :cljs cljs.core/ITransientCollection))) - -(def editable? (t/isa?|direct #?(:clj clojure.lang.IEditableCollection - :cljs cljs.core/IEditableCollection))) - (def iindexed? (t/isa?|direct #?(:clj clojure.lang.Indexed :cljs cljs.core/IIndexed))) (var/def indexed? @@ -123,10 +123,12 @@ #?(:clj dstr/char-seq? :cljs dstr/string?) arr/array?)) -(var/def insertion-ordered? - "Collections whose elements are ordered, whether in forward or reverse direction, by their - insertion." - ...) +(def ilookup? (t/isa?|direct #?(:clj clojure.lang.Lookup :cljs cljs.core/ILookup))) + +(var/def lookup? + "Indicates efficient lookup by key (via `get`). + Technically, anything that is able to be the first input to `get`." + (t/or ilookup? indexed?)) (var/def sequentially-ordered? "Collections defined by the fact that their elements must appear in a particular order, @@ -136,7 +138,14 @@ iseq? #?(:clj (t/isa? java.util.List)) +list? - indexed?)) + indexed? + ;; These four are insertion-ordered maps but when re-`assoc`ing (map) or re-`conj`ing (set), + ;; the original sequence is retained, so really they're sequentially ordered and not purely + ;; insertion-ordered. + #?(:clj (t/isa? flatland.ordered.map.OrderedMap)) + #?(:clj (t/isa? flatland.ordered.set.OrderedSet)) + (t/isa? linked.map.LinkedMap) + (t/isa? linked.set.LinkedSet))) (var/def ordered? "Collections defined by the fact that their elements must appear in a particular order. Note: @@ -147,13 +156,10 @@ - `comparator-ordered?` implies `ordered?` while `sorted?` does not necessarily, as while a collection may happen to be sorted, this does not imply that order is one of its defining aspects. - - `insertion-ordered?` implies `ordered`, as the ordering criterion can be thought of as the - designator / index of each element's insertion. - While all good hashing algorithms are deterministic, order is not (generally) guaranteed for hash-ordered collections." (t/or sequentially-ordered? - comparator-ordered? - insertion-ordered?)) + comparator-ordered?)) (def +associative? (t/isa?|direct #?(:clj clojure.lang.Associative :cljs cljs.core/IAssociative))) From de96dcc93f51e627a5ef92e8a1f47efdd0a79701 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 15 Oct 2018 16:31:54 -0600 Subject: [PATCH 520/810] Flesh out `indexed?` vs. `lookup?` vs `map?` --- src/quantum/core/data/collections.cljc | 16 +++++++++++++--- src/quantum/core/data/map.cljc | 9 +++++++-- 2 files changed, 20 insertions(+), 5 deletions(-) diff --git a/src/quantum/core/data/collections.cljc b/src/quantum/core/data/collections.cljc index 9137a1f6..e5573b6f 100644 --- a/src/quantum/core/data/collections.cljc +++ b/src/quantum/core/data/collections.cljc @@ -114,6 +114,9 @@ (var/def indexed? "Indicates efficient lookup by (`dn/integer?`) index (via `get`), and that its indices are dense. + Thus indicates a collection that maintains a one-to-one mapping from `dn/integer?` keys to + values. + An `indexed?` is distinct from a non-`indexed?` `lookup?` whose keys densely satisfy `integer?` in that when traversed sequentially, the former will behave as sequence of (unindexed) elements while the latter will behave as a sequence of key-value pairs." @@ -126,8 +129,15 @@ (def ilookup? (t/isa?|direct #?(:clj clojure.lang.Lookup :cljs cljs.core/ILookup))) (var/def lookup? - "Indicates efficient lookup by key (via `get`). - Technically, anything that is able to be the first input to `get`." + "Indicates efficient lookup by key (via `get`), and thus a collection that maintains a one-to-one + mapping from keys to values. Technically, anything that is able to be the first input to `get`. + + Distinct from `map?` in that a `map?` is effectively + `(t/- (t/and associative? lookup?) indexed?)`. + + A `lookup?` whose keys densely satisfy `integer?` is distinct from an `indexed?` in that when + traversed sequentially, the former will behave as a sequence of key-value pairs while the latter + will behave as a sequence of (unindexed) elements." (t/or ilookup? indexed?)) (var/def sequentially-ordered? @@ -203,7 +213,7 @@ (t/or #?(:clj java-coll?) #?@(:clj [(t/isa? clojure.lang.IPersistentCollection) (t/isa? clojure.lang.ITransientCollection)] - :cljs (t/isa? cljs.core/ICollection)) + :cljs (t/isa|direct? cljs.core/ICollection)) sequential? associative?)) (def reduced? (t/isa? #?(:clj clojure.lang.Reduced :cljs cljs.core/Reduced))) diff --git a/src/quantum/core/data/map.cljc b/src/quantum/core/data/map.cljc index 90e084e6..ace9b922 100644 --- a/src/quantum/core/data/map.cljc +++ b/src/quantum/core/data/map.cljc @@ -15,7 +15,7 @@ :refer [defns-]] [quantum.untyped.core.type :as ut] ;; TODO TYPED - [quantum.untyped.core.vars + [quantum.untyped.core.vars :as uvar :refer [defalias def- defmacro-]]) (:import #?@(:clj [[java.util HashMap IdentityHashMap LinkedHashMap TreeMap] @@ -1623,7 +1623,12 @@ #?(:clj (def !!map? (t/or !!unsorted-map? !!sorted-map?))) - (def map? (t/or ?!+map? !map? #?@(:clj [!!map? (t/isa? java.util.Map)]))) + (uvar/def map? + "A `map?` is in some sense anything that satisfies `dc/lookup?` — i.e., a collection + maintaining a one-to-one mapping from keys to values. However, while we define `map?` + as being effectively `(t/- (t/and associative? lookup?) indexed?)`, in practice we + limit to an enumerated set of concrete types." + (t/or ?!+map? !map? #?@(:clj [!!map? (t/isa? java.util.Map)]))) From 8b197550e49e9c5fb030e2c4f4bf34460c2a2410 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 15 Oct 2018 16:45:01 -0600 Subject: [PATCH 521/810] Clean up `associative?` and `coll?` --- resources-dev/defnt.cljc | 1 + src/quantum/core/data/collections.cljc | 9 ++++----- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index b16a5c81..8c74714f 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -54,6 +54,7 @@ TODO: - `(or (and pred then) (and (not pred) else))` (which is not correct) - needs to equal `(t/and (t/or (t/not a) b) (t/or a c))` (which is correct) - `(- (or ?!+vector? !vector? #?(:clj !!vector?)) (isa? clojure.lang.Counted))` is not right +- t/or should probably order by `t/compare` descending #_" Note that `;; TODO TYPED` is the annotation we're using for this initiative diff --git a/src/quantum/core/data/collections.cljc b/src/quantum/core/data/collections.cljc index e5573b6f..70db6441 100644 --- a/src/quantum/core/data/collections.cljc +++ b/src/quantum/core/data/collections.cljc @@ -178,14 +178,13 @@ :cljs cljs.core/ITransientAssociative))) (var/def associative? - "Indicates whether `assoc?!` is supported." + "Collections that can associate a (potentially new) key with a new value. Technically, anything + that is able to be the first input to `assoc?!`." (t/or +associative? !+associative? (t/or map/map? indexed?))) (def icounted? (t/isa?|direct #?(:clj clojure.lang.Counted :cljs cljs.core/ICounted))) -(var/def counted? - "Objects guaranteed to implement a constant-time `count`. `nil` is technically counted but this - type ignores that." +(var/def counted? "Objects guaranteed to implement a constant-time `count`." (t/or icounted? ;; It's not guaranteed that `char-seq?`s have constant-time `.length`/`count` but it's very ;; reasonable to assume. @@ -214,7 +213,7 @@ #?@(:clj [(t/isa? clojure.lang.IPersistentCollection) (t/isa? clojure.lang.ITransientCollection)] :cljs (t/isa|direct? cljs.core/ICollection)) - sequential? associative?)) + ordered? lookup? associative?)) (def reduced? (t/isa? #?(:clj clojure.lang.Reduced :cljs cljs.core/Reduced))) From 1c53235935c5d229979b006c32bbc05c1046e7e1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 15 Oct 2018 16:52:27 -0600 Subject: [PATCH 522/810] Clean up `reducible?` and `seqable?`. --- src/quantum/core/data/collections.cljc | 28 +++++++++++--------------- 1 file changed, 12 insertions(+), 16 deletions(-) diff --git a/src/quantum/core/data/collections.cljc b/src/quantum/core/data/collections.cljc index 70db6441..09a4e672 100644 --- a/src/quantum/core/data/collections.cljc +++ b/src/quantum/core/data/collections.cljc @@ -207,8 +207,8 @@ #?(:clj (def java-coll? (t/isa? java.util.Collection))) -;; A group of objects/elements -(def coll? +(var/def coll? + "An object that represents a grouping/collection of other objects (individually called elements)." (t/or #?(:clj java-coll?) #?@(:clj [(t/isa? clojure.lang.IPersistentCollection) (t/isa? clojure.lang.ITransientCollection)] @@ -223,7 +223,11 @@ > reduced? [x t/ref?] (#?(:clj clojure.lang.Reduced. :cljs cljs.core/Reduced.) x)) -(def reducible? +(var/def reducible? + "An object that is able to be reduced by some means. Technically, anything that is able to be the + first input to `reduce`. + + All collection are reducible, but not all reducibles are collections (e.g. `nil?`, `numerically-integer?`, `dasync/read-chan?`, etc.)." (t/or p/nil? dstr/string? vec/!+vector? arr/array? dn/numerically-integer? ;; TODO what about `transformer?` dasync/read-chan? @@ -240,16 +244,8 @@ iseqable? iterable?)) -;; Whatever is `seqable?` is reducible, and whatever is `reducible?` is `seqable?`. -;; Since reduction is preferred to "manual" `first`/`next` seq traversal, we prefer `reducible?` to -;; `seqable?` as the base type. -(def seqable? reducible?) - -(t/defn unkeyed - "Creates an unkeyed collection type, in which the collection may - or may not be sequential or even seqable, but must not have key-value - pairs like a map. - Examples of unkeyed collections include a vector (despite its associativity), - a list, and a set (despite its values doubling as keys). - A map is not an unkeyed collection." - [x ...] (TODO)) +(var/def seqable? + "Whatever is `seqable?` is `reducible?`, and whatever is `reducible?` is `seqable?`. + Since reduction is preferred to 'manual' `first`/`next` seq traversal for performance and + conceptual reasons, we prefer `reducible?` to `seqable?` as the base type." + reducible?) From 78cbaa20b42abe664db94f07e4cea5da5b01b97c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 15 Oct 2018 18:39:03 -0600 Subject: [PATCH 523/810] Work out some more things with ordered vs. unordered --- src-untyped/quantum/untyped/core/type.cljc | 12 ++++---- .../untyped/core/type/reifications.cljc | 21 +++++++------ src/quantum/core/data/collections.cljc | 2 +- test/quantum/test/untyped/core/type.cljc | 30 +++++++++---------- 4 files changed, 32 insertions(+), 33 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 328a5e1f..4503b225 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -163,11 +163,11 @@ (defns- isa?|class [c #?(:clj c/class? :cljs c/fn?)] (ClassType. uhash/default uhash/default nil c nil)) -;; ----- FiniteType ----- ;; +;; ----- OrderedType ----- ;; -(defns finite - ([> utr/finite-type?] (finite [])) - ([data _ > utr/finite-type?] +(defns ordered + ([> utr/ordered-type?] (ordered [])) + ([data _ > utr/ordered-type?] (let [data' (if (type? data) [data] (if-not (sequential? data) @@ -175,8 +175,8 @@ (if-not (seq-and type? data) (err! "Not every element of finite type data is a type" {}) data)))] - (FiniteType. uhash/default uhash/default nil data' nil))) - ([datum _ & data _ > utr/finite-type?] (finite (cons datum data)))) + (OrderedType. uhash/default uhash/default nil data' nil))) + ([datum _ & data _ > utr/ordered-type?] (ordered (cons datum data)))) ;; ----- ValueType ----- ;; diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 9a27a03e..97b70933 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -265,16 +265,15 @@ (defns class-type>class [t class-type?] (.-c ^ClassType t)) -;; ----- FiniteType ----- ;; +;; ----- OrderedType ----- ;; -(udt/deftype FiniteType +(udt/deftype OrderedType [#?(:clj ^int ^:unsynchronized-mutable hash :cljs ^number ^:mutable hash) #?(:clj ^int ^:unsynchronized-mutable hash-code :cljs ^number ^:mutable hash-code) meta #_meta/meta? data #_dc/sequential? name #_(t/? symbol?)] {PType nil - ;; TODO this is probably not quite right ?Fn {invoke ([_ xs] (if (seqable? xs) (reduce-2 ;; Similar to `seq-and` (fn [ret t x] (if (t x) true (reduced false))) @@ -283,23 +282,23 @@ (fn [_ _] false)) false))} ?Meta {meta ([this] meta) - with-meta ([this meta'] (FiniteType. hash hash-code meta' data name))} - ?Hash {hash ([this] (uhash/caching-set-ordered! hash FiniteType data))} - ?Object {hash-code ([this] (uhash/caching-set-code! hash-code FiniteType data)) + with-meta ([this meta'] (OrderedType. hash hash-code meta' data name))} + ?Hash {hash ([this] (uhash/caching-set-ordered! hash OrderedType data))} + ?Object {hash-code ([this] (uhash/caching-set-code! hash-code OrderedType data)) equals ([this that #_any?] (or (== this that) - (and (instance? FiniteType that) - (= data (.-data ^FiniteType that)))))} - uform/PGenForm {>form ([this] (-> (list 'quantum.untyped.core.type/finite (>form data)) + (and (instance? OrderedType that) + (= data (.-data ^OrderedType that)))))} + uform/PGenForm {>form ([this] (-> (list 'quantum.untyped.core.type/ordered (>form data)) (accounting-for-meta meta)))} fedn/IOverride nil fedn/IEdn {-edn ([this] (if name (-> name (accounting-for-meta meta)) (>form this)))}}) -(defn finite-type? [x] (instance? FiniteType x)) +(defn ordered-type? [x] (instance? OrderedType x)) -(defns finite-type>data [t finite-type?] (.-data ^FiniteType t)) +(defns ordered-type>data [t ordered-type?] (.-data ^OrderedType t)) ;; ----- ValueType ----- ;; diff --git a/src/quantum/core/data/collections.cljc b/src/quantum/core/data/collections.cljc index 09a4e672..f75a4415 100644 --- a/src/quantum/core/data/collections.cljc +++ b/src/quantum/core/data/collections.cljc @@ -15,7 +15,7 @@ ;; TODO move to `quantum.core.data.sequence` ;; ===== Sequences and sequence-wrappers ===== ;; -;; Sequential (generally not efficient Lookup / RandomAccess) +;; Sequential (generally not `lookup?`) ;; Note that lists and seqs are not fundamentally different and so we don't distinguish between them ;; here. diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 7e0b4e29..66871f87 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -432,13 +432,21 @@ (is= true ((f [(t/ordered long? boolean?)]) {0 true})) (is= true ((f (t/ordered long? boolean?)) {0 true})))) -(defn- test-basic-unordered [t] +(deftest test|unordered + (test-basic-finite t/unordered) (testing "Order should not matter; only frequency" (is= true ((t/unordered (t/value 1) (t/value 2) (t/value 3) (t/value 4) (t/value 5) (t/value 6)) [1 2 3 4 5 6])) - (dotimes [i 100] - (is= true ((t/unordered (t/value 1) (t/value 2) (t/value 3) (t/value 4)(t/value 5)(t/value 6)) - (shuffle [1 2 3 4 5 6])))) + (testing "Frequency of 1" + (dotimes [i 100] + (is= true ((t/unordered (t/value 1) (t/value 2) (t/value 3) + (t/value 4) (t/value 5) (t/value 6)) (shuffle [1 2 3 4 5 6]))))) + (testing "Frequency of 2" + (dotimes [i 100] + (is= false ((t/unordered (t/value 1) (t/value 2) (t/value 3) + (t/value 4) (t/value 5) (t/value 6)) (shuffle [1 2 3 4 5 6 6]))) + (is= false ((t/unordered (t/value 1) (t/value 2) (t/value 3) (t/value 4) (t/value 5) + (t/value 6) (t/value 6)) (shuffle [1 2 3 4 5 6 6]))))) (is= true ((t/unordered (t/value 1) (t/value 2) (t/value 3) (t/value 4) (t/value 5) (t/value 6)) #{1 2 3 4 5 6})) (is= true ((t/unordered (t/ordered (t/value :a) (t/value :b)) @@ -454,14 +462,11 @@ (t/unordered (t/value :i) (t/value :j)))] (is= true (t (->> {:a :b :c :d :e :f :g :h :i :j} (map shuffle) (into {})))))) (testing "Internally should sort types deterministically" - (let [ts (->> (range 15) (map t/value)) + (let [ts (->> (concat (range 15) (range 15)) (map t/value)) t (t/unordered ts)] (dotimes [i 100] - (is= t (t/unordered (shuffle ts))))))) - -(deftest test|unordered - (test-basic-finite t/unordered) - (test-basic-unordered t/unordered) + (is= t (t/unordered (shuffle ts)))))) + ;; This may be too computationally expensive though (testing "Combinatoric equality between `t/ordered` and `t/unordered`" (test-comparison =ident (t/unordered (t/value 1) (t/value 2)) @@ -479,11 +484,6 @@ (t/ordered (t/ordered (t/value 2) (t/value 1)) (t/ordered (t/value 2) (t/value 1))))))) -(deftest test|set ; i.e. as `unique-unordered` - (test-basic-finite t/set) - (test-basic-unordered t/set) - (testing "Order and frequency should not matter")) - (deftest test|ordered (test-basic-finite t/ordered) (testing "Order should matter" From 70ca4f495c8492cbf049eca9c808decb07529eea Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 16 Oct 2018 00:44:07 -0600 Subject: [PATCH 524/810] `t/unordered` works!! --- src-untyped/quantum/untyped/core/numeric.cljc | 2 + src-untyped/quantum/untyped/core/refs.cljc | 6 +- src-untyped/quantum/untyped/core/type.cljc | 19 ++++- .../untyped/core/type/reifications.cljc | 73 ++++++++++++++++--- test/quantum/test/untyped/core/type.cljc | 8 +- 5 files changed, 90 insertions(+), 18 deletions(-) diff --git a/src-untyped/quantum/untyped/core/numeric.cljc b/src-untyped/quantum/untyped/core/numeric.cljc index bfe40c95..7855c66f 100644 --- a/src-untyped/quantum/untyped/core/numeric.cljc +++ b/src-untyped/quantum/untyped/core/numeric.cljc @@ -51,3 +51,5 @@ (bit-or 1 (bit-shift-right x 63)))) #?(:cljs (def abs js/Math.abs)) + +(defn inc-default [x] (if (nil? x) 1 (inc x))) diff --git a/src-untyped/quantum/untyped/core/refs.cljc b/src-untyped/quantum/untyped/core/refs.cljc index 8203557f..dff0f3aa 100644 --- a/src-untyped/quantum/untyped/core/refs.cljc +++ b/src-untyped/quantum/untyped/core/refs.cljc @@ -30,7 +30,9 @@ (defn update! "A nonatomic update." - [x f] (-> x (quantum.untyped.core.refs/set! (f (get x))))) + [x f] + (quantum.untyped.core.refs/set! x (f (get x))) + x) ;; ===== Unsynchronized mutability ===== ;; @@ -44,6 +46,8 @@ :cljs cljs.core/IDeref) (#?(:clj deref :cljs -deref) [this] val)) +(defn ! [x] (MutableReference. x)) + ;; ===== Thread-local mutability ===== ;; (defn >!thread-local #_> #_(t/isa? PMutableReference) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 4503b225..5c927332 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -68,7 +68,7 @@ [quantum.untyped.core.type.reifications UniversalSetType EmptySetType NotType OrType AndType - ProtocolType ClassType FiniteType + ProtocolType ClassType UnorderedType OrderedType ValueType FnType]))) @@ -165,14 +165,27 @@ ;; ----- OrderedType ----- ;; +(defns unordered + ([> utr/unordered-type?] (unordered [])) + ([data _ > utr/unordered-type?] + (let [data' (if (utr/type? data) + {data 1} + (if-not (sequential? data) + (err! "Finite type info must be sequential" {:type (c/type data)}) + (if-not (seq-and utr/type? data) + (err! "Not every element of finite type data is a type" {}) + (frequencies data))))] + (UnorderedType. uhash/default uhash/default nil data' nil))) + ([datum _ & data _ > utr/unordered-type?] (unordered (cons datum data)))) + (defns ordered ([> utr/ordered-type?] (ordered [])) ([data _ > utr/ordered-type?] - (let [data' (if (type? data) + (let [data' (if (utr/type? data) [data] (if-not (sequential? data) (err! "Finite type info must be sequential" {:type (c/type data)}) - (if-not (seq-and type? data) + (if-not (seq-and utr/type? data) (err! "Not every element of finite type data is a type" {}) data)))] (OrderedType. uhash/default uhash/default nil data' nil))) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 97b70933..2d384c4c 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -20,6 +20,9 @@ [quantum.untyped.core.form.generate.deftype :as udt] [quantum.untyped.core.loops :refer [reduce-2]] + [quantum.untyped.core.numeric :as unum] + [quantum.untyped.core.refs :as uref + :refer [!]] [quantum.untyped.core.spec :as us]) #?(:clj (:import [quantum.untyped.core.analyze.expr Expression]))) @@ -265,22 +268,72 @@ (defns class-type>class [t class-type?] (.-c ^ClassType t)) +;; ----- UnorderedType ----- ;; + +(defn- satisfies-unordered-type? [xs data] + (and (seqable? xs) ; TODO `dc/reducible?` + (let [!frequencies (! {}) + each-input-matches-one-type-not-exceeding-frequency? + (->> xs + (reduce + (fn [each-input-matches-one-type-not-exceeding-frequency? x] + (->> data + (reduce-kv + (fn [input-matches-one-type? t freq] + (if (t x) + (do (uref/update! !frequencies #(update % t unum/inc-default)) + (if (> (get @!frequencies t) (get data t)) + (reduced (reduced false)) + true)) + input-matches-one-type?)) + false))) + true))] + (and each-input-matches-one-type-not-exceeding-frequency? + (= @!frequencies data))))) + +(udt/deftype UnorderedType + [#?(:clj ^int ^:unsynchronized-mutable hash :cljs ^number ^:mutable hash) + #?(:clj ^int ^:unsynchronized-mutable hash-code :cljs ^number ^:mutable hash-code) + meta #_meta/meta? + data #_(t/type (dc/map-of t/type? (t/and integer? (> 1))) "Val is frequency of type") + name #_(t/? symbol?)] + {PType nil + ?Fn {invoke ([_ xs] (satisfies-unordered-type? xs data))} + ?Meta {meta ([this] meta) + with-meta ([this meta'] (UnorderedType. hash hash-code meta' data name))} + ?Hash {hash ([this] (uhash/caching-set-ordered! hash OrderedType data))} + ?Object {hash-code ([this] (uhash/caching-set-code! hash-code OrderedType data)) + equals ([this that #_any?] + (or (== this that) + (and (instance? UnorderedType that) + (= data (.-data ^UnorderedType that)))))} + uform/PGenForm {>form ([this] (-> (list 'quantum.untyped.core.type/unordered (>form data)) + (accounting-for-meta meta)))} + fedn/IOverride nil + fedn/IEdn {-edn ([this] (if name + (-> name (accounting-for-meta meta)) + (>form this)))}}) + +(defn unordered-type? [x] (instance? UnorderedType x)) + +(defns unordered-type>data [t unordered-type?] (.-data ^UnorderedType t)) + ;; ----- OrderedType ----- ;; (udt/deftype OrderedType [#?(:clj ^int ^:unsynchronized-mutable hash :cljs ^number ^:mutable hash) #?(:clj ^int ^:unsynchronized-mutable hash-code :cljs ^number ^:mutable hash-code) - meta #_meta/meta? - data #_dc/sequential? - name #_(t/? symbol?)] + meta #_meta/meta? + data #_dc/sequential? + name #_(t/? symbol?)] {PType nil - ?Fn {invoke ([_ xs] (if (seqable? xs) - (reduce-2 ;; Similar to `seq-and` - (fn [ret t x] (if (t x) true (reduced false))) - true ; vacuously - (sequence data) (sequence xs) - (fn [_ _] false)) - false))} + ?Fn {invoke ([_ xs] (and (seqable? xs) ; TODO `dc/reducible?` + (reduce-2 + ;; Similar to `seq-and` + (fn [ret t x] (if (t x) true (reduced false))) + true ; vacuously + (sequence data) (sequence xs) + (fn [_ _] false))))} ?Meta {meta ([this] meta) with-meta ([this meta'] (OrderedType. hash hash-code meta' data name))} ?Hash {hash ([this] (uhash/caching-set-ordered! hash OrderedType data))} diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 66871f87..6ec79dec 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -445,7 +445,7 @@ (dotimes [i 100] (is= false ((t/unordered (t/value 1) (t/value 2) (t/value 3) (t/value 4) (t/value 5) (t/value 6)) (shuffle [1 2 3 4 5 6 6]))) - (is= false ((t/unordered (t/value 1) (t/value 2) (t/value 3) (t/value 4) (t/value 5) + (is= true ((t/unordered (t/value 1) (t/value 2) (t/value 3) (t/value 4) (t/value 5) (t/value 6) (t/value 6)) (shuffle [1 2 3 4 5 6 6]))))) (is= true ((t/unordered (t/value 1) (t/value 2) (t/value 3) (t/value 4) (t/value 5) (t/value 6)) #{1 2 3 4 5 6})) @@ -466,8 +466,8 @@ t (t/unordered ts)] (dotimes [i 100] (is= t (t/unordered (shuffle ts)))))) - ;; This may be too computationally expensive though - (testing "Combinatoric equality between `t/ordered` and `t/unordered`" + ;; This may be too computationally expensive though, given the `O(n!)` nature of it + #_(testing "Combinatoric equality between `t/ordered` and `t/unordered`" (test-comparison =ident (t/unordered (t/value 1) (t/value 2)) (t/or (t/ordered (t/value 1) (t/value 2)) @@ -496,7 +496,7 @@ (t/ordered (t/value :e) (t/value :f)) (t/ordered (t/value :g) (t/value :h)) (t/ordered (t/value :i) (t/value :j)))] - (is= false (t { :a :b :c :d :e :f :g :h :i :j})) + (is= false (t (->> {:a :b :c :d :e :f :g :h :i :j} seq shuffle (into {})))) (is= true (t (umap/om :a :b :c :d :e :f :g :h :i :j))) (is= true (t (sorted-map :a :b :c :d :e :f :g :h :i :j)))) (let [t (t/ordered (t/unordered (t/value :a) (t/value :b)) From 6481c9e23d86a393bb0e7ecfb0930e9caf363aca Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 16 Oct 2018 00:51:11 -0600 Subject: [PATCH 525/810] Fix compilation and test; all pass! --- src-untyped/quantum/untyped/core/type/reifications.cljc | 4 ++-- test/quantum/test/untyped/core/type.cljc | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 2d384c4c..174d620b 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -301,8 +301,8 @@ ?Fn {invoke ([_ xs] (satisfies-unordered-type? xs data))} ?Meta {meta ([this] meta) with-meta ([this meta'] (UnorderedType. hash hash-code meta' data name))} - ?Hash {hash ([this] (uhash/caching-set-ordered! hash OrderedType data))} - ?Object {hash-code ([this] (uhash/caching-set-code! hash-code OrderedType data)) + ?Hash {hash ([this] (uhash/caching-set-ordered! hash UnorderedType data))} + ?Object {hash-code ([this] (uhash/caching-set-code! hash-code UnorderedType data)) equals ([this that #_any?] (or (== this that) (and (instance? UnorderedType that) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 6ec79dec..5bf9fd60 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -506,11 +506,11 @@ (t/unordered (t/value :i) (t/value :j)))] (dotimes [i 100] (is= false (t (->> { :a :b :c :d :e :f :g :h :i :j} - (map shuffle) (into {})))) + (map shuffle) shuffle (into {})))) (is= true (t (->> (umap/om :a :b :c :d :e :f :g :h :i :j) - (map shuffle) (into umap/om)))) + (map shuffle) (into (umap/om))))) (is= true (t (->> (sorted-map :a :b :c :d :e :f :g :h :i :j) - (map shuffle) (apply sorted-map)))))))) + (map shuffle) (into (sorted-map))))))))) (deftest test|value (test-equality #(t/value 1)) From c894a1970205ccb86b90e8901368c97decb3a691 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 16 Oct 2018 02:13:31 -0600 Subject: [PATCH 526/810] `c?/compare` compiles :D --- src-untyped/quantum/untyped/core/analyze.cljc | 22 ++++++++++--------- src-untyped/quantum/untyped/core/type.cljc | 2 ++ src/quantum/core/compare/core.cljc | 3 ++- 3 files changed, 16 insertions(+), 11 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 3857689e..1c173451 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -223,19 +223,20 @@ (let [{:keys [all-values? m]} (->> form (uc/map+ (fn [[form-k form-v]] [(analyze* env form-k) (analyze* env form-v)])) - (educe (fn [{:as ret :keys [all-values? m]} [k v]] - (-> ret - (cond-> (and all-values? - (-> k :type utr/value-type?) - (-> v :type utr/value-type?)) - (assoc :all-values? true)) - (update :m assoc k v))) + (educe (fn ([ret] ret) + ([{:as ret :keys [all-values? m]} [k v]] + (-> ret + (cond-> (and all-values? + (-> k :type utr/value-type?) + (-> v :type utr/value-type?)) + (assoc :all-values? true)) + (update :m assoc k v)))) {:all-values? true :m {}})) t (if all-values? (->> m (uc/map+ (fn [[k v]] [(-> k :type t/unvalue) (-> v :type t/unvalue)])) (join {}) t/value) - (t/and t/+map|built-in? (t/finite (seq m))))] + (t/and t/+map|built-in? (->> m (uc/map (fn [[k v]] (t/ordered k v))) t/unordered)))] (uast/map-node {:env env :unanalyzed-form form :form (->> m (uc/map+ (fn [[k v]] [(:form k) (:form v)])) @@ -367,7 +368,7 @@ :arg-types (mapv :type args|analyzed)}) ret))) -(defns- |method-call|incrementally-analyze +(defns- analyze-seq|dot|method-call|incrementally-analyze [env ::env, form _, target uast/node?, target-class class?, method-form _ args|form _ methods-for-ct-and-kind (s/seq-of t/any?) > uast/method-call?] (let [{:keys [args|analyzed call-sites]} @@ -863,7 +864,8 @@ (uast/symbol env form node (:type node)))))) (defns- analyze* [env ::env, form _ > uast/node?] - (when (> (uref/update! !!analyze-depth inc) 200) (throw (ex-info "Stack too deep" {:form form}))) + (when (> (uref/get (uref/update! !!analyze-depth inc)) 200) + (throw (ex-info "Stack too deep" {:form form}))) (ifs (symbol? form) (analyze-symbol env form) (t/literal? form) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 5c927332..636868f4 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -166,6 +166,7 @@ ;; ----- OrderedType ----- ;; (defns unordered + "Creates a type representing an unordered collection." ([> utr/unordered-type?] (unordered [])) ([data _ > utr/unordered-type?] (let [data' (if (utr/type? data) @@ -179,6 +180,7 @@ ([datum _ & data _ > utr/unordered-type?] (unordered (cons datum data)))) (defns ordered + "Creates a type representing an ordered collection." ([> utr/ordered-type?] (ordered [])) ([data _ > utr/ordered-type?] (let [data' (if (utr/type? data) diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index 8f4b8e0c..6c574007 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -168,7 +168,8 @@ ([a t/ref?, b t/ref?] (if (== a b) (int 0) - (throw (ex-info "Cannot compare incomparable values" {:type0 (type a) :type1 (type b)}))))) + (throw (clojure.lang.ExceptionInfo. "Cannot compare incomparable values" + {:type0 (type a) :type1 (type b)}))))) (defn ^number compare [x y] From 58413263994144fbef01274bd7872f5f8b6c960d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 16 Oct 2018 10:10:10 -0600 Subject: [PATCH 527/810] CLJS compatibility --- src/quantum/core/compare/core.cljc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index 6c574007..14228782 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -168,8 +168,8 @@ ([a t/ref?, b t/ref?] (if (== a b) (int 0) - (throw (clojure.lang.ExceptionInfo. "Cannot compare incomparable values" - {:type0 (type a) :type1 (type b)}))))) + (throw (#?(:clj clojure.lang.ExceptionInfo. :cljs cljs.core/ExceptionInfo.) + "Cannot compare incomparable values" {:type0 (type a) :type1 (type b)} nil))))) (defn ^number compare [x y] From abb3d57894595858858433d8df2e3a4ba1fe5edc Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 17 Oct 2018 00:19:59 -0600 Subject: [PATCH 528/810] Add preliminary `compare` support --- src/quantum/core/compare/core.cljc | 14 -------------- src/quantum/core/data/array.cljc | 3 +++ src/quantum/core/data/numeric.cljc | 2 ++ src/quantum/core/data/primitive.cljc | 9 +++++++-- src/quantum/core/data/string.cljc | 17 ++++++++++++----- 5 files changed, 24 insertions(+), 21 deletions(-) diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index 14228782..82318caf 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -171,20 +171,6 @@ (throw (#?(:clj clojure.lang.ExceptionInfo. :cljs cljs.core/ExceptionInfo.) "Cannot compare incomparable values" {:type0 (type a) :type1 (type b)} nil))))) -(defn ^number compare - [x y] - (cond - (number? x) (if (number? y) - (garray/defaultCompare x y) - (throw (js/Error. (str "Cannot compare " x " to " y)))) - - :else - (if (and (or (string? x) (array? x) (true? x) (false? x)) - (identical? (type x) (type y))) - (garray/defaultCompare x y) - (throw (js/Error. (str "Cannot compare " x " to " y)))))) - - ; ----- `comp<` ----- ; #?(:clj (defnt' ^boolean comp<-bin diff --git a/src/quantum/core/data/array.cljc b/src/quantum/core/data/array.cljc index 91f28115..db788666 100644 --- a/src/quantum/core/data/array.cljc +++ b/src/quantum/core/data/array.cljc @@ -29,6 +29,9 @@ (ulog/this-ns) +;; TODO add `c?/compare` support +;; Note that in CLJS you can directly `<` arrays but it's not sufficient because it does `<` comparisons on its contents which might not be expected + (def typed-arrays-supported? (p/val? (aget usys/global "ArrayBuffer"))) ;; A polyfill for the `.slice` prototype method missing in Safari and some mobile browser versions diff --git a/src/quantum/core/data/numeric.cljc b/src/quantum/core/data/numeric.cljc index 1de107a0..820ae3ae 100644 --- a/src/quantum/core/data/numeric.cljc +++ b/src/quantum/core/data/numeric.cljc @@ -261,6 +261,8 @@ (c?/>= (.multiply (.numerator a) (.numerator b)) (.multiply (.denominator a) (.denominator b)))))) +;; TODO `c?/compare` + ;; ===== Comparisons to constants (e.g. to 0 or 1) ===== ;; (t/defn ^:inline >zero-of-type #_> #_zero? diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index a4b28fab..396ba780 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -278,5 +278,10 @@ ) (t/extend-defn! c?/compare -#?(:clj ([a c?/icomparable?, b primitive?] (.compareTo a b))) - ([a primitive? , b c?/icomparable?] (.compareTo (box a) b))) + ([a false? , b false?] 0) + ([a false? , b true?] -1) + ([a true? , b false?] 1) + ([a true? , b true?] 0) + ([a numeric? , b numeric?] (ifs (c?/< a b) -1 (c?/> a b) 1 0)) +#?(:clj ([a (t/ref c?/icomparable?), b primitive?] (.compareTo a b))) +#?(:clj ([a primitive? , b (t/ref c?/icomparable?)] (.compareTo (box a) b)))) diff --git a/src/quantum/core/data/string.cljc b/src/quantum/core/data/string.cljc index 42e4bdcd..30d563e7 100644 --- a/src/quantum/core/data/string.cljc +++ b/src/quantum/core/data/string.cljc @@ -9,7 +9,10 @@ [quantum.core.data.primitive :as p] [quantum.core.type :as t] ;; TODO TYPED excise - [quantum.untyped.core.core :as ucore]) + [quantum.untyped.core.core :as ucore] + ;; TODO TYPED excise + [quantum.untyped.core.logic + :refer [ifs]]) (:import #?(:clj [com.carrotsearch.hppc CharArrayDeque]) #?(:cljs [goog.string StringBuffer]))) @@ -149,11 +152,15 @@ (t/fn [x integer?] (comp/<= #?(:clj Character/MIN_RADIX :cljs 2) x #?(:clj Character/MAX_RADIX :cljs 36)))) -(t/extend-defn! ?c/compare -#?(:clj (^:in [a string?, b string?] (.compareTo a b)))) - (t/extend-defn! ?c/= -#?(:clj (^:in [a string?, b string?] (.equals a b)))) + (^:in [a string?, b string?] (#?(:clj .equals :cljs ?c/==) a b))) + +(t/extend-defn! ?c/compare +#?(:clj (^:in [a string?, b string?] (.compareTo a b))) +#?(:cljs ( [a string?, b string?] + (ifs ^boolean (js* "(~{} < ~{})" a b) -1 + ^boolean (js* "(~{} > ~{})" a b) 1 + 0)))) (t/extend-defn! dn/>boolean ([x (t/value "true")] true) From 97c27ae996d8140146811b7edc2a83f46c7e9ae5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 19 Oct 2018 00:25:41 -0600 Subject: [PATCH 529/810] Reprioritize todos; add another analysis todo --- resources-dev/defnt.cljc | 50 ++++++++++++++++++++++------------------ 1 file changed, 27 insertions(+), 23 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 8c74714f..a3e47c45 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -60,8 +60,14 @@ TODO: Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - [0] - Reflection warning, /Users/alexander/Code/quantum/src/quantum/core/data/primitive.cljc:250:1 - call to method invoke on quantum.core.compare.core.byte>boolean can't be resolved (no such method). - [1] - t/numerically : e.g. a double representing exactly what a float is able to represent + [1] - t/input-type + - This is pretty simple with the current dependent type system + - Then if those fns ever get extended then it should trigger a chain-reaction of recompilations + [2] - t/output-type + - This is pretty simple with the current dependent type system + - Then if those fns ever get extended then it should trigger a chain-reaction of recompilations + [3] - Direct dispatch needs to actually work correctly in `t/defn` + [4] - t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. - t/numerically-integer? - Primitive conversions not requiring checks can go in data.primitive @@ -69,15 +75,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - numeric definitions - numeric ranges - numeric characteristics - [2] - t/input-type - - `(t/input-type >namespace :?)` meaning the possible input types to the first input to - `>namespace` - - `(t/input-type reduce :_ :_ :?)` - - This is pretty simple with the current dependent type system - - Then if those fns ever get extended then it should trigger a chain-reaction of recompilations - [3] - t/output-type - - This is pretty simple with the current dependent type system - [4] - Direct dispatch needs to actually work correctly in `t/defn` [5] - No trailing `>` means `> ?` - ? : type inference - use logic programming and variable unification e.g. `?1` `?2` ? @@ -143,11 +140,17 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - (t/seq vector? [ [0 (t/value :a)] [1 (t/value :b)] [2 (t/value :c)]]) - (t/kv vector? { 0 [0 (t/value :a)] 1 [1 (t/value :b)] 2 [2 (t/value :c)]}) - and so on ad infinitum. Therefore we reserve `t/kv` for `(t/and t/lookup? (t/not indexed?))`. - - Analysis + - Analysis/Optimization - `(p/nil? ...)` should probably be inlined to `(?/== ... nil)` rather than using the overhead of the deftype - This should realize that we're negating a `<` and change the operator to `<=` - `(t/def nneg? (fn/comp ?/not neg?))` + - For numbers: + - (< (compare a b) 0) + -> + (< (ifs (< a b) -1 (> a b) 1 0) 0) + -> the only one that can be < 0 is the -1 + -> (< a b) - Better analysis of compound literals - Literal vectors need to be analyzed — (t/finite-of t/built-in-vector? a-type b-type ...) - Literal sets need to be analyzed — (t/finite-of t/built-in-set? a-type b-type ...) @@ -210,6 +213,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative analyzer when doing direct dispatch. Should emit a warning, not just fail. - (t/and (t/or a b) c) should -> (t/or (t/and a c) (t/and b c)) for purposes of separating dispatches - ^:inline + - should be able to mark either ^:unline or ^{:inline false} on arities of an inline function - if you do (Numeric/bitAnd a b) inline then bitAnd needs to know the primitive type so maybe we do the `let*`-binding approach to typing vars? - A good example of inlining: @@ -635,16 +639,16 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] map-indexed - [ ] mapcat - [ ] mapv - - [ ] max - - [ ] max-key + - [x x] max + - [x x] max-key - [ ] memfn - [ ] memoize - [ ] merge - [ ] merge-with - [x x] meta - [ ] methods - - [ ] min - - [ ] min-key + - [x x] min + - [x x] min-key - [ ] mix-collection-hash - [| ] mk-bound-fn - [ ] mod @@ -1099,8 +1103,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] Math.log10(double) > double - [ ] Math.pow(double, double) > double - [ ] Math.exp(double) > double - - [ ] Math.min(int, int) > int - - [ ] Math.max(int, int) > int + - [x] Math.min(int, int) > int + - [x] Math.max(int, int) > int - [ ] Math.addExact(int, int) > int - [ ] Math.addExact(long, long) > long - [ ] Math.decrementExact(int) > int @@ -1557,7 +1561,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] char_array - [ ] chars - [ ] clearBit - - [ ] compare + - [x] compare - [ ] dec - [ ] decP - [ ] denominator @@ -1585,8 +1589,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] longs - [x] lt - [x] lte - - [ ] max - - [ ] min + - [x] max + - [x] min - [ ] minus - [ ] minusP - [ ] multiply @@ -1768,8 +1772,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] negate - [ ] multiply - [ ] divide - - [ ] max - - [ ] min + - [x] max + - [x] min - [ ] rem - List of Primitive fns to implement: - uncheckedByteCast From 206f44a43a0895f0fc407bde574ecc2cc9651bdb Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 19 Oct 2018 00:25:58 -0600 Subject: [PATCH 530/810] Update return values of Numeric/max|min --- src-java/quantum/core/Numeric.java | 54 ++++++++++++++---------------- 1 file changed, 26 insertions(+), 28 deletions(-) diff --git a/src-java/quantum/core/Numeric.java b/src-java/quantum/core/Numeric.java index f33e935e..b629849a 100644 --- a/src-java/quantum/core/Numeric.java +++ b/src-java/quantum/core/Numeric.java @@ -1229,20 +1229,20 @@ public static boolean bitTest (final double x, final long i) { public static byte max (final byte a, final byte b) { return (a < b) ? b : a; } public static short max (final byte a, final short b) { return (a < b) ? b : a; } - public static char max (final byte a, final char b) { return (char)((a < b) ? b : a); } + public static int max (final byte a, final char b) { return (a < b) ? b : a; } public static int max (final byte a, final int b) { return (a < b) ? b : a; } public static long max (final byte a, final long b) { return (a < b) ? b : a; } public static float max (final byte a, final float b) { return (a < b) ? b : a; } public static double max (final byte a, final double b) { return (a < b) ? b : a; } public static short max (final short a, final byte b) { return (a < b) ? b : a; } public static short max (final short a, final short b) { return (a < b) ? b : a; } - public static short max (final short a, final char b) { return (short)((a < b) ? b : a); } + public static int max (final short a, final char b) { return (a < b) ? b : a; } public static int max (final short a, final int b) { return (a < b) ? b : a; } public static long max (final short a, final long b) { return (a < b) ? b : a; } public static float max (final short a, final float b) { return (a < b) ? b : a; } public static double max (final short a, final double b) { return (a < b) ? b : a; } - public static char max (final char a, final byte b) { return (char)((a < b) ? b : a); } - public static short max (final char a, final short b) { return (short)((a < b) ? b : a); } + public static int max (final char a, final byte b) { return (a < b) ? b : a; } + public static int max (final char a, final short b) { return (a < b) ? b : a; } public static char max (final char a, final char b) { return (a < b) ? b : a; } public static int max (final char a, final int b) { return (a < b) ? b : a; } public static long max (final char a, final long b) { return (a < b) ? b : a; } @@ -1253,49 +1253,49 @@ public static boolean bitTest (final double x, final long i) { public static int max (final int a, final char b) { return (a < b) ? b : a; } public static int max (final int a, final int b) { return Math.max(a, b); } public static long max (final int a, final long b) { return (a < b) ? b : a; } - public static float max (final int a, final float b) { return (a < b) ? b : a; } + public static double max (final int a, final float b) { return (a < b) ? b : a; } public static double max (final int a, final double b) { return (a < b) ? b : a; } public static long max (final long a, final byte b) { return (a < b) ? b : a; } public static long max (final long a, final short b) { return (a < b) ? b : a; } public static long max (final long a, final char b) { return (a < b) ? b : a; } public static long max (final long a, final int b) { return (a < b) ? b : a; } - public static long max (final long a, final long b) { return Math.max(a, b); } - public static float max (final long a, final float b) { return (a < b) ? b : a; } - public static double max (final long a, final double b) { return (a < b) ? b : a; } + public static long max (final long a, final long b) { return (a < b) ? b : a; } + public static Object max (final long a, final float b) { return (a < b) ? b : a; } + public static Object max (final long a, final double b) { return (a < b) ? b : a; } public static float max (final float a, final byte b) { return (a < b) ? b : a; } public static float max (final float a, final short b) { return (a < b) ? b : a; } public static float max (final float a, final char b) { return (a < b) ? b : a; } - public static float max (final float a, final int b) { return (a < b) ? b : a; } - public static float max (final float a, final long b) { return (a < b) ? b : a; } - public static float max (final float a, final float b) { return Math.max(a, b); } + public static double max (final float a, final int b) { return (a < b) ? b : a; } + public static Object max (final float a, final long b) { return (a < b) ? b : a; } + public static float max (final float a, final float b) { return (a < b) ? b : a; } public static double max (final float a, final double b) { return (a < b) ? b : a; } public static double max (final double a, final byte b) { return (a < b) ? b : a; } public static double max (final double a, final short b) { return (a < b) ? b : a; } public static double max (final double a, final char b) { return (a < b) ? b : a; } public static double max (final double a, final int b) { return (a < b) ? b : a; } - public static double max (final double a, final long b) { return (a < b) ? b : a; } + public static Object max (final double a, final long b) { return (a < b) ? b : a; } public static double max (final double a, final float b) { return (a < b) ? b : a; } - public static double max (final double a, final double b) { return Math.max(a, b); } + public static double max (final double a, final double b) { return (a < b) ? b : a; } // ============================== min (implicitly checked) ================================== // // "Infectious": uses the largest data type passed public static byte min (final byte a, final byte b) { return (a > b) ? b : a; } public static short min (final byte a, final short b) { return (a > b) ? b : a; } - public static char min (final byte a, final char b) { return (char)((a > b) ? b : a); } + public static int min (final byte a, final char b) { return (a > b) ? b : a; } public static int min (final byte a, final int b) { return (a > b) ? b : a; } public static long min (final byte a, final long b) { return (a > b) ? b : a; } public static float min (final byte a, final float b) { return (a > b) ? b : a; } public static double min (final byte a, final double b) { return (a > b) ? b : a; } public static short min (final short a, final byte b) { return (a > b) ? b : a; } public static short min (final short a, final short b) { return (a > b) ? b : a; } - public static short min (final short a, final char b) { return (short)((a > b) ? b : a); } + public static int min (final short a, final char b) { return (a > b) ? b : a; } public static int min (final short a, final int b) { return (a > b) ? b : a; } public static long min (final short a, final long b) { return (a > b) ? b : a; } public static float min (final short a, final float b) { return (a > b) ? b : a; } public static double min (final short a, final double b) { return (a > b) ? b : a; } - public static char min (final char a, final byte b) { return (char)((a > b) ? b : a); } - public static short min (final char a, final short b) { return (short)((a > b) ? b : a); } + public static int min (final char a, final byte b) { return (a > b) ? b : a; } + public static int min (final char a, final short b) { return (a > b) ? b : a; } public static char min (final char a, final char b) { return (a > b) ? b : a; } public static int min (final char a, final int b) { return (a > b) ? b : a; } public static long min (final char a, final long b) { return (a > b) ? b : a; } @@ -1304,33 +1304,31 @@ public static boolean bitTest (final double x, final long i) { public static int min (final int a, final byte b) { return (a > b) ? b : a; } public static int min (final int a, final short b) { return (a > b) ? b : a; } public static int min (final int a, final char b) { return (a > b) ? b : a; } - // Intrinsic; maybe the others could be acclerated in the same way? - // TODO maybe use if-optimization? public static int min (final int a, final int b) { return Math.min(a, b); } public static long min (final int a, final long b) { return (a > b) ? b : a; } - public static float min (final int a, final float b) { return (a > b) ? b : a; } + public static double min (final int a, final float b) { return (a > b) ? b : a; } public static double min (final int a, final double b) { return (a > b) ? b : a; } public static long min (final long a, final byte b) { return (a > b) ? b : a; } public static long min (final long a, final short b) { return (a > b) ? b : a; } public static long min (final long a, final char b) { return (a > b) ? b : a; } public static long min (final long a, final int b) { return (a > b) ? b : a; } - public static long min (final long a, final long b) { return Math.min(a, b); } - public static float min (final long a, final float b) { return (a > b) ? b : a; } - public static double min (final long a, final double b) { return (a > b) ? b : a; } + public static long min (final long a, final long b) { return (a > b) ? b : a; } + public static Object min (final long a, final float b) { return (a > b) ? b : a; } + public static Object min (final long a, final double b) { return (a > b) ? b : a; } public static float min (final float a, final byte b) { return (a > b) ? b : a; } public static float min (final float a, final short b) { return (a > b) ? b : a; } public static float min (final float a, final char b) { return (a > b) ? b : a; } - public static float min (final float a, final int b) { return (a > b) ? b : a; } - public static float min (final float a, final long b) { return (a > b) ? b : a; } - public static float min (final float a, final float b) { return Math.min(a, b); } + public static double min (final float a, final int b) { return (a > b) ? b : a; } + public static Object min (final float a, final long b) { return (a > b) ? b : a; } + public static float min (final float a, final float b) { return (a > b) ? b : a; } public static double min (final float a, final double b) { return (a > b) ? b : a; } public static double min (final double a, final byte b) { return (a > b) ? b : a; } public static double min (final double a, final short b) { return (a > b) ? b : a; } public static double min (final double a, final char b) { return (a > b) ? b : a; } public static double min (final double a, final int b) { return (a > b) ? b : a; } - public static double min (final double a, final long b) { return (a > b) ? b : a; } + public static Object min (final double a, final long b) { return (a > b) ? b : a; } public static double min (final double a, final float b) { return (a > b) ? b : a; } - public static double min (final double a, final double b) { return Math.min(a, b); } + public static double min (final double a, final double b) { return (a > b) ? b : a; } // ================================== rem (unchecked) ====================================== // From 024ada2a9a265f952364976b47a33f612fd2c592 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 19 Oct 2018 00:26:34 -0600 Subject: [PATCH 531/810] Dynamic dispatch must be specifically requested --- src-untyped/quantum/untyped/core/analyze.cljc | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 1c173451..dad6263d 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -605,7 +605,14 @@ (t/<= (:type input|analyzed) (get input-types i)))) seq)] (assoc ret :dispatchable-overloads-seq dispatchable-overloads-seq') - (filter-dynamic-dispatchable-overloads ret input|analyzed i caller|node body))) + (if (-> caller|node :unanalyzed-form meta :dyn) + (filter-dynamic-dispatchable-overloads ret input|analyzed i caller|node body) + (err! (str "No overloads satisfy the inputs via direct dispatch; " + "dynamic dispatch not requested") + {:caller caller|node + :inputs body + :failing-input-form (:form input|analyzed) + :failing-input-type (:type input|analyzed)})))) (defn- >dispatch|out-type [dispatch-type dispatchable-overloads-seq] (case dispatch-type From b95b25529e6d2fdacf111492069f0b07b0c10a61 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 19 Oct 2018 00:27:05 -0600 Subject: [PATCH 532/810] `defn` declare now returns a var --- src-untyped/quantum/untyped/core/type/defnt.cljc | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 6913a7aa..a6ce2596 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -721,10 +721,10 @@ fn|output-type (eval fn|output-type|form) fn|types-decl-name (symbol (str fn|name "|__types"))] (if (empty? overloads-bases) - `(do (declare + `(do (def ~fn|types-decl-name (atom [])) + (declare ~(with-meta fn|name - (assoc fn|meta :quantum.core.type/type `(t/ftype ~(>form fn|output-type))))) - (def ~fn|types-decl-name (atom []))) + (assoc fn|meta :quantum.core.type/type `(t/ftype ~(>form fn|output-type)))))) (let [gen-gensym-base (ufgen/>reproducible-gensym|generator) gen-gensym (c/fn [x] (symbol (str (gen-gensym-base x) "__"))) opts (kw-map compilation-mode gen-gensym kind lang) From fac15d905f5e0507de4668b4ee11852fd0c7db33 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 19 Oct 2018 00:27:15 -0600 Subject: [PATCH 533/810] Update type annotation --- src-untyped/quantum/untyped/core/type/reifications.cljc | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 174d620b..3df7d7fe 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -386,7 +386,8 @@ name out-type #_t/type? arities-form - arities #_(s/map-of non-zero-int? (s/seq-of :quantum.untyped.core.type/fn-type|arity))] + arities #_(s/map-of nneg-int? (s/seq-of (s/kv {:input-types (s/vec-of type?) + :output-type type?})))] {PType nil ;; Outputs whether the args match any input spec ?Fn {invoke ([this args] (TODO))} From d8853b3dbabeb3c17c1d174e2ecb79578885919e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 19 Oct 2018 00:28:15 -0600 Subject: [PATCH 534/810] Overhaul compare.core --- src/quantum/core/compare/core.cljc | 300 ++++++----------------------- 1 file changed, 63 insertions(+), 237 deletions(-) diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index 82318caf..c1e0ec81 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -5,43 +5,23 @@ A complete (w.r.t. the `quantum.core.data.*` namespaces) set of definitions for type overloads is found in `quantum.core.compare`." (:refer-clojure :exclude - [< <= = not= == not== > >= compare] - ;; TODO TYPED remove - #_[= not= < > <= >= max min max-key min-key neg? pos? zero? - -' + inc compare]) + [< <= = not= == > >= compare max max-key min min-key]) (:require - [clojure.core :as core] - ;; TODO TYPED excise - #_[quantum.core.numeric.operators :as op - :refer [- -' + abs inc div:natural]] - ;; TODO TYPED excise - #_[quantum.core.numeric.predicates :as pred - :refer [neg? pos? zero?]] - ;; TODO TYPED excise - #_[quantum.core.numeric.convert - :refer [->num ->num&]] - ;; TODO TYPED excise - #_[quantum.core.data.numeric :as dn] - [quantum.core.type :as t] + [clojure.core :as core] + [quantum.core.type :as t] ;; TODO TYPED excise [quantum.untyped.core.logic :refer [ifs]] - [quantum.untyped.core.type :as ut] + [quantum.untyped.core.type :as ut] ;; TODO TYPED excise - [quantum.untyped.core.vars :as var]) + [quantum.untyped.core.vars :as var]) #?(:clj (:import [quantum.core Numeric]))) ;; Some of the ideas here adapted from gfredericks/compare ;; TODO include diffing -;; TODO use -compare in CLJS -;; TODO do `defnt` `compare` for different types -;; TODO = vs. == vs. RT/equiv vs. etc. -;; TODO bring in from clojure.lang.RT -;; TODO comp< vs. <; comp< should include arrays -;; `=` <- `==`, `=`: permissive -;; `='` <- `=`: strict like `core/=` with numbers +;; TODO comp< vs. < on numbers ;; TODO `hash=` -;; TODO .equals vs. .equiv vs. all the others? ; ===== `==`, `=`, `not=` ===== ; @@ -78,12 +58,12 @@ > ut/boolean? ;; Everything is self-equal (except, implementationally, NaN and Infinity) ([x t/any?] true) - ([a t/nil? , b t/nil?] true) - ([a t/nil? , b (t/ref t/val?)] false) - ([a (t/ref t/val?), b t/nil?] false) + ([a t/nil? , b t/nil?] true) + ([a t/nil? , b (t/ref ut/val?)] false) + ([a (t/ref ut/val?), b t/nil?] false) ;; The fallback overload; collections (in CLJ) and protocol-native objects (in CLJS) will have a ;; more specific equivalence check as defined later on - ([a (t/ref t/val?), b (t/ref t/val?)] + ([a (t/ref ut/val?), b (t/ref ut/val?)] (or (== a b) #?(:clj (.equals a b) :cljs (-equiv ^non-native a b))))) @@ -97,7 +77,7 @@ ;; Nothing is self-unequal (except, implementationally, NaN and Infinity) ([x t/any?] false)) -; ===== `<` ===== ; +;; ===== `<` ===== ;; ;; TODO add variadic arity (t/defn ^:inline < @@ -107,7 +87,7 @@ cljs.core/< "10/14/2018"}} > ut/boolean?) -; ===== `<=` ===== ; +;; ===== `<=` ===== ;; ;; TODO add variadic arity (t/defn ^:inline <= @@ -117,7 +97,7 @@ cljs.core/<= "10/14/2018"}} > ut/boolean?) -; ===== `>` ===== ; +;; ===== `>` ===== ;; ;; TODO add variadic arity (t/defn ^:inline > @@ -127,7 +107,7 @@ cljs.core/> "10/14/2018"}} > ut/boolean?) -; ===== `>=` ===== ; +;; ===== `>=` ===== ;; ;; TODO add variadic arity (t/defn ^:inline >= @@ -137,7 +117,7 @@ cljs.core/>= "10/14/2018"}} > ut/boolean?) -; ===== `compare` ===== ; +;; ===== `compare` ===== ;; (var/def icomparable? "That which implements the interface marking comparability to its own 'concrete type' (i.e. @@ -164,205 +144,51 @@ ([a (t/ref icomparable?), b (t/ref icomparable?)] (if (== a b) (int 0) - #?(:clj (.compareTo a b) :cljs (core/-compare ^not-native a b)))) - ([a t/ref?, b t/ref?] - (if (== a b) - (int 0) - (throw (#?(:clj clojure.lang.ExceptionInfo. :cljs cljs.core/ExceptionInfo.) - "Cannot compare incomparable values" {:type0 (type a) :type1 (type b)} nil))))) - -; ----- `comp<` ----- ; - -#?(:clj (defnt' ^boolean comp<-bin - "Returns true if args are in monotonically increasing order according to `compare`, - otherwise false." - ([^comparable? x] true) - ([#{byte char short int long float double} x - #{byte char short int long float double} y] (< x y)) - ([^boolean x ^boolean y] (< (->num& x) (->num& y))) - ([^Comparable x ^Comparable y] (< (compare x y) 0)) - ([^Comparable x ^prim? y] (< (compare x y) 0)) - ([^prim? x ^Comparable y] (< (compare x y) 0)) - ; TODO numbers and nil - ) - :cljs (defn comp<-bin ([x] true) ([x y] (< (compare x y) 0)))) - -; ----- `comp<=` ----- ; - -#?(:clj (defnt' ^boolean comp<=-bin - ([^comparable? x] true) - ([#{byte char short int long float double} x - #{byte char short int long float double} y] (<= x y)) - ([^boolean x ^boolean y] (<= (->num& x) (->num& y))) - ([^Comparable x ^Comparable y] (<= (compare x y) 0)) - ([^Comparable x ^prim? y] (<= (compare x y) 0)) - ([^prim? x ^Comparable y] (<= (compare x y) 0)) - ; TODO numbers and nil - ) - :cljs (defn comp<=-bin ([x] true) ([x y] (<= (compare x y) 0)))) ; TODO rest - -#?(:clj (variadic-predicate-proxy - ^{:doc "Returns true if args are in monotonically non-decreasing order - according to `compare`, otherwise false."} - comp<= comp<=-bin)) -#?(:clj (variadic-predicate-proxy comp<=& comp<=-bin&)) - -; ===== `>` ===== ; - -; ----- `comp>` ----- ; - -#?(:clj (defnt' ^boolean comp>-bin - ([^comparable? x] true) - ([#{byte char short int long float double} x - #{byte char short int long float double} y] (> x y)) - ([^boolean x ^boolean y] (> (->num& x) (->num& y))) - ([^Comparable x ^Comparable y] (> (compare x y) 0)) - ([^Comparable x ^prim? y] (> (compare x y) 0)) - ([^prim? x ^Comparable y] (> (compare x y) 0)) - ; TODO numbers and nil - ) - :cljs (defn comp>-bin ([x] true) ([x y] (> (compare x y) 0)))) ; TODO rest - -#?(:clj (variadic-predicate-proxy - ^{:doc "Returns true if args are in monotonically decreasing order - according to `compare`, otherwise false."} - comp> comp>-bin)) -#?(:clj (variadic-predicate-proxy comp>& comp>-bin&)) - -; ===== `>=` ===== ; - -#?(:clj (defnt' ^boolean >=-bin - ([#{byte char short int long float double} x] true) - ([#{byte char short int long float double} x - #{byte char short int long float double} y] (Numeric/gte x y)) - ; TODO numbers, but not nil - ) - :cljs (defn >=-bin ([x] true) ([x y] (core/>= x y)))) - -#?(:clj (variadic-predicate-proxy >= >=-bin)) -#?(:clj (variadic-predicate-proxy >=& >=-bin&)) - -; ----- `comp>=` ----- ; - -#?(:clj (defnt' ^boolean comp>=-bin - ([^comparable? x] true) - ([#{byte char short int long float double} x - #{byte char short int long float double} y] (>= x y)) - ([^boolean x ^boolean y] (>= (->num& x) (->num& y))) - ([^Comparable x ^Comparable y] (>= (compare x y) 0)) - ([^Comparable x ^prim? y] (>= (compare x y) 0)) - ([^prim? x ^Comparable y] (>= (compare x y) 0)) - ; TODO numbers and nil - ) - :cljs (defn >=-bin ([x] true) ([x y] (core/>= (compare x y) 0)))) ; TODO defnt - -#?(:clj (variadic-predicate-proxy - ^{:doc "Returns true if args are in monotonically non-increasing order - according to `compare`, otherwise false."} - comp>= comp>=-bin)) -#?(:clj (variadic-predicate-proxy comp>=& comp>=-bin&)) - -; ===== `min` ===== ; - -#?(:clj (defnt' min-bin - ([] Double/NEGATIVE_INFINITY) ; the thing less than which there is nothing - ([#{byte char short int long float double} x] x) - ([#{byte char short int long float double} x - #{byte char short int long float double} y] (Numeric/min x y)) - ; TODO numbers, but not nil - ) - :cljs (defn min-bin ([x] x) ([x y] (if (< x y) x y)))) ; TODO defnt - -#?(:clj (variadic-proxy min min-bin)) -#?(:clj (variadic-proxy min& min-bin&)) - -; ----- `comp-min` ----- ; - -#?(:clj (defnt' comp-min-bin - ([] Double/NEGATIVE_INFINITY) ; the thing less than which there is nothing - ([^comparable? x] x) - ([#{byte char short int long float double} x - #{byte char short int long float double} y] (min x y)) - ([#{boolean Comparable} x #{boolean Comparable} y] (if (comp< x y) x y)) - ; TODO numbers and nil - ) - :cljs (defn comp-min-bin ([x] x) ([x y] (if (comp< x y) x y)))) ; TODO defnt - -#?(:clj (variadic-proxy - ^{:doc "Returns the least of the arguments according to - `compare`, preferring later values."} - comp-min comp-min-bin)) -#?(:clj (variadic-proxy comp-min& comp-min-bin&)) - -; ===== `max` ===== ; - -#?(:clj (defnt' max-bin - ([] Double/POSITIVE_INFINITY) ; the thing greater than which there is nothing - ([#{byte char short int long float double} x] x) - ([#{byte char short int long float double} x - #{byte char short int long float double} y] (Numeric/max x y)) - ; TODO numbers, but not nil - ) - :cljs (defn max-bin ([x] x) ([x y] (if (> x y) x y)))) ; TODO defnt - -#?(:clj (variadic-proxy max max-bin)) -#?(:clj (variadic-proxy max& max-bin&)) - -; ----- `comp-max` ----- ; - -#?(:clj (defnt' comp-max-bin - ([] Double/POSITIVE_INFINITY) ; the thing greater than which there is nothing - ([^comparable? x] x) - ([#{byte char short int long float double} x - #{byte char short int long float double} y] (max x y)) - ([#{boolean Comparable} x #{boolean Comparable} y] (if (comp> x y) x y)) - ; TODO numbers and nil - ) - :cljs (defn comp-max-bin ([x] x) ([x y] (if (comp> x y) x y)))) ; TODO defnt - -#?(:clj (variadic-proxy - ^{:doc "Returns the greatest of the arguments according to - `compare`, preferring later values."} - comp-max comp-max-bin)) - -; ===== extreme-`key` ===== ; - -#?(:clj -(defmacro gen-extremum-key-fn [sym base-sym] - `(defn ~sym - ([kf#] nil) ; TODO really, the min of whatever it is; maybe gen via `(kf)` ? - ([kf# x#] x#) - ([kf# x# y#] (if (~base-sym (kf# x#) (kf# y#)) x# y#)) ; TODO can terminate early here with e.g. <=, <, etc. - ([kf# x# y# & more#] - (reduce #(~sym kf# %1 %2) (~sym kf# x# y#) more#))))) - -(defn first-min-temp ([x] x) ([x y] (if (core/<= x y) x y))) -(defalias second-min-temp core/min) -(defalias min-temp second-min-temp) - -(defn first-max-temp ([x] x) ([x y] (if (core/>= x y) x y))) -(defalias second-max-temp core/max) -(defalias max-temp second-max-temp) - -(defn comp<-temp [x y] (core/< (core/compare x y) 0)) -(defn comp<=-temp [x y] (core/<= (core/compare x y) 0)) -(defn comp>-temp [x y] (core/> (core/compare x y) 0)) -(defn comp>=-temp [x y] (core/>= (core/compare x y) 0)) - -; TODO don't need to generate these once type inference is done -; `first-min-key` means `min-key`, but returns the first argument when comparison is ambiguous -(gen-extremum-key-fn first-min-key core/<=) ; TODO use comp/ version -(gen-extremum-key-fn second-min-key core/< ) ; TODO use comp/ version -(defalias min-key second-min-key) - -(gen-extremum-key-fn first-comp-min-key comp<=-temp) ; TODO use comp/ version -(gen-extremum-key-fn second-comp-min-key comp<-temp ) ; TODO use comp/ version -(defalias comp-min-key second-comp-min-key) - -(gen-extremum-key-fn first-max-key core/>=) ; TODO use comp/ version -(gen-extremum-key-fn second-max-key core/> ) ; TODO use comp/ version -(defalias max-key second-max-key) - -(gen-extremum-key-fn first-comp-max-key comp>=-temp) ; TODO use comp/ version -(gen-extremum-key-fn second-comp-max-key comp>-temp ) ; TODO use comp/ version -(defalias comp-max-key second-comp-max-key) + #?(:clj (.compareTo a b) + :cljs (core/-compare ^not-native a b))))) + +;; ----- `comp`-comparison ----- ;; + +(t/defn ^:inline comp< + "Returns true if args are in monotonically increasing order according to `compare`, + otherwise false." + > ut/boolean?) + +(t/defn ^:inline comp<= + "Returns true if args are in monotonically non-decreasing order according to `compare`, + otherwise false." + > ut/boolean?) + +(t/defn ^:inline comp= + "Returns true if args are equally ordered according to `compare`, otherwise false." + > ut/boolean?) + +(t/defn ^:inline comp>= + "Returns true if args are in monotonically non-increasing order according to `compare`, + otherwise false." + > ut/boolean?) + +(t/defn ^:inline comp> + "Returns true if args are in monotonically decreasing order according to `compare`, + otherwise false." + > ut/boolean?) + +;; ----- Extrema ----- ;; + +(t/defn ^:inline min + {:incorporated {'js/Math.min #inst "2018-10-17" + 'cljs.core/min #inst "2018-10-17"}}) + +(t/defn ^:inline max + {:incorporated {'js/Math.max #inst "2018-10-17" + 'cljs.core/max #inst "2018-10-17"}}) + +(t/defn ^:inline min-key) + +(t/defn ^:inline max-key) + +(t/defn comp-min + "Returns the least of the arguments according to `compare`, preferring later values.") + +(t/defn comp-max + "Returns the greatest of the arguments according to `compare`, preferring later values.") From be24b6cc81a37f32089f9f92504c813fe8d269cd Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 19 Oct 2018 00:28:52 -0600 Subject: [PATCH 535/810] primitive >min|max-safe-integer-value, `comp`s, min|max --- src/quantum/core/data/primitive.cljc | 197 +++++++++++++++++++-------- 1 file changed, 141 insertions(+), 56 deletions(-) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 396ba780..db37dba8 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -7,6 +7,8 @@ #?(:cljs goog.math.Long) [quantum.core.compare.core :as c?] [quantum.core.type :as t] + [quantum.untyped.core.logic + :refer [ifs]] [quantum.untyped.core.type :as ut] ;; TODO TYPED excise reference [quantum.untyped.core.vars :as var @@ -50,6 +52,11 @@ 'primitive' in some contexts." (t/or boolean? #?@(:clj [byte? short? char? int? long? float?]) double?)) + (def primitive-type? + (t/or (t/value boolean?) + #?@(:clj [(t/value byte?) (t/value short?) (t/value char?) (t/value int?) (t/value long?) + (t/value float?)]) (t/value double?))) + (var/def integer? "Specifically primitive integers." (t/or #?@(:clj [byte? short? int? long?]))) @@ -61,6 +68,8 @@ Something 'numeric' is something that may be treated as a number but may not actually *be* one." (t/- primitive? boolean?)) + (def numeric-type? (t/- primitive-type? (t/value boolean?))) + (defaliases ut true? false?) ;; ===== Boxing/unboxing ===== ;; @@ -125,58 +134,81 @@ ;; ===== Extreme magnitudes and values ===== ;; (t/defn ^:inline >min-magnitude - #?(:clj ([x byte? > (t/type x)] (byte 0))) - #?(:clj ([x short? > (t/type x)] (short 0))) - #?(:clj ([x char? > (t/type x)] (char 0))) - #?(:clj ([x int? > (t/type x)] (int 0))) - #?(:clj ([x long? > (t/type x)] (long 0))) - #?(:clj ([x float? > (t/type x)] Float/MIN_VALUE)) - ([x double? > (t/type x)] #?(:clj Double/MIN_VALUE - :cljs js/Number.MIN_VALUE))) +#?(:clj ([x (t/or byte? (t/value byte?)) > byte?] (byte 0))) +#?(:clj ([x (t/or short? (t/value short?)) > short?] (short 0))) +#?(:clj ([x (t/or char? (t/value char?)) > char?] (char 0))) +#?(:clj ([x (t/or int? (t/value int?)) > int?] (int 0))) +#?(:clj ([x (t/or long? (t/value long?)) > long?] (long 0))) +#?(:clj ([x (t/or float? (t/value float?)) > float?] Float/MIN_VALUE)) + ([x (t/or double? (t/value double?)) > double?] + #?(:clj Double/MIN_VALUE :cljs js/Number.MIN_VALUE))) ;; TODO TYPED these are probably getting boxed #?(:clj (var/def- min-float (Numeric/negate Float/MAX_VALUE))) (var/def- min-double (- #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) (t/defn ^:inline >min-value - #?(:clj ([x byte? > (t/type x)] Byte/MIN_VALUE)) - #?(:clj ([x short? > (t/type x)] Short/MIN_VALUE)) - #?(:clj ([x char? > (t/type x)] Character/MIN_VALUE)) - #?(:clj ([x int? > (t/type x)] Integer/MIN_VALUE)) - #?(:clj ([x long? > (t/type x)] Long/MIN_VALUE)) - #?(:clj ([x float? > (t/type x)] min-float)) - ([x double? > (t/type x)] min-double)) +#?(:clj ([x (t/or byte? (t/value byte?)) > byte?] Byte/MIN_VALUE)) +#?(:clj ([x (t/or short? (t/value short?)) > short?] Short/MIN_VALUE)) +#?(:clj ([x (t/or char? (t/value char?)) > char?] Character/MIN_VALUE)) +#?(:clj ([x (t/or int? (t/value int?)) > int?] Integer/MIN_VALUE)) +#?(:clj ([x (t/or long? (t/value long?)) > long?] Long/MIN_VALUE)) +#?(:clj ([x (t/or float? (t/value float?)) > float?] min-float)) + ([x (t/or double? (t/value double?)) > double?] min-double)) (t/defn ^:inline >max-value - #?@(:clj [([x byte? > (t/type x)] Byte/MAX_VALUE) - ([x short? > (t/type x)] Short/MAX_VALUE) - ([x char? > (t/type x)] Character/MAX_VALUE) - ([x int? > (t/type x)] Integer/MAX_VALUE) - ([x long? > (t/type x)] Long/MAX_VALUE) - ([x float? > (t/type x)] Float/MAX_VALUE)]) - ([x double? > (t/type x)] #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) +#?@(:clj [([x (t/or byte? (t/value byte?)) > byte?] Byte/MAX_VALUE) + ([x (t/or short? (t/value short?)) > short?] Short/MAX_VALUE) + ([x (t/or char? (t/value char?)) > char?] Character/MAX_VALUE) + ([x (t/or int? (t/value int?)) > int?] Integer/MAX_VALUE) + ([x (t/or long? (t/value long?)) > long?] Long/MAX_VALUE) + ([x (t/or float? (t/value float?)) > float?] Float/MAX_VALUE)]) + ([x (t/or double? (t/value double?)) > double?] + #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) + +(t/defn ^:inline >min-safe-integer-value +#?@(:clj [([x (t/or byte? (t/value byte?)) > byte?] (>min-value x)) + ([x (t/or short? (t/value short?)) > short?] (>min-value x)) + ([x (t/or char? (t/value char?)) > char?] (>min-value x)) + ([x (t/or int? (t/value int?)) > int?] (>min-value x)) + ([x (t/or long? (t/value long?)) > long?] (>min-value x)) + ;; [2 ^ ( + 1)] - 1 + ([x (t/or float? (t/value float?)) > float?] (float -16777216.0))]) + ([x (t/or double? (t/value double?)) > double?] -9007199254740991.0)) + +(t/defn ^:inline >max-safe-integer-value +#?@(:clj [([x (t/or byte? (t/value byte?)) > byte?] (>max-value x)) + ([x (t/or short? (t/value short?)) > short?] (>max-value x)) + ([x (t/or char? (t/value char?)) > char?] (>max-value x)) + ([x (t/or int? (t/value int?)) > int?] (>max-value x)) + ([x (t/or long? (t/value long?)) > long?] (>max-value x)) + ;; [2 ^ ( + 1)] - 1 + ([x (t/or float? (t/value float?)) > float?] (float 16777216.0))]) + ([x (t/or double? (t/value double?)) > double?] 9007199254740991.0)) ;; ===== Primitive type properties ===== ;; (t/defn ^:inline signed? - ([x (t/or char? (t/value Character))] false) -#?@(:clj [([x (t/or byte? (t/value Byte) - short? (t/value Short) - int? (t/value Integer) - long? (t/value Long) - float? (t/value Float) - double? #?(:clj Double :cljs js/Number))] true)])) + ([x (t/or char? (t/value Character) (t/value char?))] false) +#?@(:clj [([x (t/or byte? (t/value Byte) (t/value byte?) + short? (t/value Short) (t/value short?) + int? (t/value Integer) (t/value int?) + long? (t/value Long) (t/value long?) + float? (t/value Float) (t/value float?) + double? #?(:clj Double :cljs js/Number) (t/value double?))] true)])) ;; TODO TYPED `t/numerically-integer?` (t/defn ^:inline >bit-size ; > t/numerically-integer? - ([x (t/or boolean? (t/value #?(:clj Boolean :cljs js/Boolean)))] boolean-bits) -#?@(:clj [([x (t/or byte? (t/value Byte))] byte-bits) - ([x (t/or short? (t/value Short))] short-bits) - ([x (t/or char? (t/value Character))] char-bits) - ([x (t/or int? (t/value Integer))] int-bits) - ([x (t/or long? (t/value Long))] long-bits) - ([x (t/or float? (t/value Float))] float-bits)]) - ([x (t/or double? #?(:clj Double :cljs js/Number))] double-bits)) + ([x (t/or boolean? (t/value #?(:clj Boolean :cljs js/Boolean)) (t/value boolean?))] + boolean-bits) +#?@(:clj [([x (t/or byte? (t/value Byte) (t/value byte?))] byte-bits) + ([x (t/or short? (t/value Short) (t/value short?))] short-bits) + ([x (t/or char? (t/value Character) (t/value char?))] char-bits) + ([x (t/or int? (t/value Integer) (t/value int?))] int-bits) + ([x (t/or long? (t/value Long) (t/value long?))] long-bits) + ([x (t/or float? (t/value Float) (t/value float?))] float-bits)]) + ([x (t/or double? #?(:clj Double :cljs js/Number) (t/value double?))] + double-bits)) ;; ===== Conversion ===== ;; ;; Note that numeric-primitive conversions do not go here (but may be found in @@ -234,9 +266,7 @@ #?(:clj ( [a (t/- numeric? double?) , b double?] (Numeric/lt a b))) #?(:clj ( [a (t/- numeric? double? long?), b (t/- numeric? double? long?)] (Numeric/lt a b))) #?(:cljs ( [a numeric? , b numeric?] (cljs.core/< a b))) - ;; TODO rest of numbers, but not nil - ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) - ) +) (t/extend-defn! c?/<= #?(:clj (^:in [a long? , b long?] (Numbers/lte a b))) @@ -247,9 +277,7 @@ #?(:clj ( [a (t/- numeric? double?) , b double?] (Numeric/lte a b))) #?(:clj ( [a (t/- numeric? double? long?), b (t/- numeric? double? long?)] (Numeric/lte a b))) #?(:cljs ( [a numeric? , b numeric?] (cljs.core/<= a b))) - ;; TODO rest of numbers, but not nil - ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) - ) +) (t/extend-defn! c?/> #?(:clj (^:in [a long? , b long?] (Numbers/gt a b))) @@ -260,9 +288,7 @@ #?(:clj ( [a (t/- numeric? double?) , b double?] (Numeric/gt a b))) #?(:clj ( [a (t/- numeric? double? long?), b (t/- numeric? double? long?)] (Numeric/gt a b))) #?(:cljs ( [a numeric? , b numeric?] (cljs.core/> a b))) - ;; TODO rest of numbers, but not nil - ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) - ) +) (t/extend-defn! c?/>= #?(:clj (^:in [a long? , b long?] (Numbers/gte a b))) @@ -273,15 +299,74 @@ #?(:clj ( [a (t/- numeric? double?) , b double?] (Numeric/gte a b))) #?(:clj ( [a (t/- numeric? double? long?), b (t/- numeric? double? long?)] (Numeric/gte a b))) #?(:cljs ( [a numeric? , b numeric?] (cljs.core/>= a b))) - ;; TODO rest of numbers, but not nil - ;; CLJ just does `>long` for both args and performs comparison that way (which is kind of unsafe) - ) +) (t/extend-defn! c?/compare - ([a false? , b false?] 0) - ([a false? , b true?] -1) - ([a true? , b false?] 1) - ([a true? , b true?] 0) - ([a numeric? , b numeric?] (ifs (c?/< a b) -1 (c?/> a b) 1 0)) -#?(:clj ([a (t/ref c?/icomparable?), b primitive?] (.compareTo a b))) -#?(:clj ([a primitive? , b (t/ref c?/icomparable?)] (.compareTo (box a) b)))) + ([a false? , b false?] 0) + ([a false? , b true?] -1) + ([a true? , b false?] 1) + ([a true? , b true?] 0) + ([a numeric? , b numeric?] (ifs (c?/< a b) -1 (c?/> a b) 1 0)) +#?(:clj ([a (t/ref c?/icomparable?), b primitive?] (.compareTo a b))) +#?(:clj ([a primitive? , b (t/ref c?/icomparable?)] (.compareTo (box a) b)))) + +(t/extend-defn! c?/comp< + ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] + (c?/< (c?/compare a b) 0))) + +(t/extend-defn! c?/comp<= + ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] + (c?/<= (c?/compare a b) 0))) + +(t/extend-defn! c?/comp= + ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] + (c?/= (c?/compare a b) 0))) + +(t/extend-defn! c?/comp>= + ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] + (c?/>= (c?/compare a b) 0))) + +(t/extend-defn! c?/comp> + ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] + (c?/> (c?/compare a b) 0))) + +(t/defn promote-type [a nil?, b nil?]) + +(t/defn narrowest + > t/type? + ([t0 (t/and (t/input-type >min-safe-integer-value :?) + (t/input-type >max-safe-integer-value :?)) + t1 (t/and (t/input-type >min-safe-integer-value :?) + (t/input-type >max-safe-integer-value :?))] + (let [t0-min (>min-safe-integer-value t0) + t1-min (>min-safe-integer-value t1) + t0-max (>max-safe-integer-value t0) + t1-max (>max-safe-integer-value t1)] + (ifs (c?/= t0-min t1-min) + (ifs (c?/= t0-max t1-max) t0 + (c?/< t0-max t1-max) t1 + t0) + (c?/< t0-min t1-min) + (ifs (c?/< t0-max t1-max) (promote-type t0 t1) + (c?/= t0-max t1-max) t0 + t0) + (ifs (c?/> t0-max t1-max) (promote-type t0 t1) + (c?/= t0-max t1-max) t1 + t1))))) + +(t/extend-defn! c?/min +#?(:clj ( [a (t/- numeric? int?), b numeric?] (Numeric/min a b))) +#?(:clj ( [a numeric? , b (t/- numeric? int?)] (Numeric/min a b))) +#?(:clj (^:in [a int? , b int?] (Math/min a b))) +#?(:cljs ( [a double? , b double? > (t/assume double?)] (js/Math.min a b)))) + +(t/extend-defn! c?/max +#?(:clj ( [a (t/- integer? int?), b integer? > (t/narrowest (t/type a) (t/type b))] + (if (c?/> a b) a b))) +#?(:clj ( [a integer? , b (t/- integer? int?)] + (if (c?/> a b) a b))) +#?(:clj (^:in [a int? , b int?] (Math/max a b))) +#?(:clj ( [a float? , b float?] (Math/max a b))) +#?(:clj ( [a float? , b float?] (Math/max a b))) +#?(:clj ( [a double? , b double?] (Math/max a b))) +#?(:cljs ( [a double? , b double? > (t/assume double?)] (js/Math.max a b)))) From 21e6a71f574e91c95396be71e20ae9b786bb7cb0 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 19 Oct 2018 00:29:10 -0600 Subject: [PATCH 536/810] Add `input-type`; pencil in `output-type` --- src-untyped/quantum/untyped/core/type.cljc | 70 +++++++++++++++++++--- src/quantum/core/type.cljc | 6 +- test/quantum/test/untyped/core/type.cljc | 17 +++++- 3 files changed, 80 insertions(+), 13 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 636868f4..9c6997c2 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -45,7 +45,7 @@ [quantum.untyped.core.numeric :as unum] [quantum.untyped.core.print :as upr] [quantum.untyped.core.reducers :as ur - :refer [educe join]] + :refer [educe join reducei]] [quantum.untyped.core.refs :refer [?deref]] [quantum.untyped.core.spec :as us] @@ -224,6 +224,14 @@ ;; ------------------ +(defns- -|or [t0 utr/type?, t1 utr/type?] + (let [args (->> t0 utr/or-type>args (uc/remove (fn1 = t1)))] + (case (count args) + 0 empty-set + 1 (first args) + (OrType. uhash/default uhash/default nil args + (atom nil))))) + (defns - "Computes the difference of `t0` from `t1`: (& t0 (! t1)) If `t0` = `t1`, `∅` @@ -248,12 +256,8 @@ ValueType (AndType. uhash/default uhash/default nil [t0 (not t1)] (atom nil)))) OrType (condp == c1 - ClassType (let [args (->> t0 utr/or-type>args (uc/remove (fn1 = t1)))] - (case (count args) - 0 empty-set - 1 (first args) - (OrType. uhash/default uhash/default nil args - (atom nil)))))))))) + ClassType (-|or t0 t1) + ValueType (-|or t0 t1))))))) ([t0 utr/type?, t1 utr/type? & ts _ > utr/type?] (reduce - (- t0 t1) ts))) ;; TODO clean up @@ -274,7 +278,8 @@ (if-let [t (get reg name-sym)] (if (c/= (.-name ^ClassType t) name-sym) reg - (err! "Class already registered with type; must first undef" {:class x :type-name name-sym})) + (err! "Class already registered with type; must first undef" + {:class x :type-name name-sym})) (let [t (ClassType. uhash/default uhash/default nil x name-sym)] (uc/assoc-in reg [name-sym] t [:by-class x] t))))))] @@ -496,6 +501,53 @@ (defns compare|out [x0 utr/fn-type?, x1 utr/fn-type? > uset/comparison?] (utcomp/compare (fn-type>output-type x0) (fn-type>output-type x1))) +(defns input-type + "Outputs the type of a specified input to a typed fn. + + Usage in typed contexts: + - `(t/input-type >namespace :?)` + - Outputs the union of the possible types of the first input to `>namespace`. + - `(t/input-type reduce :_ :_ :?)` + - Outputs the union of the possible types of the third input to `reduce`. + - `(t/input-type reduce :? :_ string?)` + - Outputs the union of the possible types of the first input to `reduce` when the third input + satisfies `string?`. + + Usage outside of typed contexts is the same except the first input must be a `utr/fn-type?`." + [t utr/fn-type? & args (us/seq-of (us/or* #{:_ :?} type?)) + | (->> args (filter #(c/= % :?)) count (c/= 1)) + > type?] + (let [type-data-for-arity (-> t utr/fn-type>arities (get (count args))) + i|? (->> args (reducei (c/fn [_ t i] (when (c/= t :?) (reduced i))) nil))] + (->> args + (uc/map-indexed+ vector) + (uc/remove (fn-> second #{:_ :?})) + (educe + (c/fn ([] (->> type-data-for-arity (uc/lmap :input-types))) + ([input-types-seq] input-types-seq) + ([input-types-seq [i|arg arg-type]] + (c/or (->> input-types-seq + (uc/lfilter (c/fn [input-types] + (utcomp/<= arg-type (get input-types i|arg)))) + seq) + (reduced nil))))) + (uc/lmap (c/fn [input-types] (get input-types i|?))) + (apply or)))) + +(defns output-type + "Outputs the output type of a typed fn. + + Usage in typed contexts: + - `(t/output-type >namespace)` + - Outputs the union of the possible output types of `>namespace` given any valid inputs at all + - `(t/output-type reduce :_ :_ string?)` + - Outputs the union of the possible output types of `reduce` when the third input satisfies + `string?`. + + Usage outside of typed contexts is the same except the first input must be a `utr/fn-type?`." + [t utr/fn-type? > type?] + (TODO)) + ;; ===== Dependent types ===== ;; (defns type @@ -723,7 +775,7 @@ ;; Used by `quantum.untyped.core.analyze` (def fn? #?(:clj (isa? clojure.lang.Fn) - :cljs (or (isa? js/Function) ( cljs.core/Fn)))) + :cljs (or (isa? js/Function) (isa? cljs.core/Fn)))) ;; Used by `quantum.untyped.core.analyze` via `t/callable?` (uvar/def ifn? diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index d5206bbe..87d0f079 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -15,12 +15,12 @@ (defaliases udefnt fn defn extend-defn!) (defaliases ut - type + type type? ;; Generators ? *, isa? isa?|direct ; fn ; TODO TYPED rename - ftype - value, unvalue + ftype input-type output-type + value unvalue ;; Combinators and or - if not ;; Metadata suppliers diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 5bf9fd60..8aa0d1ef 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -1,6 +1,6 @@ (ns quantum.test.untyped.core.type (:refer-clojure :exclude - [boolean? char? double? float? int? ratio? string?]) + [boolean? char? double? float? fn? ifn? int? ratio? string? symbol?]) (:require [clojure.core :as core] [quantum.untyped.core.data.map :as umap] @@ -41,6 +41,11 @@ #?(:clj (def char-seq? (t/isa? CharSequence))) (def string? (t/isa? #?(:clj String :cljs js/String))) + (def symbol? t/symbol?) + + (def fn? t/fn?) + (def ifn? t/ifn?) + #?(:clj (def comparable? (t/isa? Comparable))) #?(:clj (def java-set? (t/isa? java.util.Set))) @@ -518,3 +523,13 @@ (is= (hash (t/value 1)) (hash (t/value 1))) (is= 1 (count (hash-set (t/value 1) (t/value 1)))))) + +(deftest test|input-type + (let [>namespace|type (t/ftype string? [string?] [symbol?]) + reduce|type (t/ftype t/any? [fn? t/any? string?] [ifn? t/any? java-set?])] + (is= (t/or string? symbol?) + (t/input-type >namespace|type :?)) + (is= (t/or string? java-set?) + (t/input-type reduce|type :_ :_ :?))) + (is= fn? + (t/input-type reduce|type :? :_ string?))) From c73191932cd93df27c235026fb96fb93987ba92c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 19 Oct 2018 00:49:34 -0600 Subject: [PATCH 537/810] Add `t/output-type` --- src-untyped/quantum/untyped/core/type.cljc | 41 +++++++++++++--------- test/quantum/test/untyped/core/type.cljc | 21 ++++++----- 2 files changed, 37 insertions(+), 25 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 9c6997c2..870e6c5f 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -501,6 +501,21 @@ (defns compare|out [x0 utr/fn-type?, x1 utr/fn-type? > uset/comparison?] (utcomp/compare (fn-type>output-type x0) (fn-type>output-type x1))) +(defn- match-spec>type-data-seq [t args] + (let [type-data-seq (-> t utr/fn-type>arities (get (count args)))] + (->> args + (uc/map-indexed+ vector) + (uc/remove (fn-> second #{:_ :?})) + (educe + (c/fn ([] type-data-seq) + ([type-data-seq'] type-data-seq') + ([type-data-seq' [i|arg arg-type]] + (c/or (->> type-data-seq' + (uc/lfilter (c/fn [{:keys [input-types]}] + (utcomp/<= arg-type (get input-types i|arg)))) + seq) + (reduced nil)))))))) + (defns input-type "Outputs the type of a specified input to a typed fn. @@ -517,21 +532,9 @@ [t utr/fn-type? & args (us/seq-of (us/or* #{:_ :?} type?)) | (->> args (filter #(c/= % :?)) count (c/= 1)) > type?] - (let [type-data-for-arity (-> t utr/fn-type>arities (get (count args))) - i|? (->> args (reducei (c/fn [_ t i] (when (c/= t :?) (reduced i))) nil))] - (->> args - (uc/map-indexed+ vector) - (uc/remove (fn-> second #{:_ :?})) - (educe - (c/fn ([] (->> type-data-for-arity (uc/lmap :input-types))) - ([input-types-seq] input-types-seq) - ([input-types-seq [i|arg arg-type]] - (c/or (->> input-types-seq - (uc/lfilter (c/fn [input-types] - (utcomp/<= arg-type (get input-types i|arg)))) - seq) - (reduced nil))))) - (uc/lmap (c/fn [input-types] (get input-types i|?))) + (let [i|? (->> args (reducei (c/fn [_ t i] (when (c/= t :?) (reduced i))) nil))] + (->> (match-spec>type-data-seq t args) + (uc/lmap (c/fn [{:keys [input-types]}] (get input-types i|?))) (apply or)))) (defns output-type @@ -545,8 +548,12 @@ `string?`. Usage outside of typed contexts is the same except the first input must be a `utr/fn-type?`." - [t utr/fn-type? > type?] - (TODO)) + ([t utr/fn-type?] + (->> t utr/fn-type>arities (uc/mapcat+ val) (uc/map :output-type) (apply or))) + ([t utr/fn-type? & args (us/seq-of (us/or* #{:_} type?)) > type?] + (->> (match-spec>type-data-seq t args) + (uc/lmap :output-type) + (apply or)))) ;; ===== Dependent types ===== ;; diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 8aa0d1ef..5724a833 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -524,12 +524,17 @@ (is= 1 (count (hash-set (t/value 1) (t/value 1)))))) +(def >namespace|type (t/ftype string? [string?] [symbol?])) + +(def reduce|type (t/ftype t/any? [fn? t/any? string? :> char-seq?] + [ifn? t/any? java-set? :> comparable?])) + (deftest test|input-type - (let [>namespace|type (t/ftype string? [string?] [symbol?]) - reduce|type (t/ftype t/any? [fn? t/any? string?] [ifn? t/any? java-set?])] - (is= (t/or string? symbol?) - (t/input-type >namespace|type :?)) - (is= (t/or string? java-set?) - (t/input-type reduce|type :_ :_ :?))) - (is= fn? - (t/input-type reduce|type :? :_ string?))) + (is= (t/or string? symbol?) (t/input-type >namespace|type :?)) + (is= (t/or string? java-set?) (t/input-type reduce|type :_ :_ :?))) + (is= fn? (t/input-type reduce|type :? :_ string?)) + +(deftest test|output-type + (is= string? (t/output-type >namespace|type)) + (is= (t/or char-seq? comparable?) (t/output-type reduce|type)) + (is= char-seq? (t/output-type reduce|type :_ :_ string?))) From 70a8182edca4c4f59fd76d0d44f720f03eb54630 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 19 Oct 2018 15:55:05 -0600 Subject: [PATCH 538/810] Begin to have input/output-type dep type work; fix type hint in field AST --- src-untyped/quantum/untyped/core/analyze.cljc | 46 ++++++++++++------- .../quantum/untyped/core/analyze/ast.cljc | 1 + src-untyped/quantum/untyped/core/type.cljc | 34 ++++++++------ .../quantum/test/untyped/core/type/defnt.cljc | 28 ++++++++++- 4 files changed, 77 insertions(+), 32 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index dad6263d..07159fac 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -418,11 +418,12 @@ [env ::env, form _, target _, field-form simple-symbol?, field (t/isa? Field) > uast/field-access?] (uast/field-access - {:env env - :form form - :target target - :field field-form - :type (-> field :class (maybe-with-assume-val form))})) + {:env env + :unanalyzed-form form + :form (:form target) + :target target + :field field-form + :type (-> field :class (maybe-with-assume-val form))})) (defns classes>class "Ensure that given a set of classes, that set consists of at most a class C and nil. @@ -665,20 +666,26 @@ :dispatchable-overloads-seq)) (defns- analyze-seq|dependent-type-call - [env ::env, [caller|form _, arg-form _ & extra-args-form _ :as form] _ > uast/node?] - (if (not (empty? extra-args-form)) + [env ::env, [caller|form _, & args-form _ :as form] _ > uast/node?] + (if (and (-> caller|form name (= "type")) + (-> args-form count (not= 1))) (err! "Incorrect number of args passed to dependent type call" - {:form form :args-ct (-> extra-args-form count inc)}) - (let [arg-node (analyze* env arg-form) - caller|node (analyze* env caller|form)] + {:form form :args-ct (count args-form)}) + (let [arg-nodes (->> args-form (mapv #(analyze* env %))) + caller|node (analyze* env caller|form) + t (case (name caller|form) + "type" (-> arg-nodes first :type) + "input-type" (apply t/input-type (-> arg-nodes first :type) + (->> arg-nodes rest (map :type) (map t/unvalue))) + "output-type" (apply t/output-type (-> arg-nodes first :type) + (->> arg-nodes rest (map :type) (map t/unvalue))))] (uast/call-node {:env env - ;; We replace the `form` with the form of the arg type :unanalyzed-form form - :form (-> arg-node :type uform/>form) + :form (uform/>form t) :caller caller|node - :args [arg-node] - :type (t/value (:type arg-node))})))) + :args arg-nodes + :type (t/value t)})))) (defns- apply-arg-type-combine [combinef fn?, input-nodes _ > t/value-type?] (->> input-nodes @@ -792,7 +799,11 @@ (when-let [sym (some-> (uvar/resolve *ns* caller|form) uid/>symbol)] (case sym (quantum.core.type/type - quantum.untyped.core.type/type) true + quantum.untyped.core.type/type + quantum.core.type/input-type + quantum.untyped.core.type/input-type + quantum.core.type/output-type + quantum.untyped.core.type/output-type) true false)))] (analyze-seq|dependent-type-call env form) (analyze-seq|call env form)) @@ -926,7 +937,8 @@ ;; TODO excise (defn pr! [x] (binding [quantum.untyped.core.analyze.ast/*print-env?* false - quantum.untyped.core.print/*collapse-symbols?* true] + quantum.untyped.core.print/*collapse-symbols?* true + *print-meta* true] (quantum.untyped.core.print/ppr x))) #?(:clj @@ -953,7 +965,7 @@ (defns type>split+primitivized [t t/type? > (s/vec-of t/type?)] (let [primitive-subtypes (->> t - t/type>primitive-subtypes + (t/type>primitive-subtypes false) (sort-by sort-guide) ; For cleanliness and reproducibility in tests vec)] (uc/distinct (join primitive-subtypes (type>split t))))) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index ae8557ac..2bfe7e1a 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -264,6 +264,7 @@ (defrecord FieldAccess [env #_::env + unanalyzed-form #_::t/form form #_::t/form target #_::node field #_unqualified-symbol? diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 870e6c5f..320a69ab 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -519,7 +519,7 @@ (defns input-type "Outputs the type of a specified input to a typed fn. - Usage in typed contexts: + Usage in arglist contexts: - `(t/input-type >namespace :?)` - Outputs the union of the possible types of the first input to `>namespace`. - `(t/input-type reduce :_ :_ :?)` @@ -528,7 +528,7 @@ - Outputs the union of the possible types of the first input to `reduce` when the third input satisfies `string?`. - Usage outside of typed contexts is the same except the first input must be a `utr/fn-type?`." + Usage outside of arglist contexts is the same except the first input must be a `utr/fn-type?`." [t utr/fn-type? & args (us/seq-of (us/or* #{:_ :?} type?)) | (->> args (filter #(c/= % :?)) count (c/= 1)) > type?] @@ -540,14 +540,14 @@ (defns output-type "Outputs the output type of a typed fn. - Usage in typed contexts: + Usage in arglist contexts: - `(t/output-type >namespace)` - Outputs the union of the possible output types of `>namespace` given any valid inputs at all - `(t/output-type reduce :_ :_ string?)` - Outputs the union of the possible output types of `reduce` when the third input satisfies `string?`. - Usage outside of typed contexts is the same except the first input must be a `utr/fn-type?`." + Usage outside of arglist contexts is the same except the first input must be a `utr/fn-type?`." ([t utr/fn-type?] (->> t utr/fn-type>arities (uc/mapcat+ val) (uc/map :output-type) (apply or))) ([t utr/fn-type? & args (us/seq-of (us/or* #{:_} type?)) > type?] @@ -615,30 +615,35 @@ #?(:clj (def primitive-classes (->> unboxed-symbol->type-meta vals (uc/map+ :unboxed) (join #{})))) (defns- -type>classes - [t utr/type?, classes c/set? > (us/set-of (us/nilable #?(:clj c/class? :cljs c/fn?)))] + [t utr/type?, include-classes-of-value-type? c/boolean?, classes c/set? + > (us/set-of (us/nilable #?(:clj c/class? :cljs c/fn?)))] (cond (utr/class-type? t) (conj classes (utr/class-type>class t)) (utr/value-type? t) - (conj classes (-> t utr/value-type>value c/type)) + (cond-> classes + include-classes-of-value-type? (conj (-> t utr/value-type>value c/type))) (c/= t universal-set) #?(:clj #{nil java.lang.Object} :cljs (TODO "Not sure what to do in the case of universal CLJS set")) (c/= t empty-set) #{} (utr/and-type? t) - (reduce (c/fn [classes' t'] (-type>classes t' classes')) + (reduce (c/fn [classes' t'] (-type>classes t' include-classes-of-value-type? classes')) classes (utr/and-type>args t)) (utr/or-type? t) - (reduce (c/fn [classes' t'] (-type>classes t' classes')) + (reduce (c/fn [classes' t'] (-type>classes t' include-classes-of-value-type? classes')) classes (utr/or-type>args t)) (c/= val?) - (-type>classes val|by-class? classes) + (-type>classes val|by-class? include-classes-of-value-type? classes) :else (err! "Not sure how to handle type" t))) (defns type>classes "Outputs the set of all the classes ->`t` can embody, possibly including nil." - [t utr/type? > (us/set-of (us/nilable #?(:clj c/class? :cljs c/fn?)))] (-type>classes t #{})) + ([t utr/type? > (us/set-of (us/nilable #?(:clj c/class? :cljs c/fn?)))] (type>classes t true)) + ([t utr/type?, include-classes-of-value-type? c/boolean? + > (us/set-of (us/nilable #?(:clj c/class? :cljs c/fn?)))] + (-type>classes t include-classes-of-value-type? #{}))) ;; TODO move #?(:clj @@ -666,14 +671,17 @@ (->> cs (uc/map+ class>most-primitive-class) (ur/join #{})))))) #?(:clj -(defns type>primitive-subtypes [t type? > (us/set-of type?)] +(defns type>primitive-subtypes + ([t type? > (us/set-of type?)] (type>primitive-subtypes t true)) + ([t type?, include-subtypes-of-value-type? c/boolean? > (us/set-of type?)] (if (-> t c/meta :quantum.core.type/ref?) #{} - (->> t type>classes + (->> t + (type>classes include-subtypes-of-value-type?) (uc/mapcat+ class>boxed-subclasses+) uc/distinct+ (uc/map+ isa?) - (ur/join #{}))))) + (ur/join #{})))))) #?(:clj (defns- -type>?class-value [t utr/type?, type-nilable? c/boolean?] diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index da5fa568..d0cd117c 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1443,7 +1443,31 @@ nil))) (deftest dependent-type-test - (testing "Combination/integration test" + (testing "t/type" + (let [actual + (macroexpand ' + (self/defn type-test + #_"1. Analyze `a` = `(t/type (>long-checked \"23\"))` + 1. Analyze `(>long-checked \"23\")` + -> `(t/value 23)` + -> Put `out` in env as `(t/value 23)`" + [out (t/type (>long-checked "23"))] + (self/fn type-test-inner + ([a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) + c (t/or tt/short? tt/char?) + d (let [b (t/- tt/char? tt/long?)] + (t/or tt/char? (t/type b) (t/type c))) + > (t/or (t/type b) (t/type d))] b)))) + expected + (case (env-lang) + :clj + ($ (do ...)))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '(do ...))))) + (testing "t/input-type" (let [actual (macroexpand ' (self/defn dependent-type-combo @@ -1458,7 +1482,7 @@ c (t/or tt/short? tt/char?) d (let [b (t/- tt/char? tt/long?)] (t/or tt/char? (t/type b) (t/type c))) - > (t/or (t/type b) (t/type d))] b))) + > (t/or (t/type b) (t/type d))] b)))) expected (case (env-lang) :clj From fb3da9b1b5ce53cafb9095fa8b1338d1b15cbed5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 19 Oct 2018 15:56:32 -0600 Subject: [PATCH 539/810] Fix NPE --- src-untyped/quantum/untyped/core/analyze.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 07159fac..3cba934b 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -813,7 +813,7 @@ (let [expanded-form (ufeval/macroexpand form)] (if-let [no-expansion? (ucomp/== form expanded-form)] (analyze-seq* env expanded-form) - (let [expanded-form' (-> expanded-form (update-meta merge (meta form))) + (let [expanded-form' (some-> expanded-form (update-meta merge (meta form))) expanded (analyze* env expanded-form')] (uast/macro-call {:env env From ffd87e7e08db5178de712e810cfe6a39570edd46 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 19 Oct 2018 18:23:48 -0600 Subject: [PATCH 540/810] `t/input-type` works :D --- src-untyped/quantum/untyped/core/analyze.cljc | 3 +-- src-untyped/quantum/untyped/core/type.cljc | 8 ++++---- src-untyped/quantum/untyped/core/type/defnt.cljc | 2 +- test/quantum/test/untyped/core/type/defnt.cljc | 15 ++------------- 4 files changed, 8 insertions(+), 20 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 3cba934b..e2d3143c 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -964,8 +964,7 @@ (defns type>split+primitivized [t t/type? > (s/vec-of t/type?)] (let [primitive-subtypes - (->> t - (t/type>primitive-subtypes false) + (->> (t/type>primitive-subtypes t false) (sort-by sort-guide) ; For cleanliness and reproducibility in tests vec)] (uc/distinct (join primitive-subtypes (type>split t))))) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 320a69ab..a828fcb2 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -529,12 +529,13 @@ satisfies `string?`. Usage outside of arglist contexts is the same except the first input must be a `utr/fn-type?`." - [t utr/fn-type? & args (us/seq-of (us/or* #{:_ :?} type?)) + [t utr/fn-type? & args _ #_(us/seq-of (us/or* #{:_ :?} type?)) | (->> args (filter #(c/= % :?)) count (c/= 1)) > type?] (let [i|? (->> args (reducei (c/fn [_ t i] (when (c/= t :?) (reduced i))) nil))] (->> (match-spec>type-data-seq t args) - (uc/lmap (c/fn [{:keys [input-types]}] (get input-types i|?))) + (uc/lmap (c/fn [{:keys [input-types]}] + (get input-types i|?))) (apply or)))) (defns output-type @@ -676,8 +677,7 @@ ([t type?, include-subtypes-of-value-type? c/boolean? > (us/set-of type?)] (if (-> t c/meta :quantum.core.type/ref?) #{} - (->> t - (type>classes include-subtypes-of-value-type?) + (->> (type>classes t include-subtypes-of-value-type?) (uc/mapcat+ class>boxed-subclasses+) uc/distinct+ (uc/map+ isa?) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index a6ce2596..976608bb 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -747,7 +747,7 @@ ~dynamic-dispatch] (remove nil?))] (case kind - :fn (TODO) + :fn (TODO "Haven't done t/fn yet") (:defn :extend-defn!) `(do ~@fn-codelist)))))) #?(:clj diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index d0cd117c..22179701 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1470,19 +1470,8 @@ (testing "t/input-type" (let [actual (macroexpand ' - (self/defn dependent-type-combo - #_"1. Analyze `a` = `(t/type (>long-checked \"23\"))` - 1. Analyze `(>long-checked \"23\")` - -> `(t/value 23)` - -> Put `out` in env as `(t/value 23)`" - [out (t/type (>long-checked "23"))] - (self/fn dependent-type-combo-inner - ([a (t/or tt/boolean? (t/type b)) - b (t/or tt/byte? (t/type d)) - c (t/or tt/short? tt/char?) - d (let [b (t/- tt/char? tt/long?)] - (t/or tt/char? (t/type b) (t/type c))) - > (t/or (t/type b) (t/type d))] b)))) + (self/defn input-type-test + [a (t/input-type >long-checked (t/value "23"))])) expected (case (env-lang) :clj From 52d9b65d6f5a1cc5141aa80e79d9cb3b37409119 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 20 Oct 2018 08:27:23 -0600 Subject: [PATCH 541/810] Fix `t/output-type` --- resources-dev/defnt.cljc | 9 +++------ src-untyped/quantum/untyped/core/type.cljc | 2 +- test/quantum/test/untyped/core/type.cljc | 2 +- test/quantum/test/untyped/core/type/defnt.cljc | 2 +- 4 files changed, 6 insertions(+), 9 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index a3e47c45..19ef3333 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -61,11 +61,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: [1] - t/input-type - - This is pretty simple with the current dependent type system - - Then if those fns ever get extended then it should trigger a chain-reaction of recompilations + - If fns ever get extended then it should trigger a chain-reaction of recompilations [2] - t/output-type - - This is pretty simple with the current dependent type system - - Then if those fns ever get extended then it should trigger a chain-reaction of recompilations + - If fns ever get extended then it should trigger a chain-reaction of recompilations [3] - Direct dispatch needs to actually work correctly in `t/defn` [4] - t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. @@ -188,8 +186,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - (if (A) ...) should be (if ^boolean (A) ...) if A returns a `p/boolean?` - We'll should make a special class or *something* like that to ensure that typed bindings are only bound within typed contexts. - - `t/defn` declaration: `(t/defn >std-fixint > std-fixint?)` - - `t/defn` `|` (pre-types) - t/defrecord - t/def-concrete-type (i.e. `t/deftype`) - expressions (`quantum.untyped.core.analyze.expr`) @@ -206,6 +202,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative we annotate like `(name ^:dyn (read ...))`, meaning figure out at runtime what the out-type of the call to `(read ...)` is, not, call `name` dynamically. - `t/defn` + - `|` (pre-types) - Arity elision: if any type in an arity is `t/none?` then elide it and emit a warning - `([x bigint?] x)` - t/defn- diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index a828fcb2..b4bbf4be 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -551,7 +551,7 @@ Usage outside of arglist contexts is the same except the first input must be a `utr/fn-type?`." ([t utr/fn-type?] (->> t utr/fn-type>arities (uc/mapcat+ val) (uc/map :output-type) (apply or))) - ([t utr/fn-type? & args (us/seq-of (us/or* #{:_} type?)) > type?] + ([t utr/fn-type? args (us/seq-of (us/or* #{:_} type?)) > type?] (->> (match-spec>type-data-seq t args) (uc/lmap :output-type) (apply or)))) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 5724a833..6b20881b 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -537,4 +537,4 @@ (deftest test|output-type (is= string? (t/output-type >namespace|type)) (is= (t/or char-seq? comparable?) (t/output-type reduce|type)) - (is= char-seq? (t/output-type reduce|type :_ :_ string?))) + (is= char-seq? (t/output-type reduce|type [:_ :_ string?]))) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 22179701..3a7d6cba 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1471,7 +1471,7 @@ (let [actual (macroexpand ' (self/defn input-type-test - [a (t/input-type >long-checked (t/value "23"))])) + [> (t/output-type >long-checked [t/string?])] 1)) expected (case (env-lang) :clj From 7922cacdf751fdba992cdb5a27b900657dc82184 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 20 Oct 2018 13:58:08 -0600 Subject: [PATCH 542/810] `unsynchronized-mutable` / `mutable` difference unified --- .gitignore | 1 + .../untyped/core/form/generate/deftype.cljc | 80 +++++++++++++------ .../untyped/core/type/reifications.cljc | 36 ++++----- src/quantum/core/data/reactive.cljc | 1 + 4 files changed, 75 insertions(+), 43 deletions(-) create mode 100644 src/quantum/core/data/reactive.cljc diff --git a/.gitignore b/.gitignore index 70c8ea6d..791e9204 100644 --- a/.gitignore +++ b/.gitignore @@ -42,3 +42,4 @@ pom.xml.asc *.class *.extract-native-dependencies *.swp +*.swo diff --git a/src-untyped/quantum/untyped/core/form/generate/deftype.cljc b/src-untyped/quantum/untyped/core/form/generate/deftype.cljc index 3e2fc2f3..8af3e169 100644 --- a/src-untyped/quantum/untyped/core/form/generate/deftype.cljc +++ b/src-untyped/quantum/untyped/core/form/generate/deftype.cljc @@ -15,27 +15,48 @@ [quantum.untyped.core.identifiers :as uident] [quantum.untyped.core.string :as ustr])) -(defn ?Associative [lang] (case lang :clj 'clojure.lang.Associative :cljs 'cljs.core/IAssociative)) -(defn ?Collection [lang] (case lang :clj 'clojure.lang.IPersistentCollection :cljs 'cljs.core/ICollection )) -(defn ?Comparable [lang] (case lang :clj 'java.lang.Comparable :cljs 'cljs.core/IComparable )) -(defn ?Counted [lang] (case lang :clj 'clojure.lang.Counted :cljs 'cljs.core/ICounted )) -(defn ?Deref [lang] (case lang :clj 'clojure.lang.IDeref :cljs 'cljs.core/IDeref )) -(defn ?Fn [lang] (case lang :clj 'clojure.lang.IFn :cljs 'cljs.core/IFn )) -(defn ?Hash [lang] (case lang :clj 'clojure.lang.IHashEq :cljs 'cljs.core/IHash )) -(defn ?Indexed [lang] (case lang :clj 'clojure.lang.Indexed :cljs 'cljs.core/IIndexed )) -(defn ?Iterable [lang] (case lang :clj 'java.lang.Iterable :cljs 'cljs.core/IIterable )) -(defn ?Lookup [lang] (case lang :clj 'clojure.lang.ILookup :cljs 'cljs.core/ILookup )) -(defn ?Map [lang] (case lang :clj 'clojure.lang.IPersistentMap :cljs 'cljs.core/IMap )) -(defn ?MutableMap [lang] (case lang :clj 'java.util.Map nil)) -(defn ?Object [lang] (case lang :clj 'java.lang.Object :cljs 'Object )) -(defn ?Record [lang] (case lang :clj 'clojure.lang.IRecord :cljs 'cljs.core/IRecord )) -(defn ?Reset [lang] (case lang :clj 'clojure.lang.IAtom :cljs 'cljs.core/IReset )) -(defn ?Reversible [lang] (case lang :clj 'clojure.lang.Reversible :cljs 'cljs.core/IReversible )) -(defn ?Seq [lang] (case lang :clj 'clojure.lang.ISeq :cljs 'cljs.core/ISeq )) -(defn ?Seqable [lang] (case lang :clj 'clojure.lang.Seqable :cljs 'cljs.core/ISeqable )) -(defn ?Sequential [lang] (case lang :clj 'clojure.lang.Sequential :cljs 'cljs.core/ISequential )) -(defn ?Stack [lang] (case lang :clj 'clojure.lang.IPersistentStack :cljs 'cljs.core/IStack )) -(defn ?Swap [lang] (case lang :clj 'clojure.lang.IAtom :cljs 'cljs.core/ISwap )) +(defn ?Associative [lang] + (case lang :clj 'clojure.lang.Associative :cljs 'cljs.core/IAssociative)) +(defn ?Collection [lang] + (case lang :clj 'clojure.lang.IPersistentCollection :cljs 'cljs.core/ICollection )) +(defn ?Comparable [lang] + (case lang :clj 'java.lang.Comparable :cljs 'cljs.core/IComparable )) +(defn ?Counted [lang] + (case lang :clj 'clojure.lang.Counted :cljs 'cljs.core/ICounted )) +(defn ?Deref [lang] + (case lang :clj 'clojure.lang.IDeref :cljs 'cljs.core/IDeref )) +(defn ?Fn [lang] + (case lang :clj 'clojure.lang.IFn :cljs 'cljs.core/IFn )) +(defn ?Hash [lang] + (case lang :clj 'clojure.lang.IHashEq :cljs 'cljs.core/IHash )) +(defn ?Indexed [lang] + (case lang :clj 'clojure.lang.Indexed :cljs 'cljs.core/IIndexed )) +(defn ?Iterable [lang] + (case lang :clj 'java.lang.Iterable :cljs 'cljs.core/IIterable )) +(defn ?Lookup [lang] + (case lang :clj 'clojure.lang.ILookup :cljs 'cljs.core/ILookup )) +(defn ?Map [lang] + (case lang :clj 'clojure.lang.IPersistentMap :cljs 'cljs.core/IMap )) +(defn ?MutableMap [lang] + (case lang :clj 'java.util.Map nil)) +(defn ?Object [lang] + (case lang :clj 'java.lang.Object :cljs 'Object )) +(defn ?Record [lang] + (case lang :clj 'clojure.lang.IRecord :cljs 'cljs.core/IRecord )) +(defn ?Reset [lang] + (case lang :clj 'clojure.lang.IAtom :cljs 'cljs.core/IReset )) +(defn ?Reversible [lang] + (case lang :clj 'clojure.lang.Reversible :cljs 'cljs.core/IReversible )) +(defn ?Seq [lang] + (case lang :clj 'clojure.lang.ISeq :cljs 'cljs.core/ISeq )) +(defn ?Seqable [lang] + (case lang :clj 'clojure.lang.Seqable :cljs 'cljs.core/ISeqable )) +(defn ?Sequential [lang] + (case lang :clj 'clojure.lang.Sequential :cljs 'cljs.core/ISequential )) +(defn ?Stack [lang] + (case lang :clj 'clojure.lang.IPersistentStack :cljs 'cljs.core/IStack )) +(defn ?Swap [lang] + (case lang :clj 'clojure.lang.IAtom :cljs 'cljs.core/ISwap )) (defn- pfn "Protocol fn" @@ -323,15 +344,24 @@ (merge methods-spec {interface-sym (->> methods (map :quantum.core.form.generate.deftype/deftype|method) (reduce merge))})})))) +;; WARNING: actually evals interface code when requested ; TODO fix this #?(:clj -(defmethod ufgen/generate :quantum.core.form.generate.deftype/deftype ; WARNING: actually evals interface code when requested ; TODO fix this +(defmethod ufgen/generate :quantum.core.form.generate.deftype/deftype [_ {:keys [&env lang type-sym fields methods-spec]}] - (let [{:keys [preamble methods-spec]} - (apply-getters+setters lang type-sym fields methods-spec) + (let [fields' (->> fields + (mapv #(vary-meta % + (fn [m] (let [m' (dissoc m :! :mutable :unsynchronized-mutable)] + (if (contains? m :!) + (case lang + :clj (assoc m' :unsynchronized-mutable (:! m)) + :cljs (assoc m' :mutable (:! m))) + m')))))) + {:keys [preamble methods-spec]} + (apply-getters+setters lang type-sym fields' methods-spec) _ (eval preamble) deftype-code (apply (case lang :clj deftype|clj :cljs deftype|cljs) - &env type-sym fields + &env type-sym fields' (apply concat (deftype-helper methods-spec lang)))] ; in order to help `deftype` recognize that there is an interface, when there is one `(do ~deftype-code ~(when (= lang :clj) `(import (quote ~(uident/qualify|class type-sym)))))))) ; TODO doesn't this already happen? diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 3df7d7fe..35dd1528 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -88,8 +88,8 @@ ;; ----- NotType (`t/not` / `t/!`) ----- ;; (udt/deftype NotType - [#?(:clj ^int ^:unsynchronized-mutable hash :cljs ^number ^:mutable hash) - #?(:clj ^int ^:unsynchronized-mutable hash-code :cljs ^number ^:mutable hash-code) + [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) + #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_(t/? ::meta) t #_t/type?] {PType nil @@ -114,8 +114,8 @@ ;; ----- OrType (`t/or` / `t/|`) ----- ;; (udt/deftype OrType - [#?(:clj ^int ^:unsynchronized-mutable hash :cljs ^number ^:mutable hash) - #?(:clj ^int ^:unsynchronized-mutable hash-code :cljs ^number ^:mutable hash-code) + [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) + #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_(t/? ::meta) args #_(t/and t/indexed? (t/seq t/type?)) *logical-complement] @@ -146,8 +146,8 @@ ;; ----- AndType (`t/and` | `t/&`) ----- ;; (udt/deftype AndType - [#?(:clj ^int ^:unsynchronized-mutable hash :cljs ^number ^:mutable hash) - #?(:clj ^int ^:unsynchronized-mutable hash-code :cljs ^number ^:mutable hash-code) + [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) + #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_(t/? ::meta) args #_(t/and t/indexed? (t/seq t/type?)) *logical-complement] @@ -180,8 +180,8 @@ ;; ----- ProtocolType ----- ;; (udt/deftype ProtocolType - [#?(:clj ^int ^:unsynchronized-mutable hash :cljs ^number ^:mutable hash) - #?(:clj ^int ^:unsynchronized-mutable hash-code :cljs ^number ^:mutable hash-code) + [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) + #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_(t/? ::meta) p #_t/protocol? name #_(t/? symbol?)] @@ -213,8 +213,8 @@ ^{:doc "Differs from `ProtocolType` in that an `implements?` check is performed instead of a `satisfies?` check, i.e. native-type protocol dispatch is ignored."} DirectProtocolType - [^number ^:mutable hash - ^number ^:mutable hash-code + [^number ^:! hash + ^number ^:! hash-code meta #_(t/? ::meta) p #_t/protocol? name #_(t/? symbol?)] @@ -242,8 +242,8 @@ ;; ----- ClassType ----- ;; (udt/deftype ClassType - [#?(:clj ^int ^:unsynchronized-mutable hash :cljs ^number ^:mutable hash) - #?(:clj ^int ^:unsynchronized-mutable hash-code :cljs ^number ^:mutable hash-code) + [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) + #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_meta/meta? ^Class c #_t/class? name #_(t/? symbol?)] @@ -292,8 +292,8 @@ (= @!frequencies data))))) (udt/deftype UnorderedType - [#?(:clj ^int ^:unsynchronized-mutable hash :cljs ^number ^:mutable hash) - #?(:clj ^int ^:unsynchronized-mutable hash-code :cljs ^number ^:mutable hash-code) + [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) + #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_meta/meta? data #_(t/type (dc/map-of t/type? (t/and integer? (> 1))) "Val is frequency of type") name #_(t/? symbol?)] @@ -321,8 +321,8 @@ ;; ----- OrderedType ----- ;; (udt/deftype OrderedType - [#?(:clj ^int ^:unsynchronized-mutable hash :cljs ^number ^:mutable hash) - #?(:clj ^int ^:unsynchronized-mutable hash-code :cljs ^number ^:mutable hash-code) + [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) + #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_meta/meta? data #_dc/sequential? name #_(t/? symbol?)] @@ -356,8 +356,8 @@ ;; ----- ValueType ----- ;; (udt/deftype ValueType - [#?(:clj ^int ^:unsynchronized-mutable hash :cljs ^number ^:mutable hash) - #?(:clj ^int ^:unsynchronized-mutable hash-code :cljs ^number ^:mutable hash-code) + [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) + #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_(t/? ::meta) v #_any?] {PType nil diff --git a/src/quantum/core/data/reactive.cljc b/src/quantum/core/data/reactive.cljc new file mode 100644 index 00000000..63d6e8c0 --- /dev/null +++ b/src/quantum/core/data/reactive.cljc @@ -0,0 +1 @@ +(ns quantum.core.data.reactive) From cf9a2255bb60404203021b8c6d8d8651e5ef27d9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 21 Oct 2018 22:59:19 -0600 Subject: [PATCH 543/810] Make some updates to compatible `deftype` --- .../quantum/untyped/core/analyze/expr.cljc | 13 ++-- .../untyped/core/form/generate/deftype.cljc | 64 ++++++++++-------- .../untyped/core/type/reifications.cljc | 66 +++++++++---------- src/quantum/core/data/finger_tree.cljc | 31 +++++---- src/quantum/core/data/validated.cljc | 19 +++--- src/quantum/location/climate.cljc | 12 ++-- 6 files changed, 111 insertions(+), 94 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze/expr.cljc b/src-untyped/quantum/untyped/core/analyze/expr.cljc index 63412853..fe96e510 100644 --- a/src-untyped/quantum/untyped/core/analyze/expr.cljc +++ b/src-untyped/quantum/untyped/core/analyze/expr.cljc @@ -68,6 +68,12 @@ (#?(:clj eval :cljs (TODO "eval not supported")) form'))) update-form ([this f] (with-form this (f form))) >evaled ([this] evaled)} + ?Equals {= ([this that] + (or (== this that) + (and (instance? Expression that) + (let [^Expression that that] + (= evaled (.-evaled that)) + (= form (.-form that))))))} ;; `form`-like ?Associative {assoc ([this k v] (with-form this (assoc form k v))) dissoc ([this k] (with-form this (dissoc form k))) @@ -78,12 +84,7 @@ ([this k else] (with-form this (find form else))))} ?Collection {empty ([this] (with-form this (empty form))) conj ([this x] (with-form this (conj form x))) - empty? ([this] (empty? form)) - equals ([this that] (or (== this that) - (and (instance? Expression that) - (let [^Expression that that] - (= evaled (.-evaled that)) - (= form (.-form that))))))} + empty? ([this] (empty? form))} ?Counted {count ([this] (count form))} ?Indexed {nth ([this i] (with-form this (nth form i)))} ?Lookup {get (([this k] (with-form this (get form k))) diff --git a/src-untyped/quantum/untyped/core/form/generate/deftype.cljc b/src-untyped/quantum/untyped/core/form/generate/deftype.cljc index 8af3e169..fab5bac7 100644 --- a/src-untyped/quantum/untyped/core/form/generate/deftype.cljc +++ b/src-untyped/quantum/untyped/core/form/generate/deftype.cljc @@ -84,8 +84,7 @@ 'java.util.Map 'java.util.Collection)) -(defn- deftype-helper - [methods-spec lang] +(defn- deftype-helper [methods-spec lang] (for [[iname impls] methods-spec] (case iname ?Comparable @@ -105,21 +104,21 @@ :clj `[~(?Seq lang) ~@(p-arity 'first (get impls 'first)) - ~@(p-arity 'more (get impls 'rest )) - ~@(p-arity 'next (get impls 'next ))] + ~@(p-arity 'more (get impls 'rest)) + ~@(p-arity 'next (get impls 'next))] :cljs `[~(?Seq lang) ~@(p-arity '-first (get impls 'first)) - ~@(p-arity '-rest (get impls 'rest )) + ~@(p-arity '-rest (get impls 'rest)) cljs.core/INext - ~@(p-arity '-next (get impls 'next ))]) + ~@(p-arity '-next (get impls 'next))]) ?Stack `[~(?Stack lang) ~@(p-arity (pfn 'peek lang) (get impls 'peek)) - ~@(p-arity (pfn 'pop lang) (get impls 'pop ))] + ~@(p-arity (pfn 'pop lang) (get impls 'pop))] ?Reversible `[~(?Reversible lang) - ~@(p-arity (pfn 'rseq lang) (get impls 'rseq ))] + ~@(p-arity (pfn 'rseq lang) (get impls 'rseq))] ?Counted `[~(?Counted lang) ~@(p-arity (pfn 'count lang) (get impls 'count)) @@ -127,18 +126,23 @@ `[~(implement-map-or-collection methods-spec) ~@(p-arity 'size (get impls 'count))] nil)] - ?Object + ?Equals (case lang :clj `[~(?Object lang) - ~@(p-arity 'equals (get impls 'equals )) - ~@(p-arity 'hashCode (get impls 'hash-code))] + ~@(p-arity 'equals (get impls '=))] :cljs `[~(?Object lang) - ~@(p-arity 'equiv (get impls 'equals))]) + ~@(p-arity 'equiv (get impls '=)) + cljs.core/IEquiv + ~@(p-arity '-equiv (get impls '=))]) ?Hash `[~(?Hash lang) - ~@(p-arity (case lang :clj 'hasheq :cljs '-hash) (get impls 'hash))] + ~@(p-arity (case lang :clj 'hasheq :cljs '-hash) (get impls 'hash)) + ~@(case lang + :clj `[~(?Object lang) + ~@(p-arity 'hashCode (or (get impls 'hash-code) (get impls 'hash)))] + nil)] ?Meta (case lang :clj @@ -146,27 +150,25 @@ ~@(p-arity 'meta (get impls 'meta )) ~@(p-arity 'withMeta (get impls 'with-meta))] :cljs - `[cljs.core/IMeta + `[~@(when (get impls 'meta) ['cljs.core/IMeta]) ~@(p-arity '-meta (get impls 'meta )) - cljs.core/IWithMeta + ~@(when (get impls 'with-meta) ['cljs.core/IWithMeta]) ~@(p-arity '-with-meta (get impls 'with-meta))]) ?Collection (case lang :clj `[~(?Collection lang) - ~@(p-arity 'empty (get impls 'empty )) - ~@(p-arity 'equiv (get impls 'equals)) ; TBD - ~@(p-arity 'cons (get impls 'conj )) + ~@(p-arity 'empty (get impls 'empty)) + ~@(p-arity 'equiv (get-in impls ['?Equals '=])) ; TBD + ~@(p-arity 'cons (get impls 'conj)) ~(implement-map-or-collection methods-spec) ~@(p-arity 'isEmpty (get impls 'empty?)) ~@(p-arity 'clear (get impls 'empty!))] :cljs - `[cljs.core/IEmptyableCollection - ~@(p-arity '-empty (get impls 'empty )) - cljs.core/IEquiv - ~@(p-arity '-equiv (get impls 'equals)) ; TBD - ~(?Collection lang) - ~@(p-arity '-conj (get impls 'conj ))]) + `[~@(when (get impls 'empty) ['cljs.core/IEmptyableCollection]) + ~@(p-arity '-empty (get impls 'empty)) + ~@(when (get impls 'conj) [(?Collection lang)]) + ~@(p-arity '-conj (get impls 'conj))]) ?Lookup `[~(?Lookup lang) ~@(p-arity (case lang :clj 'valAt :cljs '-lookup) (get impls 'get)) @@ -210,13 +212,22 @@ ?Deref `[~(?Deref lang) ~@(p-arity (pfn 'deref lang) (get impls 'deref))] + ?Watchable + (case lang + :clj `[clojure.lang.IRef + ~@(p-arity 'addWatch (get impls 'add-watch!)) + ~@(p-arity 'removeWatch (get impls 'remove-watch!))] + :cljs `[cljs.core/IWatchable + ~@(p-arity (pfn 'add-watch lang) (get impls 'add-watch!)) + ~@(p-arity (pfn 'remove-watch lang) (get impls 'remove-watch!))]) ?Atom (case lang :clj `[clojure.lang.IAtom ~@(p-arity (pfn 'swap lang) (get impls 'swap!)) ~@(p-arity (pfn 'compareAndSet lang) (get impls 'compare-and-set!)) ~@(p-arity (pfn 'reset lang) (get impls 'reset!))] - :cljs `[cljs.core/IReset + :cljs `[cljs.core/IAtom + cljs.core/IReset ~@(p-arity (pfn 'reset! lang) (get impls 'reset!)) cljs.core/ISwap ~@(p-arity (pfn 'swap! lang) (get impls 'swap!))]) @@ -291,7 +302,8 @@ body)}) (defn- ?symbol->getter|setter - "Generates a getter or setter from a field symbol" + "Generates a getter or setter from a field symbol. + Useful for Clojure mutable `deftype` fields which are private." [qualified-interface-sym prefix field-sym] (when (-> field-sym meta (get prefix)) (let [type-sym (type-hint field-sym) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 35dd1528..0aaf70d9 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -55,9 +55,9 @@ ?Fn {invoke ([_ x] true)} ?Meta {meta ([this] meta) with-meta ([this meta'] (UniversalSetType. meta'))} - ?Hash {hash ([this] (hash UniversalSetType))} - ?Object {hash-code ([this] (uhash/code UniversalSetType)) - equals ([this that] (or (== this that) (instance? UniversalSetType that)))} + ?Hash {hash ([this] (hash UniversalSetType)) + hash-code ([this] (uhash/code UniversalSetType))} + ?Equals {= ([this that] (or (== this that) (instance? UniversalSetType that)))} uform/PGenForm {>form ([this] (-> 'quantum.untyped.core.type/any? (accounting-for-meta meta)))} fedn/IOverride nil @@ -75,9 +75,9 @@ ?Fn {invoke ([_ x] false)} ?Meta {meta ([this] meta) with-meta ([this meta'] (EmptySetType. meta'))} - ?Hash {hash ([this] (hash EmptySetType))} - ?Object {hash-code ([this] (uhash/code EmptySetType)) - equals ([this that] (or (== this that) (instance? EmptySetType that)))} + ?Hash {hash ([this] (hash EmptySetType)) + hash-code ([this] (uhash/code EmptySetType))} + ?Equals {= ([this that] (or (== this that) (instance? EmptySetType that)))} uform/PGenForm {>form ([this] (-> 'quantum.untyped.core.type/none? (accounting-for-meta meta)))} fedn/IOverride nil @@ -96,9 +96,9 @@ ?Fn {invoke ([_ x] (not (t x)))} ?Meta {meta ([this] meta) with-meta ([this meta'] (NotType. hash hash-code meta' t))} - ?Hash {hash ([this] (uhash/caching-set-ordered! hash NotType t))} - ?Object {hash-code ([this] (uhash/caching-set-code! hash-code NotType t)) - equals ([this that] + ?Hash {hash ([this] (uhash/caching-set-ordered! hash NotType t)) + hash-code ([this] (uhash/caching-set-code! hash-code NotType t))} + ?Equals {= ([this that] (or (== this that) (and (instance? NotType that) (= t (.-t ^NotType that)))))} @@ -128,9 +128,9 @@ args))} ?Meta {meta ([this] meta) with-meta ([this meta'] (OrType. hash hash-code meta' args *logical-complement))} - ?Hash {hash ([this] (uhash/caching-set-ordered! hash OrType args))} - ?Object {hash-code ([this] (uhash/caching-set-code! hash-code OrType args)) - equals ([this that] + ?Hash {hash ([this] (uhash/caching-set-ordered! hash OrType args)) + hash-code ([this] (uhash/caching-set-code! hash-code OrType args))} + ?Equals {= ([this that] (or (== this that) (and (instance? OrType that) (= args (.-args ^OrType that)))))} @@ -158,9 +158,9 @@ ?Meta {meta ([this] meta) with-meta ([this meta'] (AndType. hash hash-code meta' args *logical-complement))} - ?Hash {hash ([this] (uhash/caching-set-ordered! hash AndType args))} - ?Object {hash-code ([this] (uhash/caching-set-code! hash-code AndType args)) - equals ([this that] + ?Hash {hash ([this] (uhash/caching-set-ordered! hash AndType args)) + hash-code ([this] (uhash/caching-set-code! hash-code AndType args))} + ?Equals {= ([this that] (or (== this that) (and (instance? AndType that) (= args (.-args ^AndType that)))))} @@ -189,9 +189,9 @@ ?Fn {invoke ([_ x] (satisfies? p x))} ?Meta {meta ([this] meta) with-meta ([this meta'] (ProtocolType. hash hash-code meta' p name))} - ?Hash {hash ([this] (uhash/caching-set-ordered! hash ProtocolType p))} - ?Object {hash-code ([this] (uhash/caching-set-code! hash-code ProtocolType p)) - equals ([this that #_any?] + ?Hash {hash ([this] (uhash/caching-set-ordered! hash ProtocolType p)) + hash-code ([this] (uhash/caching-set-code! hash-code ProtocolType p))} + ?Equals {= ([this that #_any?] (or (== this that) (and (instance? ProtocolType that) (= p (.-p ^ProtocolType that)))))} @@ -222,9 +222,9 @@ ?Fn {invoke ([_ x] (implements? p x))} ?Meta {meta ([this] meta) with-meta ([this meta'] (ProtocolType. hash hash-code meta' p name))} - ?Hash {hash ([this] (uhash/caching-set-ordered! hash ProtocolType p))} - ?Object {hash-code ([this] (uhash/caching-set-code! hash-code ProtocolType p)) - equals ([this that #_any?] + ?Hash {hash ([this] (uhash/caching-set-ordered! hash ProtocolType p)) + hash-code ([this] (uhash/caching-set-code! hash-code ProtocolType p))} + ?Equals {= ([this that #_any?] (or (== this that) (and (instance? ProtocolType that) (= p (.-p ^ProtocolType that)))))} @@ -251,9 +251,9 @@ ?Fn {invoke ([_ x] (instance? c x))} ?Meta {meta ([this] meta) with-meta ([this meta'] (ClassType. hash hash-code meta' c name))} - ?Hash {hash ([this] (uhash/caching-set-ordered! hash ClassType c))} - ?Object {hash-code ([this] (uhash/caching-set-code! hash-code ClassType c)) - equals ([this that #_any?] + ?Hash {hash ([this] (uhash/caching-set-ordered! hash ClassType c)) + hash-code ([this] (uhash/caching-set-code! hash-code ClassType c))} + ?Equals {= ([this that #_any?] (or (== this that) (and (instance? ClassType that) (= c (.-c ^ClassType that)))))} @@ -301,9 +301,9 @@ ?Fn {invoke ([_ xs] (satisfies-unordered-type? xs data))} ?Meta {meta ([this] meta) with-meta ([this meta'] (UnorderedType. hash hash-code meta' data name))} - ?Hash {hash ([this] (uhash/caching-set-ordered! hash UnorderedType data))} - ?Object {hash-code ([this] (uhash/caching-set-code! hash-code UnorderedType data)) - equals ([this that #_any?] + ?Hash {hash ([this] (uhash/caching-set-ordered! hash UnorderedType data)) + hash-code ([this] (uhash/caching-set-code! hash-code UnorderedType data))} + ?Equals {= ([this that #_any?] (or (== this that) (and (instance? UnorderedType that) (= data (.-data ^UnorderedType that)))))} @@ -336,9 +336,9 @@ (fn [_ _] false))))} ?Meta {meta ([this] meta) with-meta ([this meta'] (OrderedType. hash hash-code meta' data name))} - ?Hash {hash ([this] (uhash/caching-set-ordered! hash OrderedType data))} - ?Object {hash-code ([this] (uhash/caching-set-code! hash-code OrderedType data)) - equals ([this that #_any?] + ?Hash {hash ([this] (uhash/caching-set-ordered! hash OrderedType data)) + hash-code ([this] (uhash/caching-set-code! hash-code OrderedType data))} + ?Equals {= ([this that #_any?] (or (== this that) (and (instance? OrderedType that) (= data (.-data ^OrderedType that)))))} @@ -364,9 +364,9 @@ ?Fn {invoke ([_ x] (= x v))} ?Meta {meta ([this] meta) with-meta ([this meta'] (ValueType. hash hash-code meta' v))} - ?Hash {hash ([this] (uhash/caching-set-ordered! hash ValueType v))} - ?Object {hash-code ([this] (uhash/caching-set-code! hash-code ValueType v)) - equals ([this that #_any?] + ?Hash {hash ([this] (uhash/caching-set-ordered! hash ValueType v)) + hash-code ([this] (uhash/caching-set-code! hash-code ValueType v))} + ?Equals {= ([this that #_any?] (or (== this that) (and (instance? ValueType that) (= v (.-v ^ValueType that)))))} diff --git a/src/quantum/core/data/finger_tree.cljc b/src/quantum/core/data/finger_tree.cljc index 095b9883..ef3ceecb 100644 --- a/src/quantum/core/data/finger_tree.cljc +++ b/src/quantum/core/data/finger_tree.cljc @@ -119,8 +119,10 @@ (v (+ (int 2) i))))))))))) (deftype/deftype EmptyTree [meter-obj] - {?Seqable - {seq ([_] nil)} + {?Equals + {= ([_ x] false)} ; TBD + ?Seqable + {seq ([_] nil)} ?Sequential true ?Seq {first ([_] nil ) @@ -133,7 +135,6 @@ {rseq ([_] nil )} ?Collection {empty ([this] this) - equiv ([_ x] false) ; TBD conj ([_ b] (newSingleTree meter-obj b))} ?Counted {count ([_ ] 0 )} ; not needed? @@ -164,7 +165,9 @@ (->> t getMeter idElem (split t p))) (deftype/deftype DelayedTree [tree-ref mval] - {?Seqable + {?Equals + {= ([_ x] false)} ; TBD + ?Seqable {seq ([this] this)} ?Sequential true ?Seq @@ -180,7 +183,6 @@ {count ([_])} ; not needed? ?Collection {empty ([_] (empty @tree-ref)) - equals ([_ x] false) ; TBD cons ([_ b] (conj @tree-ref b))} ConjL {conjl ([_ a] (conjl @tree-ref a))} @@ -219,7 +221,9 @@ (app3 t1 nil t2)) (deftype/deftype SingleTree [meter-obj x] - {?Seqable + {?Equals + {= ([_ x] false)} ; TBD + ?Seqable {seq ([this] this)} ?Sequential true ?Seq @@ -235,7 +239,6 @@ {count ([_])}; not needed? ?Collection {empty ([_] (EmptyTree. meter-obj)) ; not needed? - equals ([_ x] false) ; TBD conj ([_ b] (deep (digit meter-obj x) (EmptyTree. (finger-meter meter-obj)) (digit meter-obj b)))} @@ -266,7 +269,9 @@ (measured suf)))) (deftype/deftype DeepTree [meter-obj pre mid suf mval] - {?Seqable + {?Equals + {= ([_ x] false)} ; TBD + ?Seqable {seq ([this] this)} ?Sequential true ?Seq @@ -282,7 +287,6 @@ {count ([_])} ; not needed? ?Collection {empty ([_] (newEmptyTree meter-obj)) - equals ([_ x] false) ; TBD conj ([_ a] (if (< (count suf) 4) (deep pre mid (conj suf a)) @@ -341,11 +345,11 @@ (op (measured pre) (measured suf)))))))) (deftype/deftype CountedDoubleList [tree mdata] - {?Object - {equals ([_ x] (seq= tree x)) - hash-code ([this] (hashcode (map identity this)))} + {?Equals + {= ([_ x] (seq= tree x))} ?Hash - {hash ([this] (hash-ordered this))} + {hash ([this] (hash-ordered this)) + hash-code ([this] (hashcode (map identity this)))} ?Meta {meta ([_] mdata) with-meta ([_ mdata] (CountedDoubleList. tree mdata))} @@ -365,7 +369,6 @@ {count ([_] (measured tree))} ?Collection {empty ([_] (CountedDoubleList. (empty tree) mdata)) - equiv ([_ x] (seq= tree x)) ; TBD conj ([_ x] (CountedDoubleList. (conj tree x) mdata))} ?Associative {assoc ([this k v] diff --git a/src/quantum/core/data/validated.cljc b/src/quantum/core/data/validated.cljc index f95b5d90..69e460b2 100644 --- a/src/quantum/core/data/validated.cljc +++ b/src/quantum/core/data/validated.cljc @@ -258,11 +258,13 @@ schema (when db-mode? (spec->schema sym-0 spec)) code `(do (def ~conformer-sym ~conformer) (deftype/deftype ~(with-meta sym {:no-factory? true}) ~'[v] - {~'?Object - {~'hash-code ([_#] (.hashCode ~'v)) - ~'equals ~(std-equals sym other '=)} + {~'?Equals + {~'= ~(std-equals sym other '=)} ~'?Hash - {~'hash ([_#] (int (bit-xor ~type-hash (~(case-env :clj '.hashEq :cljs '-hash) ~'v))))} + {~'hash ([_#] (int (bit-xor ~type-hash + (~(case-env :clj '.hashEq + :cljs '-hash) ~'v)))) + ~'hash-code ([_#] (.hashCode ~'v))} ~'?Deref {~'deref ([_#] ~'v)} refs/IValue @@ -413,7 +415,6 @@ {~'empty ([_#] (~(case-env :clj '.empty :cljs '-empty) ~'v)) ~'empty! ([_#] (throw (UnsupportedOperationException.))) ~'empty? ([_#] (~(case-env :clj '.isEmpty :cljs nil ) ~'v)) - ~'equals ~(std-equals sym other (case-env :clj '.equiv :cljs '-equiv)) ~'conj ([_# [k0# v0#]] (let [~k-gen (or (get ~all-mod-keys-record k0#) (get ~un-ks-to-ks k0#) @@ -468,9 +469,8 @@ ~'find ([_# k#] #_(enforce-get ~empty-record ~sym ~spec-sym k#) (~(case-env :clj '.entryAt :cljs nil) ~'v k#))} - ~'?Object - {~'hash-code ([_#] (.hashCode ~'v)) - ~'equals ~(std-equals sym other (case-env :clj '.equiv :cljs '.equiv))} + ~'?Equals + {~'= ~(std-equals sym other (case-env :clj '.equiv :cljs '-equiv))} ~'?Iterable {~'iterator ([_#] (~(case-env :clj '.iterator :cljs '-iterator) ~'v))} ~'?Meta @@ -479,7 +479,8 @@ ~'?Print {~'pr ([_# w# opts#] (~'-pr-writer ~'v w# opts#))} ~'?Hash - {~'hash ([_#] (int (bit-xor ~type-hash (~(case-env :clj '.hashEq :cljs '-hash) ~'v))))} + {~'hash ([_#] (int (bit-xor ~type-hash (~(case-env :clj '.hashEq :cljs '-hash) ~'v)))) + ~'hash-code ([_#] (.hashCode ~'v))} refs/IValue {~'get ([_#] ~'v) ~'set ([_# v#] (if (instance? ~sym v#) v# (new ~sym (~create v#))))}}) diff --git a/src/quantum/location/climate.cljc b/src/quantum/location/climate.cljc index b29571db..3d985726 100644 --- a/src/quantum/location/climate.cljc +++ b/src/quantum/location/climate.cljc @@ -77,12 +77,12 @@ (.evaluate grid (org.geotools.geometry.DirectPosition2D. longitude latitude))) (deftype/deftype ClimateDataPoint ; 8 (ref) + 8 (header) + 6*4 (fields) -> 40 bytes - [^:get ^:set ^:unsynchronized-mutable ^float precipitation - ^:get ^:set ^:unsynchronized-mutable ^float solar-radiation - ^:get ^:set ^:unsynchronized-mutable ^float wind - ^:get ^:set ^:unsynchronized-mutable ^float min-temperature - ^:get ^:set ^:unsynchronized-mutable ^float avg-temperature - ^:get ^:set ^:unsynchronized-mutable ^float max-temperature]) + [^:get ^:set ^:! ^float precipitation + ^:get ^:set ^:! ^float solar-radiation + ^:get ^:set ^:! ^float wind + ^:get ^:set ^:! ^float min-temperature + ^:get ^:set ^:! ^float avg-temperature + ^:get ^:set ^:! ^float max-temperature]) (def ^GeoTiffReader reader ; If you load this first (after importing the class), it's fine, but if you load it after the namespaces, certain classes aren't found... strange! (GeoTiffReader. From 2f84249545b434afe83e528b9a8ff05a46e4956f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 21 Oct 2018 22:59:25 -0600 Subject: [PATCH 544/810] `at-next-tick` --- src-untyped/quantum/untyped/core/async.cljc | 16 ++++++++++++++++ src/quantum/core/async.cljc | 14 ++------------ 2 files changed, 18 insertions(+), 12 deletions(-) create mode 100644 src-untyped/quantum/untyped/core/async.cljc diff --git a/src-untyped/quantum/untyped/core/async.cljc b/src-untyped/quantum/untyped/core/async.cljc new file mode 100644 index 00000000..df83a49d --- /dev/null +++ b/src-untyped/quantum/untyped/core/async.cljc @@ -0,0 +1,16 @@ +(ns quantum.untyped.core.async + (:require + [quantum.untyped.core.system :as usys])) + +#?(:cljs +(def at-next-tick + (or (.-requestAnimationFrame usys/global) + (.-webkitRequestAnimationFrame usys/global) + (.-mozRequestAnimationFrame usys/global) + (.-msRequestAnimationFrame usys/global) + (.-oRequestAnimationFrame usys/global) + (let [t0 (.getTime (js/Date.))] + (fn [f] + (js/setTimeout + #(f (- (.getTime (js/Date.)) t0)) + 16.66666)))))) diff --git a/src/quantum/core/async.cljc b/src/quantum/core/async.cljc index 1c809e8e..cde93558 100644 --- a/src/quantum/core/async.cljc +++ b/src/quantum/core/async.cljc @@ -42,6 +42,7 @@ :refer [val?]] [quantum.core.vars :as var :refer [defalias defmalias]] + [quantum.untyped.core.async :as uasync] [quantum.untyped.core.form.evaluate :as ufeval :refer [case-env]] [quantum.untyped.core.string @@ -819,15 +820,4 @@ #?(:clj (defmacro if-timeout! [[v c timeout-ms] then else] `(handle-timeout! [~v ~c ~timeout-ms] if ~then ~else))) #?(:clj (defmacro when-timeout! [[v c timeout-ms] & body] `(handle-timeout! [~v ~c ~timeout-ms] when ~@body))) -#?(:cljs -(def request-animation-frame - (or (.-requestAnimationFrame sys/global) - (.-webkitRequestAnimationFrame sys/global) - (.-mozRequestAnimationFrame sys/global) - (.-msRequestAnimationFrame sys/global) - (.-oRequestAnimationFrame sys/global) - (let [t0 (.getTime (js/Date.))] - (fn [f] - (js/setTimeout - #(f (- (.getTime (js/Date.)) t0)) - 16.66666)))))) +(defalias uasync/at-next-tick) From 780072a051405d56f3185ad141bd8602dccda431 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 21 Oct 2018 22:59:37 -0600 Subject: [PATCH 545/810] Add advanced-compilation-safe `dot!` and `dot!` --- src-untyped/quantum/untyped/core/core.cljc | 49 ++++++++++++++++++++++ 1 file changed, 49 insertions(+) diff --git a/src-untyped/quantum/untyped/core/core.cljc b/src-untyped/quantum/untyped/core/core.cljc index c51c297d..fa4543b0 100644 --- a/src-untyped/quantum/untyped/core/core.cljc +++ b/src-untyped/quantum/untyped/core/core.cljc @@ -4,6 +4,7 @@ (:require [clojure.core :as core] #?(:clj [clojure.future :as fcore]) + [clojure.string :as str] [cuerdas.core :as str+] #?@(:clj [[environ.core :as env]])) #?(:cljs (:require-macros @@ -39,6 +40,54 @@ (defonce sentinel (>sentinel)) +(defn- js-call [f args] + (let [argstr (->> (repeat (count args) "~{}") + (str/join ","))] + (list* 'js* (str "~{}(" argstr ")") f args))) + +(defn- dot-args [object member] + (assert (symbol? member) + (str "Symbol expected, not " (pr-str member))) + (assert (not (re-find #"\." (name object))) + (str "Dot not allowed in " object)) + (let [n (name member) + field? (= (subs n 0 1) "-") + names (-> (str/replace n #"^-" "") + (str/split #"\."))] + [field? names])) + +#?(:clj +(defmacro dot + "Access member in a JavaScript object, in a Closure-safe way. + `member` is assumed to be a field if it is a keyword or if the name starts with '-', otherwise + the named function is called with the optional args. + 'member' may contain '.', to allow access in nested objects. + If 'object' is a symbol it is not allowed contain '.'. + `(dot o :foo)` is equivalent to `(.-foo o)`, except that it gives the same result under advanced + compilation. + `(dot o foo arg1 arg2)` is the same as `(.foo o arg1 arg2)`." + {:adapted-from 'reagent.interop/$!} + [object member & args] + (let [[field names] (dot-args object member)] + (if field + (do (assert (empty? args) (str "Passing args to field doesn't make sense: " member)) + `(cljs.core/aget ~object ~@names)) + (js-call (list* `cljs.core/aget object names) args))))) + +#?(:clj +(defmacro dot! + "Set field in a JavaScript object, in a Closure-safe way. + `field` should be a keyword or a symbol starting with '-'. + `field` may contain '.', to allow access in nested objects. + If `object` is a symbol it is not allowed contain '.'. + `(dot! o :foo 1)` is equivalent to `(set! (.-foo o) 1)`, except that it gives the same result + under advanced compilation." + {:adapted-from 'reagent.interop/dot!} + [object field value] + (let [[field names] (dot-args object field)] + (assert field (str "Field name must start with - in " field)) + `(cljs.core/aset ~object ~@names ~value)))) + ;; From `quantum.untyped.core.form.evaluate` — used below in `defalias` (defn cljs-env? From a7af726de7fac21af708836af1e69171c3be2cd5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 21 Oct 2018 22:59:44 -0600 Subject: [PATCH 546/810] `defonce-` --- src-untyped/quantum/untyped/core/vars.cljc | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src-untyped/quantum/untyped/core/vars.cljc b/src-untyped/quantum/untyped/core/vars.cljc index f53ca368..48a4492a 100644 --- a/src-untyped/quantum/untyped/core/vars.cljc +++ b/src-untyped/quantum/untyped/core/vars.cljc @@ -40,6 +40,13 @@ (let [[name [expr]] (ufgen/name-with-attrs name sigs)] `(core/defonce ~name ~expr)))) +#?(:clj +(defmacro defonce- + "`defonce-` : `defonce` :: `defn-` : `defn`" + [name & sigs] + (let [[name [expr]] (ufgen/name-with-attrs (vary-meta name assoc :private true) sigs)] + `(core/defonce ~name ~expr)))) + #?(:clj (defmacro def- "Like `def` but adds the ^:private metadatum to the bound var. From 37aad9442a5f13b92197b5657acb17bc2dc49bdc Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 21 Oct 2018 22:59:51 -0600 Subject: [PATCH 547/810] At least it compiles --- .../quantum/untyped/core/data/reactive.cljc | 428 ++++++++++++++++++ 1 file changed, 428 insertions(+) create mode 100644 src-untyped/quantum/untyped/core/data/reactive.cljc diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc new file mode 100644 index 00000000..b74728e5 --- /dev/null +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -0,0 +1,428 @@ +(ns quantum.untyped.core.data.reactive + "Adapted from `reagent.ratom` 2018-10-20." + (:refer-clojure :exclude + [run!]) + (:require + [clojure.set :as set] + [quantum.untyped.core.async :as uasync] + [quantum.untyped.core.core + :refer [dot dot!]] + [quantum.untyped.core.error :as uerr] + [quantum.untyped.core.form.generate.deftype :as udt] + [quantum.untyped.core.log :as ulog] + [quantum.untyped.core.logic + :refer [ifs]] + [quantum.untyped.core.vars + :refer [defonce-]]) +#?(:clj (:import [java.util ArrayList]))) + +;; TODO add subscriptions to this too; for now we will just use the Reagent ratom +;; TODO the update batching is very Reagent-specific; we need to abstract that for it to work in CLJS + +;; TODO move +;; ===== Array-list fns ===== ;; + +(defn- alist-get + #?(:clj [^ArrayList xs ^long i] + :cljs [ xs ^number i]) + (#?(:clj .get :cljs aget) xs i)) + +(defn- alist-set! + #?(:clj [^ArrayList xs ^long i v] + :cljs [ xs ^number i v]) + (#?(:clj .set :cljs aset) xs i v)) + +(defn- alist-conj! [#?(:clj ^ArrayList xs :cljs xs) v] + (doto xs (#?(:clj .add :cljs .push) v))) + +(defn- #?(:clj alist-count :cljs ^number alist-count) [#?(:clj ^ArrayList xs :cljs xs)] + (#?(:clj .size :cljs alength) xs)) + +(defn- #?(:clj alist-empty? :cljs ^boolean alist-empty?) [#?(:clj ^ArrayList xs :cljs xs)] + (== (#?(:clj .size :cljs alength) xs) 0)) + +(defn- alist-empty! [#?(:clj ^ArrayList xs :cljs xs)] + #?(:clj (.clear xs) :cljs (set! (.-length xs) 0)) + xs) + +(defn- #?(:clj alist== :cljs ^boolean alist==) + [#?(:clj ^ArrayList x :cljs x) #?(:clj ^ArrayList y :cljs y)] + (let [len (if (nil? x) 0 (long (alist-count x)))] + (and (== len (if (nil? y) 0 (long (alist-count y)))) + (loop [i 0] + (or (== i len) + (if (identical? (alist-get x i) (alist-get y i)) + (recur (inc i)) + false)))))) + +(defn- #?(:clj ^ArrayList alist :cljs alist) + ([] #?(:clj (ArrayList.) :cljs #js [])) + ([x] #?(:clj (doto (ArrayList.) (.add x)) :cljs #js [x]))) + +;; ===== Internal functions for reactivity ===== ;; + +(def ^:dynamic *ratom-context* nil) + +(defonce #?(:clj debug? :cljs ^boolean debug?) false) + +(defonce- *running (atom 0)) + +(defn #?(:clj reactive? :cljs ^boolean reactive?) [] (some? *ratom-context*)) + +(defn- check-watches [old new] + (when debug? (swap! *running + (- (count new) (count old)))) + new) + +(defprotocol PWatchable + (getWatches [this]) + (setWatches [this v]) + (getWatchesArr [this]) + (setWatchesArr [this v])) + +(defn- add-w! [^quantum.untyped.core.data.reactive.PWatchable this k f] + (let [w (.getWatches this)] + (.setWatches this (check-watches w (assoc w k f))) + (.setWatchesArr this nil))) + +(defn- remove-w! [^quantum.untyped.core.data.reactive.PWatchable this k] + (let [w (.getWatches this)] + (.setWatches this (check-watches w (dissoc w k))) + (.setWatchesArr this nil))) + +(defn- conj-kv! [#?(:clj ^ArrayList xs :cljs xs) k v] + (-> xs (alist-conj! k) (alist-conj! v))) + +(defn- notify-w! [^quantum.untyped.core.data.reactive.PWatchable this old new] + (let [w (.getWatchesArr this) + #?(:clj ^ArrayList a :cljs a) + (if (nil? w) + ;; Copy watches to array-list for speed + (->> (.getWatches this) + (reduce-kv conj-kv! alist) + (.setWatchesArr this)) + w)] + (let [len (long (alist-count a))] + (loop [i (int 0)] + (when (< i len) + (let [k (alist-get a i) + f (alist-get a (unchecked-inc-int i))] + (f k this old new)) + (recur (+ 2 i))))))) + +#?(:cljs +(defn- pr-atom! [a writer opts s] + (-write writer (str "#<" s " ")) + (pr-writer (binding [*ratom-context* nil] (-deref a)) writer opts) + (-write writer ">"))) + +;; ===== RAtom ===== ;; + +(defprotocol PReactiveAtom) + +(defprotocol PHasCaptured + (getCaptured [this]) + (setCaptured [this v])) + +(defn- notify-deref-watcher! + "Add `derefed` to the `captured` field of `*ratom-context*`. + + See also `in-context`" + [derefed] + (when-some [context *ratom-context*] + (let [^quantum.untyped.core.data.reactive.PHasCaptured r context] + (if-some [c (.getCaptured r)] + (alist-conj! c derefed) + (.setCaptured r (alist derefed)))))) + +(udt/deftype ReactiveAtom [^:! state meta validator ^:! watches ^:! watchesArr] + {;; IPrintWithWriter + ;; (-pr-writer [a w opts] (pr-atom a w opts "Atom:")) + PReactiveAtom {} + ?Equals {= ([this that] (identical? this that))} + ?Deref {deref ([this] + (notify-deref-watcher! this) + state)} + ?Atom {reset! ([a new-value] + (when-not (nil? validator) + (assert (validator new-value) "Validator rejected reference state")) + (let [old-value state] + (set! state new-value) + (when-not (nil? watches) + (notify-w! a old-value new-value)) + new-value)) + swap! (([a f] (#?(:clj .reset :cljs -reset!) a (f state))) + ([a f x] (#?(:clj .reset :cljs -reset!) a (f state x))) + ([a f x y] (#?(:clj .reset :cljs -reset!) a (f state x y))) + ([a f x y more] (#?(:clj .reset :cljs -reset!) a (apply f state x y more))))} + ?Watchable {add-watch! ([this k f] (add-w! this k f)) + remove-watch! ([this k] (remove-w! this k))} + PWatchable {getWatches ([this] watches) + setWatches ([this v] (set! watches v)) + setWatchesArr ([this v] (set! watchesArr v))} + ?Meta {meta ([_] meta) + with-meta ([_ meta'] (ReactiveAtom. state meta' validator watches watchesArr))} +#?@(:cljs [?Hash {hash ([_] (goog/getUid this))}])}) + +(defn ratom + "'R'eactive 'atom'. Like `core/atom`, except that it keeps track of derefs." + ([x] (ReactiveAtom. x nil nil nil nil)) + ([x & {:keys [meta validator]}] (ReactiveAtom. x meta validator nil nil))) + +;; ===== Reaction ===== ;; + +;; Similar to java.io.Closeable +;; TODO move +(defprotocol PDisposable + (dispose [this]) + (addOnDispose [this f])) + +(declare flush! peek-at run-reaction!) + +;; TODO +;; Fields of a Reaction +;; - captured +;; - ratomGeneration +(udt/deftype Reaction + [^:! auto-run + ^:! caught + ^:! captured + ^:! ^boolean dirty? + f + ^boolean no-cache? + ^:! on-dispose + ^:! on-dispose-arr + ^:! on-set + queue + ^:! state + ^:! watching + ^:! watches] + {;; IPrintWithWriter + ;; (-pr-writer [a w opts] (pr-atom a w opts (str "Reaction " (hash a) ":"))) + ?Equals {= ([this that] (identical? this that))} +#?@(:cljs [?Hash {hash ([this] (goog/getUid this))}]) + PReactiveAtom {} + ?Deref {deref ([this] + (when-some [e caught] (throw e)) + (let [non-reactive? (nil? *ratom-context*)] + (when non-reactive? (flush! queue)) + (if (and non-reactive? (nil? auto-run)) + (when dirty? + (let [old-state state] + (set! state (f)) + (when-not (or (nil? watches) (= old-state state)) + (notify-w! this old-state state)))) + (do (notify-deref-watcher! this) + (when dirty? (run-reaction! this false))))) + state)} + ?Watchable {add-watch! ([this k f] (add-w! this k f)) + remove-watch! ([this k] + (let [was-empty? (empty? watches)] + (remove-w! this k) + (when (and (not was-empty?) + (empty? watches) + (nil? auto-run)) + (.dispose this))))} + PWatchable {getWatches ([this] watches) + setWatches ([this v] (set! watches v))} + ?Atom + {reset! ([a newv] + (assert (fn? (.-on-set a)) "Reaction is read only; on-set is not allowed") + (let [oldv state] + (set! state newv) + ((.-on-set a) oldv newv) + (notify-w! a oldv newv) + newv)) + swap! (([a f] (#?(:clj .reset :cljs -reset!) a (f (peek-at a)))) + ([a f x] (#?(:clj .reset :cljs -reset!) a (f (peek-at a) x))) + ([a f x y] (#?(:clj .reset :cljs -reset!) a (f (peek-at a) x y))) + ([a f x y more] (#?(:clj .reset :cljs -reset!) a (apply f (peek-at a) x y more))))} + PDisposable + {dispose + ([this] + (let [s state, wg watching] + (set! watching nil) + (set! state nil) + (set! auto-run nil) + (set! dirty? #?(:clj (boolean true) :cljs true)) + (doseq [w (set wg)] (#?(:clj remove-watch :cljs -remove-watch) w this)) + (when (some? (.-on-dispose this)) ((.-on-dispose this) s)) + (when-some [a (.-on-dispose-arr this)] + (dotimes [i (long (alist-count a))] ((alist-get a i) this))))) + addOnDispose + ([this f] + ;; f is called with the reaction as argument when it is no longer active + (if-some [a (.-on-dispose-arr this)] + (alist-conj! a f) + (set! (.-on-dispose-arr this) (alist f))))}}) + +(defn- peek-at [^Reaction rx] (binding [*ratom-context* nil] (#?(:clj .deref :cljs -deref) rx))) + +(defn- deref-capture! + "Returns `(in-context f r)`. Calls `_update-watching` on r with any + `deref`ed atoms captured during `in-context`, if any differ from the + `watching` field of r. Clears the `dirty?` flag on r. + + Inside '_update-watching' along with adding the ratoms in 'r.watching' of reaction, + the reaction is also added to the list of watches on each ratoms f derefs." + [f ^Reaction rx] + (set! (.-captured rx) nil) + (let [res (in-context rx f) + c (.-captured rx)] + (set! (.-dirty? rx) false) + ;; Optimize common case where derefs occur in same order + (when-not (alist== c (.-watching rx)) (update-watching! rx c)) + res)) + +(defn- try-capture! [^Reaction rx f] + (uerr/catch-all + (do (set! (.-caught rx) nil) + (deref-capture! f rx)) + e + (do (set! (.-state rx) e) + (set! (.-caught rx) e) + (set! (.-dirty? rx) false)))) + +(defn- run-reaction! [^Reaction rx check?] + (let [old-state (.-state rx) + res (if check? + (try-capture! rx (.-f rx)) + (deref-capture! (.-f rx) rx))] + (when-not (.-no-cache? rx) + (set! (.-state rx) res) + ;; Use = to determine equality from reactions, since + ;; they are likely to produce new data structures. + (when-not (or (nil? (.-watches rx)) + (= old-state res)) + (notify-w! rx old-state res))) + res)) + +;; Gets flushed in a scheduled way by `flush!` +(defn- enqueue! [rx queue] + ;; It is at this point in CLJS that the rendering is scheduled like so: + ;; `(when (alist-empty? queue) (schedule! global-render-queue queue))` + (alist-conj! queue rx)) + +(defn- handle-reaction-change! [^Reaction rx sender oldv newv] + (when-not (or (identical? oldv newv) (.-dirty? rx)) + (let [auto-run (.-auto-run rx)] + (ifs (nil? auto-run) + (do (set! (.-dirty? rx) true) + (enqueue! rx (.-queue rx))) + (true? auto-run) + (run-reaction! rx false) + (auto-run rx))))) + +(defn- queued-run-reaction! [^Reaction rx] + (when (and (.-dirty? rx) (some? (.-watching rx))) + (run-reaction! rx true))) + +(defn- flush! [queue] + (loop [] + (let [q queue] + (when-not (alist-empty? queue) + (alist-empty! queue) + (dotimes [i (alist-count q)] (queued-run-reaction! (alist-get q i))) + (recur))))) + +(defn- update-watching! [^Reaction rx derefed] + (let [new (set (.-derefed rx)) ; TODO incrementally calculate `set` + old (set (.-watching rx))] + (set! (.-watching rx) derefed) + (doseq [w (set/difference new old)] + (#?(:clj add-watch :cljs -add-watch) w rx handle-reaction-change!)) + (doseq [w (set/difference old new)] + (#?(:clj remove-watch :cljs -remove-watch) w rx)))) + +(defn- in-context + "When f is executed, if (f) derefs any ratoms, they are then added to 'obj.captured'(*ratom-context*). + + See function notify-deref-watcher! to know how *ratom-context* is updated" + [obj f] (binding [*ratom-context* obj] (f))) + +(defn ^Reaction >reaction + ([f] (>reaction f nil)) + ([f {:keys [auto-run no-cache? on-set on-dispose queue]}] + (Reaction. auto-run nil nil true f (if (nil? no-cache?) false no-cache?) on-dispose nil + on-set queue nil nil nil))) + +#?(:clj (defmacro reaction [& body] `(>reaction (fn [] ~@body)))) + +#?(:clj +(defmacro run! + "Runs body immediately, and runs again whenever atoms deferenced in the body change. Body should side effect." + [& body] + `(let [co# (>reaction (fn [] ~@body) {:auto-run true})] + (deref co#) + co#))) + +;; ===== Track ===== ;; + +(udt/deftype TrackableFn [f ^:! rx-cache]) + +(declare cached-reaction) + +(udt/deftype Track [^TrackableFn trackable-fn, args, ^:! ^Reaction rx] + {;; IPrintWithWriter + ;; (-pr-writer [a w opts] (pr-atom a w opts "Track:")) + PReactiveAtom {} + ?Deref {deref ([this] + (if (nil? rx) + (cached-reaction #(apply (.-f trackable-fn) args) + trackable-fn args this nil) + (#?(:clj .deref :cljs -deref) rx)))}} + ?Equals {= ([_ other] + (and (instance? Track other) + (-> ^Track other .-trackable-fn .-f (= (.-f trackable-fn))) + (-> ^Track other .-args (= args))))} + ?Hash {hash ([_] (hash [f args]))}) + +(defn- cached-reaction [f trackable-fn k ^Track obj destroy-fn] + (let [m (.-rx-cache trackable-fn) + m (if (nil? m) {} m) + r (m k nil)] + (cond + (some? r) (#?(:clj .deref :cljs -deref) r) + (nil? *ratom-context*) (f) + :else (let [r (>reaction f + {:on-dispose + (fn [x] + (when debug? (swap! *running dec)) + (as-> (.-rx-cache trackable-fn) cache + (dissoc cache k) + (set! (.-rx-cache trackable-fn) cache)) + (when (some? obj) + (set! (.-rx obj) nil)) + (when (some? destroy-fn) + (destroy-fn x)))}) + v (#?(:clj .deref :cljs -deref) r)] + (set! (.-rx-cache trackable-fn) (assoc m k r)) + (when debug? (swap! *running inc)) + (when (some? obj) + (set! (.-rx obj) r)) + v)))) + +(defn ^Track >track [f args] (Track. (TrackableFn. f nil) args nil)) + +(defn >track! [f args] + (let [t (>track f args) + r (>reaction #(#?(:clj .deref :cljs -deref) t) {:auto-run true})] + @r + r)) + +;; TODO move +(defn ratom-perf [] + ;; (set! debug? false) ; yes but we need to think about CLJ + (dotimes [_ 10] + (let [a (ratom 0) + f (fn [] (quot (long @a) 10)) + q (alist) + mid (>reaction f {:queue q}) + res (>track! (fn [] (inc (long @mid))) [])] + @res + (time (dotimes [_ 100000] + (swap! a inc) + (flush! q))) + (dispose res)))) + +;; TODO move +(ratom-perf) From 04d24a1066727ac8e73a28d4af8910b0d98032b8 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 21 Oct 2018 23:46:40 -0600 Subject: [PATCH 548/810] Fix `flush!` --- .../quantum/untyped/core/data/reactive.cljc | 45 ++++++++++++------- 1 file changed, 30 insertions(+), 15 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index b74728e5..a3b6889b 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -1,5 +1,10 @@ (ns quantum.untyped.core.data.reactive - "Adapted from `reagent.ratom` 2018-10-20." + "Most of the content adapted from `reagent.ratom` 2018-10-20. + + Includes ReactiveAtom and Reaction; will include Subscription. + + Currently only safe for single-threaded use; needs a rethink to accommodate concurrent + modification/access and customizable queueing strategies." (:refer-clojure :exclude [run!]) (:require @@ -187,6 +192,7 @@ ^:! caught ^:! captured ^:! ^boolean dirty? + eq-f f ^boolean no-cache? ^:! on-dispose @@ -194,7 +200,7 @@ ^:! on-set queue ^:! state - ^:! watching + ^:! watching ; i.e. 'dependents' ^:! watches] {;; IPrintWithWriter ;; (-pr-writer [a w opts] (pr-atom a w opts (str "Reaction " (hash a) ":"))) @@ -209,7 +215,7 @@ (when dirty? (let [old-state state] (set! state (f)) - (when-not (or (nil? watches) (= old-state state)) + (when-not (or (nil? watches) (eq-f old-state state)) (notify-w! this old-state state)))) (do (notify-deref-watcher! this) (when dirty? (run-reaction! this false))))) @@ -297,6 +303,7 @@ res)) ;; Gets flushed in a scheduled way by `flush!` +;; TODO `enqueue!` needs to be a parameter of `Reaction` (defn- enqueue! [rx queue] ;; It is at this point in CLJS that the rendering is scheduled like so: ;; `(when (alist-empty? queue) (schedule! global-render-queue queue))` @@ -312,17 +319,25 @@ (run-reaction! rx false) (auto-run rx))))) -(defn- queued-run-reaction! [^Reaction rx] - (when (and (.-dirty? rx) (some? (.-watching rx))) - (run-reaction! rx true))) - +;; Called by: +;; - `(when non-reactive? (flush! queue))` in `Reactive`.deref +;; - when a scheduled flushing is performed (defn- flush! [queue] - (loop [] - (let [q queue] - (when-not (alist-empty? queue) + (loop [i 0] + (let [ct (-> queue alist-count long)] + ;; NOTE: We avoid `pop`-ing in order to reduce churn but in theory it presents a memory issue + ;; NOTE: In the Reagent version, every time a new "chunk" of the queue is worked on, that + ;; chunk is scheduled for re-render + ;; I.e. took care of all queue entries and reached a stable state + (if-let [reached-last-index? (>= i (unchecked-dec ct))] (alist-empty! queue) - (dotimes [i (alist-count q)] (queued-run-reaction! (alist-get q i))) - (recur))))) + (let [remaining-ct (unchecked-subtract ct i)] + (dotimes [i* remaining-ct] + (let [rx (alist-get queue (unchecked-add i i*))] + (when (and (.-dirty? rx) (some? (.-watching rx))) + (run-reaction! rx true)))) + ;; `recur`s because sometimes the queue gets added to in the process of running rx's + (recur (+ i remaining-ct))))))) (defn- update-watching! [^Reaction rx derefed] (let [new (set (.-derefed rx)) ; TODO incrementally calculate `set` @@ -341,9 +356,9 @@ (defn ^Reaction >reaction ([f] (>reaction f nil)) - ([f {:keys [auto-run no-cache? on-set on-dispose queue]}] - (Reaction. auto-run nil nil true f (if (nil? no-cache?) false no-cache?) on-dispose nil - on-set queue nil nil nil))) + ([f {:keys [auto-run eq-f no-cache? on-set on-dispose queue]}] + (Reaction. auto-run nil nil true (or eq-f =) f (if (nil? no-cache?) false no-cache?) on-dispose + nil on-set queue nil nil nil))) #?(:clj (defmacro reaction [& body] `(>reaction (fn [] ~@body)))) From bd277ac89e8d66512c38c87486a47a3882133f0a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 09:24:09 -0600 Subject: [PATCH 549/810] All current reactive functionality works and quickly! --- .../quantum/untyped/core/data/reactive.cljc | 140 ++++++++++-------- 1 file changed, 77 insertions(+), 63 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index a3b6889b..1aaabf67 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -72,6 +72,8 @@ (defonce- *running (atom 0)) +(defonce- global-queue (alist)) + (defn #?(:clj reactive? :cljs ^boolean reactive?) [] (some? *ratom-context*)) (defn- check-watches [old new] @@ -103,7 +105,7 @@ (if (nil? w) ;; Copy watches to array-list for speed (->> (.getWatches this) - (reduce-kv conj-kv! alist) + (reduce-kv conj-kv! (alist)) (.setWatchesArr this)) w)] (let [len (long (alist-count a))] @@ -163,6 +165,7 @@ remove-watch! ([this k] (remove-w! this k))} PWatchable {getWatches ([this] watches) setWatches ([this v] (set! watches v)) + getWatchesArr ([this] watchesArr) setWatchesArr ([this v] (set! watchesArr v))} ?Meta {meta ([_] meta) with-meta ([_ meta'] (ReactiveAtom. state meta' validator watches watchesArr))} @@ -188,20 +191,21 @@ ;; - captured ;; - ratomGeneration (udt/deftype Reaction - [^:! auto-run - ^:! caught - ^:! captured - ^:! ^boolean dirty? - eq-f - f - ^boolean no-cache? - ^:! on-dispose - ^:! on-dispose-arr - ^:! on-set - queue - ^:! state - ^:! watching ; i.e. 'dependents' - ^:! watches] + [^:! ^:get autoRun + ^:! ^:get ^:set caught + ^:! captured + ^:! ^boolean ^:get ^:set dirty + eq-f + f + ^boolean no-cache? + ^:! on-dispose + ^:! on-dispose-arr + ^:! on-set + queue + ^:! ^:get ^:set state + ^:! ^:get ^:set watching ; i.e. 'dependents' + ^:! watches + ^:! watchesArr] {;; IPrintWithWriter ;; (-pr-writer [a w opts] (pr-atom a w opts (str "Reaction " (hash a) ":"))) ?Equals {= ([this that] (identical? this that))} @@ -211,14 +215,14 @@ (when-some [e caught] (throw e)) (let [non-reactive? (nil? *ratom-context*)] (when non-reactive? (flush! queue)) - (if (and non-reactive? (nil? auto-run)) - (when dirty? + (if (and non-reactive? (nil? autoRun)) + (when dirty (let [old-state state] (set! state (f)) (when-not (or (nil? watches) (eq-f old-state state)) (notify-w! this old-state state)))) (do (notify-deref-watcher! this) - (when dirty? (run-reaction! this false))))) + (when dirty (run-reaction! this false))))) state)} ?Watchable {add-watch! ([this k f] (add-w! this k f)) remove-watch! ([this k] @@ -226,10 +230,12 @@ (remove-w! this k) (when (and (not was-empty?) (empty? watches) - (nil? auto-run)) + (nil? autoRun)) (.dispose this))))} - PWatchable {getWatches ([this] watches) - setWatches ([this v] (set! watches v))} + PWatchable {getWatches ([this] watches) + setWatches ([this v] (set! watches v)) + getWatchesArr ([this] watchesArr) + setWatchesArr ([this v] (set! watchesArr v))} ?Atom {reset! ([a newv] (assert (fn? (.-on-set a)) "Reaction is read only; on-set is not allowed") @@ -242,14 +248,17 @@ ([a f x] (#?(:clj .reset :cljs -reset!) a (f (peek-at a) x))) ([a f x y] (#?(:clj .reset :cljs -reset!) a (f (peek-at a) x y))) ([a f x y more] (#?(:clj .reset :cljs -reset!) a (apply f (peek-at a) x y more))))} + PHasCaptured + {getCaptured ([this] captured) + setCaptured ([this v] (set! captured v))} PDisposable {dispose ([this] (let [s state, wg watching] (set! watching nil) (set! state nil) - (set! auto-run nil) - (set! dirty? #?(:clj (boolean true) :cljs true)) + (set! autoRun nil) + (set! dirty #?(:clj (boolean true) :cljs true)) (doseq [w (set wg)] (#?(:clj remove-watch :cljs -remove-watch) w this)) (when (some? (.-on-dispose this)) ((.-on-dispose this) s)) (when-some [a (.-on-dispose-arr this)] @@ -266,38 +275,38 @@ (defn- deref-capture! "Returns `(in-context f r)`. Calls `_update-watching` on r with any `deref`ed atoms captured during `in-context`, if any differ from the - `watching` field of r. Clears the `dirty?` flag on r. + `watching` field of r. Clears the `dirty` flag on r. Inside '_update-watching' along with adding the ratoms in 'r.watching' of reaction, the reaction is also added to the list of watches on each ratoms f derefs." [f ^Reaction rx] - (set! (.-captured rx) nil) + (.setCaptured rx nil) (let [res (in-context rx f) - c (.-captured rx)] - (set! (.-dirty? rx) false) + c (.getCaptured rx)] + (.setDirty rx false) ;; Optimize common case where derefs occur in same order - (when-not (alist== c (.-watching rx)) (update-watching! rx c)) + (when-not (alist== c (.getWatching rx)) (update-watching! rx c)) res)) (defn- try-capture! [^Reaction rx f] (uerr/catch-all - (do (set! (.-caught rx) nil) + (do (.setCaught rx nil) (deref-capture! f rx)) e - (do (set! (.-state rx) e) - (set! (.-caught rx) e) - (set! (.-dirty? rx) false)))) + (do (.setState rx e) + (.setCaught rx e) + (.setDirty rx false)))) (defn- run-reaction! [^Reaction rx check?] - (let [old-state (.-state rx) + (let [old-state (.getState rx) res (if check? (try-capture! rx (.-f rx)) (deref-capture! (.-f rx) rx))] (when-not (.-no-cache? rx) - (set! (.-state rx) res) + (.setState rx res) ;; Use = to determine equality from reactions, since ;; they are likely to produce new data structures. - (when-not (or (nil? (.-watches rx)) + (when-not (or (nil? (.getWatches rx)) (= old-state res)) (notify-w! rx old-state res))) res)) @@ -310,10 +319,10 @@ (alist-conj! queue rx)) (defn- handle-reaction-change! [^Reaction rx sender oldv newv] - (when-not (or (identical? oldv newv) (.-dirty? rx)) - (let [auto-run (.-auto-run rx)] + (when-not (or (identical? oldv newv) (.getDirty rx)) + (let [auto-run (.getAutoRun rx)] (ifs (nil? auto-run) - (do (set! (.-dirty? rx) true) + (do (.setDirty rx true) (enqueue! rx (.-queue rx))) (true? auto-run) (run-reaction! rx false) @@ -333,16 +342,16 @@ (alist-empty! queue) (let [remaining-ct (unchecked-subtract ct i)] (dotimes [i* remaining-ct] - (let [rx (alist-get queue (unchecked-add i i*))] - (when (and (.-dirty? rx) (some? (.-watching rx))) + (let [^Reaction rx (alist-get queue (unchecked-add i i*))] + (when (and (.getDirty rx) (some? (.getWatching rx))) (run-reaction! rx true)))) ;; `recur`s because sometimes the queue gets added to in the process of running rx's (recur (+ i remaining-ct))))))) (defn- update-watching! [^Reaction rx derefed] - (let [new (set (.-derefed rx)) ; TODO incrementally calculate `set` - old (set (.-watching rx))] - (set! (.-watching rx) derefed) + (let [new (set derefed) ; TODO incrementally calculate `set` + old (set (.getWatching rx))] + (.setWatching rx derefed) (doseq [w (set/difference new old)] (#?(:clj add-watch :cljs -add-watch) w rx handle-reaction-change!)) (doseq [w (set/difference old new)] @@ -358,25 +367,26 @@ ([f] (>reaction f nil)) ([f {:keys [auto-run eq-f no-cache? on-set on-dispose queue]}] (Reaction. auto-run nil nil true (or eq-f =) f (if (nil? no-cache?) false no-cache?) on-dispose - nil on-set queue nil nil nil))) + nil on-set queue nil nil nil nil))) -#?(:clj (defmacro reaction [& body] `(>reaction (fn [] ~@body)))) +#?(:clj (defmacro reaction [& body] `(>reaction (fn [] ~@body) {:queue global-queue}))) #?(:clj (defmacro run! "Runs body immediately, and runs again whenever atoms deferenced in the body change. Body should side effect." [& body] - `(let [co# (>reaction (fn [] ~@body) {:auto-run true})] + `(let [co# (>reaction (fn [] ~@body) {:auto-run true :queue (alist)})] (deref co#) co#))) ;; ===== Track ===== ;; -(udt/deftype TrackableFn [f ^:! rx-cache]) +(udt/deftype TrackableFn [f ^:! ^:get ^:set rxCache]) (declare cached-reaction) -(udt/deftype Track [^TrackableFn trackable-fn, args, ^:! ^Reaction rx] +(udt/deftype Track + [^TrackableFn trackable-fn, args, ^:! ^quantum.untyped.core.data.reactive.Reaction ^:get ^:set rx] {;; IPrintWithWriter ;; (-pr-writer [a w opts] (pr-atom a w opts "Track:")) PReactiveAtom {} @@ -391,10 +401,10 @@ (-> ^Track other .-args (= args))))} ?Hash {hash ([_] (hash [f args]))}) -(defn- cached-reaction [f trackable-fn k ^Track obj destroy-fn] - (let [m (.-rx-cache trackable-fn) - m (if (nil? m) {} m) - r (m k nil)] +(defn- cached-reaction [f ^TrackableFn trackable-fn k ^Track t destroy-fn] + (let [ m (.getRxCache trackable-fn) + m (if (nil? m) {} m) + ^Reaction r (m k nil)] (cond (some? r) (#?(:clj .deref :cljs -deref) r) (nil? *ratom-context*) (f) @@ -402,25 +412,28 @@ {:on-dispose (fn [x] (when debug? (swap! *running dec)) - (as-> (.-rx-cache trackable-fn) cache + (as-> (.getRxCache trackable-fn) cache (dissoc cache k) - (set! (.-rx-cache trackable-fn) cache)) - (when (some? obj) - (set! (.-rx obj) nil)) + (.setRxCache trackable-fn cache)) + (when (some? t) + (.setRx t nil)) (when (some? destroy-fn) - (destroy-fn x)))}) + (destroy-fn x))) + ;; Inherits the queue + :queue (some-> t .getRx .-queue)}) v (#?(:clj .deref :cljs -deref) r)] - (set! (.-rx-cache trackable-fn) (assoc m k r)) + (.setRxCache trackable-fn (assoc m k r)) (when debug? (swap! *running inc)) - (when (some? obj) - (set! (.-rx obj) r)) + (when (some? t) + (.setRx t r)) v)))) (defn ^Track >track [f args] (Track. (TrackableFn. f nil) args nil)) -(defn >track! [f args] +(defn >track! [f args opts] (let [t (>track f args) - r (>reaction #(#?(:clj .deref :cljs -deref) t) {:auto-run true})] + r (>reaction #(#?(:clj .deref :cljs -deref) t) + {:auto-run true :queue (or (:queue opts) global-queue)})] @r r)) @@ -432,7 +445,7 @@ f (fn [] (quot (long @a) 10)) q (alist) mid (>reaction f {:queue q}) - res (>track! (fn [] (inc (long @mid))) [])] + res (>track! (fn [] (inc (long @mid))) [] {:queue q})] @res (time (dotimes [_ 100000] (swap! a inc) @@ -440,4 +453,5 @@ (dispose res)))) ;; TODO move +;; TODO maybe have the queue as a binding and default to `default-queue`? Bindings can be complicated/subtle but at least think about it. For now we can just pass the params in (ratom-perf) From 19920882fde1e7ea58411386c4bcf1bae74aa13e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 10:59:02 -0600 Subject: [PATCH 550/810] Fix boundary condition and add test --- .../quantum/untyped/core/data/reactive.cljc | 109 ++++++++---------- .../test/untyped/core/data/reactive.cljc | 41 +++++++ 2 files changed, 88 insertions(+), 62 deletions(-) create mode 100644 test/quantum/test/untyped/core/data/reactive.cljc diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index 1aaabf67..1daa43b1 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -60,7 +60,7 @@ (recur (inc i)) false)))))) -(defn- #?(:clj ^ArrayList alist :cljs alist) +(defn #?(:clj ^ArrayList alist :cljs alist) ([] #?(:clj (ArrayList.) :cljs #js [])) ([x] #?(:clj (doto (ArrayList.) (.add x)) :cljs #js [x]))) @@ -72,7 +72,7 @@ (defonce- *running (atom 0)) -(defonce- global-queue (alist)) +(defonce global-queue (alist)) (defn #?(:clj reactive? :cljs ^boolean reactive?) [] (some? *ratom-context*)) @@ -184,7 +184,7 @@ (dispose [this]) (addOnDispose [this f])) -(declare flush! peek-at run-reaction!) +(declare flush! peek-at run-reaction! update-watching!) ;; TODO ;; Fields of a Reaction @@ -195,7 +195,8 @@ ^:! ^:get ^:set caught ^:! captured ^:! ^boolean ^:get ^:set dirty - eq-f + enqueue-fn + eq-fn f ^boolean no-cache? ^:! on-dispose @@ -219,7 +220,7 @@ (when dirty (let [old-state state] (set! state (f)) - (when-not (or (nil? watches) (eq-f old-state state)) + (when-not (or (nil? watches) (eq-fn old-state state)) (notify-w! this old-state state)))) (do (notify-deref-watcher! this) (when dirty (run-reaction! this false))))) @@ -272,6 +273,13 @@ (defn- peek-at [^Reaction rx] (binding [*ratom-context* nil] (#?(:clj .deref :cljs -deref) rx))) +(defn- in-context + "When f is executed, if (f) derefs any ratoms, they are then added to + 'obj.captured'(*ratom-context*). + + See function notify-deref-watcher! to know how *ratom-context* is updated" + [obj f] (binding [*ratom-context* obj] (f))) + (defn- deref-capture! "Returns `(in-context f r)`. Calls `_update-watching` on r with any `deref`ed atoms captured during `in-context`, if any differ from the @@ -311,71 +319,67 @@ (notify-w! rx old-state res))) res)) -;; Gets flushed in a scheduled way by `flush!` -;; TODO `enqueue!` needs to be a parameter of `Reaction` -(defn- enqueue! [rx queue] - ;; It is at this point in CLJS that the rendering is scheduled like so: - ;; `(when (alist-empty? queue) (schedule! global-render-queue queue))` - (alist-conj! queue rx)) - (defn- handle-reaction-change! [^Reaction rx sender oldv newv] (when-not (or (identical? oldv newv) (.getDirty rx)) (let [auto-run (.getAutoRun rx)] (ifs (nil? auto-run) (do (.setDirty rx true) - (enqueue! rx (.-queue rx))) + ((.-enqueue-fn rx) (.-queue rx) rx)) (true? auto-run) (run-reaction! rx false) (auto-run rx))))) -;; Called by: -;; - `(when non-reactive? (flush! queue))` in `Reactive`.deref -;; - when a scheduled flushing is performed +(defn- update-watching! [^Reaction rx derefed] + (let [new (set derefed) ; TODO incrementally calculate `set` + old (set (.getWatching rx))] + (.setWatching rx derefed) + (doseq [w (set/difference new old)] + (#?(:clj add-watch :cljs -add-watch) w rx handle-reaction-change!)) + (doseq [w (set/difference old new)] + (#?(:clj remove-watch :cljs -remove-watch) w rx)))) + +(defn- run-reaction-from-queue! [^Reaction rx] + (when (and (.getDirty rx) (some? (.getWatching rx))) + (run-reaction! rx true))) + (defn- flush! [queue] (loop [i 0] (let [ct (-> queue alist-count long)] ;; NOTE: We avoid `pop`-ing in order to reduce churn but in theory it presents a memory issue + ;; due to the possible unboundedness of the queue ;; NOTE: In the Reagent version, every time a new "chunk" of the queue is worked on, that ;; chunk is scheduled for re-render ;; I.e. took care of all queue entries and reached a stable state - (if-let [reached-last-index? (>= i (unchecked-dec ct))] + (if-let [reached-last-index? (>= i ct)] (alist-empty! queue) (let [remaining-ct (unchecked-subtract ct i)] (dotimes [i* remaining-ct] - (let [^Reaction rx (alist-get queue (unchecked-add i i*))] - (when (and (.getDirty rx) (some? (.getWatching rx))) - (run-reaction! rx true)))) + (run-reaction-from-queue! (alist-get queue (unchecked-add i i*)))) ;; `recur`s because sometimes the queue gets added to in the process of running rx's (recur (+ i remaining-ct))))))) -(defn- update-watching! [^Reaction rx derefed] - (let [new (set derefed) ; TODO incrementally calculate `set` - old (set (.getWatching rx))] - (.setWatching rx derefed) - (doseq [w (set/difference new old)] - (#?(:clj add-watch :cljs -add-watch) w rx handle-reaction-change!)) - (doseq [w (set/difference old new)] - (#?(:clj remove-watch :cljs -remove-watch) w rx)))) +(defn- default-enqueue! [queue rx] + ;; Immediate run without touching the queue + (run-reaction-from-queue! rx)) -(defn- in-context - "When f is executed, if (f) derefs any ratoms, they are then added to 'obj.captured'(*ratom-context*). +(def ^:dynamic *enqueue!* default-enqueue!) - See function notify-deref-watcher! to know how *ratom-context* is updated" - [obj f] (binding [*ratom-context* obj] (f))) +(def ^:dynamic *queue* global-queue) -(defn ^Reaction >reaction - ([f] (>reaction f nil)) - ([f {:keys [auto-run eq-f no-cache? on-set on-dispose queue]}] - (Reaction. auto-run nil nil true (or eq-f =) f (if (nil? no-cache?) false no-cache?) on-dispose - nil on-set queue nil nil nil nil))) +(defn ^Reaction >rx + ([f] (>rx f nil)) + ([f {:keys [auto-run enqueue-fn eq-fn no-cache? on-set on-dispose queue]}] + (Reaction. auto-run nil nil true (or enqueue-fn *enqueue!*) (or eq-fn =) f + (if (nil? no-cache?) false no-cache?) on-dispose nil on-set (or queue *queue*) nil + nil nil nil))) -#?(:clj (defmacro reaction [& body] `(>reaction (fn [] ~@body) {:queue global-queue}))) +#?(:clj (defmacro rx [& body] `(>rx (fn [] ~@body)))) #?(:clj (defmacro run! "Runs body immediately, and runs again whenever atoms deferenced in the body change. Body should side effect." [& body] - `(let [co# (>reaction (fn [] ~@body) {:auto-run true :queue (alist)})] + `(let [co# (>rx (fn [] ~@body) {:auto-run true})] (deref co#) co#))) @@ -386,7 +390,7 @@ (declare cached-reaction) (udt/deftype Track - [^TrackableFn trackable-fn, args, ^:! ^quantum.untyped.core.data.reactive.Reaction ^:get ^:set rx] + [^TrackableFn trackable-fn, args, ^:! ^:get ^:set ^quantum.untyped.core.data.reactive.Reaction rx] {;; IPrintWithWriter ;; (-pr-writer [a w opts] (pr-atom a w opts "Track:")) PReactiveAtom {} @@ -408,7 +412,7 @@ (cond (some? r) (#?(:clj .deref :cljs -deref) r) (nil? *ratom-context*) (f) - :else (let [r (>reaction f + :else (let [r (>rx f {:on-dispose (fn [x] (when debug? (swap! *running dec)) @@ -432,26 +436,7 @@ (defn >track! [f args opts] (let [t (>track f args) - r (>reaction #(#?(:clj .deref :cljs -deref) t) - {:auto-run true :queue (or (:queue opts) global-queue)})] + r (>rx #(#?(:clj .deref :cljs -deref) t) + {:auto-run true :queue (or (:queue opts) global-queue)})] @r r)) - -;; TODO move -(defn ratom-perf [] - ;; (set! debug? false) ; yes but we need to think about CLJ - (dotimes [_ 10] - (let [a (ratom 0) - f (fn [] (quot (long @a) 10)) - q (alist) - mid (>reaction f {:queue q}) - res (>track! (fn [] (inc (long @mid))) [] {:queue q})] - @res - (time (dotimes [_ 100000] - (swap! a inc) - (flush! q))) - (dispose res)))) - -;; TODO move -;; TODO maybe have the queue as a binding and default to `default-queue`? Bindings can be complicated/subtle but at least think about it. For now we can just pass the params in -(ratom-perf) diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc new file mode 100644 index 00000000..bfff0279 --- /dev/null +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -0,0 +1,41 @@ +(ns quantum.test.untyped.core.data.reactive + (:require + [quantum.untyped.core.test + :refer [deftest is testing]] + [quantum.untyped.core.data.reactive :as self + :refer [ratom rx]])) + +(defn test-perf [] + ;; (set! debug? false) ; yes but we need to think about CLJ + (dotimes [_ 10] + (let [a (self/ratom 0) + f (fn [] (quot (long @a) 10)) + q (self/alist) + mid (self/>rx f {:queue q}) + res (self/>track! (fn [] (inc (long @mid))) [] {:queue q})] + @res + (time (dotimes [_ 100000] ; ~70ms per 100K + (swap! a inc) + (@#'self/flush! q))) + (self/dispose res)))) + +(deftest basic-ratom + (binding [self/*enqueue!* @#'self/alist-conj!] + (let [runs @@#'self/*running + start (ratom 0) + sv (rx @start) + comp (rx @sv (+ 2 @sv)) + c2 (rx (inc @comp)) + ct (ratom 0) + out (ratom 0) + res (rx (swap! ct inc) + @sv @c2 @comp) + const (self/run! (reset! out @res))] + (is (= @ct 1) "constrain ran") + (is (= @out 2)) + (reset! start 1) + (@#'self/flush! self/global-queue) + (is (= @out 3)) ; not correct; showing 2 + (is (<= 2 @ct 3)) + (self/dispose const) + (is (= @@#'self/*running runs))))) From de1d92d7286f6bed2f76e336743522b65c13fdec Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 11:00:37 -0600 Subject: [PATCH 551/810] Another test passes! --- .../quantum/untyped/core/data/reactive.cljc | 2 +- .../test/untyped/core/data/reactive.cljc | 25 ++++++++++++++++++- 2 files changed, 25 insertions(+), 2 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index 1daa43b1..e3564a74 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -342,7 +342,7 @@ (when (and (.getDirty rx) (some? (.getWatching rx))) (run-reaction! rx true))) -(defn- flush! [queue] +(defn flush! [queue] (loop [i 0] (let [ct (-> queue alist-count long)] ;; NOTE: We avoid `pop`-ing in order to reduce churn but in theory it presents a memory issue diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index bfff0279..18f5de9e 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -34,8 +34,31 @@ (is (= @ct 1) "constrain ran") (is (= @out 2)) (reset! start 1) - (@#'self/flush! self/global-queue) + (self/flush! self/global-queue) (is (= @out 3)) ; not correct; showing 2 (is (<= 2 @ct 3)) (self/dispose const) (is (= @@#'self/*running runs))))) + +(deftest double-dependency + (let [runs @@#'self/*running + start (ratom 0) + c3-count (ratom 0) + c1 (rx @start 1) + c2 (rx @start) + c3 (self/>rx + (fn [] + (swap! c3-count inc) + (+ @c1 @c2)) + {:auto-run true :queue self/global-queue})] + (self/flush! self/global-queue) + (is (= @c3-count 0)) + (is (= @c3 1)) + (is (= @c3-count 1) "t1") + (swap! start inc) + (self/flush! self/global-queue) + (is (= @c3-count 2) "t2") + (is (= @c3 2)) + (is (= @c3-count 2) "t3") + (self/dispose c3) + (is (= @@#'self/*running runs)))) From 852d08c706154b119cd7a1f5c29ab5a7683ff430 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 11:03:35 -0600 Subject: [PATCH 552/810] Another test passes! --- .../quantum/untyped/core/data/reactive.cljc | 2 ++ .../test/untyped/core/data/reactive.cljc | 30 +++++++++++++++++-- 2 files changed, 29 insertions(+), 3 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index e3564a74..4540f2a7 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -184,6 +184,8 @@ (dispose [this]) (addOnDispose [this f])) +(defn dispose! [x] (dispose x)) + (declare flush! peek-at run-reaction! update-watching!) ;; TODO diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index 18f5de9e..12cdb34f 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -1,4 +1,5 @@ (ns quantum.test.untyped.core.data.reactive + "Tests adapted from `reagenttest.testratom`." (:require [quantum.untyped.core.test :refer [deftest is testing]] @@ -17,7 +18,7 @@ (time (dotimes [_ 100000] ; ~70ms per 100K (swap! a inc) (@#'self/flush! q))) - (self/dispose res)))) + (self/dispose! res)))) (deftest basic-ratom (binding [self/*enqueue!* @#'self/alist-conj!] @@ -37,7 +38,7 @@ (self/flush! self/global-queue) (is (= @out 3)) ; not correct; showing 2 (is (<= 2 @ct 3)) - (self/dispose const) + (self/dispose! const) (is (= @@#'self/*running runs))))) (deftest double-dependency @@ -60,5 +61,28 @@ (is (= @c3-count 2) "t2") (is (= @c3 2)) (is (= @c3-count 2) "t3") - (self/dispose c3) + (self/dispose! c3) (is (= @@#'self/*running runs)))) + +(deftest test-from-reflex + (let [runs @@#'self/*running] + (let [*counter (ratom 0) + *signal (ratom "All I do is change") + co (self/run! + ;; when I change... + @*signal + ;; update the counter + (swap! *counter inc))] + (is (= 1 @*counter) "Constraint run on init") + (reset! *signal "foo") + (self/flush! self/global-queue) + (is (= 2 @*counter) + "Counter auto updated") + (self/dispose co)) + (let [*x (ratom 0) + *co (self/>rx #(inc @*x) {:auto-run true :queue self/global-queue})] + (is (= 1 @*co) "CO has correct value on first deref") + (swap! *x inc) + (is (= 2 @*co) "CO auto-updates") + (self/dispose! *co)) + (is (= runs @@#'self/*running)))) From ed947fc1a0356bf240fdeb3f498d7ea3f79fba4e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 11:06:49 -0600 Subject: [PATCH 553/810] Another test passes --- .../quantum/untyped/core/data/reactive.cljc | 2 +- .../test/untyped/core/data/reactive.cljc | 68 +++++++++++++++---- 2 files changed, 56 insertions(+), 14 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index 4540f2a7..07c37bbf 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -60,7 +60,7 @@ (recur (inc i)) false)))))) -(defn #?(:clj ^ArrayList alist :cljs alist) +(defn- #?(:clj ^ArrayList alist :cljs alist) ([] #?(:clj (ArrayList.) :cljs #js [])) ([x] #?(:clj (doto (ArrayList.) (.add x)) :cljs #js [x]))) diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index 12cdb34f..6c5bbfbb 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -4,21 +4,21 @@ [quantum.untyped.core.test :refer [deftest is testing]] [quantum.untyped.core.data.reactive :as self - :refer [ratom rx]])) + :refer [dispose! flush! ratom rx]])) (defn test-perf [] ;; (set! debug? false) ; yes but we need to think about CLJ (dotimes [_ 10] - (let [a (self/ratom 0) + (let [a (ratom 0) f (fn [] (quot (long @a) 10)) - q (self/alist) + q (@#'self/alist) mid (self/>rx f {:queue q}) res (self/>track! (fn [] (inc (long @mid))) [] {:queue q})] @res (time (dotimes [_ 100000] ; ~70ms per 100K (swap! a inc) (@#'self/flush! q))) - (self/dispose! res)))) + (dispose! res)))) (deftest basic-ratom (binding [self/*enqueue!* @#'self/alist-conj!] @@ -35,10 +35,10 @@ (is (= @ct 1) "constrain ran") (is (= @out 2)) (reset! start 1) - (self/flush! self/global-queue) + (flush! self/global-queue) (is (= @out 3)) ; not correct; showing 2 (is (<= 2 @ct 3)) - (self/dispose! const) + (dispose! const) (is (= @@#'self/*running runs))))) (deftest double-dependency @@ -52,19 +52,19 @@ (swap! c3-count inc) (+ @c1 @c2)) {:auto-run true :queue self/global-queue})] - (self/flush! self/global-queue) + (flush! self/global-queue) (is (= @c3-count 0)) (is (= @c3 1)) (is (= @c3-count 1) "t1") (swap! start inc) - (self/flush! self/global-queue) + (flush! self/global-queue) (is (= @c3-count 2) "t2") (is (= @c3 2)) (is (= @c3-count 2) "t3") - (self/dispose! c3) + (dispose! c3) (is (= @@#'self/*running runs)))) -(deftest test-from-reflex +(deftest test-from-reflex ; https://github.com/reflex-frp/reflex (let [runs @@#'self/*running] (let [*counter (ratom 0) *signal (ratom "All I do is change") @@ -75,14 +75,56 @@ (swap! *counter inc))] (is (= 1 @*counter) "Constraint run on init") (reset! *signal "foo") - (self/flush! self/global-queue) + (flush! self/global-queue) (is (= 2 @*counter) "Counter auto updated") - (self/dispose co)) + (dispose! co)) (let [*x (ratom 0) *co (self/>rx #(inc @*x) {:auto-run true :queue self/global-queue})] (is (= 1 @*co) "CO has correct value on first deref") (swap! *x inc) (is (= 2 @*co) "CO auto-updates") - (self/dispose! *co)) + (dispose! *co)) (is (= runs @@#'self/*running)))) + +(deftest test-unsubscribe + (dotimes [x 10] + (let [runs @@#'self/*running + a (ratom 0) + a1 (rx (inc @a)) + a2 (rx @a) + b-changed (ratom 0) + c-changed (ratom 0) + b (rx (swap! b-changed inc) + (inc @a1)) + c (rx (swap! c-changed inc) + (+ 10 @a2)) + res (self/run! (if (< @a2 1) @b @c))] + (is (= @res (+ 2 @a))) + (is (= @b-changed 1)) + (is (= @c-changed 0)) + + (reset! a -1) + (is (= @res (+ 2 @a))) + (is (= @b-changed 2)) + (is (= @c-changed 0)) + + (reset! a 2) + (is (= @res (+ 10 @a))) + (is (<= 2 @b-changed 3)) + (is (= @c-changed 1)) + + (reset! a 3) + (is (= @res (+ 10 @a))) + (is (<= 2 @b-changed 3)) + (is (= @c-changed 2)) + + (reset! a 3) + (is (= @res (+ 10 @a))) + (is (<= 2 @b-changed 3)) + (is (= @c-changed 2)) + + (reset! a -1) + (is (= @res (+ 2 @a))) + (dispose! res) + (is (= runs @@#'self/*running))))) From 850af1fac880bb8ebcf498ad513fc791f8165a9a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 11:12:19 -0600 Subject: [PATCH 554/810] Another test passes! --- .../quantum/untyped/core/data/reactive.cljc | 2 +- .../test/untyped/core/data/reactive.cljc | 51 +++++++++++++++---- 2 files changed, 43 insertions(+), 10 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index 07c37bbf..ef468a46 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -176,7 +176,7 @@ ([x] (ReactiveAtom. x nil nil nil nil)) ([x & {:keys [meta validator]}] (ReactiveAtom. x meta validator nil nil))) -;; ===== Reaction ===== ;; +;; ===== Reaction ("Computed Observable") ===== ;; ;; Similar to java.io.Closeable ;; TODO move diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index 6c5bbfbb..be617920 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -6,6 +6,8 @@ [quantum.untyped.core.data.reactive :as self :refer [dispose! flush! ratom rx]])) +(defn- running [] @@#'self/*running) + (defn test-perf [] ;; (set! debug? false) ; yes but we need to think about CLJ (dotimes [_ 10] @@ -22,7 +24,7 @@ (deftest basic-ratom (binding [self/*enqueue!* @#'self/alist-conj!] - (let [runs @@#'self/*running + (let [runs (running) start (ratom 0) sv (rx @start) comp (rx @sv (+ 2 @sv)) @@ -39,10 +41,10 @@ (is (= @out 3)) ; not correct; showing 2 (is (<= 2 @ct 3)) (dispose! const) - (is (= @@#'self/*running runs))))) + (is (= (running) runs))))) (deftest double-dependency - (let [runs @@#'self/*running + (let [runs (running) start (ratom 0) c3-count (ratom 0) c1 (rx @start 1) @@ -62,10 +64,10 @@ (is (= @c3 2)) (is (= @c3-count 2) "t3") (dispose! c3) - (is (= @@#'self/*running runs)))) + (is (= (running) runs)))) -(deftest test-from-reflex ; https://github.com/reflex-frp/reflex - (let [runs @@#'self/*running] +(deftest test-from-reflex ; https://github.com/lynaghk/reflex + (let [runs (running)] (let [*counter (ratom 0) *signal (ratom "All I do is change") co (self/run! @@ -85,11 +87,11 @@ (swap! *x inc) (is (= 2 @*co) "CO auto-updates") (dispose! *co)) - (is (= runs @@#'self/*running)))) + (is (= runs (running))))) (deftest test-unsubscribe (dotimes [x 10] - (let [runs @@#'self/*running + (let [runs (running) a (ratom 0) a1 (rx (inc @a)) a2 (rx @a) @@ -127,4 +129,35 @@ (reset! a -1) (is (= @res (+ 2 @a))) (dispose! res) - (is (= runs @@#'self/*running))))) + (is (= runs (running)))))) + +(deftest maybe-broken + (let [runs (running)] + (let [runs (running) + a (ratom 0) + b (rx (inc @a)) + c (rx (dec @a)) + d (rx (str @b)) + res (ratom 0) + cs (self/run! (reset! res @d))] + (is (= @res "1")) + (dispose! cs)) + ;; should be broken according to https://github.com/lynaghk/reflex/issues/1 + ;; but isnt + (let [a (ratom 0) + b (rx (inc @a)) + c (rx (dec @a)) + d (self/run! [@b @c])] + (is (= @d [1 -1])) + (dispose! d)) + (let [a (ratom 0) + b (rx (inc @a)) + c (rx (dec @a)) + d (self/run! [@b @c]) + res (ratom 0)] + (is (= @d [1 -1])) + (let [e (self/run! (reset! res @d))] + (is (= @res [1 -1])) + (dispose! e)) + (dispose! d)) + (is (= runs (running))))) From 0a8520c56b8ffbd989bbc343c6e2d7d08fea889d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 11:24:56 -0600 Subject: [PATCH 555/810] Another test passes! --- .../quantum/untyped/core/data/reactive.cljc | 8 +-- src-untyped/quantum/untyped/core/test.cljc | 7 +- .../test/untyped/core/data/reactive.cljc | 66 +++++++++++++++++-- 3 files changed, 70 insertions(+), 11 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index ef468a46..0de70027 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -68,7 +68,7 @@ (def ^:dynamic *ratom-context* nil) -(defonce #?(:clj debug? :cljs ^boolean debug?) false) +(def ^:dynamic #?(:clj *debug?* :cljs ^boolean *debug?*) false) (defonce- *running (atom 0)) @@ -77,7 +77,7 @@ (defn #?(:clj reactive? :cljs ^boolean reactive?) [] (some? *ratom-context*)) (defn- check-watches [old new] - (when debug? (swap! *running + (- (count new) (count old)))) + (when (boolean *debug?*) (swap! *running + (- (count new) (count old)))) new) (defprotocol PWatchable @@ -417,7 +417,7 @@ :else (let [r (>rx f {:on-dispose (fn [x] - (when debug? (swap! *running dec)) + (when (boolean *debug?*) (swap! *running dec)) (as-> (.getRxCache trackable-fn) cache (dissoc cache k) (.setRxCache trackable-fn cache)) @@ -429,7 +429,7 @@ :queue (some-> t .getRx .-queue)}) v (#?(:clj .deref :cljs -deref) r)] (.setRxCache trackable-fn (assoc m k r)) - (when debug? (swap! *running inc)) + (when (boolean *debug?*) (swap! *running inc)) (when (some? t) (.setRx t r)) v)))) diff --git a/src-untyped/quantum/untyped/core/test.cljc b/src-untyped/quantum/untyped/core/test.cljc index e0983504..770209c3 100644 --- a/src-untyped/quantum/untyped/core/test.cljc +++ b/src-untyped/quantum/untyped/core/test.cljc @@ -16,10 +16,11 @@ [quantum.untyped.core.vars :refer [defalias defmalias metable?]])) -#?(:clj (defmalias is clojure.test/is cljs.test/is )) -#?(:clj (defmalias deftest clojure.test/deftest cljs.test/deftest)) -#?(:clj (defmalias testing clojure.test/testing cljs.test/testing)) +#?(:clj (defmalias is clojure.test/is cljs.test/is )) +#?(:clj (defmalias deftest clojure.test/deftest cljs.test/deftest)) +#?(:clj (defmalias testing clojure.test/testing cljs.test/testing)) #?(:clj (defalias test/test-ns)) + (defalias test/use-fixtures) #?(:clj (defn test-nss [& ns-syms] (->> ns-syms (map test-ns) doall))) diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index be617920..3e015cc6 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -1,11 +1,17 @@ (ns quantum.test.untyped.core.data.reactive "Tests adapted from `reagenttest.testratom`." (:require - [quantum.untyped.core.test + [quantum.untyped.core.test :as utest :refer [deftest is testing]] [quantum.untyped.core.data.reactive :as self :refer [dispose! flush! ratom rx]])) +(defn with-debug [f] + (flush! self/global-queue) + (binding [self/*debug?* true] (f))) + +(utest/use-fixtures :once with-debug) + (defn- running [] @@#'self/*running) (defn test-perf [] @@ -87,7 +93,7 @@ (swap! *x inc) (is (= 2 @*co) "CO auto-updates") (dispose! *co)) - (is (= runs (running))))) + (is (= (running) runs)))) (deftest test-unsubscribe (dotimes [x 10] @@ -129,7 +135,7 @@ (reset! a -1) (is (= @res (+ 2 @a))) (dispose! res) - (is (= runs (running)))))) + (is (= (running) runs))))) (deftest maybe-broken (let [runs (running)] @@ -160,4 +166,56 @@ (is (= @res [1 -1])) (dispose! e)) (dispose! d)) - (is (= runs (running))))) + (is (= (running) runs)))) + +(deftest test-dispose + (dotimes [x 10] + (let [runs (running) + a (ratom 0) + disposed (ratom nil) + disposed-c (ratom nil) + disposed-cns (ratom nil) + count-b (ratom 0) + b (self/>rx (fn [] + (swap! count-b inc) + (inc @a)) + {:on-dispose (fn [r] (reset! disposed true)) + :queue self/global-queue}) + c (self/>rx #(if (< @a 1) (inc @b) (dec @a)) + {:on-dispose (fn [r] (reset! disposed-c true)) + :queue self/global-queue}) + res (ratom nil) + cns (self/>rx #(reset! res @c) + {:auto-run true + :on-dispose (fn [r] (reset! disposed-cns true)) + :queue self/global-queue})] + @cns + (is (= @res 2)) + (is (= (+ 4 runs) (running))) + (is (= @count-b 1)) + (reset! a -1) + (flush! self/global-queue) + (is (= @res 1)) + (is (= @disposed nil)) + (is (= @count-b 2)) + (is (= (+ 4 runs) (running)) "still running") + (reset! a 2) + (flush! self/global-queue) + (is (= @res 1)) + (is (= @disposed true)) + (is (= (+ 2 runs) (running)) "less running count") + + (reset! disposed nil) + (reset! a -1) + (flush! self/global-queue) + ;; This fails sometimes on node. I have no idea why. + (is (= 1 @res) "should be one again") + (is (= @disposed nil)) + (reset! a 2) + (flush! self/global-queue) + (is (= @res 1)) + (is (= @disposed true)) + (dispose! cns) + (is (= @disposed-c true)) + (is (= @disposed-cns true)) + (is (= runs (running)))))) From d1d0cd6459f01ebd32abfd590b4103af9abd1791 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 11:27:52 -0600 Subject: [PATCH 556/810] And another test --- .../quantum/untyped/core/data/reactive.cljc | 9 ++-- .../test/untyped/core/data/reactive.cljc | 47 +++++++++++++++++++ 2 files changed, 52 insertions(+), 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index 0de70027..230f69af 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -77,7 +77,7 @@ (defn #?(:clj reactive? :cljs ^boolean reactive?) [] (some? *ratom-context*)) (defn- check-watches [old new] - (when (boolean *debug?*) (swap! *running + (- (count new) (count old)))) + (when (true? *debug?*) (swap! *running + (- (count new) (count old)))) new) (defprotocol PWatchable @@ -184,7 +184,8 @@ (dispose [this]) (addOnDispose [this f])) -(defn dispose! [x] (dispose x)) +(defn dispose! [x] (dispose x)) +(defn add-on-dispose! [x f] (addOnDispose x f)) (declare flush! peek-at run-reaction! update-watching!) @@ -417,7 +418,7 @@ :else (let [r (>rx f {:on-dispose (fn [x] - (when (boolean *debug?*) (swap! *running dec)) + (when (true? *debug?*) (swap! *running dec)) (as-> (.getRxCache trackable-fn) cache (dissoc cache k) (.setRxCache trackable-fn cache)) @@ -429,7 +430,7 @@ :queue (some-> t .getRx .-queue)}) v (#?(:clj .deref :cljs -deref) r)] (.setRxCache trackable-fn (assoc m k r)) - (when (boolean *debug?*) (swap! *running inc)) + (when (true? *debug?*) (swap! *running inc)) (when (some? t) (.setRx t r)) v)))) diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index 3e015cc6..6cd8a48b 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -219,3 +219,50 @@ (is (= @disposed-c true)) (is (= @disposed-cns true)) (is (= runs (running)))))) + +(deftest test-add-dispose + (dotimes [x 10] + (let [runs (running) + a (ratom 0) + disposed (ratom nil) + disposed-c (ratom nil) + disposed-cns (ratom nil) + count-b (ratom 0) + b (self/>rx (fn [] (swap! count-b inc) (inc @a)) {:queue self/global-queue}) + c (self/>rx #(if (< @a 1) (inc @b) (dec @a)) {:queue self/global-queue}) + res (ratom nil) + cns (self/>rx #(reset! res @c) {:auto-run true :queue self/global-queue})] + (self/add-on-dispose! b (fn [r] + (is (= r b)) + (reset! disposed true))) + (self/add-on-dispose! c (fn [r] (reset! disposed-c true))) + (self/add-on-dispose! cns (fn [r] (reset! disposed-cns true))) + @cns + (is (= @res 2)) + (is (= (+ 4 runs) (running))) + (is (= @count-b 1)) + (reset! a -1) + (flush! self/global-queue) + (is (= @res 1)) + (is (= @disposed nil)) + (is (= @count-b 2)) + (is (= (+ 4 runs) (running)) "still running") + (reset! a 2) + (flush! self/global-queue) + (is (= @res 1)) + (is (= @disposed true)) + (is (= (+ 2 runs) (running)) "less running count") + + (reset! disposed nil) + (reset! a -1) + (flush! self/global-queue) + (is (= 1 @res) "should be one again") + (is (= @disposed nil)) + (reset! a 2) + (flush! self/global-queue) + (is (= @res 1)) + (is (= @disposed true)) + (dispose! cns) + (is (= @disposed-c true)) + (is (= @disposed-cns true)) + (is (= runs (running)))))) From 8809c1172a76f034b0c412c7ba2cc94f61c1dce2 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 11:28:33 -0600 Subject: [PATCH 557/810] And another --- .../test/untyped/core/data/reactive.cljc | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index 6cd8a48b..1602ee1d 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -266,3 +266,21 @@ (is (= @disposed-c true)) (is (= @disposed-cns true)) (is (= runs (running)))))) + +(deftest test-on-set + (let [runs (running) + a (ratom 0) + b (self/>rx #(+ 5 @a) + {:auto-run true + :on-set (fn [oldv newv] + (reset! a (+ 10 newv))) + :queue self/global-queue})] + @b + (is (= 5 @b)) + (reset! a 1) + (is (= 6 @b)) + (reset! b 1) + (is (= 11 @a)) + (is (= 16 @b)) + (dispose! b) + (is (= runs (running))))) From a495af7d0e65d8328ba760cd59ae2a87592619da Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 11:28:52 -0600 Subject: [PATCH 558/810] And another --- test/quantum/test/untyped/core/data/reactive.cljc | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index 1602ee1d..5a2fd1ce 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -284,3 +284,14 @@ (is (= 16 @b)) (dispose! b) (is (= runs (running))))) + +(deftest non-reactive-deref + (let [runs (running) + a (ratom 0) + b (self/>rx #(+ 5 @a))] + (is (= @b 5)) + (is (= runs (running))) + + (reset! a 1) + (is (= @b 6)) + (is (= runs (running))))) From df8f29554ff5c2d72d7a2549bfb5a3e97a50b5e1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 11:34:31 -0600 Subject: [PATCH 559/810] And another --- .../test/untyped/core/data/reactive.cljc | 25 ++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index 5a2fd1ce..5256f39c 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -4,7 +4,8 @@ [quantum.untyped.core.test :as utest :refer [deftest is testing]] [quantum.untyped.core.data.reactive :as self - :refer [dispose! flush! ratom rx]])) + :refer [dispose! flush! ratom rx]] + [quantum.untyped.core.error :as uerr])) (defn with-debug [f] (flush! self/global-queue) @@ -295,3 +296,25 @@ (reset! a 1) (is (= @b 6)) (is (= runs (running))))) + +(deftest reset-in-reaction + (let [runs (running) + state (ratom {}) + c1 (rx (get-in @state [:data :a])) + c2 (rx (get-in @state [:data :b])) + rxn (self/>rx + #(let [cc1 @c1 + cc2 @c2] + (swap! state assoc :derived (+ (or cc1 0) (or cc2 0))) + nil) + {:auto-run true :queue self/global-queue})] + @rxn + (is (= (:derived @state) 0)) + (swap! state assoc :data {:a 1 :b 2}) + (flush! self/global-queue) + (is (= (:derived @state) 3)) + (swap! state assoc :data {:a 11 :b 22}) + (flush! self/global-queue) + (is (= (:derived @state) 33)) + (dispose! rxn) + (is (= runs (running))))) From ba662c98e98e7f41f8c3cc0b7e1ed8ec0c90f4c5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 11:36:42 -0600 Subject: [PATCH 560/810] And another --- .../test/untyped/core/data/reactive.cljc | 21 +++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index 5256f39c..d1ff2321 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -4,8 +4,7 @@ [quantum.untyped.core.test :as utest :refer [deftest is testing]] [quantum.untyped.core.data.reactive :as self - :refer [dispose! flush! ratom rx]] - [quantum.untyped.core.error :as uerr])) + :refer [dispose! flush! ratom rx]])) (defn with-debug [f] (flush! self/global-queue) @@ -318,3 +317,21 @@ (is (= (:derived @state) 33)) (dispose! rxn) (is (= runs (running))))) + +(deftest exception-recover + (let [runs (running) + state (ratom 1) + count (ratom 0) + r (self/run! + (swap! count inc) + (when (> @state 1) (throw (ex-info "oops" {}))))] + (is (= @count 1)) + (is (thrown? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) + (do (swap! state inc) + (flush! self/global-queue)))) + (is (= @count 2)) + (swap! state dec) + (flush! self/global-queue) + (is (= @count 3)) + (dispose! r) + (is (= runs (running))))) From 20702a6c9d5aaddcf92cd44b5ed7e8bd11fb7606 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 11:37:25 -0600 Subject: [PATCH 561/810] And another --- .../test/untyped/core/data/reactive.cljc | 21 +++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index d1ff2321..608b5c2d 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -335,3 +335,24 @@ (is (= @count 3)) (dispose! r) (is (= runs (running))))) + +(deftest exception-recover-indirect + (let [runs (running) + state (ratom 1) + count (ratom 0) + ref (rx (when (= @state 2) + (throw (ex-info "err" {})))) + r (self/run! + (swap! count inc) + @ref)] + (is (= @count 1)) + (is (thrown? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) + (do (swap! state inc) + (flush! self/global-queue)))) + (is (= @count 2)) + (is (thrown? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) @ref)) + (swap! state inc) + (flush! self/global-queue) + (is (= @count 3)) + (dispose! r) + (is (= runs (running))))) From dc83c762604953528a73d983ecec022df64d8630 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 11:39:41 -0600 Subject: [PATCH 562/810] And another --- .../test/untyped/core/data/reactive.cljc | 25 +++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index 608b5c2d..3d06895a 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -356,3 +356,28 @@ (is (= @count 3)) (dispose! r) (is (= runs (running))))) + +(deftest exception-side-effect + (let [runs (running) + state (ratom {:val 1}) + rstate (rx @state) + spy (atom nil) + r1 (self/run! @rstate) + r2 (let [val (rx (:val @rstate))] + (self/run! + (reset! spy @val) + (is (some? @val)))) + r3 (self/run! + (when (:error? @rstate) + (throw (ex-info "Error detected!" {}))))] + (swap! state assoc :val 2) + (flush! self/global-queue) + (swap! state assoc :error? true) + (is (thrown? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) + (flush! self/global-queue))) + (flush! self/global-queue) + (flush! self/global-queue) + (dispose! r1) + (dispose! r2) + (dispose! r3) + (is (= runs (running))))) From c9d7eba6154a64701a5a1b3050f23ce86b933557 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 11:57:29 -0600 Subject: [PATCH 563/810] Fixed a test so quickly --- .../test/untyped/core/data/reactive.cljc | 47 ++++++++++--------- 1 file changed, 24 insertions(+), 23 deletions(-) diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index 3d06895a..e7543d31 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -358,26 +358,27 @@ (is (= runs (running))))) (deftest exception-side-effect - (let [runs (running) - state (ratom {:val 1}) - rstate (rx @state) - spy (atom nil) - r1 (self/run! @rstate) - r2 (let [val (rx (:val @rstate))] - (self/run! - (reset! spy @val) - (is (some? @val)))) - r3 (self/run! - (when (:error? @rstate) - (throw (ex-info "Error detected!" {}))))] - (swap! state assoc :val 2) - (flush! self/global-queue) - (swap! state assoc :error? true) - (is (thrown? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) - (flush! self/global-queue))) - (flush! self/global-queue) - (flush! self/global-queue) - (dispose! r1) - (dispose! r2) - (dispose! r3) - (is (= runs (running))))) + (binding [self/*enqueue!* @#'self/alist-conj!] + (let [runs (running) + state (ratom {:val 1}) + rstate (rx @state) + spy (atom nil) + r1 (self/run! @rstate) + r2 (let [val (rx (:val @rstate))] + (self/run! + (reset! spy @val) + (is (some? @val)))) + r3 (self/run! + (when (:error? @rstate) + (throw (ex-info "Error detected!" {}))))] + (swap! state assoc :val 2) + (flush! self/global-queue) + (swap! state assoc :error? true) + (is (thrown? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) + (flush! self/global-queue))) + (flush! self/global-queue) + (flush! self/global-queue) + (dispose! r1) + (dispose! r2) + (dispose! r3) + (is (= runs (running)))))) From 768d39f005ec35815136945a69ea4341e612d065 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 11:58:12 -0600 Subject: [PATCH 564/810] Another test passes! --- .../quantum/test/untyped/core/data/reactive.cljc | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index e7543d31..641aafd8 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -382,3 +382,19 @@ (dispose! r2) (dispose! r3) (is (= runs (running)))))) + +(deftest exception-reporting + (binding [self/*enqueue!* @#'self/alist-conj!] + (let [runs (running) + state (ratom {:val 1}) + rstate (rx (:val @state)) + r1 (self/run! + (when (= @rstate 13) + (throw (ex-info "fail" {}))))] + (swap! state assoc :val 13) + (is (thrown? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) + (flush! self/global-queue))) + (swap! state assoc :val 2) + (flush! self/global-queue) + (dispose! r1) + (is (= runs (running)))))) From d8fb078d3c01d087b0e569fdf1a21522b95e0db6 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 11:58:42 -0600 Subject: [PATCH 565/810] All tests from Reagent pass! --- test/quantum/test/untyped/core/data/reactive.cljc | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index 641aafd8..990607d7 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -398,3 +398,10 @@ (flush! self/global-queue) (dispose! r1) (is (= runs (running)))))) + +(deftest ratom-with-meta + (let [value {:val 1} + meta-value {:meta-val 1} + state (with-meta (ratom value) meta-value)] + (is (= (meta state) meta-value)) + (is (= @state value)))) From 94fb22105cefa8828a63c3c624d4858c2b74fbdd Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 11:58:56 -0600 Subject: [PATCH 566/810] Fulfill todo --- src-untyped/quantum/untyped/core/data/reactive.cljc | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index 230f69af..f767f085 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -189,10 +189,6 @@ (declare flush! peek-at run-reaction! update-watching!) -;; TODO -;; Fields of a Reaction -;; - captured -;; - ratomGeneration (udt/deftype Reaction [^:! ^:get autoRun ^:! ^:get ^:set caught From ea9ffffb823726d303805547f3c11b6a76921e6a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 13:23:55 -0600 Subject: [PATCH 567/810] Add note to data.reactive --- src-untyped/quantum/untyped/core/data/reactive.cljc | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index f767f085..37a3bfb4 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -4,7 +4,10 @@ Includes ReactiveAtom and Reaction; will include Subscription. Currently only safe for single-threaded use; needs a rethink to accommodate concurrent - modification/access and customizable queueing strategies." + modification/access and customizable queueing strategies. + - We could either introduce concurrency-safe versions of `Reaction` and `ReactiveAtom`, or we + could introduce a global single thread on which `Reaction`s and `ReactiveAtom`s are modified, + but from which any number of threads can read, in a clojure.async sort of way." (:refer-clojure :exclude [run!]) (:require From 9f8185ba5ef8db92111058dae0248c6b9d7476dc Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 14:45:05 -0600 Subject: [PATCH 568/810] Make some naming/functionality clearer --- .../quantum/untyped/core/data/reactive.cljc | 143 +++--- .../test/untyped/core/data/reactive.cljc | 424 ++++++++++-------- 2 files changed, 308 insertions(+), 259 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index 37a3bfb4..000adc98 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -1,15 +1,15 @@ (ns quantum.untyped.core.data.reactive "Most of the content adapted from `reagent.ratom` 2018-10-20. - Includes ReactiveAtom and Reaction; will include Subscription. + Includes `Atom` and `Reaction`; may include `Subscription` at some point. Currently only safe for single-threaded use; needs a rethink to accommodate concurrent modification/access and customizable queueing strategies. - - We could either introduce concurrency-safe versions of `Reaction` and `ReactiveAtom`, or we - could introduce a global single thread on which `Reaction`s and `ReactiveAtom`s are modified, + - We could either introduce concurrency-safe versions of `Reaction` and `Atom`, or we + could introduce a global single thread on which `Reaction`s and `Atom`s are modified, but from which any number of threads can read, in a clojure.async sort of way." (:refer-clojure :exclude - [run!]) + [atom run!]) (:require [clojure.set :as set] [quantum.untyped.core.async :as uasync] @@ -24,9 +24,6 @@ :refer [defonce-]]) #?(:clj (:import [java.util ArrayList]))) -;; TODO add subscriptions to this too; for now we will just use the Reagent ratom -;; TODO the update batching is very Reagent-specific; we need to abstract that for it to work in CLJS - ;; TODO move ;; ===== Array-list fns ===== ;; @@ -69,7 +66,7 @@ ;; ===== Internal functions for reactivity ===== ;; -(def ^:dynamic *ratom-context* nil) +(def ^:dynamic *atom-context* nil) (def ^:dynamic #?(:clj *debug?* :cljs ^boolean *debug?*) false) @@ -77,7 +74,7 @@ (defonce global-queue (alist)) -(defn #?(:clj reactive? :cljs ^boolean reactive?) [] (some? *ratom-context*)) +(defn #?(:clj reactive? :cljs ^boolean reactive?) [] (some? *atom-context*)) (defn- check-watches [old new] (when (true? *debug?*) (swap! *running + (- (count new) (count old)))) @@ -122,29 +119,29 @@ #?(:cljs (defn- pr-atom! [a writer opts s] (-write writer (str "#<" s " ")) - (pr-writer (binding [*ratom-context* nil] (-deref a)) writer opts) + (pr-writer (binding [*atom-context* nil] (-deref a)) writer opts) (-write writer ">"))) -;; ===== RAtom ===== ;; +;; ===== Atom ===== ;; -(defprotocol PReactiveAtom) +(defprotocol PReactive) (defprotocol PHasCaptured (getCaptured [this]) (setCaptured [this v])) (defn- notify-deref-watcher! - "Add `derefed` to the `captured` field of `*ratom-context*`. + "Add `derefed` to the `captured` field of `*atom-context*`. See also `in-context`" [derefed] - (when-some [context *ratom-context*] + (when-some [context *atom-context*] (let [^quantum.untyped.core.data.reactive.PHasCaptured r context] (if-some [c (.getCaptured r)] (alist-conj! c derefed) (.setCaptured r (alist derefed)))))) -(udt/deftype ReactiveAtom [^:! state meta validator ^:! watches ^:! watchesArr] +(udt/deftype Atom [^:! state meta validator ^:! watches ^:! watchesArr] {;; IPrintWithWriter ;; (-pr-writer [a w opts] (pr-atom a w opts "Atom:")) PReactiveAtom {} @@ -171,13 +168,13 @@ getWatchesArr ([this] watchesArr) setWatchesArr ([this v] (set! watchesArr v))} ?Meta {meta ([_] meta) - with-meta ([_ meta'] (ReactiveAtom. state meta' validator watches watchesArr))} + with-meta ([_ meta'] (Atom. state meta' validator watches watchesArr))} #?@(:cljs [?Hash {hash ([_] (goog/getUid this))}])}) -(defn ratom - "'R'eactive 'atom'. Like `core/atom`, except that it keeps track of derefs." - ([x] (ReactiveAtom. x nil nil nil nil)) - ([x & {:keys [meta validator]}] (ReactiveAtom. x meta validator nil nil))) +(defn atom + "Reactive 'atom'. Like `core/atom`, except that it keeps track of derefs." + ([x] (Atom. x nil nil nil nil)) + ([x & {:keys [meta validator]}] (Atom. x meta validator nil nil))) ;; ===== Reaction ("Computed Observable") ===== ;; @@ -193,10 +190,10 @@ (declare flush! peek-at run-reaction! update-watching!) (udt/deftype Reaction - [^:! ^:get autoRun + [^:! ^boolean ^:get alwaysRecompute ^:! ^:get ^:set caught ^:! captured - ^:! ^boolean ^:get ^:set dirty + ^:! ^boolean ^:get ^:set computed enqueue-fn eq-fn f @@ -213,27 +210,28 @@ ;; (-pr-writer [a w opts] (pr-atom a w opts (str "Reaction " (hash a) ":"))) ?Equals {= ([this that] (identical? this that))} #?@(:cljs [?Hash {hash ([this] (goog/getUid this))}]) - PReactiveAtom {} + PReactive {} ?Deref {deref ([this] - (when-some [e caught] (throw e)) - (let [non-reactive? (nil? *ratom-context*)] - (when non-reactive? (flush! queue)) - (if (and non-reactive? (nil? autoRun)) - (when dirty - (let [old-state state] - (set! state (f)) - (when-not (or (nil? watches) (eq-fn old-state state)) - (notify-w! this old-state state)))) - (do (notify-deref-watcher! this) - (when dirty (run-reaction! this false))))) - state)} + (if-not (nil? caught) + (throw caught) + (let [non-reactive? (nil? *atom-context*)] + (when non-reactive? (flush! queue)) + (if (and non-reactive? (true? alwaysRecompute)) + (when-not computed + (let [old-state state] + (set! state (f)) + (when-not (or (nil? watches) (eq-fn old-state state)) + (notify-w! this old-state state)))) + (do (notify-deref-watcher! this) + (when-not computed (run-reaction! this false)))) + state)))} ?Watchable {add-watch! ([this k f] (add-w! this k f)) remove-watch! ([this k] (let [was-empty? (empty? watches)] (remove-w! this k) (when (and (not was-empty?) (empty? watches) - (nil? autoRun)) + (true? alwaysRecompute)) (.dispose this))))} PWatchable {getWatches ([this] watches) setWatches ([this v] (set! watches v)) @@ -258,10 +256,10 @@ {dispose ([this] (let [s state, wg watching] - (set! watching nil) - (set! state nil) - (set! autoRun nil) - (set! dirty #?(:clj (boolean true) :cljs true)) + (set! watching nil) + (set! state nil) + (set! alwaysRecompute #?(:clj (boolean true) :cljs true)) + (set! computed #?(:clj (boolean false) :cljs false)) (doseq [w (set wg)] (#?(:clj remove-watch :cljs -remove-watch) w this)) (when (some? (.-on-dispose this)) ((.-on-dispose this) s)) (when-some [a (.-on-dispose-arr this)] @@ -273,27 +271,27 @@ (alist-conj! a f) (set! (.-on-dispose-arr this) (alist f))))}}) -(defn- peek-at [^Reaction rx] (binding [*ratom-context* nil] (#?(:clj .deref :cljs -deref) rx))) +(defn- peek-at [^Reaction rx] (binding [*atom-context* nil] (#?(:clj .deref :cljs -deref) rx))) (defn- in-context - "When f is executed, if (f) derefs any ratoms, they are then added to - 'obj.captured'(*ratom-context*). + "When f is executed, if (f) derefs any atoms, they are then added to + 'obj.captured'(*atom-context*). - See function notify-deref-watcher! to know how *ratom-context* is updated" - [obj f] (binding [*ratom-context* obj] (f))) + See function notify-deref-watcher! to know how *atom-context* is updated" + [obj f] (binding [*atom-context* obj] (f))) (defn- deref-capture! "Returns `(in-context f r)`. Calls `_update-watching` on r with any `deref`ed atoms captured during `in-context`, if any differ from the - `watching` field of r. Clears the `dirty` flag on r. + `watching` field of r. Sets the `computed` flag on r to true. - Inside '_update-watching' along with adding the ratoms in 'r.watching' of reaction, - the reaction is also added to the list of watches on each ratoms f derefs." + Inside '_update-watching' along with adding the atoms in 'r.watching' of reaction, + the reaction is also added to the list of watches on each atoms f derefs." [f ^Reaction rx] (.setCaptured rx nil) (let [res (in-context rx f) c (.getCaptured rx)] - (.setDirty rx false) + (.setComputed rx true) ;; Optimize common case where derefs occur in same order (when-not (alist== c (.getWatching rx)) (update-watching! rx c)) res)) @@ -305,7 +303,7 @@ e (do (.setState rx e) (.setCaught rx e) - (.setDirty rx false)))) + (.setComputed rx true)))) (defn- run-reaction! [^Reaction rx check?] (let [old-state (.getState rx) @@ -322,14 +320,11 @@ res)) (defn- handle-reaction-change! [^Reaction rx sender oldv newv] - (when-not (or (identical? oldv newv) (.getDirty rx)) - (let [auto-run (.getAutoRun rx)] - (ifs (nil? auto-run) - (do (.setDirty rx true) - ((.-enqueue-fn rx) (.-queue rx) rx)) - (true? auto-run) - (run-reaction! rx false) - (auto-run rx))))) + (when-not (or (identical? oldv newv) (not (.getComputed rx))) + (if (.getAlwaysRecompute rx) + (do (.setComputed rx false) ; TODO is this line necessary? + ((.-enqueue-fn rx) (.-queue rx) rx)) + (run-reaction! rx false)))) (defn- update-watching! [^Reaction rx derefed] (let [new (set derefed) ; TODO incrementally calculate `set` @@ -341,7 +336,7 @@ (#?(:clj remove-watch :cljs -remove-watch) w rx)))) (defn- run-reaction-from-queue! [^Reaction rx] - (when (and (.getDirty rx) (some? (.getWatching rx))) + (when-not (or (.getComputed rx) (nil? (.getWatching rx))) (run-reaction! rx true))) (defn flush! [queue] @@ -370,20 +365,30 @@ (defn ^Reaction >rx ([f] (>rx f nil)) - ([f {:keys [auto-run enqueue-fn eq-fn no-cache? on-set on-dispose queue]}] - (Reaction. auto-run nil nil true (or enqueue-fn *enqueue!*) (or eq-fn =) f - (if (nil? no-cache?) false no-cache?) on-dispose nil on-set (or queue *queue*) nil - nil nil nil))) + ([f {:keys [always-recompute? enqueue-fn eq-fn no-cache? on-set on-dispose queue]}] + (Reaction. (if (nil? always-recompute?) false always-recompute?) + nil + nil + false + (or enqueue-fn *enqueue!*) + (or eq-fn =) + f + (if (nil? no-cache?) false no-cache?) + on-dispose + nil + on-set + (or queue *queue*) + nil nil nil nil))) #?(:clj (defmacro rx [& body] `(>rx (fn [] ~@body)))) +#?(:clj (defmacro eager-rx [& body] `(>rx (fn [] ~@body) {:always-recompute? true}))) + #?(:clj (defmacro run! "Runs body immediately, and runs again whenever atoms deferenced in the body change. Body should side effect." [& body] - `(let [co# (>rx (fn [] ~@body) {:auto-run true})] - (deref co#) - co#))) + `(doto (rx ~@body) deref))) ;; ===== Track ===== ;; @@ -395,7 +400,7 @@ [^TrackableFn trackable-fn, args, ^:! ^:get ^:set ^quantum.untyped.core.data.reactive.Reaction rx] {;; IPrintWithWriter ;; (-pr-writer [a w opts] (pr-atom a w opts "Track:")) - PReactiveAtom {} + PReactive {} ?Deref {deref ([this] (if (nil? rx) (cached-reaction #(apply (.-f trackable-fn) args) @@ -413,7 +418,7 @@ ^Reaction r (m k nil)] (cond (some? r) (#?(:clj .deref :cljs -deref) r) - (nil? *ratom-context*) (f) + (nil? *atom-context*) (f) :else (let [r (>rx f {:on-dispose (fn [x] @@ -439,6 +444,6 @@ (defn >track! [f args opts] (let [t (>track f args) r (>rx #(#?(:clj .deref :cljs -deref) t) - {:auto-run true :queue (or (:queue opts) global-queue)})] + {:queue (or (:queue opts) global-queue)})] @r r)) diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index 990607d7..c287aa7b 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -1,71 +1,69 @@ (ns quantum.test.untyped.core.data.reactive "Tests adapted from `reagenttest.testratom`." + {:todo #{"Adapt tests from https://github.com/reagent-project/reagent/blob/master/test/reagenttest/testratomasync.cljs" + "Adapt tests from https://github.com/reagent-project/reagent/blob/master/test/reagenttest/testtrack.cljs"}} (:require [quantum.untyped.core.test :as utest - :refer [deftest is testing]] - [quantum.untyped.core.data.reactive :as self - :refer [dispose! flush! ratom rx]])) + :refer [deftest is is= testing]] + [quantum.untyped.core.data.reactive :as rx + :refer [dispose! eager-rx flush! rx]])) (defn with-debug [f] - (flush! self/global-queue) - (binding [self/*debug?* true] (f))) + (flush! rx/global-queue) + (binding [rx/*debug?* true] (f))) (utest/use-fixtures :once with-debug) -(defn- running [] @@#'self/*running) +(defn- running [] @@#'rx/*running) (defn test-perf [] ;; (set! debug? false) ; yes but we need to think about CLJ (dotimes [_ 10] - (let [a (ratom 0) + (let [a (rx/atom 0) f (fn [] (quot (long @a) 10)) - q (@#'self/alist) - mid (self/>rx f {:queue q}) - res (self/>track! (fn [] (inc (long @mid))) [] {:queue q})] + q (@#'rx/alist) + mid (rx/>rx f {:queue q}) + res (rx/>track! (fn [] (inc (long @mid))) [] {:queue q})] @res - (time (dotimes [_ 100000] ; ~70ms per 100K + (time (dotimes [_ 100000] ; ~70ms per 100K in CLJ so 0.0007ms for one (0.7 µs or 700 ns) (swap! a inc) - (@#'self/flush! q))) + (@#'rx/flush! q))) (dispose! res)))) -(deftest basic-ratom - (binding [self/*enqueue!* @#'self/alist-conj!] +(deftest basic-atom + (binding [rx/*enqueue!* @#'rx/alist-conj!] (let [runs (running) - start (ratom 0) - sv (rx @start) - comp (rx @sv (+ 2 @sv)) - c2 (rx (inc @comp)) - ct (ratom 0) - out (ratom 0) - res (rx (swap! ct inc) - @sv @c2 @comp) - const (self/run! (reset! out @res))] + start (rx/atom 0) + sv (eager-rx @start) + comp (eager-rx @sv (+ 2 @sv)) + c2 (eager-rx (inc @comp)) + ct (rx/atom 0) + out (rx/atom 0) + res (eager-rx (swap! ct inc) @sv @c2 @comp) + const (rx/run! (reset! out @res))] (is (= @ct 1) "constrain ran") (is (= @out 2)) (reset! start 1) - (flush! self/global-queue) + (flush! rx/global-queue) (is (= @out 3)) ; not correct; showing 2 (is (<= 2 @ct 3)) (dispose! const) (is (= (running) runs))))) (deftest double-dependency - (let [runs (running) - start (ratom 0) - c3-count (ratom 0) - c1 (rx @start 1) - c2 (rx @start) - c3 (self/>rx - (fn [] - (swap! c3-count inc) - (+ @c1 @c2)) - {:auto-run true :queue self/global-queue})] - (flush! self/global-queue) + (let [runs (running) + start (rx/atom 0) + c3-count (rx/atom 0) + c1 (eager-rx @start 1) + c2 (eager-rx @start) + c3 (rx (swap! c3-count inc) + (+ @c1 @c2))] + (flush! rx/global-queue) (is (= @c3-count 0)) (is (= @c3 1)) (is (= @c3-count 1) "t1") (swap! start inc) - (flush! self/global-queue) + (flush! rx/global-queue) (is (= @c3-count 2) "t2") (is (= @c3 2)) (is (= @c3-count 2) "t3") @@ -74,21 +72,17 @@ (deftest test-from-reflex ; https://github.com/lynaghk/reflex (let [runs (running)] - (let [*counter (ratom 0) - *signal (ratom "All I do is change") - co (self/run! - ;; when I change... - @*signal - ;; update the counter - (swap! *counter inc))] + (let [*counter (rx/atom 0) + *signal (rx/atom "All I do is change") + co (rx/run! @*signal (swap! *counter inc))] (is (= 1 @*counter) "Constraint run on init") (reset! *signal "foo") - (flush! self/global-queue) + (flush! rx/global-queue) (is (= 2 @*counter) "Counter auto updated") (dispose! co)) - (let [*x (ratom 0) - *co (self/>rx #(inc @*x) {:auto-run true :queue self/global-queue})] + (let [*x (rx/atom 0) + *co (rx (inc @*x))] (is (= 1 @*co) "CO has correct value on first deref") (swap! *x inc) (is (= 2 @*co) "CO auto-updates") @@ -97,17 +91,19 @@ (deftest test-unsubscribe (dotimes [x 10] - (let [runs (running) - a (ratom 0) - a1 (rx (inc @a)) - a2 (rx @a) - b-changed (ratom 0) - c-changed (ratom 0) - b (rx (swap! b-changed inc) - (inc @a1)) - c (rx (swap! c-changed inc) - (+ 10 @a2)) - res (self/run! (if (< @a2 1) @b @c))] + (let [runs (running) + a (rx/atom 0) + a1 (eager-rx (inc @a)) + a2 (eager-rx @a) + b-changed (rx/atom 0) + c-changed (rx/atom 0) + b (eager-rx + (swap! b-changed inc) + (inc @a1)) + c (eager-rx + (swap! c-changed inc) + (+ 10 @a2)) + res (rx/run! (if (< @a2 1) @b @c))] (is (= @res (+ 2 @a))) (is (= @b-changed 1)) (is (= @c-changed 0)) @@ -140,126 +136,126 @@ (deftest maybe-broken (let [runs (running)] (let [runs (running) - a (ratom 0) - b (rx (inc @a)) - c (rx (dec @a)) - d (rx (str @b)) - res (ratom 0) - cs (self/run! (reset! res @d))] + a (rx/atom 0) + b (eager-rx (inc @a)) + c (eager-rx (dec @a)) + d (eager-rx (str @b)) + res (rx/atom 0) + cs (rx/run! (reset! res @d))] (is (= @res "1")) (dispose! cs)) ;; should be broken according to https://github.com/lynaghk/reflex/issues/1 ;; but isnt - (let [a (ratom 0) - b (rx (inc @a)) - c (rx (dec @a)) - d (self/run! [@b @c])] + (let [a (rx/atom 0) + b (eager-rx (inc @a)) + c (eager-rx (dec @a)) + d (rx/run! [@b @c])] (is (= @d [1 -1])) (dispose! d)) - (let [a (ratom 0) - b (rx (inc @a)) - c (rx (dec @a)) - d (self/run! [@b @c]) - res (ratom 0)] + (let [a (rx/atom 0) + b (eager-rx (inc @a)) + c (eager-rx (dec @a)) + d (rx/run! [@b @c]) + res (rx/atom 0)] (is (= @d [1 -1])) - (let [e (self/run! (reset! res @d))] + (let [e (rx/run! (reset! res @d))] (is (= @res [1 -1])) (dispose! e)) (dispose! d)) (is (= (running) runs)))) (deftest test-dispose - (dotimes [x 10] - (let [runs (running) - a (ratom 0) - disposed (ratom nil) - disposed-c (ratom nil) - disposed-cns (ratom nil) - count-b (ratom 0) - b (self/>rx (fn [] - (swap! count-b inc) - (inc @a)) - {:on-dispose (fn [r] (reset! disposed true)) - :queue self/global-queue}) - c (self/>rx #(if (< @a 1) (inc @b) (dec @a)) - {:on-dispose (fn [r] (reset! disposed-c true)) - :queue self/global-queue}) - res (ratom nil) - cns (self/>rx #(reset! res @c) - {:auto-run true - :on-dispose (fn [r] (reset! disposed-cns true)) - :queue self/global-queue})] - @cns - (is (= @res 2)) - (is (= (+ 4 runs) (running))) - (is (= @count-b 1)) - (reset! a -1) - (flush! self/global-queue) - (is (= @res 1)) - (is (= @disposed nil)) - (is (= @count-b 2)) - (is (= (+ 4 runs) (running)) "still running") - (reset! a 2) - (flush! self/global-queue) - (is (= @res 1)) - (is (= @disposed true)) - (is (= (+ 2 runs) (running)) "less running count") + (binding [rx/*enqueue!* @#'rx/alist-conj!] + (dotimes [x 10] + (let [runs (running) + a (rx/atom 0) + disposed (rx/atom nil) + disposed-c (rx/atom nil) + disposed-cns (rx/atom nil) + count-b (rx/atom 0) + b (rx/>rx (fn [] (swap! count-b inc) (inc @a)) + {:always-recompute? true + :on-dispose (fn [r] (reset! disposed true)) + :queue rx/global-queue}) + c (rx/>rx #(if (< @a 1) (inc @b) (dec @a)) + {:always-recompute? true + :on-dispose (fn [r] (reset! disposed-c true)) + :queue rx/global-queue}) + res (rx/atom nil) + cns (rx/>rx #(reset! res @c) + {:on-dispose (fn [r] (reset! disposed-cns true)) + :queue rx/global-queue})] + @cns + (is (= @res 2)) + (is (= (+ 4 runs) (running))) + (is (= @count-b 1)) + (reset! a -1) + (flush! rx/global-queue) + (is (= @res 1)) + (is (= @disposed nil)) + (is (= @count-b 2)) + (is (= (+ 4 runs) (running)) "still running") + (reset! a 2) + (flush! rx/global-queue) + (is (= @res 1)) + (is (= @disposed true)) + (is (= (+ 2 runs) (running)) "less running count") - (reset! disposed nil) - (reset! a -1) - (flush! self/global-queue) - ;; This fails sometimes on node. I have no idea why. - (is (= 1 @res) "should be one again") - (is (= @disposed nil)) - (reset! a 2) - (flush! self/global-queue) - (is (= @res 1)) - (is (= @disposed true)) - (dispose! cns) - (is (= @disposed-c true)) - (is (= @disposed-cns true)) - (is (= runs (running)))))) + (reset! disposed nil) + (reset! a -1) + (flush! rx/global-queue) + ;; This fails sometimes on node. I have no idea why. + (is (= 1 @res) "should be one again") + (is (= @disposed nil)) + (reset! a 2) + (flush! rx/global-queue) + (is (= @res 1)) + (is (= @disposed true)) + (dispose! cns) + (is (= @disposed-c true)) + (is (= @disposed-cns true)) + (is (= runs (running))))))) (deftest test-add-dispose (dotimes [x 10] (let [runs (running) - a (ratom 0) - disposed (ratom nil) - disposed-c (ratom nil) - disposed-cns (ratom nil) - count-b (ratom 0) - b (self/>rx (fn [] (swap! count-b inc) (inc @a)) {:queue self/global-queue}) - c (self/>rx #(if (< @a 1) (inc @b) (dec @a)) {:queue self/global-queue}) - res (ratom nil) - cns (self/>rx #(reset! res @c) {:auto-run true :queue self/global-queue})] - (self/add-on-dispose! b (fn [r] + a (rx/atom 0) + disposed (rx/atom nil) + disposed-c (rx/atom nil) + disposed-cns (rx/atom nil) + count-b (rx/atom 0) + b (eager-rx (swap! count-b inc) (inc @a)) + c (eager-rx (if (< @a 1) (inc @b) (dec @a))) + res (rx/atom nil) + cns (rx (reset! res @c))] + (rx/add-on-dispose! b (fn [r] (is (= r b)) (reset! disposed true))) - (self/add-on-dispose! c (fn [r] (reset! disposed-c true))) - (self/add-on-dispose! cns (fn [r] (reset! disposed-cns true))) + (rx/add-on-dispose! c (fn [r] (reset! disposed-c true))) + (rx/add-on-dispose! cns (fn [r] (reset! disposed-cns true))) @cns (is (= @res 2)) (is (= (+ 4 runs) (running))) (is (= @count-b 1)) (reset! a -1) - (flush! self/global-queue) + (flush! rx/global-queue) (is (= @res 1)) (is (= @disposed nil)) (is (= @count-b 2)) (is (= (+ 4 runs) (running)) "still running") (reset! a 2) - (flush! self/global-queue) + (flush! rx/global-queue) (is (= @res 1)) (is (= @disposed true)) (is (= (+ 2 runs) (running)) "less running count") (reset! disposed nil) (reset! a -1) - (flush! self/global-queue) + (flush! rx/global-queue) (is (= 1 @res) "should be one again") (is (= @disposed nil)) (reset! a 2) - (flush! self/global-queue) + (flush! rx/global-queue) (is (= @res 1)) (is (= @disposed true)) (dispose! cns) @@ -269,12 +265,10 @@ (deftest test-on-set (let [runs (running) - a (ratom 0) - b (self/>rx #(+ 5 @a) - {:auto-run true - :on-set (fn [oldv newv] - (reset! a (+ 10 newv))) - :queue self/global-queue})] + a (rx/atom 0) + b (rx/>rx #(+ 5 @a) + {:on-set (fn [oldv newv] (reset! a (+ 10 newv))) + :queue rx/global-queue})] @b (is (= 5 @b)) (reset! a 1) @@ -287,8 +281,8 @@ (deftest non-reactive-deref (let [runs (running) - a (ratom 0) - b (self/>rx #(+ 5 @a))] + a (rx/atom 0) + b (eager-rx (+ 5 @a))] (is (= @b 5)) (is (= runs (running))) @@ -296,112 +290,162 @@ (is (= @b 6)) (is (= runs (running))))) -(deftest reset-in-reaction +(deftest rx/ (let [runs (running) - state (ratom {}) - c1 (rx (get-in @state [:data :a])) - c2 (rx (get-in @state [:data :b])) - rxn (self/>rx - #(let [cc1 @c1 - cc2 @c2] - (swap! state assoc :derived (+ (or cc1 0) (or cc2 0))) - nil) - {:auto-run true :queue self/global-queue})] + state (rx/atom {}) + c1 (eager-rx (get-in @state [:data :a])) + c2 (eager-rx (get-in @state [:data :b])) + rxn (rx (let [cc1 @c1, cc2 @c2] + (swap! state assoc :derived (+ (or cc1 0) (or cc2 0))) + nil))] @rxn (is (= (:derived @state) 0)) (swap! state assoc :data {:a 1 :b 2}) - (flush! self/global-queue) + (flush! rx/global-queue) (is (= (:derived @state) 3)) (swap! state assoc :data {:a 11 :b 22}) - (flush! self/global-queue) + (flush! rx/global-queue) (is (= (:derived @state) 33)) (dispose! rxn) (is (= runs (running))))) (deftest exception-recover (let [runs (running) - state (ratom 1) - count (ratom 0) - r (self/run! + state (rx/atom 1) + count (rx/atom 0) + r (rx/run! (swap! count inc) (when (> @state 1) (throw (ex-info "oops" {}))))] (is (= @count 1)) (is (thrown? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) (do (swap! state inc) - (flush! self/global-queue)))) + (flush! rx/global-queue)))) (is (= @count 2)) (swap! state dec) - (flush! self/global-queue) + (flush! rx/global-queue) (is (= @count 3)) (dispose! r) (is (= runs (running))))) (deftest exception-recover-indirect (let [runs (running) - state (ratom 1) - count (ratom 0) - ref (rx (when (= @state 2) - (throw (ex-info "err" {})))) - r (self/run! + state (rx/atom 1) + count (rx/atom 0) + ref (eager-rx (when (= @state 2) + (throw (ex-info "err" {})))) + r (rx/run! (swap! count inc) @ref)] (is (= @count 1)) (is (thrown? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) (do (swap! state inc) - (flush! self/global-queue)))) + (flush! rx/global-queue)))) (is (= @count 2)) (is (thrown? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) @ref)) (swap! state inc) - (flush! self/global-queue) + (flush! rx/global-queue) (is (= @count 3)) (dispose! r) (is (= runs (running))))) (deftest exception-side-effect - (binding [self/*enqueue!* @#'self/alist-conj!] + (binding [rx/*enqueue!* @#'rx/alist-conj!] (let [runs (running) - state (ratom {:val 1}) - rstate (rx @state) + state (rx/atom {:val 1}) + rstate (eager-rx @state) spy (atom nil) - r1 (self/run! @rstate) - r2 (let [val (rx (:val @rstate))] - (self/run! + r1 (rx/run! @rstate) + r2 (let [val (eager-rx (:val @rstate))] + (rx/run! (reset! spy @val) (is (some? @val)))) - r3 (self/run! + r3 (rx/run! (when (:error? @rstate) (throw (ex-info "Error detected!" {}))))] (swap! state assoc :val 2) - (flush! self/global-queue) + (flush! rx/global-queue) (swap! state assoc :error? true) (is (thrown? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) - (flush! self/global-queue))) - (flush! self/global-queue) - (flush! self/global-queue) + (flush! rx/global-queue))) + (flush! rx/global-queue) + (flush! rx/global-queue) (dispose! r1) (dispose! r2) (dispose! r3) (is (= runs (running)))))) (deftest exception-reporting - (binding [self/*enqueue!* @#'self/alist-conj!] + (binding [rx/*enqueue!* @#'rx/alist-conj!] (let [runs (running) - state (ratom {:val 1}) - rstate (rx (:val @state)) - r1 (self/run! + state (rx/atom {:val 1}) + rstate (eager-rx (:val @state)) + r1 (rx/run! (when (= @rstate 13) (throw (ex-info "fail" {}))))] (swap! state assoc :val 13) (is (thrown? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) - (flush! self/global-queue))) + (flush! rx/global-queue))) (swap! state assoc :val 2) - (flush! self/global-queue) + (flush! rx/global-queue) (dispose! r1) (is (= runs (running)))))) -(deftest ratom-with-meta - (let [value {:val 1} +(deftest atom-with-meta + (let [value {:val 1} meta-value {:meta-val 1} - state (with-meta (ratom value) meta-value)] + state (with-meta (rx/atom value) meta-value)] (is (= (meta state) meta-value)) (is (= @state value)))) + +(deftest test-eager-vs-lazy-reaction + (let [a (rx/atom 123) + b-ct (atom 0) + b (eager-rx (swap! b-ct inc) (+ @a 2)) + c-ct (atom 0) + c (eager-rx (swap! c-ct inc) (* @b -1)) + b-lazy-ct (atom 0) + b-lazy (rx (swap! b-lazy-ct inc) (+ @a 2)) + c-lazy-ct (atom 0) + c-lazy (rx (swap! c-lazy-ct inc) (* @b-lazy -1))] + (testing "eager" + @c + (is= @b-ct 1) + (is= @c-ct 1) + @c + (is= @b-ct 2) + (is= @c-ct 2) + @c + (is= @b-ct 3) + (is= @c-ct 3) + + (reset! a 234) + + @c + (is= @b-ct 4) + (is= @c-ct 4)) + + (testing "lazy" + @c-lazy + (is= @b-lazy-ct 1) + (is= @c-lazy-ct 1) + @c-lazy + (is= @b-lazy-ct 1) + (is= @c-lazy-ct 1) + @c-lazy + (is= @b-lazy-ct 1) + (is= @c-lazy-ct 1) + + (reset! a 234) + + @c-lazy + (is= @b-lazy-ct 2) + (is= @c-lazy-ct 1) + + (reset! a 123) + + @c-lazy + (is= @b-lazy-ct 3) + (is= @c-lazy-ct 2) + @c-lazy + (is= @b-lazy-ct 3) + (is= @c-lazy-ct 2)))) From 3927240a781fd851c223d0aca76f66659470e83e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 14:53:53 -0600 Subject: [PATCH 569/810] Add some notes and fix compilation --- resources-dev/defnt.cljc | 3 ++- src-untyped/quantum/untyped/core/data/reactive.cljc | 6 ++++-- test/quantum/test/untyped/core/data/reactive.cljc | 2 +- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 19ef3333..958ed802 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -34,7 +34,7 @@ Note that for anything built-in js/, the `t/isa?` predicates might nee `(let [expr# ~expr] ~@body expr#))) - +(rx @) @@ -86,6 +86,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative [ ] - Non-boxed `def`s: `(var/def- min-float (Numeric/negate Float/MAX_VALUE))` - `(t/validate x (t/* t/string?))` for `(t/* t/string?)` needs to be more performant - Don't re-create type on each call + - replace `deref` with `ref/deref` in typed contexts? So we can do `@` still - Type Logic and Predicates - We should probably have a 'normal form' so we can correctly hash if we do spec lookup - t/- : fix diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index 000adc98..7215cfc7 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -322,7 +322,7 @@ (defn- handle-reaction-change! [^Reaction rx sender oldv newv] (when-not (or (identical? oldv newv) (not (.getComputed rx))) (if (.getAlwaysRecompute rx) - (do (.setComputed rx false) ; TODO is this line necessary? + (do (.setComputed rx false) ((.-enqueue-fn rx) (.-queue rx) rx)) (run-reaction! rx false)))) @@ -386,7 +386,8 @@ #?(:clj (defmacro run! - "Runs body immediately, and runs again whenever atoms deferenced in the body change. Body should side effect." + "Runs body immediately, and runs again whenever atoms deferenced in the body change. Body should + side effect." [& body] `(doto (rx ~@body) deref))) @@ -396,6 +397,7 @@ (declare cached-reaction) +;; For perf test in `quantum.test.untyped.core.data.reactive`. TODO excise? (udt/deftype Track [^TrackableFn trackable-fn, args, ^:! ^:get ^:set ^quantum.untyped.core.data.reactive.Reaction rx] {;; IPrintWithWriter diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index c287aa7b..7c0da37e 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -290,7 +290,7 @@ (is (= @b 6)) (is (= runs (running))))) -(deftest rx/ +(deftest reset-in-reaction (let [runs (running) state (rx/atom {}) c1 (eager-rx (get-in @state [:data :a])) From ffbc313223ed0eef9c7367c755b8ed14de81b188 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 16:26:27 -0600 Subject: [PATCH 570/810] Remove `watchesArr` --- resources-dev/defnt.cljc | 37 ++++---- .../quantum/untyped/core/data/reactive.cljc | 85 +++++++++---------- .../test/untyped/core/data/reactive.cljc | 2 +- 3 files changed, 55 insertions(+), 69 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 958ed802..dbfdd918 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -33,11 +33,6 @@ Note that for anything built-in js/, the `t/isa?` predicates might nee [expr #_t/form?, & body #_(? (t/seq-of t/form?))] `(let [expr# ~expr] ~@body expr#))) - -(rx @) - - - ;; Truncation is different from safe coercion `>integer` is for e.g.: - truncation e.g. js/Math.trunc @@ -60,12 +55,19 @@ TODO: Note that `;; TODO TYPED` is the annotation we're using for this initiative - TODO implement the following: - [1] - t/input-type - - If fns ever get extended then it should trigger a chain-reaction of recompilations - [2] - t/output-type - - If fns ever get extended then it should trigger a chain-reaction of recompilations - [3] - Direct dispatch needs to actually work correctly in `t/defn` - [4] - t/numerically : e.g. a double representing exactly what a float is able to represent + [1] - Reactive recompilation + - Non-constant types should trigger a chain-reaction of recompilations for its + dependents/watchers when they change: + - t/input-type + - t/output-type + - `t/defn` that gets extended via `t/extend-defn!` (if the input-types and output-types have + changed) + - Examples + - (rx/rx @(t/output-type ...)) + - We want the reactivity to be explicit somehow but perhaps we want to hide the implementation?: + - (t/rx @(t/output-type ...)) + [2] - Direct dispatch needs to actually work correctly in typed contexts + [3] - t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. - t/numerically-integer? - Primitive conversions not requiring checks can go in data.primitive @@ -73,7 +75,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - numeric definitions - numeric ranges - numeric characteristics - [5] - No trailing `>` means `> ?` + [4] - No trailing `>` means `> ?`f - ? : type inference - use logic programming and variable unification e.g. `?1` `?2` ? - For this situation: `?` is `(t/- dc/counted?)` @@ -237,11 +239,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - t/dotyped - t/extend-defn! [ ] Ability to add output type restriction after the fact? - [ ] Should we trigger a recompilation of everything that depended on that `t/defn` because the - input-types and output-types will have both gotten bigger? (Maybe not on that overload but - still.) - - This will be a more advanced feature. For now we just accept that we might have some odd - behavior around extending `t/defn`s. - lazy compilation especially around `t/input-type` - equivalence of typed predicates (i.e. that which is `t/<=` `(t/fn [x t/any? :> p/boolean?])`) to types: @@ -1838,10 +1835,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative ever changes, `abcde` needs to be recompiled and `abcde`'s output type recomputed. If, on the other hand, `f`'s output type (given the input) ever changes, `abcde` need not be recompiled, but rather, only its output type need be recomputed. - - I think this reactive approach (do we need a library for that? probably not?) should - solve our problems and let us code in a very flexible way. It'll just (currently) be a - way that depends on a compiler in which the metalanguage and object language are - identical. + - I think this reactive approach should solve our problems and let us code in a very flexible + way. [ ] Runtime (Dynamic) Dispatch [—] Protocol generation - For now we won't do it because we can very often find the correct overload at compile diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index 7215cfc7..28d2f25d 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -1,5 +1,8 @@ (ns quantum.untyped.core.data.reactive - "Most of the content adapted from `reagent.ratom` 2018-10-20. + "Most of the content adapted from `reagent.ratom` 2018-10-20. Note that `lynaghk/reflex` was the + source of the Reagent Atom and Reaction (and before that https://knockoutjs.com/documentation/computedObservables.html, and before that probably + something else), and it makes do with 78 LOC (!) whereas we grapple with nearly 400 for + presumably very similar functionality. Perhaps someday this code can be compressed. Includes `Atom` and `Reaction`; may include `Subscription` at some point. @@ -81,40 +84,30 @@ new) (defprotocol PWatchable - (getWatches [this]) - (setWatches [this v]) - (getWatchesArr [this]) - (setWatchesArr [this v])) + (getWatches [this]) + (setWatches [this v])) -(defn- add-w! [^quantum.untyped.core.data.reactive.PWatchable this k f] - (let [w (.getWatches this)] - (.setWatches this (check-watches w (assoc w k f))) - (.setWatchesArr this nil))) +(defn- add-w! [^quantum.untyped.core.data.reactive.PWatchable x k f] + (let [w (.getWatches x)] + (.setWatches x (check-watches w (assoc w k f))) + x)) -(defn- remove-w! [^quantum.untyped.core.data.reactive.PWatchable this k] - (let [w (.getWatches this)] - (.setWatches this (check-watches w (dissoc w k))) - (.setWatchesArr this nil))) +(defn- remove-w! [^quantum.untyped.core.data.reactive.PWatchable x k] + (let [w (.getWatches x)] + (.setWatches x (check-watches w (dissoc w k))) + x)) (defn- conj-kv! [#?(:clj ^ArrayList xs :cljs xs) k v] (-> xs (alist-conj! k) (alist-conj! v))) -(defn- notify-w! [^quantum.untyped.core.data.reactive.PWatchable this old new] - (let [w (.getWatchesArr this) - #?(:clj ^ArrayList a :cljs a) - (if (nil? w) - ;; Copy watches to array-list for speed - (->> (.getWatches this) - (reduce-kv conj-kv! (alist)) - (.setWatchesArr this)) - w)] - (let [len (long (alist-count a))] - (loop [i (int 0)] - (when (< i len) - (let [k (alist-get a i) - f (alist-get a (unchecked-inc-int i))] - (f k this old new)) - (recur (+ 2 i))))))) +(defn- notify-w! [^quantum.untyped.core.data.reactive.PWatchable x old new] + ;; Unlike Reagent, we do not copy to an array-list because in order to do so, we have to traverse + ;; the map anyway if the watches have changed. Plus we avoid garbage (except for the closure). + ;; Reagent optimizes for the case that watches will more rarely change than not. It would be nice + ;; to avoid that tradeoff by having a sufficiently fast reduction. + (when-some [w #?(:clj ^clojure.lang.IKVReduce (.getWatches x) :cljs ^non-native (.getWatches x))] + (#?(:clj .kvreduce :cljs -kv-reduce) w (fn [_ k f] (f k x old new)) nil)) + x) #?(:cljs (defn- pr-atom! [a writer opts s] @@ -141,7 +134,7 @@ (alist-conj! c derefed) (.setCaptured r (alist derefed)))))) -(udt/deftype Atom [^:! state meta validator ^:! watches ^:! watchesArr] +(udt/deftype Atom [^:! state meta validator ^:! watches] {;; IPrintWithWriter ;; (-pr-writer [a w opts] (pr-atom a w opts "Atom:")) PReactiveAtom {} @@ -153,10 +146,13 @@ (when-not (nil? validator) (assert (validator new-value) "Validator rejected reference state")) (let [old-value state] - (set! state new-value) - (when-not (nil? watches) - (notify-w! a old-value new-value)) - new-value)) + (if (identical? old-value new-value) + new-value + (let [old-value state] + (set! state new-value) + (when-not (nil? watches) + (notify-w! a old-value new-value)) + new-value)))) swap! (([a f] (#?(:clj .reset :cljs -reset!) a (f state))) ([a f x] (#?(:clj .reset :cljs -reset!) a (f state x))) ([a f x y] (#?(:clj .reset :cljs -reset!) a (f state x y))) @@ -164,17 +160,15 @@ ?Watchable {add-watch! ([this k f] (add-w! this k f)) remove-watch! ([this k] (remove-w! this k))} PWatchable {getWatches ([this] watches) - setWatches ([this v] (set! watches v)) - getWatchesArr ([this] watchesArr) - setWatchesArr ([this v] (set! watchesArr v))} + setWatches ([this v] (set! watches v))} ?Meta {meta ([_] meta) - with-meta ([_ meta'] (Atom. state meta' validator watches watchesArr))} + with-meta ([_ meta'] (Atom. state meta' validator watches))} #?@(:cljs [?Hash {hash ([_] (goog/getUid this))}])}) (defn atom "Reactive 'atom'. Like `core/atom`, except that it keeps track of derefs." - ([x] (Atom. x nil nil nil nil)) - ([x & {:keys [meta validator]}] (Atom. x meta validator nil nil))) + ([x] (Atom. x nil nil nil)) + ([x & {:keys [meta validator]}] (Atom. x meta validator nil))) ;; ===== Reaction ("Computed Observable") ===== ;; @@ -204,8 +198,7 @@ queue ^:! ^:get ^:set state ^:! ^:get ^:set watching ; i.e. 'dependents' - ^:! watches - ^:! watchesArr] + ^:! watches] {;; IPrintWithWriter ;; (-pr-writer [a w opts] (pr-atom a w opts (str "Reaction " (hash a) ":"))) ?Equals {= ([this that] (identical? this that))} @@ -233,10 +226,8 @@ (empty? watches) (true? alwaysRecompute)) (.dispose this))))} - PWatchable {getWatches ([this] watches) - setWatches ([this v] (set! watches v)) - getWatchesArr ([this] watchesArr) - setWatchesArr ([this v] (set! watchesArr v))} + PWatchable {getWatches ([this] watches) + setWatches ([this v] (set! watches v))} ?Atom {reset! ([a newv] (assert (fn? (.-on-set a)) "Reaction is read only; on-set is not allowed") @@ -378,7 +369,7 @@ nil on-set (or queue *queue*) - nil nil nil nil))) + nil nil nil))) #?(:clj (defmacro rx [& body] `(>rx (fn [] ~@body)))) diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index 7c0da37e..bb16e86d 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -435,7 +435,7 @@ (is= @b-lazy-ct 1) (is= @c-lazy-ct 1) - (reset! a 234) + (reset! a 234) ; resetting to the same state @c-lazy (is= @b-lazy-ct 2) From e765ac7b9739ae6c66a46d457f91067649281264 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 16:41:52 -0600 Subject: [PATCH 571/810] Add some optimization notes --- .../quantum/untyped/core/data/reactive.cljc | 33 +++++++++---------- 1 file changed, 16 insertions(+), 17 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index 28d2f25d..5e99ee6d 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -112,7 +112,7 @@ #?(:cljs (defn- pr-atom! [a writer opts s] (-write writer (str "#<" s " ")) - (pr-writer (binding [*atom-context* nil] (-deref a)) writer opts) + (pr-writer (binding [*atom-context* nil] (-deref ^non-native a)) writer opts) (-write writer ">"))) ;; ===== Atom ===== ;; @@ -198,7 +198,7 @@ queue ^:! ^:get ^:set state ^:! ^:get ^:set watching ; i.e. 'dependents' - ^:! watches] + ^:! watches] ; TODO consider a mutable map for `watches` {;; IPrintWithWriter ;; (-pr-writer [a w opts] (pr-atom a w opts (str "Reaction " (hash a) ":"))) ?Equals {= ([this that] (identical? this that))} @@ -262,7 +262,8 @@ (alist-conj! a f) (set! (.-on-dispose-arr this) (alist f))))}}) -(defn- peek-at [^Reaction rx] (binding [*atom-context* nil] (#?(:clj .deref :cljs -deref) rx))) +(defn- peek-at [^Reaction rx] + (binding [*atom-context* nil] #?(:clj (.deref rx) :cljs (-deref ^non-native rx)))) (defn- in-context "When f is executed, if (f) derefs any atoms, they are then added to @@ -298,17 +299,15 @@ (defn- run-reaction! [^Reaction rx check?] (let [old-state (.getState rx) - res (if check? + new-state (if check? (try-capture! rx (.-f rx)) (deref-capture! (.-f rx) rx))] (when-not (.-no-cache? rx) - (.setState rx res) - ;; Use = to determine equality from reactions, since - ;; they are likely to produce new data structures. + (.setState rx new-state) (when-not (or (nil? (.getWatches rx)) - (= old-state res)) - (notify-w! rx old-state res))) - res)) + ((.-eq-fn rx) old-state new-state)) + (notify-w! rx old-state new-state))) + new-state)) (defn- handle-reaction-change! [^Reaction rx sender oldv newv] (when-not (or (identical? oldv newv) (not (.getComputed rx))) @@ -319,11 +318,11 @@ (defn- update-watching! [^Reaction rx derefed] (let [new (set derefed) ; TODO incrementally calculate `set` - old (set (.getWatching rx))] + old (set (.getWatching rx))] ; TODO incrementally calculate `set` (.setWatching rx derefed) - (doseq [w (set/difference new old)] + (doseq [w (set/difference new old)] ; TODO optimize (#?(:clj add-watch :cljs -add-watch) w rx handle-reaction-change!)) - (doseq [w (set/difference old new)] + (doseq [w (set/difference old new)] ; TODO optimize (#?(:clj remove-watch :cljs -remove-watch) w rx)))) (defn- run-reaction-from-queue! [^Reaction rx] @@ -398,7 +397,7 @@ (if (nil? rx) (cached-reaction #(apply (.-f trackable-fn) args) trackable-fn args this nil) - (#?(:clj .deref :cljs -deref) rx)))}} + #?(:clj (.deref rx) :cljs (-deref ^non-native rx))))}} ?Equals {= ([_ other] (and (instance? Track other) (-> ^Track other .-trackable-fn .-f (= (.-f trackable-fn))) @@ -410,7 +409,7 @@ m (if (nil? m) {} m) ^Reaction r (m k nil)] (cond - (some? r) (#?(:clj .deref :cljs -deref) r) + (some? r) #?(:clj (.deref r) :cljs (-deref ^non-native r)) (nil? *atom-context*) (f) :else (let [r (>rx f {:on-dispose @@ -425,7 +424,7 @@ (destroy-fn x))) ;; Inherits the queue :queue (some-> t .getRx .-queue)}) - v (#?(:clj .deref :cljs -deref) r)] + v #?(:clj (.deref r) :cljs (-deref ^non-native r))] (.setRxCache trackable-fn (assoc m k r)) (when (true? *debug?*) (swap! *running inc)) (when (some? t) @@ -436,7 +435,7 @@ (defn >track! [f args opts] (let [t (>track f args) - r (>rx #(#?(:clj .deref :cljs -deref) t) + r (>rx (fn [] #?(:clj (.deref t) :cljs (-deref ^non-native t))) {:queue (or (:queue opts) global-queue)})] @r r)) From 3e6cd2e695985984ea8ed17a46a32c58ed956435 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 16:41:59 -0600 Subject: [PATCH 572/810] Add some notes about reactive types --- resources-dev/defnt.cljc | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index dbfdd918..89d29868 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -59,13 +59,20 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - Non-constant types should trigger a chain-reaction of recompilations for its dependents/watchers when they change: - t/input-type + - changed via `t/extend-defn!` - t/output-type + - changed via `t/extend-defn!` - `t/defn` that gets extended via `t/extend-defn!` (if the input-types and output-types have changed) - Examples - - (rx/rx @(t/output-type ...)) - - We want the reactivity to be explicit somehow but perhaps we want to hide the implementation?: - - (t/rx @(t/output-type ...)) + - (t/rx @(t/rx-input-type ...)) + - (t/rx @(t/rx-output-type ...)) + - One could imagine a dynamic set of types corresponding to a given predicate, e.g. + `decimal?`. Say someone comes up with a new `decimal?`-like class and wants to redefine + `decimal?` to accommodate. We could define `decimal?` as a reactive/extensible type to + do this. However, it seems preferable to instead define a marker protocol called + `PDecimal` or some such and put that on the defined `deftype` itself, and incorporate + `PDecimal` into `decimal?` from the start. [2] - Direct dispatch needs to actually work correctly in typed contexts [3] - t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. From f62c6f1a09016d9603eec2745f4f5afb9e9cf1b9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 22 Oct 2018 17:04:17 -0600 Subject: [PATCH 573/810] A little more of a comment --- resources-dev/defnt.cljc | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 89d29868..f08dfbf3 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -65,8 +65,13 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - `t/defn` that gets extended via `t/extend-defn!` (if the input-types and output-types have changed) - Examples - - (t/rx @(t/rx-input-type ...)) - - (t/rx @(t/rx-output-type ...)) + - (t/input-type ...) + - This returns a `PReactive` in an arglist context for extensible targets (i.e. `t/defn` + but not `t/fn`). This is because the `:type` of a `defn` is reactive. + - Thus there is no special behavior for `input|output-type` but just special behavior + for the underlying type. + - (t/output-type ...) + - Same as above - One could imagine a dynamic set of types corresponding to a given predicate, e.g. `decimal?`. Say someone comes up with a new `decimal?`-like class and wants to redefine `decimal?` to accommodate. We could define `decimal?` as a reactive/extensible type to From 33f62510471b2433526171c5c64f32f51242c852 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 23 Oct 2018 14:48:30 -0600 Subject: [PATCH 574/810] Add some hashing macros --- .../quantum/untyped/core/data/hash.cljc | 37 ++++++++++++------- 1 file changed, 23 insertions(+), 14 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/hash.cljc b/src-untyped/quantum/untyped/core/data/hash.cljc index 201f05ff..a2cce0f6 100644 --- a/src-untyped/quantum/untyped/core/data/hash.cljc +++ b/src-untyped/quantum/untyped/core/data/hash.cljc @@ -18,6 +18,13 @@ (def ordered hash-unordered-coll) (def mix mix-collection-hash) +#?(:clj +;; Macro for efficiency; we will demacro in the typed version +(defmacro unordered-args [& args] + `(-> 0 ~@(->> args (map (fn [arg] `(unchecked-add-int (hash ~arg))))) + (mix-collection-hash ~(count args)) + int))) + #?(:clj (defmacro caching-set-unordered! "Tries to retrive an cached unordered hash value at the provided field. If not found, sets the @@ -26,12 +33,18 @@ See also https://clojure.org/reference/data_structures." [field #_simple-symbol? & args] `(if (identical? ~field default) - (set! ~field - (-> 0 ~@(->> args (map (fn [arg] `(unchecked-add-int (hash ~arg))))) - (mix-collection-hash ~(count args)) - int)) + (set! ~field (unordered-args ~@args)) ~field))) +#?(:clj +;; Macro for efficiency; we will demacro in the typed version +(defmacro ordered-args [& args] + `(-> 1 ~@(->> args (map (fn [arg] + `(-> (unchecked-multiply-int 31) + (unchecked-add-int (hash ~arg)))))) + (mix-collection-hash ~(count args)) + int))) + #?(:clj (defmacro caching-set-ordered! "Tries to retrive an cached ordered hash value at the provided field. If not found, sets the @@ -40,17 +53,13 @@ See also https://clojure.org/reference/data_structures." [field #_simple-symbol? & args] `(if (identical? ~field default) - (set! ~field - (-> 1 ~@(->> args (map (fn [arg] - `(-> (unchecked-multiply-int 31) - (unchecked-add-int (hash ~arg)))))) - (mix-collection-hash ~(count args)) - int)) + (set! ~field (ordered-args ~@args)) ~field))) -(defn hash-unordered [collection] - (-> (reduce unchecked-add-int 0 (map hash collection)) - (mix-collection-hash (count collection)))) +#?(:clj +;; Macro for efficiency; we will demacro in the typed version +(defmacro code-args [& args] + `(-> 0 ~@(->> args (map (fn [arg] `(unchecked-add-int (code ~arg)))))))) #?(:clj (defmacro caching-set-code! @@ -58,5 +67,5 @@ with a computed hash-code using the sum of the hash-codes of the provided args." [field #_simple-symbol? & args] `(if (identical? ~field default) - (set! ~field (-> 0 ~@(->> args (map (fn [arg] `(unchecked-add-int (code ~arg))))))) + (set! ~field (code-args ~@args)) ~field))) From 16688a2de72121a3f381f37fd42e102bf3a677bd Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 23 Oct 2018 14:48:35 -0600 Subject: [PATCH 575/810] Some brief notes --- resources-dev/defnt.cljc | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index f08dfbf3..10906f19 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -65,8 +65,11 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - `t/defn` that gets extended via `t/extend-defn!` (if the input-types and output-types have changed) - Examples + - Every `t/` needs to accommodate for reactive types now + - t/defn needs to emit a reactive ftype in its `::type` meta + - quantum.untyped.core.data.reactive - (t/input-type ...) - - This returns a `PReactive` in an arglist context for extensible targets (i.e. `t/defn` + - This returns a `PReactive` for extensible targets (i.e. `t/defn` but not `t/fn`). This is because the `:type` of a `defn` is reactive. - Thus there is no special behavior for `input|output-type` but just special behavior for the underlying type. From e8ef7f2061e95b4570e718d7be92c6c6698424e6 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 23 Oct 2018 14:48:44 -0600 Subject: [PATCH 576/810] Add `norx-deref` --- .../quantum/untyped/core/data/reactive.cljc | 28 ++++++++++--------- 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index 5e99ee6d..a30419d3 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -77,12 +77,15 @@ (defonce global-queue (alist)) -(defn #?(:clj reactive? :cljs ^boolean reactive?) [] (some? *atom-context*)) - (defn- check-watches [old new] (when (true? *debug?*) (swap! *running + (- (count new) (count old)))) new) +(defn norx-deref [rx] + (binding [*atom-context* nil] + #?(:clj (.deref ^clojure.lang.IDeref rx) + :cljs (-deref ^non-native rx)))) + (defprotocol PWatchable (getWatches [this]) (setWatches [this v])) @@ -137,7 +140,7 @@ (udt/deftype Atom [^:! state meta validator ^:! watches] {;; IPrintWithWriter ;; (-pr-writer [a w opts] (pr-atom a w opts "Atom:")) - PReactiveAtom {} + PReactive nil ?Equals {= ([this that] (identical? this that))} ?Deref {deref ([this] (notify-deref-watcher! this) @@ -181,7 +184,7 @@ (defn dispose! [x] (dispose x)) (defn add-on-dispose! [x f] (addOnDispose x f)) -(declare flush! peek-at run-reaction! update-watching!) +(declare flush! run-reaction! update-watching!) (udt/deftype Reaction [^:! ^boolean ^:get alwaysRecompute @@ -203,7 +206,7 @@ ;; (-pr-writer [a w opts] (pr-atom a w opts (str "Reaction " (hash a) ":"))) ?Equals {= ([this that] (identical? this that))} #?@(:cljs [?Hash {hash ([this] (goog/getUid this))}]) - PReactive {} + PReactive nil ?Deref {deref ([this] (if-not (nil? caught) (throw caught) @@ -236,10 +239,10 @@ ((.-on-set a) oldv newv) (notify-w! a oldv newv) newv)) - swap! (([a f] (#?(:clj .reset :cljs -reset!) a (f (peek-at a)))) - ([a f x] (#?(:clj .reset :cljs -reset!) a (f (peek-at a) x))) - ([a f x y] (#?(:clj .reset :cljs -reset!) a (f (peek-at a) x y))) - ([a f x y more] (#?(:clj .reset :cljs -reset!) a (apply f (peek-at a) x y more))))} + swap! (([a f] (#?(:clj .reset :cljs -reset!) a (f (norx-deref a)))) + ([a f x] (#?(:clj .reset :cljs -reset!) a (f (norx-deref a) x))) + ([a f x y] (#?(:clj .reset :cljs -reset!) a (f (norx-deref a) x y))) + ([a f x y more] (#?(:clj .reset :cljs -reset!) a (apply f (norx-deref a) x y more))))} PHasCaptured {getCaptured ([this] captured) setCaptured ([this v] (set! captured v))} @@ -262,9 +265,6 @@ (alist-conj! a f) (set! (.-on-dispose-arr this) (alist f))))}}) -(defn- peek-at [^Reaction rx] - (binding [*atom-context* nil] #?(:clj (.deref rx) :cljs (-deref ^non-native rx)))) - (defn- in-context "When f is executed, if (f) derefs any atoms, they are then added to 'obj.captured'(*atom-context*). @@ -392,7 +392,7 @@ [^TrackableFn trackable-fn, args, ^:! ^:get ^:set ^quantum.untyped.core.data.reactive.Reaction rx] {;; IPrintWithWriter ;; (-pr-writer [a w opts] (pr-atom a w opts "Track:")) - PReactive {} + PReactive nil ?Deref {deref ([this] (if (nil? rx) (cached-reaction #(apply (.-f trackable-fn) args) @@ -439,3 +439,5 @@ {:queue (or (:queue opts) global-queue)})] @r r)) + +(defn #?(:clj reactive? :cljs ^boolean reactive?) [x] (satisfies? PReactive x)) From 90187e2a7be75b273bf53e033816434c54bde672 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 23 Oct 2018 14:48:55 -0600 Subject: [PATCH 577/810] Fix `parse-impls` to not overwrite --- .../untyped/core/form/generate/deftype.cljc | 35 ++++++++++++++++++- 1 file changed, 34 insertions(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/form/generate/deftype.cljc b/src-untyped/quantum/untyped/core/form/generate/deftype.cljc index fab5bac7..4e69d050 100644 --- a/src-untyped/quantum/untyped/core/form/generate/deftype.cljc +++ b/src-untyped/quantum/untyped/core/form/generate/deftype.cljc @@ -262,11 +262,44 @@ (@#'cljs.core/build-positional-factory t r fields)) ~t)))) +(defn- parse-impls + "Exists because `clojure.core/parse-impls` overwrites when interface, impls, same interface, more + impls." + {:adapted-from 'clojure.core/parse-impls} + [specs] + (loop [ret {} s specs] + (if (seq s) + (recur (update ret (first s) #(concat % (take-while seq? (next s)))) + (drop-while seq? (next s))) + ret))) + +(defn- parse-opts+specs + "Exists because `clojure.core/parse-impls` overwrites when interface, impls, same interface, more + impls." + {:adapted-from 'clojure.core/parse-opts+specs} + [opts+specs] + (let [[opts specs] (@#'clojure.core/parse-opts opts+specs) + impls (parse-impls specs) + interfaces (-> (map #(if (var? (resolve %)) + (:on (deref (resolve %))) + %) + (keys impls)) + set + (disj 'Object 'java.lang.Object) + vec) + methods (->> impls vals (apply concat) + (map (fn [[name params & body]] + (cons name (@#'clojure.core/maybe-destructured params body)))))] + (when-let [bad-opts (seq (remove #{:no-print :load-ns} (keys opts)))] + (throw (IllegalArgumentException. + ^String (apply print-str "Unsupported option(s) -" bad-opts)))) + [interfaces methods opts])) + #?(:clj (defn- deftype|clj [env name fields & opts+specs] (@#'clojure.core/validate-fields fields name) (let [gname name - [interfaces methods opts] (@#'clojure.core/parse-opts+specs opts+specs) + [interfaces methods opts] (parse-opts+specs opts+specs) ns-part (namespace-munge *ns*) classname (symbol (str ns-part "." gname)) hinted-fields fields From 19a295bfcff3add89ccbfc2bfa00b21d49e3e960 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 23 Oct 2018 14:49:02 -0600 Subject: [PATCH 578/810] Fix prefer-method for print-method --- src-untyped/quantum/untyped/core/print/prettier.cljc | 1 + 1 file changed, 1 insertion(+) diff --git a/src-untyped/quantum/untyped/core/print/prettier.cljc b/src-untyped/quantum/untyped/core/print/prettier.cljc index 017938b0..b7f4a211 100644 --- a/src-untyped/quantum/untyped/core/print/prettier.cljc +++ b/src-untyped/quantum/untyped/core/print/prettier.cljc @@ -18,6 +18,7 @@ #?(:clj (prefer-method print-method fipp.ednize.IEdn clojure.lang.IPersistentMap)) #?(:clj (prefer-method print-method fipp.ednize.IEdn java.util.Map)) #?(:clj (prefer-method print-method fipp.ednize.IEdn clojure.lang.ISeq)) +#?(:clj (prefer-method print-method fipp.ednize.IEdn clojure.lang.IDeref)) #?(:clj (prefer-method print-method clojure.lang.IRecord Throwable)) #?(:clj (in-ns 'fipp.visit)) From 7b736661e82cb6a9315d339d1449d3815a012084 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 23 Oct 2018 14:49:24 -0600 Subject: [PATCH 579/810] Add `t/rx` --- src-untyped/quantum/untyped/core/type.cljc | 16 +++++- .../untyped/core/type/reifications.cljc | 53 ++++++++++++++++++- test/quantum/test/untyped/core/type.cljc | 11 ++++ 3 files changed, 77 insertions(+), 3 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index b4bbf4be..263cced5 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -28,6 +28,7 @@ [quantum.untyped.core.core :as ucore] [quantum.untyped.core.data.bits :as ubit] [quantum.untyped.core.data.hash :as uhash] + [quantum.untyped.core.data.reactive :as urx] [quantum.untyped.core.data.set :as uset :refer [ident >ident]] [quantum.untyped.core.data.tuple] @@ -37,6 +38,8 @@ :refer [err! TODO catch-all]] [quantum.untyped.core.fn :as ufn :refer [fn1 rcomp <- fn->]] + [quantum.untyped.core.form + :refer [$]] [quantum.untyped.core.form.generate.deftype :as udt] [quantum.untyped.core.identifiers :refer [>symbol]] @@ -70,7 +73,8 @@ NotType OrType AndType ProtocolType ClassType UnorderedType OrderedType ValueType - FnType]))) + FnType + ReactiveType]))) (ucore/log-this-ns) @@ -96,6 +100,16 @@ (uvar/defalias utr/empty-set) +;; ----- ReactiveType (`t/rx`) ----- ;; + +(defns rx* [r urx/reactive?, body-codelist _ > utr/reactive-type?] + (ReactiveType. uhash/default uhash/default nil body-codelist nil r)) + +#?(:clj +(defmacro rx + "The only macro in all of the core type predicates." + [& body] `(rx* (urx/rx ~@body) ($ ~(vec body))))) + ;; ----- NotType (`t/not` / `t/!`) ----- ;; (defns not [t utr/type? > utr/type?] diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 0aaf70d9..08c30155 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -2,6 +2,7 @@ (:refer-clojure :exclude [==]) (:require + [clojure.core :as core] [clojure.set :as set] [fipp.ednize :as fedn] [quantum.untyped.core.analyze.expr @@ -10,11 +11,11 @@ :refer [== not==]] [quantum.untyped.core.core :as ucore] [quantum.untyped.core.data.hash :as uhash] - + [quantum.untyped.core.data.reactive :as urx] [quantum.untyped.core.defnt :refer [defns]] [quantum.untyped.core.error - :refer [TODO]] + :refer [err! TODO]] [quantum.untyped.core.form :as uform :refer [>form]] [quantum.untyped.core.form.generate.deftype :as udt] @@ -414,3 +415,51 @@ (fn [x] (-> x (update :output-type-pair :type) (update :input-types vec) (set/rename-keys {:output-type-pair :output-type})))))) + +;; ----- ReactiveType ----- ;; + +(defn- validate-type [x] + (or (type? x) + (err! "Found non-type when derefing `ReactiveType`" + {:kind (core/type x)}))) + +(udt/deftype ReactiveType + [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) + #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) + meta #_(t/? ::meta) + body-codelist #_(t/seq-of form?) + ^:! v #_(t/? type?) + rx #_(t/isa? urx/PReactive)] + {PType nil + urx/PReactive nil + ?Fn {invoke ([_ x] (let [t (urx/norx-deref rx)] + (validate-type t) + (t x)))} + ?Meta {meta ([this] meta) + with-meta ([this meta'] (ReactiveType. hash hash-code meta' body-codelist v rx))} + ?Hash {hash ([this] (let [v' (urx/norx-deref rx)] + (if (identical? v' v) + (uhash/caching-set-ordered! hash ReactiveType v) + (do (validate-type v') + (set! v v') + (set! hash (uhash/ordered-args ReactiveType v')))))) + hash-code ([this] (let [v' (urx/norx-deref rx)] + (if (identical? v' v) + (uhash/caching-set-code! hash-code ReactiveType v) + (do (validate-type v') + (set! v v') + (set! hash-code + (uhash/code-args ReactiveType v'))))))} + ?Equals {= ([this that #_any?] + (or (== this that) + (and (instance? ReactiveType that) + ;; TODO determine if this should be reactive or not + (= (doto (urx/norx-deref rx) validate-type) + (urx/norx-deref that)))))} + ?Deref {deref ([this] (doto @rx validate-type))} + uform/PGenForm {>form ([this] (-> (list* 'quantum.untyped.core.type/rx body-codelist) + (accounting-for-meta meta)))} + fedn/IOverride nil + fedn/IEdn {-edn ([this] (>form this))}}) + +(defn reactive-type? [x] (instance? ReactiveType x)) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 6b20881b..febb7018 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -538,3 +538,14 @@ (is= string? (t/output-type >namespace|type)) (is= (t/or char-seq? comparable?) (t/output-type reduce|type)) (is= char-seq? (t/output-type reduce|type [:_ :_ string?]))) + +(deftest test|rx + (testing "=" + ;; TODO use a generator + (doseq [gen-t [#(t/isa? #?(:clj Double :cljs js/Number)) + #(do t/empty-set) + #(do t/universal-set) + #(t/value 1) + #(t/value "abc") + #(t/or (t/isa? #?(:clj Double :cljs js/Number)) (t/value "abc"))]] + (= (t/rx (gen-t)) (t/rx (gen-t)))))) From 9a99e063f9de53ed7763d2400ac06d51a271c1bb Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 23 Oct 2018 23:13:29 -0600 Subject: [PATCH 580/810] Every `t/` now accommodates reactive types --- resources-dev/defnt.cljc | 10 +- src-untyped/quantum/untyped/core/analyze.cljc | 7 +- .../quantum/untyped/core/collections.cljc | 15 +- src-untyped/quantum/untyped/core/type.cljc | 306 ++++++++++-------- .../untyped/core/type/reifications.cljc | 10 +- src/quantum/core/collections_typed.cljc | 10 +- src/quantum/core/data/identifiers.cljc | 4 +- src/quantum/core/data/primitive.cljc | 18 +- test/quantum/test/untyped/core/type.cljc | 18 +- 9 files changed, 216 insertions(+), 182 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 10906f19..3b2d3f3e 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -53,6 +53,8 @@ TODO: #_" Note that `;; TODO TYPED` is the annotation we're using for this initiative +- There will be some code duplication with untyped code for now and that's okay. +- No typed namespace should refer to any untyped namespace - TODO implement the following: [1] - Reactive recompilation @@ -65,16 +67,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - `t/defn` that gets extended via `t/extend-defn!` (if the input-types and output-types have changed) - Examples - - Every `t/` needs to accommodate for reactive types now - t/defn needs to emit a reactive ftype in its `::type` meta - quantum.untyped.core.data.reactive - - (t/input-type ...) - - This returns a `PReactive` for extensible targets (i.e. `t/defn` - but not `t/fn`). This is because the `:type` of a `defn` is reactive. - - Thus there is no special behavior for `input|output-type` but just special behavior - for the underlying type. - - (t/output-type ...) - - Same as above - One could imagine a dynamic set of types corresponding to a given predicate, e.g. `decimal?`. Say someone comes up with a new `decimal?`-like class and wants to redefine `decimal?` to accommodate. We could define `decimal?` as a reactive/extensible type to diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index e2d3143c..3f747958 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -675,9 +675,9 @@ caller|node (analyze* env caller|form) t (case (name caller|form) "type" (-> arg-nodes first :type) - "input-type" (apply t/input-type (-> arg-nodes first :type) + "input-type" (t/input-type (-> arg-nodes first :type) (->> arg-nodes rest (map :type) (map t/unvalue))) - "output-type" (apply t/output-type (-> arg-nodes first :type) + "output-type" (t/output-type (-> arg-nodes first :type) (->> arg-nodes rest (map :type) (map t/unvalue))))] (uast/call-node {:env env @@ -792,6 +792,7 @@ quote (analyze-seq|quote env form) new (analyze-seq|new env form) throw (analyze-seq|throw env form) + try (TODO "try") var (analyze-seq|var env form) (if (-> env :opts :arglist-context?) (if-let [caller-form-dependent-type-call? @@ -887,7 +888,7 @@ (ifs (symbol? form) (analyze-symbol env form) (t/literal? form) - (uast/literal env form (t/>type form)) + (uast/literal env form (t/value form)) (or (vector? form) (set? form)) ;; TODO use `uast/vector-node` and `uast/set-node` diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index 26bad8d2..bb7a7f7b 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -2,7 +2,8 @@ "Operations on collections." (:refer-clojure :exclude [#?(:cljs array?) assoc-in cat conj! contains? count distinct distinct? first get group-by - filter flatten last map map-indexed mapcat partition-all pmap remove reverse zipmap]) + filter flatten frequencies last map map-indexed mapcat partition-all pmap remove reverse + zipmap]) (:require [clojure.core :as core] [fast-zip.core :as zip] @@ -331,6 +332,14 @@ xs (recur (dec n) (lcat xs))))) +(defn frequencies + "Like `frequencies` but uses `educe` internally" + [f xs] + (educe (fn ([] (transient {})) + ([cts] (persistent! cts)) + ([cts x] (assoc! cts x (inc (get cts x 0))))) + xs)) + (defn frequencies-by "Like `frequencies` crossed with `group-by`." {:in '[second [[1 2 3] [4 2 6] [5 2 7]]] @@ -353,12 +362,12 @@ (defn group-by "Like `group-by` but uses `educe` internally" - [f coll] + [f xs] (educe (aritoid (fn' (transient {})) persistent! (fn [ret x] (let [k (f x)] (assoc! ret k (conj (get ret k []) x))))) - coll)) + xs)) (defn lcat [xs] (apply concat xs)) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 263cced5..86e54c7d 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -102,51 +102,84 @@ ;; ----- ReactiveType (`t/rx`) ----- ;; +(defn- deref-when-reactive [x] + (if (utr/reactive-type? x) + @x + x)) + +(defns- separate-rx-and-apply + "Only works for commutative functions." + [f fn?, type-args (fn-> count (c/> 1)) > utr/type?] + ;; For efficiency, so as much as possible gets run outside a reaction + (if-let [rx-args (->> type-args (filter utr/reactive-type?) seq)] + (if-let [norx-args (->> type-args (remove utr/reactive-type?) seq)] + (let [t (f norx-args)] + (rx (f (cons t (map deref rx-args))))) + (rx (f (map deref rx-args)))) + (f type-args))) + (defns rx* [r urx/reactive?, body-codelist _ > utr/reactive-type?] (ReactiveType. uhash/default uhash/default nil body-codelist nil r)) #?(:clj (defmacro rx - "The only macro in all of the core type predicates." + "Creates a reactive type. + + The only macro in all of the core type predicates. + + Note that if a type-generating fn (e.g. `and` or `or`) is provided with even one reactive input, + then the whole type will become reactive. Thus, reactivity is 'infectious'." [& body] `(rx* (urx/rx ~@body) ($ ~(vec body))))) ;; ----- NotType (`t/not` / `t/!`) ----- ;; (defns not [t utr/type? > utr/type?] - (ifs (= t universal-set) empty-set - (= t empty-set) universal-set - (= t val|by-class?) nil? - (utr/not-type? t) (utr/not-type>inner-type t) + (ifs (utr/reactive-type? t) (rx (not @t)) + (= t universal-set) empty-set + (= t empty-set) universal-set + (= t val|by-class?) nil? + (utr/not-type? t) (utr/not-type>inner-type t) ;; DeMorgan's Law - (utr/or-type? t) (->> t utr/or-type>args (uc/lmap not) (apply and)) + (utr/or-type? t) (->> t utr/or-type>args (uc/lmap not) (apply and)) ;; DeMorgan's Law - (utr/and-type? t) (->> t utr/and-type>args (uc/lmap not) (apply or )) + (utr/and-type? t) (->> t utr/and-type>args (uc/lmap not) (apply or )) (NotType. uhash/default uhash/default nil t))) (uvar/defalias ! not) ;; ----- OrType (`t/or` / `t/|`) ----- ;; +(def- comparison-denotes-supersession?|or (fn1 c/= >ident)) + +(defn- or* [ts] + (create-logical-type :or ->OrType utr/or-type? utr/or-type>args + comparison-denotes-supersession?|or ts)) + (defn or "Sequential/ordered `or`. Analogous to `set/union`. Applies as much 'compression'/deduplication/simplification as possible to the supplied types. - Effectively computes the union of the extension of the ->`args`." + Effectively computes the union of the extension of the ->`ts`." ([] empty-set) - ([arg & args] - (create-logical-type :or ->OrType utr/or-type? utr/or-type>args - (cons arg args) (fn1 c/= >ident)))) + ([t] t) + ([t & ts] (separate-rx-and-apply or* (cons t ts)))) (uvar/defalias | or) ;; ----- AndType (`t/and` | `t/&`) ----- ;; +(def- comparison-denotes-supersession?|and (fn1 c/= AndType utr/and-type? utr/and-type>args + comparison-denotes-supersession?|and ts)) + (defn and "Sequential/ordered `and`. Analogous to `set/intersection`. Applies as much 'compression'/deduplication/simplification as possible to the supplied types. - Effectively computes the intersection of the extension of the ->`args`." - [arg & args] - (create-logical-type :and ->AndType utr/and-type? utr/and-type>args - (cons arg args) (fn1 c/= `ts`." + ([] universal-set) + ([t] t) + ([t & ts] (separate-rx-and-apply and* (cons t ts)))) (uvar/defalias & and) @@ -183,28 +216,36 @@ "Creates a type representing an unordered collection." ([> utr/unordered-type?] (unordered [])) ([data _ > utr/unordered-type?] - (let [data' (if (utr/type? data) - {data 1} - (if-not (sequential? data) - (err! "Finite type info must be sequential" {:type (c/type data)}) - (if-not (seq-and utr/type? data) - (err! "Not every element of finite type data is a type" {}) - (frequencies data))))] - (UnorderedType. uhash/default uhash/default nil data' nil))) + (ifs (utr/reactive-type? data) + (rx (UnorderedType. uhash/default uhash/default nil {@data 1} nil)) + (utr/type? data) + (UnorderedType. uhash/default uhash/default nil {data 1} nil) + (c/not (sequential? data)) + (err! "Finite type info must be sequential" {:type (c/type data)}) + (c/not (seq-and utr/type? data)) + (err! "Not every element of finite type data is a type") + (seq-or utr/reactive-type? data) + (rx (UnorderedType. uhash/default uhash/default nil + (->> data (uc/map+ deref-when-reactive) uc/frequencies) nil)) + (UnorderedType. uhash/default uhash/default nil (frequencies data) nil))) ([datum _ & data _ > utr/unordered-type?] (unordered (cons datum data)))) (defns ordered "Creates a type representing an ordered collection." ([> utr/ordered-type?] (ordered [])) ([data _ > utr/ordered-type?] - (let [data' (if (utr/type? data) - [data] - (if-not (sequential? data) - (err! "Finite type info must be sequential" {:type (c/type data)}) - (if-not (seq-and utr/type? data) - (err! "Not every element of finite type data is a type" {}) - data)))] - (OrderedType. uhash/default uhash/default nil data' nil))) + (ifs (utr/reactive-type? data) + (rx (OrderedType. uhash/default uhash/default nil [@data] nil)) + (utr/type? data) + (OrderedType. uhash/default uhash/default nil [data] nil) + (c/not (sequential? data)) + (err! "Finite type info must be sequential" {:type (c/type data)}) + (c/not (seq-and utr/type? data)) + (err! "Not every element of finite type data is a type") + (seq-or utr/reactive-type? data) + (rx (OrderedType. uhash/default uhash/default nil + (->> data (uc/map+ deref-when-reactive) uc/frequencies) nil)) + (OrderedType. uhash/default uhash/default nil data nil))) ([datum _ & data _ > utr/ordered-type?] (ordered (cons datum data)))) ;; ----- ValueType ----- ;; @@ -254,64 +295,32 @@ If `t0` > | >< `t1`, `t0` with all elements of `t1` removed" ([t0 utr/type? > utr/type?] t0) ([t0 utr/type?, t1 utr/type? > utr/type?] - (let [c (compare t0 t1)] - (case c - (0 -1) empty-set - 3 t0 - (1 2) - (let [c0 (c/type t0) c1 (c/type t1)] - ;; TODO add dispatch? - (condp == c0 - NotType (condp == (-> t0 utr/not-type>inner-type c/type) - ClassType (condp == c1 - ClassType (AndType. uhash/default uhash/default nil - [t0 (not t1)] (atom nil))) - ValueType (condp == c1 - ValueType (AndType. uhash/default uhash/default nil - [t0 (not t1)] (atom nil)))) - OrType (condp == c1 - ClassType (-|or t0 t1) - ValueType (-|or t0 t1))))))) + (if (utr/reactive-type? t0) + (if (utr/reactive-type? t1) + (rx (- @t0 @t1)) + (rx (- @t0 t1))) + (if (utr/reactive-type? t1) + (rx (- t0 @t1)) + (let [c (c/int (compare t0 t1))] + (case c + (0 -1) empty-set + 3 t0 + (1 2) + (let [c0 (c/type t0) c1 (c/type t1)] + ;; TODO add dispatch? + (condp == c0 + NotType (condp == (-> t0 utr/not-type>inner-type c/type) + ClassType (condp == c1 + ClassType (AndType. uhash/default uhash/default nil + [t0 (not t1)] (atom nil))) + ValueType (condp == c1 + ValueType (AndType. uhash/default uhash/default nil + [t0 (not t1)] (atom nil)))) + OrType (condp == c1 + ClassType (-|or t0 t1) + ValueType (-|or t0 t1))))))))) ([t0 utr/type?, t1 utr/type? & ts _ > utr/type?] (reduce - (- t0 t1) ts))) -;; TODO clean up -(defns >type - "Coerces ->`x` to a type, recording its ->`name-sym` if provided." - ([x _ > utr/type?] (>type x nil)) - ([x _, name-sym (us/nilable c/symbol?) > utr/type?] - #?(:clj - (ifs - (satisfies? PType x) - x ; TODO should add in its name? - (c/class? x) - (let [x (c/or #?(:clj (utcore/unboxed->boxed x)) x) - reg (if (c/nil? name-sym) - @*type-registry - (swap! *type-registry - (c/fn [reg] - (if-let [t (get reg name-sym)] - (if (c/= (.-name ^ClassType t) name-sym) - reg - (err! "Class already registered with type; must first undef" - {:class x :type-name name-sym})) - (let [t (ClassType. uhash/default uhash/default nil x name-sym)] - (uc/assoc-in reg [name-sym] t - [:by-class x] t))))))] - (c/or (get-in reg [:by-class x]) - (ClassType. uhash/default uhash/default nil ^Class x name-sym))) - (c/fn? x) - (let [sym (c/or name-sym (>symbol x)) - _ (when-not name-sym - (let [resolved (?deref (ns-resolve *ns* sym))] - (assert (== resolved x) {:x x :sym sym :resolved resolved})))] - (Expression. sym x)) - (c/nil? x) - nil? - (uclass/protocol? x) - (ProtocolType. uhash/default uhash/default nil x name-sym) - (value x)) - :cljs nil))) - (def type? (isa? PType)) (def not-type? (isa? NotType)) (def or-type? (isa? OrType)) @@ -324,26 +333,36 @@ (def nil? (value nil)) (def object? (isa? #?(:clj java.lang.Object :cljs js/Object))) -;; ===== Type metadata ===== ;; +;; ===== Type metadata (not for reactive types) ===== ;; (defns assume "Denotes that, whatever the declared output type (to which `assume` is applied) of a function may be, it is assumed that the output satisfies that type." - [t utr/type? > utr/type?] (update-meta t assoc :quantum.core.type/assume? true)) + [t utr/type? > utr/type?] + (assert (c/not (utr/reactive-type? t))) + (update-meta t assoc :quantum.core.type/assume? true)) -(defns unassume [t utr/type? > utr/type?] (update-meta t dissoc :quantum.core.type/assume?)) +(defns unassume [t utr/type? > utr/type?] + (assert (c/not (utr/reactive-type? t))) + (update-meta t dissoc :quantum.core.type/assume?)) (defns * "Denote on a type that it must be enforced at runtime. For use with `defnt`." - [t utr/type? > utr/type?] (update-meta t assoc :quantum.core.type/runtime? true)) + [t utr/type? > utr/type?] + (assert (c/not (utr/reactive-type? t))) + (update-meta t assoc :quantum.core.type/runtime? true)) (defns ref "Denote on a type that it must not be expanded to use primitive values. For use with `defnt`." - [t utr/type? > utr/type?] (update-meta t assoc :quantum.core.type/ref? true)) + [t utr/type? > utr/type?] + (assert (c/not (utr/reactive-type? t))) + (update-meta t assoc :quantum.core.type/ref? true)) -(defns unref [t utr/type? > utr/type?] (update-meta t dissoc :quantum.core.type/ref?)) +(defns unref [t utr/type? > utr/type?] + (assert (c/not (utr/reactive-type? t))) + (update-meta t dissoc :quantum.core.type/ref?)) ;; ===== Logical ===== ;; @@ -443,7 +462,7 @@ (defn- simplify-logical-type|structural-identity+ "Simplification via structural identity: `(| a b a)` -> `(| a b)`" [type-args #_(of reducible? utr/type?)] - (->> type-args (uc/map+ >type) uc/distinct+)) + (->> type-args uc/distinct+)) (defn- simplify-logical-type|comparison "Simplification via intension comparison" @@ -458,19 +477,17 @@ type-args)) (defns- create-logical-type - [kind #{:or :and}, construct-fn _, type-pred _, type>args _, type-args (fn-> count (c/>= 1)) - comparison-denotes-supersession? c/fn? > utr/type?] - (if (-> type-args count (c/= 1)) - (first type-args) - (let [simplified - (->> type-args - (simplify-logical-type|inner-expansion+ type-pred type>args) - simplify-logical-type|structural-identity+ - (simplify-logical-type|comparison kind comparison-denotes-supersession?))] - (assert (-> simplified count (c/>= 1))) ; for internal implementation correctness - (if (-> simplified count (c/= 1)) - (first simplified) - (construct-fn uhash/default uhash/default nil simplified (atom nil)))))) + [kind #{:or :and}, construct-fn _, type-pred _, type>args _ + comparison-denotes-supersession? c/fn?, type-args (fn-> count (c/>= 1)) > utr/type?] + (let [simplified + (->> type-args + (simplify-logical-type|inner-expansion+ type-pred type>args) + simplify-logical-type|structural-identity+ + (simplify-logical-type|comparison kind comparison-denotes-supersession?))] + (assert (-> simplified count (c/>= 1))) ; for internal implementation correctness + (if (-> simplified count (c/= 1)) + (first simplified) + (construct-fn uhash/default uhash/default nil simplified (atom nil))))) ;; ===== `t/ftype` ===== ;; @@ -530,45 +547,56 @@ seq) (reduced nil)))))))) -(defns input-type - "Outputs the type of a specified input to a typed fn. +(defn- input-type*|norx [t args] + (let [i|? (->> args (reducei (c/fn [_ t i] (when (c/= t :?) (reduced i))) nil))] + (->> (match-spec>type-data-seq t args) + (uc/lmap (c/fn [{:keys [input-types]}] (get input-types i|?))) + (apply or)))) + +(defns input-type* + "Outputs the type of a specified input to a typed fn." + [t utr/fn-type? args _ #_(us/seq-of (us/or* #{:_ :?} type?)) + | (->> args (filter #(c/= % :?)) count (c/= 1)) + > type?] + (if (seq-or utr/reactive-type? args) + (rx (input-type*|norx t (map deref-when-reactive args))) + (input-type*|norx t args))) - Usage in arglist contexts: - - `(t/input-type >namespace :?)` +(defn input-type + "Usage in arglist contexts: + - `(t/input-type >namespace [:?])` - Outputs the union of the possible types of the first input to `>namespace`. - - `(t/input-type reduce :_ :_ :?)` + - `(t/input-type reduce [:_ :_ :?])` - Outputs the union of the possible types of the third input to `reduce`. - - `(t/input-type reduce :? :_ string?)` + - `(t/input-type reduce [:? :_ string?])` - Outputs the union of the possible types of the first input to `reduce` when the third input - satisfies `string?`. + satisfies `string?`." + ([t] (err! "Can't use `input-type` outside of arglist contexts")) + ([t args] (err! "Can't use `input-type` outside of arglist contexts"))) - Usage outside of arglist contexts is the same except the first input must be a `utr/fn-type?`." - [t utr/fn-type? & args _ #_(us/seq-of (us/or* #{:_ :?} type?)) - | (->> args (filter #(c/= % :?)) count (c/= 1)) - > type?] - (let [i|? (->> args (reducei (c/fn [_ t i] (when (c/= t :?) (reduced i))) nil))] - (->> (match-spec>type-data-seq t args) - (uc/lmap (c/fn [{:keys [input-types]}] - (get input-types i|?))) - (apply or)))) +(defn- output-type*|norx [t args] + (->> (match-spec>type-data-seq t args) + (uc/lmap :output-type) + (apply or))) -(defns output-type - "Outputs the output type of a typed fn. +(defns output-type* + "Outputs the output type of a typed fn." + ([t utr/fn-type?] + (->> t utr/fn-type>arities (uc/mapcat+ val) (uc/map :output-type) (apply or))) + ([t utr/fn-type? args (us/seq-of (us/or* #{:_} type?)) > type?] + (if (seq-or utr/reactive-type? args) + (rx (output-type*|norx t (map deref-when-reactive args))) + (output-type*|norx t args)))) - Usage in arglist contexts: +(defn output-type + "Usage in arglist contexts: - `(t/output-type >namespace)` - Outputs the union of the possible output types of `>namespace` given any valid inputs at all - - `(t/output-type reduce :_ :_ string?)` + - `(t/output-type reduce [:_ :_ string?])` - Outputs the union of the possible output types of `reduce` when the third input satisfies - `string?`. - - Usage outside of arglist contexts is the same except the first input must be a `utr/fn-type?`." - ([t utr/fn-type?] - (->> t utr/fn-type>arities (uc/mapcat+ val) (uc/map :output-type) (apply or))) - ([t utr/fn-type? args (us/seq-of (us/or* #{:_} type?)) > type?] - (->> (match-spec>type-data-seq t args) - (uc/lmap :output-type) - (apply or)))) + `string?`." + ([t] (err! "Can't use `output-type` outside of arglist contexts")) + ([t args] (err! "Can't use `output-type` outside of arglist contexts"))) ;; ===== Dependent types ===== ;; @@ -591,10 +619,8 @@ (defns deducible [x type? > deducible-type?] (DeducibleType. (atom x)))) (defns ? - "Arity 1: Computes a type denoting a nilable value satisfying `t`. - Arity 2: Computes whether `x` is nil or satisfies `t`." - ([t utr/type? > utr/type?] (or nil? t)) - ([t utr/type?, x _ > c/boolean?] (c/or (c/nil? x) (t x)))) + "Computes a type denoting a nilable value satisfying `t`." + ([t utr/type? > utr/type?] (or nil? t))) ;; ===== Etc. ===== ;; diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 08c30155..cddc9989 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -418,12 +418,16 @@ ;; ----- ReactiveType ----- ;; +(declare reactive-type?) + (defn- validate-type [x] - (or (type? x) - (err! "Found non-type when derefing `ReactiveType`" + (or (and (type? x) (not (reactive-type? x))) + (err! "Found invalid value when derefing `ReactiveType`" {:kind (core/type x)}))) -(udt/deftype ReactiveType +(udt/deftype + ^{:doc "Warning: produces a possibly different hash every time its value is recomputed."} + ReactiveType [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_(t/? ::meta) diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index 37388b70..1c447033 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -367,9 +367,9 @@ Like `reduce`, does not have a notion of a transforming function (unlike `transduce`). Like `transduce`, uses the seed (0-arity) and completing (1-arity) arities of the reducing function `rf` when performing a reduction (unlike `reduce`)." - ([rf rf?, xs (t/input-type reduce :_ :_ :?)] (educe rf (rf) xs)) + ([rf rf?, xs (t/input-type reduce [:_ :_ :?])] (educe rf (rf) xs)) ([rf rf?, init t/any?, x dasync/read-chan?] (async/go (rf (async/ p/int?] (.size xs))) #?(:clj ([xs dc/java-map? > p/int?] (.size xs))) ;; Not counted - ([xs (t/input-type educe :_ :_ :?)] (educe count|rf xs))) + ([xs (t/input-type educe [:_ :_ :?])] (educe count|rf xs))) (t/defn ^:inline gen-bounded-count|rf [n dn/std-integer?] (t/fn {:inline true} @@ -416,7 +416,7 @@ (t/defn ^:inline bounded-count > dn/std-integer? ([n dn/std-integer?, xs dc/counted?] (count xs)) - ([n dn/std-integer?, xs (t/input-type educe :_ :_ :?)] (educe (gen-bounded-count|rf n) xs))) + ([n dn/std-integer?, xs (t/input-type educe [:_ :_ :?])] (educe (gen-bounded-count|rf n) xs))) (t/def ^:inline empty?|rf (fn/aritoid @@ -428,4 +428,4 @@ (t/defn ^:inline empty? > p/boolean? ([x p/nil?] true) ([xs dc/counted?] (-> xs count num/zero?)) - ([xs (t/input-type educe :_ :_ :?)] (educe empty?|rf x))) + ([xs (t/input-type educe [:_ :_ :?])] (educe empty?|rf x))) diff --git a/src/quantum/core/data/identifiers.cljc b/src/quantum/core/data/identifiers.cljc index 8e497e94..53b40e7f 100644 --- a/src/quantum/core/data/identifiers.cljc +++ b/src/quantum/core/data/identifiers.cljc @@ -71,8 +71,8 @@ (t/defn unqualify > symbol? [sym symbol?] (-> sym >name >symbol)) -(t/defn unqualified? [x (t/input-type >namespace t/?)] (-> x >namespace t/nil?)) -(t/defn qualified? [x (t/input-type >namespace t/?)] (-> x >namespace t/val?)) +(t/defn unqualified? [x (t/input-type >namespace [:?])] (-> x >namespace t/nil?)) +(t/defn qualified? [x (t/input-type >namespace [:?])] (-> x >namespace t/val?)) (def unqualified-keyword? (t/and keyword? unqualified?)) (def qualified-keyword? (t/and keyword? qualified?)) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index db37dba8..a30eb9fc 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -311,33 +311,33 @@ #?(:clj ([a primitive? , b (t/ref c?/icomparable?)] (.compareTo (box a) b)))) (t/extend-defn! c?/comp< - ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] + ([a (t/input-type c?/compare [:? :_]), b (t/input-type c?/compare [:_ :?])] (c?/< (c?/compare a b) 0))) (t/extend-defn! c?/comp<= - ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] + ([a (t/input-type c?/compare [:? :_]), b (t/input-type c?/compare [:_ :?])] (c?/<= (c?/compare a b) 0))) (t/extend-defn! c?/comp= - ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] + ([a (t/input-type c?/compare [:? :_]), b (t/input-type c?/compare [:_ :?])] (c?/= (c?/compare a b) 0))) (t/extend-defn! c?/comp>= - ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] + ([a (t/input-type c?/compare [:? :_]), b (t/input-type c?/compare [:_ :?])] (c?/>= (c?/compare a b) 0))) (t/extend-defn! c?/comp> - ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] + ([a (t/input-type c?/compare [:? :_]), b (t/input-type c?/compare [:_ :?])] (c?/> (c?/compare a b) 0))) (t/defn promote-type [a nil?, b nil?]) (t/defn narrowest > t/type? - ([t0 (t/and (t/input-type >min-safe-integer-value :?) - (t/input-type >max-safe-integer-value :?)) - t1 (t/and (t/input-type >min-safe-integer-value :?) - (t/input-type >max-safe-integer-value :?))] + ([t0 (t/and (t/input-type >min-safe-integer-value [:?]) + (t/input-type >max-safe-integer-value [:?])) + t1 (t/and (t/input-type >min-safe-integer-value [:?]) + (t/input-type >max-safe-integer-value [:?]))] (let [t0-min (>min-safe-integer-value t0) t1-min (>min-safe-integer-value t1) t0-max (>max-safe-integer-value t0) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index febb7018..f2686484 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -529,15 +529,15 @@ (def reduce|type (t/ftype t/any? [fn? t/any? string? :> char-seq?] [ifn? t/any? java-set? :> comparable?])) -(deftest test|input-type - (is= (t/or string? symbol?) (t/input-type >namespace|type :?)) - (is= (t/or string? java-set?) (t/input-type reduce|type :_ :_ :?))) - (is= fn? (t/input-type reduce|type :? :_ string?)) - -(deftest test|output-type - (is= string? (t/output-type >namespace|type)) - (is= (t/or char-seq? comparable?) (t/output-type reduce|type)) - (is= char-seq? (t/output-type reduce|type [:_ :_ string?]))) +(deftest test|input-type* + (is= (t/or string? symbol?) (t/input-type* >namespace|type [:?])) + (is= (t/or string? java-set?) (t/input-type* reduce|type [:_ :_ :?]))) + (is= fn? (t/input-type* reduce|type [:? :_ string?])) + +(deftest test|output-type* + (is= string? (t/output-type* >namespace|type)) + (is= (t/or char-seq? comparable?) (t/output-type* reduce|type)) + (is= char-seq? (t/output-type* reduce|type [:_ :_ string?]))) (deftest test|rx (testing "=" From 6c5cef0267f19586ef2e68a496c5aab758ad9bec Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 23 Oct 2018 23:29:54 -0600 Subject: [PATCH 581/810] Fix some compilation and tests --- .../quantum/untyped/core/data/reactive.cljc | 3 +- src-untyped/quantum/untyped/core/type.cljc | 34 +++++++++---------- test/quantum/test/untyped/core/type.cljc | 9 +++-- 3 files changed, 25 insertions(+), 21 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index a30419d3..fd72c4ac 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -14,6 +14,7 @@ (:refer-clojure :exclude [atom run!]) (:require + [clojure.core :as core] [clojure.set :as set] [quantum.untyped.core.async :as uasync] [quantum.untyped.core.core @@ -73,7 +74,7 @@ (def ^:dynamic #?(:clj *debug?* :cljs ^boolean *debug?*) false) -(defonce- *running (atom 0)) +(defonce- *running (core/atom 0)) (defonce global-queue (alist)) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 86e54c7d..e43ff69a 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -102,6 +102,19 @@ ;; ----- ReactiveType (`t/rx`) ----- ;; +(defns rx* [r urx/reactive?, body-codelist _ > utr/reactive-type?] + (ReactiveType. uhash/default uhash/default nil body-codelist nil r)) + +#?(:clj +(defmacro rx + "Creates a reactive type. + + The only macro in all of the core type predicates. + + Note that if a type-generating fn (e.g. `and` or `or`) is provided with even one reactive input, + then the whole type will become reactive. Thus, reactivity is 'infectious'." + [& body] `(rx* (urx/rx ~@body) ($ ~(vec body))))) + (defn- deref-when-reactive [x] (if (utr/reactive-type? x) @x @@ -109,7 +122,7 @@ (defns- separate-rx-and-apply "Only works for commutative functions." - [f fn?, type-args (fn-> count (c/> 1)) > utr/type?] + [f c/fn?, type-args (fn-> count (c/> 1)) > utr/type?] ;; For efficiency, so as much as possible gets run outside a reaction (if-let [rx-args (->> type-args (filter utr/reactive-type?) seq)] (if-let [norx-args (->> type-args (remove utr/reactive-type?) seq)] @@ -118,19 +131,6 @@ (rx (f (map deref rx-args)))) (f type-args))) -(defns rx* [r urx/reactive?, body-codelist _ > utr/reactive-type?] - (ReactiveType. uhash/default uhash/default nil body-codelist nil r)) - -#?(:clj -(defmacro rx - "Creates a reactive type. - - The only macro in all of the core type predicates. - - Note that if a type-generating fn (e.g. `and` or `or`) is provided with even one reactive input, - then the whole type will become reactive. Thus, reactivity is 'infectious'." - [& body] `(rx* (urx/rx ~@body) ($ ~(vec body))))) - ;; ----- NotType (`t/not` / `t/!`) ----- ;; (defns not [t utr/type? > utr/type?] @@ -156,7 +156,7 @@ comparison-denotes-supersession?|or ts)) (defn or - "Sequential/ordered `or`. Analogous to `set/union`. + "Unordered `or`. Analogous to `set/union`. Applies as much 'compression'/deduplication/simplification as possible to the supplied types. Effectively computes the union of the extension of the ->`ts`." ([] empty-set) @@ -174,7 +174,7 @@ comparison-denotes-supersession?|and ts)) (defn and - "Sequential/ordered `and`. Analogous to `set/intersection`. + "Unordered `and`. Analogous to `set/intersection`. Applies as much 'compression'/deduplication/simplification as possible to the supplied types. Effectively computes the intersection of the extension of the ->`ts`." ([] universal-set) @@ -244,7 +244,7 @@ (err! "Not every element of finite type data is a type") (seq-or utr/reactive-type? data) (rx (OrderedType. uhash/default uhash/default nil - (->> data (uc/map+ deref-when-reactive) uc/frequencies) nil)) + (->> data (uc/map deref-when-reactive)) nil)) (OrderedType. uhash/default uhash/default nil data nil))) ([datum _ & data _ > utr/ordered-type?] (ordered (cons datum data)))) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index f2686484..f530cc9a 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -136,7 +136,7 @@ (def protocol-types (->> [AProtocolAll AProtocolString AProtocolNonNil AProtocolOnlyNil AProtocolNone] - (map t/>type) set)) + (map t/isa?) set)) ) @@ -510,8 +510,11 @@ (t/unordered (t/value :g) (t/value :h)) (t/unordered (t/value :i) (t/value :j)))] (dotimes [i 100] - (is= false (t (->> { :a :b :c :d :e :f :g :h :i :j} - (map shuffle) shuffle (into {})))) + (let [base [[:a :b] [:c :d] [:e :f] [:g :h] [:i :j]] + shuffled (->> base (map shuffle) shuffle (into {}))] + (if (= base (->> shuffled (map sort))) + (is= true (t shuffled)) + (is= false (t shuffled)))) (is= true (t (->> (umap/om :a :b :c :d :e :f :g :h :i :j) (map shuffle) (into (umap/om))))) (is= true (t (->> (sorted-map :a :b :c :d :e :f :g :h :i :j) From f203fa2c60a647f663ce6447c785d4c0339f7342 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 24 Oct 2018 00:27:22 -0600 Subject: [PATCH 582/810] Further implement reactivity --- resources-dev/defnt.cljc | 1 + src-untyped/quantum/untyped/core/analyze.cljc | 7 ++-- .../quantum/untyped/core/data/reactive.cljc | 6 +-- src-untyped/quantum/untyped/core/type.cljc | 40 +++++++++++-------- .../untyped/core/type/reifications.cljc | 28 ++----------- src/quantum/core/data/numeric.cljc | 4 +- 6 files changed, 38 insertions(+), 48 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 3b2d3f3e..2355eb25 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -66,6 +66,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - changed via `t/extend-defn!` - `t/defn` that gets extended via `t/extend-defn!` (if the input-types and output-types have changed) + - We can `defonce` a `urx/atom` per `t/defn` and `reset!` on each `t/extend-defn!` - Examples - t/defn needs to emit a reactive ftype in its `::type` meta - quantum.untyped.core.data.reactive diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 3f747958..603d6231 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -673,11 +673,12 @@ {:form form :args-ct (count args-form)}) (let [arg-nodes (->> args-form (mapv #(analyze* env %))) caller|node (analyze* env caller|form) + caller|type (-> arg-nodes first :type) t (case (name caller|form) - "type" (-> arg-nodes first :type) - "input-type" (t/input-type (-> arg-nodes first :type) + "type" caller|type + "input-type" (t/input-type* caller|type (->> arg-nodes rest (map :type) (map t/unvalue))) - "output-type" (t/output-type (-> arg-nodes first :type) + "output-type" (t/output-type* caller|type (->> arg-nodes rest (map :type) (map t/unvalue))))] (uast/call-node {:env env diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index fd72c4ac..77829af2 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -213,7 +213,7 @@ (throw caught) (let [non-reactive? (nil? *atom-context*)] (when non-reactive? (flush! queue)) - (if (and non-reactive? (true? alwaysRecompute)) + (if (and non-reactive? alwaysRecompute) (when-not computed (let [old-state state] (set! state (f)) @@ -301,8 +301,8 @@ (defn- run-reaction! [^Reaction rx check?] (let [old-state (.getState rx) new-state (if check? - (try-capture! rx (.-f rx)) - (deref-capture! (.-f rx) rx))] + (try-capture! rx (.-f rx)) + (deref-capture! (.-f rx) rx))] (when-not (.-no-cache? rx) (.setState rx new-state) (when-not (or (nil? (.getWatches rx)) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index e43ff69a..b73f9495 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -547,6 +547,15 @@ seq) (reduced nil)))))))) +(defn- input-or-output-type-handle-reactive [f t args] + (if (utr/reactive-type? t) + (if (seq-or utr/reactive-type? args) + (rx (f @t (map deref-when-reactive args))) + (rx (f @t args))) + (if (seq-or utr/reactive-type? args) + (rx (f t (map deref-when-reactive args))) + (f t args)))) + (defn- input-type*|norx [t args] (let [i|? (->> args (reducei (c/fn [_ t i] (when (c/= t :?) (reduced i))) nil))] (->> (match-spec>type-data-seq t args) @@ -555,22 +564,22 @@ (defns input-type* "Outputs the type of a specified input to a typed fn." - [t utr/fn-type? args _ #_(us/seq-of (us/or* #{:_ :?} type?)) + [t (us/or* utr/fn-type? utr/reactive-type?) args _ #_(us/seq-of (us/or* #{:_ :?} type?)) | (->> args (filter #(c/= % :?)) count (c/= 1)) > type?] - (if (seq-or utr/reactive-type? args) - (rx (input-type*|norx t (map deref-when-reactive args))) - (input-type*|norx t args))) + (input-or-output-type-handle-reactive input-type*|norx t args)) (defn input-type "Usage in arglist contexts: - `(t/input-type >namespace [:?])` - - Outputs the union of the possible types of the first input to `>namespace`. + - Outputs a reactive type embodying the union of the possible types of the first input to + `>namespace`. - `(t/input-type reduce [:_ :_ :?])` - - Outputs the union of the possible types of the third input to `reduce`. + - Outputs a reactive type embodying the union of the possible types of the third input to + `reduce`. - `(t/input-type reduce [:? :_ string?])` - - Outputs the union of the possible types of the first input to `reduce` when the third input - satisfies `string?`." + - Outputs a reactive type embodying the union of the possible types of the first input to + `reduce` when the third input satisfies `string?`." ([t] (err! "Can't use `input-type` outside of arglist contexts")) ([t args] (err! "Can't use `input-type` outside of arglist contexts"))) @@ -581,20 +590,19 @@ (defns output-type* "Outputs the output type of a typed fn." - ([t utr/fn-type?] + ([t (us/or* utr/fn-type? utr/reactive-type?)] (->> t utr/fn-type>arities (uc/mapcat+ val) (uc/map :output-type) (apply or))) - ([t utr/fn-type? args (us/seq-of (us/or* #{:_} type?)) > type?] - (if (seq-or utr/reactive-type? args) - (rx (output-type*|norx t (map deref-when-reactive args))) - (output-type*|norx t args)))) + ([t (us/or* utr/fn-type? utr/reactive-type?) args (us/seq-of (us/or* #{:_} type?)) > type?] + (input-or-output-type-handle-reactive output-type*|norx t args))) (defn output-type "Usage in arglist contexts: - `(t/output-type >namespace)` - - Outputs the union of the possible output types of `>namespace` given any valid inputs at all + - Outputs a reactive type embodying the union of the possible output types of `>namespace` + given any valid inputs at all - `(t/output-type reduce [:_ :_ string?])` - - Outputs the union of the possible output types of `reduce` when the third input satisfies - `string?`." + - Outputs a reactive type embodying the union of the possible output types of `reduce` when + the third input satisfies `string?`." ([t] (err! "Can't use `output-type` outside of arglist contexts")) ([t args] (err! "Can't use `output-type` outside of arglist contexts"))) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index cddc9989..13adff67 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -425,9 +425,7 @@ (err! "Found invalid value when derefing `ReactiveType`" {:kind (core/type x)}))) -(udt/deftype - ^{:doc "Warning: produces a possibly different hash every time its value is recomputed."} - ReactiveType +(udt/deftype ReactiveType [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_(t/? ::meta) @@ -436,33 +434,15 @@ rx #_(t/isa? urx/PReactive)] {PType nil urx/PReactive nil - ?Fn {invoke ([_ x] (let [t (urx/norx-deref rx)] - (validate-type t) - (t x)))} ?Meta {meta ([this] meta) with-meta ([this meta'] (ReactiveType. hash hash-code meta' body-codelist v rx))} - ?Hash {hash ([this] (let [v' (urx/norx-deref rx)] - (if (identical? v' v) - (uhash/caching-set-ordered! hash ReactiveType v) - (do (validate-type v') - (set! v v') - (set! hash (uhash/ordered-args ReactiveType v')))))) - hash-code ([this] (let [v' (urx/norx-deref rx)] - (if (identical? v' v) - (uhash/caching-set-code! hash-code ReactiveType v) - (do (validate-type v') - (set! v v') - (set! hash-code - (uhash/code-args ReactiveType v'))))))} + ?Hash {hash ([this] (uhash/caching-set-ordered! hash ReactiveType rx)) + hash-code ([this] (uhash/caching-set-code! hash-code ReactiveType rx))} ?Equals {= ([this that #_any?] (or (== this that) (and (instance? ReactiveType that) - ;; TODO determine if this should be reactive or not - (= (doto (urx/norx-deref rx) validate-type) - (urx/norx-deref that)))))} + (= rx (.-rx ^ReactiveType that)))))} ?Deref {deref ([this] (doto @rx validate-type))} - uform/PGenForm {>form ([this] (-> (list* 'quantum.untyped.core.type/rx body-codelist) - (accounting-for-meta meta)))} fedn/IOverride nil fedn/IEdn {-edn ([this] (>form this))}}) diff --git a/src/quantum/core/data/numeric.cljc b/src/quantum/core/data/numeric.cljc index 820ae3ae..ff2231ae 100644 --- a/src/quantum/core/data/numeric.cljc +++ b/src/quantum/core/data/numeric.cljc @@ -241,7 +241,7 @@ #?(:clj ([a numeric? , b bigdec?] (c?/> (>bigdec a) b))) #?(:clj ([a clj-bigint?, b clj-bigint?] (if (and (p/nil? (.bipart a)) (p/nil? (.bipart b))) - (c?/> (.lpart a) (.lpart b)) + (c?/> (.lpart a) (.lpart b)) (c?/comp> (>java-bigint a) (>java-bigint b))))) #?(:clj ([a ratio? , b ratio?] (c?/> (.multiply (.numerator a) (.numerator b)) @@ -255,7 +255,7 @@ #?(:clj ([a numeric? , b bigdec?] (c?/>= (>bigdec a) b))) #?(:clj ([a clj-bigint?, b clj-bigint?] (if (and (p/nil? (.bipart a)) (p/nil? (.bipart b))) - (c?/>= (.lpart a) (.lpart b)) + (c?/>= (.lpart a) (.lpart b)) (c?/comp>= (>java-bigint a) (>java-bigint b))))) #?(:clj ([a ratio? , b ratio?] (c?/>= (.multiply (.numerator a) (.numerator b)) From 5680d67bc1d41627dd068fdb6a0aaf71d14ffe39 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 24 Oct 2018 09:59:56 -0600 Subject: [PATCH 583/810] Change some names to reflect true status of thread-(un)safety --- .../quantum/untyped/core/data/reactive.cljc | 88 ++++----- .../test/untyped/core/data/reactive.cljc | 186 +++++++++--------- 2 files changed, 135 insertions(+), 139 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index 77829af2..f0c3addf 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -4,21 +4,17 @@ something else), and it makes do with 78 LOC (!) whereas we grapple with nearly 400 for presumably very similar functionality. Perhaps someday this code can be compressed. - Includes `Atom` and `Reaction`; may include `Subscription` at some point. + Includes `Reference` and `Reaction`; may include `Subscription` at some point. Currently only safe for single-threaded use; needs a rethink to accommodate concurrent modification/access and customizable queueing strategies. - - We could either introduce concurrency-safe versions of `Reaction` and `Atom`, or we - could introduce a global single thread on which `Reaction`s and `Atom`s are modified, + - We could either introduce concurrency-safe versions of `Reaction` and `Reference`, or we + could introduce a global single thread on which `Reaction`s and `Reference`s are modified, but from which any number of threads can read, in a clojure.async sort of way." - (:refer-clojure :exclude - [atom run!]) (:require [clojure.core :as core] [clojure.set :as set] [quantum.untyped.core.async :as uasync] - [quantum.untyped.core.core - :refer [dot dot!]] [quantum.untyped.core.error :as uerr] [quantum.untyped.core.form.generate.deftype :as udt] [quantum.untyped.core.log :as ulog] @@ -70,7 +66,7 @@ ;; ===== Internal functions for reactivity ===== ;; -(def ^:dynamic *atom-context* nil) +(def ^:dynamic *ref-context* nil) (def ^:dynamic #?(:clj *debug?* :cljs ^boolean *debug?*) false) @@ -83,7 +79,7 @@ new) (defn norx-deref [rx] - (binding [*atom-context* nil] + (binding [*ref-context* nil] #?(:clj (.deref ^clojure.lang.IDeref rx) :cljs (-deref ^non-native rx)))) @@ -114,12 +110,12 @@ x) #?(:cljs -(defn- pr-atom! [a writer opts s] +(defn- pr-ref! [a writer opts s] (-write writer (str "#<" s " ")) - (pr-writer (binding [*atom-context* nil] (-deref ^non-native a)) writer opts) + (pr-writer (binding [*ref-context* nil] (-deref ^non-native a)) writer opts) (-write writer ">"))) -;; ===== Atom ===== ;; +;; ===== Reference ===== ;; (defprotocol PReactive) @@ -128,19 +124,19 @@ (setCaptured [this v])) (defn- notify-deref-watcher! - "Add `derefed` to the `captured` field of `*atom-context*`. + "Add `derefed` to the `captured` field of `*ref-context*`. See also `in-context`" [derefed] - (when-some [context *atom-context*] + (when-some [context *ref-context*] (let [^quantum.untyped.core.data.reactive.PHasCaptured r context] (if-some [c (.getCaptured r)] (alist-conj! c derefed) (.setCaptured r (alist derefed)))))) -(udt/deftype Atom [^:! state meta validator ^:! watches] +(udt/deftype Reference [^:! state meta validator ^:! watches] {;; IPrintWithWriter - ;; (-pr-writer [a w opts] (pr-atom a w opts "Atom:")) + ;; (-pr-writer [a w opts] (pr-ref a w opts "Reference:")) PReactive nil ?Equals {= ([this that] (identical? this that))} ?Deref {deref ([this] @@ -166,13 +162,14 @@ PWatchable {getWatches ([this] watches) setWatches ([this v] (set! watches v))} ?Meta {meta ([_] meta) - with-meta ([_ meta'] (Atom. state meta' validator watches))} + with-meta ([_ meta'] (Reference. state meta' validator watches))} #?@(:cljs [?Hash {hash ([_] (goog/getUid this))}])}) -(defn atom - "Reactive 'atom'. Like `core/atom`, except that it keeps track of derefs." - ([x] (Atom. x nil nil nil)) - ([x & {:keys [meta validator]}] (Atom. x meta validator nil))) +(defn ! + "Reactive '!' (single-threaded mutable reference). Like `ref/!`, except that it keeps track of + derefs." + ([x] (Reference. x nil nil nil)) + ([x & {:keys [meta validator]}] (Reference. x meta validator nil))) ;; ===== Reaction ("Computed Observable") ===== ;; @@ -204,14 +201,14 @@ ^:! ^:get ^:set watching ; i.e. 'dependents' ^:! watches] ; TODO consider a mutable map for `watches` {;; IPrintWithWriter - ;; (-pr-writer [a w opts] (pr-atom a w opts (str "Reaction " (hash a) ":"))) + ;; (-pr-writer [a w opts] (pr-ref a w opts (str "Reaction " (hash a) ":"))) ?Equals {= ([this that] (identical? this that))} #?@(:cljs [?Hash {hash ([this] (goog/getUid this))}]) PReactive nil ?Deref {deref ([this] (if-not (nil? caught) (throw caught) - (let [non-reactive? (nil? *atom-context*)] + (let [non-reactive? (nil? *ref-context*)] (when non-reactive? (flush! queue)) (if (and non-reactive? alwaysRecompute) (when-not computed @@ -267,19 +264,19 @@ (set! (.-on-dispose-arr this) (alist f))))}}) (defn- in-context - "When f is executed, if (f) derefs any atoms, they are then added to - 'obj.captured'(*atom-context*). + "When f is executed, if (f) derefs any reactive references, they are then added to + 'obj.captured' (*ref-context*). - See function notify-deref-watcher! to know how *atom-context* is updated" - [obj f] (binding [*atom-context* obj] (f))) + See function notify-deref-watcher! to know how *ref-context* is updated." + [obj f] (binding [*ref-context* obj] (f))) (defn- deref-capture! - "Returns `(in-context f r)`. Calls `_update-watching` on r with any - `deref`ed atoms captured during `in-context`, if any differ from the - `watching` field of r. Sets the `computed` flag on r to true. + "Returns `(in-context f r)`. Calls `update-watching!` on `rx` with any `deref`ed reactive + references captured during `in-context`, if any differ from the `watching` field of `rx`. Sets + the `computed` flag on `rx` to true. - Inside '_update-watching' along with adding the atoms in 'r.watching' of reaction, - the reaction is also added to the list of watches on each atoms f derefs." + Inside `update-watching!` along with adding the references in 'rx.watching' of reaction, the + reaction is also added to the list of watches on each of the references that `f` derefs." [f ^Reaction rx] (.setCaptured rx nil) (let [res (in-context rx f) @@ -354,8 +351,8 @@ (def ^:dynamic *queue* global-queue) -(defn ^Reaction >rx - ([f] (>rx f nil)) +(defn ^Reaction >!rx + ([f] (>!rx f nil)) ([f {:keys [always-recompute? enqueue-fn eq-fn no-cache? on-set on-dispose queue]}] (Reaction. (if (nil? always-recompute?) false always-recompute?) nil @@ -371,16 +368,15 @@ (or queue *queue*) nil nil nil))) -#?(:clj (defmacro rx [& body] `(>rx (fn [] ~@body)))) +#?(:clj (defmacro !rx "Creates a single-threaded reaction." [& body] `(>!rx (fn [] ~@body)))) -#?(:clj (defmacro eager-rx [& body] `(>rx (fn [] ~@body) {:always-recompute? true}))) +#?(:clj (defmacro !eager-rx [& body] `(>!rx (fn [] ~@body) {:always-recompute? true}))) #?(:clj -(defmacro run! - "Runs body immediately, and runs again whenever atoms deferenced in the body change. Body should - side effect." - [& body] - `(doto (rx ~@body) deref))) +(defmacro !run-rx + "Runs body immediately, and runs again whenever reactive references deferenced in the body + change. Body should side effect." + [& body] `(doto (!rx ~@body) deref))) ;; ===== Track ===== ;; @@ -392,7 +388,7 @@ (udt/deftype Track [^TrackableFn trackable-fn, args, ^:! ^:get ^:set ^quantum.untyped.core.data.reactive.Reaction rx] {;; IPrintWithWriter - ;; (-pr-writer [a w opts] (pr-atom a w opts "Track:")) + ;; (-pr-writer [a w opts] (pr-ref a w opts "Track:")) PReactive nil ?Deref {deref ([this] (if (nil? rx) @@ -411,8 +407,8 @@ ^Reaction r (m k nil)] (cond (some? r) #?(:clj (.deref r) :cljs (-deref ^non-native r)) - (nil? *atom-context*) (f) - :else (let [r (>rx f + (nil? *ref-context*) (f) + :else (let [r (>!rx f {:on-dispose (fn [x] (when (true? *debug?*) (swap! *running dec)) @@ -436,8 +432,8 @@ (defn >track! [f args opts] (let [t (>track f args) - r (>rx (fn [] #?(:clj (.deref t) :cljs (-deref ^non-native t))) - {:queue (or (:queue opts) global-queue)})] + r (>!rx (fn [] #?(:clj (.deref t) :cljs (-deref ^non-native t))) + {:queue (or (:queue opts) global-queue)})] @r r)) diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index bb16e86d..df25ffa9 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -6,7 +6,7 @@ [quantum.untyped.core.test :as utest :refer [deftest is is= testing]] [quantum.untyped.core.data.reactive :as rx - :refer [dispose! eager-rx flush! rx]])) + :refer [! !eager-rx !run-rx !rx >!rx dispose! flush!]])) (defn with-debug [f] (flush! rx/global-queue) @@ -19,10 +19,10 @@ (defn test-perf [] ;; (set! debug? false) ; yes but we need to think about CLJ (dotimes [_ 10] - (let [a (rx/atom 0) + (let [a (! 0) f (fn [] (quot (long @a) 10)) q (@#'rx/alist) - mid (rx/>rx f {:queue q}) + mid (>!rx f {:queue q}) res (rx/>track! (fn [] (inc (long @mid))) [] {:queue q})] @res (time (dotimes [_ 100000] ; ~70ms per 100K in CLJ so 0.0007ms for one (0.7 µs or 700 ns) @@ -33,14 +33,14 @@ (deftest basic-atom (binding [rx/*enqueue!* @#'rx/alist-conj!] (let [runs (running) - start (rx/atom 0) - sv (eager-rx @start) - comp (eager-rx @sv (+ 2 @sv)) - c2 (eager-rx (inc @comp)) - ct (rx/atom 0) - out (rx/atom 0) - res (eager-rx (swap! ct inc) @sv @c2 @comp) - const (rx/run! (reset! out @res))] + start (! 0) + sv (!eager-rx @start) + comp (!eager-rx @sv (+ 2 @sv)) + c2 (!eager-rx (inc @comp)) + ct (! 0) + out (! 0) + res (!eager-rx (swap! ct inc) @sv @c2 @comp) + const (!run-rx (reset! out @res))] (is (= @ct 1) "constrain ran") (is (= @out 2)) (reset! start 1) @@ -52,11 +52,11 @@ (deftest double-dependency (let [runs (running) - start (rx/atom 0) - c3-count (rx/atom 0) - c1 (eager-rx @start 1) - c2 (eager-rx @start) - c3 (rx (swap! c3-count inc) + start (! 0) + c3-count (! 0) + c1 (!eager-rx @start 1) + c2 (!eager-rx @start) + c3 (!rx (swap! c3-count inc) (+ @c1 @c2))] (flush! rx/global-queue) (is (= @c3-count 0)) @@ -72,17 +72,17 @@ (deftest test-from-reflex ; https://github.com/lynaghk/reflex (let [runs (running)] - (let [*counter (rx/atom 0) - *signal (rx/atom "All I do is change") - co (rx/run! @*signal (swap! *counter inc))] + (let [*counter (! 0) + *signal (! "All I do is change") + co (!run-rx @*signal (swap! *counter inc))] (is (= 1 @*counter) "Constraint run on init") (reset! *signal "foo") (flush! rx/global-queue) (is (= 2 @*counter) "Counter auto updated") (dispose! co)) - (let [*x (rx/atom 0) - *co (rx (inc @*x))] + (let [*x (! 0) + *co (!rx (inc @*x))] (is (= 1 @*co) "CO has correct value on first deref") (swap! *x inc) (is (= 2 @*co) "CO auto-updates") @@ -92,18 +92,18 @@ (deftest test-unsubscribe (dotimes [x 10] (let [runs (running) - a (rx/atom 0) - a1 (eager-rx (inc @a)) - a2 (eager-rx @a) - b-changed (rx/atom 0) - c-changed (rx/atom 0) - b (eager-rx + a (! 0) + a1 (!eager-rx (inc @a)) + a2 (!eager-rx @a) + b-changed (! 0) + c-changed (! 0) + b (!eager-rx (swap! b-changed inc) (inc @a1)) - c (eager-rx + c (!eager-rx (swap! c-changed inc) (+ 10 @a2)) - res (rx/run! (if (< @a2 1) @b @c))] + res (!run-rx (if (< @a2 1) @b @c))] (is (= @res (+ 2 @a))) (is (= @b-changed 1)) (is (= @c-changed 0)) @@ -136,29 +136,29 @@ (deftest maybe-broken (let [runs (running)] (let [runs (running) - a (rx/atom 0) - b (eager-rx (inc @a)) - c (eager-rx (dec @a)) - d (eager-rx (str @b)) - res (rx/atom 0) - cs (rx/run! (reset! res @d))] + a (! 0) + b (!eager-rx (inc @a)) + c (!eager-rx (dec @a)) + d (!eager-rx (str @b)) + res (! 0) + cs (!run-rx (reset! res @d))] (is (= @res "1")) (dispose! cs)) ;; should be broken according to https://github.com/lynaghk/reflex/issues/1 ;; but isnt - (let [a (rx/atom 0) - b (eager-rx (inc @a)) - c (eager-rx (dec @a)) - d (rx/run! [@b @c])] + (let [a (! 0) + b (!eager-rx (inc @a)) + c (!eager-rx (dec @a)) + d (!run-rx [@b @c])] (is (= @d [1 -1])) (dispose! d)) - (let [a (rx/atom 0) - b (eager-rx (inc @a)) - c (eager-rx (dec @a)) - d (rx/run! [@b @c]) - res (rx/atom 0)] + (let [a (! 0) + b (!eager-rx (inc @a)) + c (!eager-rx (dec @a)) + d (!run-rx [@b @c]) + res (! 0)] (is (= @d [1 -1])) - (let [e (rx/run! (reset! res @d))] + (let [e (!run-rx (reset! res @d))] (is (= @res [1 -1])) (dispose! e)) (dispose! d)) @@ -168,21 +168,21 @@ (binding [rx/*enqueue!* @#'rx/alist-conj!] (dotimes [x 10] (let [runs (running) - a (rx/atom 0) - disposed (rx/atom nil) - disposed-c (rx/atom nil) - disposed-cns (rx/atom nil) - count-b (rx/atom 0) - b (rx/>rx (fn [] (swap! count-b inc) (inc @a)) + a (! 0) + disposed (! nil) + disposed-c (! nil) + disposed-cns (! nil) + count-b (! 0) + b (>!rx (fn [] (swap! count-b inc) (inc @a)) {:always-recompute? true :on-dispose (fn [r] (reset! disposed true)) :queue rx/global-queue}) - c (rx/>rx #(if (< @a 1) (inc @b) (dec @a)) + c (>!rx #(if (< @a 1) (inc @b) (dec @a)) {:always-recompute? true :on-dispose (fn [r] (reset! disposed-c true)) :queue rx/global-queue}) - res (rx/atom nil) - cns (rx/>rx #(reset! res @c) + res (! nil) + cns (>!rx #(reset! res @c) {:on-dispose (fn [r] (reset! disposed-cns true)) :queue rx/global-queue})] @cns @@ -219,15 +219,15 @@ (deftest test-add-dispose (dotimes [x 10] (let [runs (running) - a (rx/atom 0) - disposed (rx/atom nil) - disposed-c (rx/atom nil) - disposed-cns (rx/atom nil) - count-b (rx/atom 0) - b (eager-rx (swap! count-b inc) (inc @a)) - c (eager-rx (if (< @a 1) (inc @b) (dec @a))) - res (rx/atom nil) - cns (rx (reset! res @c))] + a (! 0) + disposed (! nil) + disposed-c (! nil) + disposed-cns (! nil) + count-b (! 0) + b (!eager-rx (swap! count-b inc) (inc @a)) + c (!eager-rx (if (< @a 1) (inc @b) (dec @a))) + res (! nil) + cns (!rx (reset! res @c))] (rx/add-on-dispose! b (fn [r] (is (= r b)) (reset! disposed true))) @@ -265,8 +265,8 @@ (deftest test-on-set (let [runs (running) - a (rx/atom 0) - b (rx/>rx #(+ 5 @a) + a (! 0) + b (>!rx #(+ 5 @a) {:on-set (fn [oldv newv] (reset! a (+ 10 newv))) :queue rx/global-queue})] @b @@ -281,8 +281,8 @@ (deftest non-reactive-deref (let [runs (running) - a (rx/atom 0) - b (eager-rx (+ 5 @a))] + a (! 0) + b (!eager-rx (+ 5 @a))] (is (= @b 5)) (is (= runs (running))) @@ -292,10 +292,10 @@ (deftest reset-in-reaction (let [runs (running) - state (rx/atom {}) - c1 (eager-rx (get-in @state [:data :a])) - c2 (eager-rx (get-in @state [:data :b])) - rxn (rx (let [cc1 @c1, cc2 @c2] + state (! {}) + c1 (!eager-rx (get-in @state [:data :a])) + c2 (!eager-rx (get-in @state [:data :b])) + rxn (!rx (let [cc1 @c1, cc2 @c2] (swap! state assoc :derived (+ (or cc1 0) (or cc2 0))) nil))] @rxn @@ -311,9 +311,9 @@ (deftest exception-recover (let [runs (running) - state (rx/atom 1) - count (rx/atom 0) - r (rx/run! + state (! 1) + count (! 0) + r (!run-rx (swap! count inc) (when (> @state 1) (throw (ex-info "oops" {}))))] (is (= @count 1)) @@ -329,11 +329,11 @@ (deftest exception-recover-indirect (let [runs (running) - state (rx/atom 1) - count (rx/atom 0) - ref (eager-rx (when (= @state 2) + state (! 1) + count (! 0) + ref (!eager-rx (when (= @state 2) (throw (ex-info "err" {})))) - r (rx/run! + r (!run-rx (swap! count inc) @ref)] (is (= @count 1)) @@ -351,15 +351,15 @@ (deftest exception-side-effect (binding [rx/*enqueue!* @#'rx/alist-conj!] (let [runs (running) - state (rx/atom {:val 1}) - rstate (eager-rx @state) + state (! {:val 1}) + rstate (!eager-rx @state) spy (atom nil) - r1 (rx/run! @rstate) - r2 (let [val (eager-rx (:val @rstate))] - (rx/run! + r1 (!run-rx @rstate) + r2 (let [val (!eager-rx (:val @rstate))] + (!run-rx (reset! spy @val) (is (some? @val)))) - r3 (rx/run! + r3 (!run-rx (when (:error? @rstate) (throw (ex-info "Error detected!" {}))))] (swap! state assoc :val 2) @@ -377,9 +377,9 @@ (deftest exception-reporting (binding [rx/*enqueue!* @#'rx/alist-conj!] (let [runs (running) - state (rx/atom {:val 1}) - rstate (eager-rx (:val @state)) - r1 (rx/run! + state (! {:val 1}) + rstate (!eager-rx (:val @state)) + r1 (!run-rx (when (= @rstate 13) (throw (ex-info "fail" {}))))] (swap! state assoc :val 13) @@ -393,20 +393,20 @@ (deftest atom-with-meta (let [value {:val 1} meta-value {:meta-val 1} - state (with-meta (rx/atom value) meta-value)] + state (with-meta (! value) meta-value)] (is (= (meta state) meta-value)) (is (= @state value)))) (deftest test-eager-vs-lazy-reaction - (let [a (rx/atom 123) + (let [a (! 123) b-ct (atom 0) - b (eager-rx (swap! b-ct inc) (+ @a 2)) + b (!eager-rx (swap! b-ct inc) (+ @a 2)) c-ct (atom 0) - c (eager-rx (swap! c-ct inc) (* @b -1)) + c (!eager-rx (swap! c-ct inc) (* @b -1)) b-lazy-ct (atom 0) - b-lazy (rx (swap! b-lazy-ct inc) (+ @a 2)) + b-lazy (!rx (swap! b-lazy-ct inc) (+ @a 2)) c-lazy-ct (atom 0) - c-lazy (rx (swap! c-lazy-ct inc) (* @b-lazy -1))] + c-lazy (!rx (swap! c-lazy-ct inc) (* @b-lazy -1))] (testing "eager" @c (is= @b-ct 1) From 5d946904244b7736a21f6f3fea3a35a6e9ecf042 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 24 Oct 2018 10:00:21 -0600 Subject: [PATCH 584/810] Add some notes about reactive recompilation --- resources-dev/defnt.cljc | 25 +++++++++++++++++++++++-- 1 file changed, 23 insertions(+), 2 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 2355eb25..8b6455c4 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -51,6 +51,26 @@ TODO: - `(- (or ?!+vector? !vector? #?(:clj !!vector?)) (isa? clojure.lang.Counted))` is not right - t/or should probably order by `t/compare` descending +- Suppose you have: + - (t/defn abcde [a t/int?] ...) + - (t/defn fghij [b (t/input-type abcde :_)] ...) + - Resulting in `b`'s type as: + - (rx (t/input-type* @abcde-type-atom :_)) + - Resulting in `fghij`'s type as: + - (let [bt (rx (t/input-type* @abcde-type-atom :_))] + (rx (ftype t/any? [@bt]))) + - should the equality check for the type atom be `t/=` instead of `=`? + - Resulting in `fghij`'s code as: + - (rx/run! + ) + - TODO `ftype` should accommodate reactive types + - + - (rx/dispose! ) when the `t/defn` is redefined (?) + - (t/extend-defn! abcde [c t/string?] ...) + - This `reset!`s `abcde-type-atom` to (t/ftype t/any? [t/int?] [t/string?]) + - This does automatically cause watching reactions to re-run in the thread in which + the `reset!` happens. + #_" Note that `;; TODO TYPED` is the annotation we're using for this initiative - There will be some code duplication with untyped code for now and that's okay. @@ -67,9 +87,10 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - `t/defn` that gets extended via `t/extend-defn!` (if the input-types and output-types have changed) - We can `defonce` a `urx/atom` per `t/defn` and `reset!` on each `t/extend-defn!` + - reactive ftype in ::type meta + - Probably should disallow recursive type references, including: + (t/defn f [x (t/input-type f ...)]) - Examples - - t/defn needs to emit a reactive ftype in its `::type` meta - - quantum.untyped.core.data.reactive - One could imagine a dynamic set of types corresponding to a given predicate, e.g. `decimal?`. Say someone comes up with a new `decimal?`-like class and wants to redefine `decimal?` to accommodate. We could define `decimal?` as a reactive/extensible type to From f097c7354363cbb440863888f6fdcb1bb10b0d6f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 24 Oct 2018 16:49:48 -0600 Subject: [PATCH 585/810] Think out more of reactive recompilation --- resources-dev/defnt.cljc | 51 ++++++++++++++----- src-untyped/quantum/untyped/core/type.cljc | 8 +-- .../quantum/untyped/core/type/defnt.cljc | 12 +++-- 3 files changed, 52 insertions(+), 19 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 8b6455c4..49a98304 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -53,21 +53,47 @@ TODO: - Suppose you have: - (t/defn abcde [a t/int?] ...) + - Resulting in `a`'s type as: + - t/int? + - Resulting in `abcde`'s type as: + - (let [!types-decl (rx/! ) + out-type t/any?] + (rx (type-data>ftype @!types-decl out-type))) + - Resulting in `abcde`'s compile-time-emission code (assuming no :test mode) as: + - (do (intern '.../abcde|__type + (let [out-type t/any?] + (rx (type-data>ftype @abcde|__types out-type)))) + (intern '.../abcde|__types + (let [t|0|0 t/int?] + (rx/! [{:id 0 :arg-types [t|0|0] :output-type ...}]))) + (rx/run! (list 'do + (list 'declare 'abcde) + ;; Internally `types-decl>arg-types` reactively derefs + (def abcde|__0|types (types-decl>arg-types abcde|__types 0)) + ))) + - Resulting in `abcde`'s runtime-emission code (assuming runtime stripping of type data) as: + - (do (def ) + (defn abcde [x00__] + (ifs ((Array/get abcde|__0|types))))) - (t/defn fghij [b (t/input-type abcde :_)] ...) - Resulting in `b`'s type as: - - (rx (t/input-type* @abcde-type-atom :_)) + - (rx (t/input-type* @abcde-type :_)) - Resulting in `fghij`'s type as: - - (let [bt (rx (t/input-type* @abcde-type-atom :_))] - (rx (ftype t/any? [@bt]))) - - should the equality check for the type atom be `t/=` instead of `=`? + - (let [!types-decl + (rx/! [{:id 0 :arg-types [(rx (t/input-type* @abcde-type :_))] :output-type ...}]) + out-type t/any?] + (rx (type-data>ftype @!types-decl out-type))) - Resulting in `fghij`'s code as: - - (rx/run! - ) + - (rx/run! (eval `(do + ))) - TODO `ftype` should accommodate reactive types - - + - TODO `or` and `and` should be `=` regardless of order + - To fix this, sort when it's created? - (rx/dispose! ) when the `t/defn` is redefined (?) + - Dependents should not get recompiled if the type has not changed but only the implementation has - (t/extend-defn! abcde [c t/string?] ...) - - This `reset!`s `abcde-type-atom` to (t/ftype t/any? [t/int?] [t/string?]) + - (reset! abcde|__type-atom + (t/ftype t/any? [t/in?] [t/string?])) - This does automatically cause watching reactions to re-run in the thread in which the `reset!` happens. @@ -1899,8 +1925,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative [ ] Types yielding generative specs [—] Types using the clojure.spec interface - Not yet; wait for it to come out of alpha -[—] Support for compilers in which the metalanguage differs from the object language (i.e. 'normal' - non-CLJS-in-CLJS CLJS) - - This will have to be approached later. We may or may not choose to figure it out, but it seems - promising enough. +[ ] We don't need to use bootstrapped CLJS per se (though that's cool and we can look into it); we + can try to hook in to the JS version of the Closure Compiler. That's for later. +[ ] We should probably have configurable whether we want to preserve type data at runtime and emit + that in the runtime code (e.g. for REPL purposes) or whether we want to strip it to conserve + memory. " diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index b73f9495..0ecc6fea 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -107,12 +107,12 @@ #?(:clj (defmacro rx - "Creates a reactive type. - - The only macro in all of the core type predicates. + "Creates a reactive type. Note that the current implementation of reactivity is thread-unsafe. Note that if a type-generating fn (e.g. `and` or `or`) is provided with even one reactive input, - then the whole type will become reactive. Thus, reactivity is 'infectious'." + then the whole type will become reactive. Thus, reactivity is 'infectious'. + + The only macro in all of the core type predicates." [& body] `(rx* (urx/rx ~@body) ($ ~(vec body))))) (defn- deref-when-reactive [x] diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 976608bb..1710e355 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -21,6 +21,7 @@ :refer [kw-map]] [quantum.untyped.core.data.array :as uarr] [quantum.untyped.core.data.map :as umap] + [quantum.untyped.core.data.reactive :as urx] [quantum.untyped.core.data.set :as uset] [quantum.untyped.core.error :as err :refer [TODO err!]] @@ -788,9 +789,14 @@ - Example: `(t/defn ^:inline abc ([] ...) ([...] ...))` Note that inlining is possible only in typed contexts. - `fnt` only works in languages in which the metalanguage (compiler language) is the same as the - object language. As such, for CLJS, we choose to use only a CLJS-in-CLJS / bootstrapped compiler - even if that means alienating the mainstream CLJS-in-CLJ workflow." + `t/fn` only works fully in contexts in which the metalanguage (compiler language) is the same as + the object language. Otherwise, while the compiler could still analyze types symbolically to an + extent, it could not actually run evaluated type-predicates on inputs to determine type-satisfaction. + - Consumers wishing to use the full-featured `t/fn` in ClojureScript must either use + bootstrapped ClojureScript or transpile ClojureScript via the JavaScript implementation of + the Google Closure Compiler. Consumers for whom the version of `t/fn` with purely symbolic + analysis is acceptable may use the standard approach of transpiling ClojureScript via the Java + implementation of the Google Closure Compiler." [& args] (fn|code :fn (ufeval/env-lang) *compilation-mode* args))) #?(:clj From 9d984e44bbd71a3203fa4814e02fe68b5dde5292 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 26 Oct 2018 18:05:45 -0600 Subject: [PATCH 586/810] Reactive fn extensions outline is done! --- resources-dev/defnt.cljc | 44 +------ src-untyped/quantum/untyped/core/analyze.cljc | 1 + src/quantum/core/data/map.cljc | 1 + src/quantum/core/data/set.cljc | 1 + .../quantum/test/untyped/core/type/defnt.cljc | 112 ++++++++++++++++++ 5 files changed, 116 insertions(+), 43 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 49a98304..454010f2 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -51,51 +51,12 @@ TODO: - `(- (or ?!+vector? !vector? #?(:clj !!vector?)) (isa? clojure.lang.Counted))` is not right - t/or should probably order by `t/compare` descending -- Suppose you have: - - (t/defn abcde [a t/int?] ...) - - Resulting in `a`'s type as: - - t/int? - - Resulting in `abcde`'s type as: - - (let [!types-decl (rx/! ) - out-type t/any?] - (rx (type-data>ftype @!types-decl out-type))) - - Resulting in `abcde`'s compile-time-emission code (assuming no :test mode) as: - - (do (intern '.../abcde|__type - (let [out-type t/any?] - (rx (type-data>ftype @abcde|__types out-type)))) - (intern '.../abcde|__types - (let [t|0|0 t/int?] - (rx/! [{:id 0 :arg-types [t|0|0] :output-type ...}]))) - (rx/run! (list 'do - (list 'declare 'abcde) - ;; Internally `types-decl>arg-types` reactively derefs - (def abcde|__0|types (types-decl>arg-types abcde|__types 0)) - ))) - - Resulting in `abcde`'s runtime-emission code (assuming runtime stripping of type data) as: - - (do (def ) - (defn abcde [x00__] - (ifs ((Array/get abcde|__0|types))))) - - (t/defn fghij [b (t/input-type abcde :_)] ...) - - Resulting in `b`'s type as: - - (rx (t/input-type* @abcde-type :_)) - - Resulting in `fghij`'s type as: - - (let [!types-decl - (rx/! [{:id 0 :arg-types [(rx (t/input-type* @abcde-type :_))] :output-type ...}]) - out-type t/any?] - (rx (type-data>ftype @!types-decl out-type))) - - Resulting in `fghij`'s code as: - - (rx/run! (eval `(do - ))) + - TODO `ftype` should accommodate reactive types - TODO `or` and `and` should be `=` regardless of order - To fix this, sort when it's created? - (rx/dispose! ) when the `t/defn` is redefined (?) - Dependents should not get recompiled if the type has not changed but only the implementation has - - (t/extend-defn! abcde [c t/string?] ...) - - (reset! abcde|__type-atom - (t/ftype t/any? [t/in?] [t/string?])) - - This does automatically cause watching reactions to re-run in the thread in which - the `reset!` happens. #_" Note that `;; TODO TYPED` is the annotation we're using for this initiative @@ -1927,7 +1888,4 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - Not yet; wait for it to come out of alpha [ ] We don't need to use bootstrapped CLJS per se (though that's cool and we can look into it); we can try to hook in to the JS version of the Closure Compiler. That's for later. -[ ] We should probably have configurable whether we want to preserve type data at runtime and emit - that in the runtime code (e.g. for REPL purposes) or whether we want to strip it to conserve - memory. " diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 603d6231..eda378b5 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -785,6 +785,7 @@ do (analyze-seq|do env form) let* (analyze-seq|let* env form) deftype* (TODO "deftype*") + reify* (TODO "reify") ; NOTE only for CLJ fn* (TODO "fn*") def (TODO "def") set! (TODO "set!") diff --git a/src/quantum/core/data/map.cljc b/src/quantum/core/data/map.cljc index ace9b922..bf06f906 100644 --- a/src/quantum/core/data/map.cljc +++ b/src/quantum/core/data/map.cljc @@ -1,6 +1,7 @@ (ns ^{:attribution "alexandergunnarson"} quantum.core.data.map "Useful map functions. |map-entry|, a better merge, sorted-maps, etc." + {:todo #{"Explore the possibility of 64-bit `PersistentHashMap`s"}} (:refer-clojure :exclude [split-at, map?, merge, sorted-map sorted-map-by]) (:require diff --git a/src/quantum/core/data/set.cljc b/src/quantum/core/data/set.cljc index 0ca09d77..dec4fff4 100644 --- a/src/quantum/core/data/set.cljc +++ b/src/quantum/core/data/set.cljc @@ -1,5 +1,6 @@ (ns quantum.core.data.set "A set may be thought of as a special type of Map whose keys and vals are identical." + {:todo #{"Explore the possibility of 64-bit `PersistentHashSet`s"}} (:refer-clojure :exclude [+ -, and or not, compare, split-at hash-set]) (:require diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 3a7d6cba..ddc0e31c 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1875,3 +1875,115 @@ ((Array/get ~'extensible|__0|types 0) ~'x00__) (. extensible|__0 invoke x00__) (unsupported! `extensible [~'x00__] 0))))))) + +;; ===== Reactive types ===== ;; + +- Suppose you have: + - (t/defn abcde [a t/int?] ...) + - Resulting in `abcde`'s compile-time-emission code (assuming no :test mode) as: + - (do (intern '.../abcde|__types ; CLJS compiler needs this to perform analysis + (rx/! [{:id 0 :arg-types [t/int?] :output-type ...}])) + (intern '.../abcde|__expanded-types ; CLJS compiler needs this to perform analysis + (!rx (split-and-primitivize @abcde|__types))) + (intern '.../abcde|__type + (let [out-type t/any?] + (t/rx (type-data>ftype @abcde|__expanded-types (?deref out-type)))))) + - Resulting in `abcde`'s runtime-emission code in CLJ as: + - (do (def abcde|__0 (reify* [...] (invoke ([x00__ a] ...)))) + (def abcde + (let [;; Each of these types should be completely unreactive. + ;; Internally does a norx deref on `abcde|__expanded-types` + types|0 (types-decl>arg-types abcde|__expanded-types 0)] + (fn [x00__] + (ifs ((Array/get types|0 0) x00__) ... + (unsupported! ...)))))) + - Resulting in `abcde`'s runtime-emission code in CLJS (assuming runtime type data elision i.e. + no type decl or reactivity etc.) as: + - (do (def abcde|__0 (do (deftype* A [] nil (extend-type A Object (invoke ([x00__ a] ...)))) + (new A))) + (def abcde + (let [0|types (array t/int?))] + (fn [x00__] + (ifs ((aget 0|types 0) x00__) ... + (unsupported! ...)))))) + - (t/defn fghij [b (t/input-type abcde :_)] ...) + - Resulting in `fghij`'s compile-time-emission code (assuming no :test mode) as: + - (do (intern '.../fghij|__types + (rx/! [{:id 0 :arg-types [(rx (t/input-type* @abcde|__type :_))] :output-type ...}])) + (intern '.../fghij|__expanded-types + (!rx (split-and-primitivize @fghij|__types))) + (intern '.../fghij|__type + (let [out-type t/any?] + (t/rx (type-data>ftype fghij|__types out-type))))) + - Resulting in `fghij`'s runtime-emission code in CLJ as: + - (do (def fghij|__0 (reify* [...] (invoke ([x00__ b] ...)))) + (def fghij + (let [types|0 (types-decl>arg-types fghij|__expanded-types 0)] + (fn [x00__] + (ifs ((Array/get types|0 0) x00__) (. fghij|__0 invoke x00__) + (unsupported! ...)))))) + - Resulting in `abcde`'s runtime-emission code in CLJS (assuming runtime type data elision i.e. + no type decl or reactivity etc.) as: + - (do (def fghij|__0 (do (deftype* B [] nil (extend-type A Object (invoke ([x00__ b] ...)))) + (new B))) + (def fghij + (let [0|types (array t/int?))] + (fn [x00__] + (ifs ((aget 0|types 0) x00__) (. fghij|__0 invoke x00__) + (unsupported! ...)))))) + - (t/extend-defn! abcde [c t/string?] ...) + ;; We probably need a few things: + #_"- A : rx/! : distinct overload types, in insertion/definition order + - B : rx/!rx : split+primitivized types correctly ordered, rx-ly referencing overload types + - C : rx/!rx : ftype based on split+primitivized types, reactively referencing them + - Q : ArrayList : a global queue which `extend-defn!` conj's to and `defn` pops + + A is only touched by `extend-defn!` on that f. + - Then B and C are reactively modified + - What about overloads to be created? Maybe have a watch on B in which if IDs are added, puts + the new ID-entries on Q. + " + - Resulting in `abcde`'s compile-time-emission code (assuming no :test mode) as: + - (do (reset! abcde|__types + ;; The `arg-types` below are not reconstructed if they've already been defined; + ;; they're just shown here in their complete form. + [{:id 0 :arg-types [t/int?] :output-type ...} + {:id 1 :arg-types [t/string?] :output-type ...}]) + ;; Not explicitly executed, but this is what happens reactively as `abcde|__types` is + ;; reset. + (rx-set! abcde|__expanded-types + [{:id 0 :arg-types [t/int?] :output-type ...} + {:id 1 :arg-types [t/string?] :output-type ...}]) + ;; Reactively in a watch on `abcde|__expanded-types` + (alist-conj! defnt/overload-queue + ['.../abcde {:id 1 :arg-types [t/string?] :output-type ...}]) + (rx-set! abcde|__type (ftype t/any? [t/int?] [t/string?])) + ;; Reactively because `abcde|__type` was set + (rx-set! fghij|__expanded-types + [{:id 0 :arg-types [t/int?] :output-type ...} + {:id 1 :arg-types [t/string?] :output-type ...}]) + ;; Reactively in a watch on `fghij|__expanded-types` + (alist-conj! defnt/overload-queue + ['.../fghij {:id 1 :arg-types [t/string?] :output-type ...}]) + ;; Reactively because `fghij|__expanded-types` was set + (rx-set! fghij|__type (ftype t/any? [t/int?] [t/string?]))) + - Resulting in `abcde`'s runtime-emission code in CLJ as (easy to adapt for CLJS): + - (do ;; Consuming the `defnt/overload-queue` (iterate then clear, not incremental pop) + (intern '.../abcde|__1 (reify* [...] (invoke ([x00__ c] ...)))) + (intern '.../abcde + (let [types|0 (types-decl>arg-types .../abcde|__types 0) + types|1 (types-decl>arg-types .../abcde|__types 1)] + (fn [x00__] + (ifs ((Array/get types|0 0) x00__) (. .../abcde|__0 invoke x00__) + ((Array/get types|0 1) x00__) (. .../abcde|__1 invoke x00__) + (unsupported! ...))))) + ;; TODO figure out how it's going to get the data to figure out the args and body of this + (intern '.../fghij|__1 (reify* [...] (invoke ([x00__ b] ...)))) + (intern '.../fghij + (let [types|0 (types-decl>arg-types .../fghij|types 0) + types|1 (types-decl>arg-types .../fghij|types 1)] + (fn [x00__] + (ifs ((Array/get types|0 0) x00__) (. .../fghij|__0 invoke x00__) + ((Array/get types|0 1) x00__) (. .../fghij|__1 invoke x00__) + (unsupported! ...))))) + (var .../abcde)) From a1ce7ea93f16fe42353c8f128e6095a13c8a2bce Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 27 Oct 2018 16:37:44 -0600 Subject: [PATCH 587/810] It seems rx overloads should be all prepped to work! --- .../quantum/test/untyped/core/type/defnt.cljc | 271 ++++++++++++------ 1 file changed, 180 insertions(+), 91 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index ddc0e31c..2c05744e 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1878,112 +1878,201 @@ ;; ===== Reactive types ===== ;; +- We need to store the forms of the overloads that are reactive and re-split the whole overload + every time to get dependent types right without messing up existing logic too much + - Also this is easier anyway. We'll have to see about performance +- `t/fn`s should either disallow reactive types or norx-deref them (at least for now) +- Redefining should empty the `watching` (so no reactivity happens) but keep the reference + +([a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) + c (t/or tt/short? tt/char?) + d (let [b (t/- tt/char? tt/long?)] + (t/or tt/char? (t/type b) (t/type c))) + > (t/or (t/type b) (t/type d))]) +-> +;; Imagine this with `let`s, essentially — reference sharing. This is just written out +;; Then instead of handing the analyzer forms, we can hand it types to split +;; In this way we don't have to re-analyze the arglist every time, but we do still have to analyze +;; the body which is expected + ([a (t/rx (t/or tt/boolean? + (t/arglist-type ; t/arglist-type is always t/>< + (t/or tt/byte? + (t/arglist-type + (t/or tt/char? + (t/- @(t/input-type* abcde :?) tt/long?) + (t/arglist-type (t/or tt/short? tt/string?)))))))) + b (t/rx (t/or tt/byte? + (t/arglist-type + (t/or tt/char? + (t/- @(t/input-type* abcde :?) tt/long?) + (t/arglist-type (t/or tt/short? tt/string?)))))) + c (t/or tt/short? tt/string?) + d (t/rx (t/or tt/char? + (t/- @(t/input-type* abcde :?) tt/long?) + (t/arglist-type (t/or tt/short? tt/string?)))) + > (t/rx (t/or (t/arglist-type + (t/or tt/byte? + (t/arglist-type + (t/or tt/char? + (t/- @(t/input-type* abcde :?) tt/long?) + (t/arglist-type (t/or tt/short? tt/string?)))))) + (t/or tt/char? + (t/- @(t/input-type* abcde :?) tt/long?) + (t/arglist-type (t/or tt/short? tt/string?)))))])) + - Suppose you have: - - (t/defn abcde [a t/int?] ...) + - (defn- expand-rx-types [rx-types] + (->> rx-types + (c/map+ (fn [{:keys [arg-types out-type]}] + {:arg-types (mapv ?deref arg-types) :out-type (?deref out-type)})) + expand-types)) + - (defn- overload-queue-watch [_ _ oldv newv] + (let [first-new-id (count oldv)] + (->> newv + (c/filter+ (fn-> :id (>= first-new-id))) + (c/each (fn [x] (alist-conj! defnt/overload-queue x)))))) + - (t/defn abcde [a t/int? > t/long?] ...) ; in `ns0` - Resulting in `abcde`'s compile-time-emission code (assuming no :test mode) as: - - (do (intern '.../abcde|__types ; CLJS compiler needs this to perform analysis - (rx/! [{:id 0 :arg-types [t/int?] :output-type ...}])) - (intern '.../abcde|__expanded-types ; CLJS compiler needs this to perform analysis - (!rx (split-and-primitivize @abcde|__types))) - (intern '.../abcde|__type + - (do ;; These are append-only + ;; TODO need to analyze these bodies in the proper context. Thus can't do `t/defn` + ;; (properly) unless in most "exterior" part of namespace + ;; Yes we could drop `:body` for non-reactive, non-inline overloads but it's fine for + ;; now; we will optimize later after correctness is achieved + ;; Needs to maintain previous fully-derefed version so `overloads>type-decl` knows which + ;; reactive overloads have changed + (intern 'ns0/abcde|__overload-bases ; CLJS compiler needs this to perform analysis + (rx/! {:prev nil + :current + [{:ns 'ns0 + :arg-types [t/int?] + :output-type t/long? + :body [...] + :reactive? false}]})) + ;; Will not re-analyze overload if it is identical (`=`?) to the previous version of that + ;; overload + ;; Must include the :body and :defined-in-ns of each one in order to analyze and create + ;; new overloads when putting on the overload queue + ;; Internally rx-derefs reactive overloads + ;; CLJS compiler needs this to perform analysis + (intern 'ns0/abcde|__types (!rx (overloads>type-decl @ns0/abcde|__overload-bases))) + (add-watch ns0/abcde|__types :overload-queue overload-queue-watch) + (intern 'ns0/abcde|__type (let [out-type t/any?] - (t/rx (type-data>ftype @abcde|__expanded-types (?deref out-type)))))) + (t/rx (type-data>ftype @ns0/abcde|__types (?deref out-type))))) + ;; Each of these types should be completely unreactive. + (when (= lang :clj) + (intern '.../abcde|__types|0 + (types-decl>arg-types (rx/norx-deref ns0/abcde|__types) 0)))) - Resulting in `abcde`'s runtime-emission code in CLJ as: - - (do (def abcde|__0 (reify* [...] (invoke ([x00__ a] ...)))) - (def abcde - (let [;; Each of these types should be completely unreactive. - ;; Internally does a norx deref on `abcde|__expanded-types` - types|0 (types-decl>arg-types abcde|__expanded-types 0)] - (fn [x00__] - (ifs ((Array/get types|0 0) x00__) ... - (unsupported! ...)))))) + - (do (def abcde|__0 (reify* [int>long] (invoke ([x00__ a] ...)))) + (defn abcde [x00__] + (ifs ((Array/get ns0/abcde|__types|0 0) x00__) ... + (unsupported! ...)))) - Resulting in `abcde`'s runtime-emission code in CLJS (assuming runtime type data elision i.e. no type decl or reactivity etc.) as: - - (do (def abcde|__0 (do (deftype* A [] nil (extend-type A Object (invoke ([x00__ a] ...)))) + - (do (def abcde|__types|0 (array t/int?)) + (def abcde|__0 (do (deftype* A [] nil (extend-type A Object (invoke ([x00__ a] ...)))) (new A))) - (def abcde - (let [0|types (array t/int?))] - (fn [x00__] - (ifs ((aget 0|types 0) x00__) ... - (unsupported! ...)))))) - - (t/defn fghij [b (t/input-type abcde :_)] ...) + (defn abcde [x00__] + (ifs ((aget ns0/abcde|__types|0 0) x00__) ... + (unsupported! ...)))) + - (t/defn fghij ; in `ns1` + ([b t/string? > (t/type b)] ...) + ([c (t/input-type ns0/abcde :?) > (t/output-type ns0/abcde (t/type c))] ...)) - Resulting in `fghij`'s compile-time-emission code (assuming no :test mode) as: - - (do (intern '.../fghij|__types - (rx/! [{:id 0 :arg-types [(rx (t/input-type* @abcde|__type :_))] :output-type ...}])) - (intern '.../fghij|__expanded-types - (!rx (split-and-primitivize @fghij|__types))) - (intern '.../fghij|__type + - (do (intern 'ns1/fghij|__overload-bases + (rx/! {:prev nil + :current + [(let [t0 t/string?] + {:ns 'ns1 + :arg-types [t0] + :output-type (t/type* t0) + :body [...] + :reactive? false}) + (let [t0 (t/rx (t/input-type* @ns0/abcde|__type :?))] + {:ns 'ns1 + :arg-types [t0] + :output-type (t/rx (t/output-type* @ns0/abcde|__type (t/type* @t0))) + :body [...] + :reactive? true})]})) + (intern 'ns1/fghij|__types (!rx (overloads>type-decl @ns1/fghij|__overload-bases))) + (add-watch ns1/fghij|__types :overload-queue overload-queue-watch) + (intern 'ns1/fghij|__type (let [out-type t/any?] - (t/rx (type-data>ftype fghij|__types out-type))))) + (t/rx (type-data>ftype @ns1/fghij|__types (?deref out-type))))) + (when (= lang :clj) + (intern 'ns1/fghij|__types|0 + (types-decl>arg-types (rx/norx-deref ns1/fghij|__types) 0)))) - Resulting in `fghij`'s runtime-emission code in CLJ as: - - (do (def fghij|__0 (reify* [...] (invoke ([x00__ b] ...)))) - (def fghij - (let [types|0 (types-decl>arg-types fghij|__expanded-types 0)] - (fn [x00__] - (ifs ((Array/get types|0 0) x00__) (. fghij|__0 invoke x00__) - (unsupported! ...)))))) + - (do (def fghij|__types|0 (types-decl>arg-types ns0/fghij|__types 0)) + (def fghij|__0 (reify* [int>long] (invoke ([x00__ b] ...)))) + (def fghij|__1 (reify* [Object>Object] (invoke ([x00__ c] ...)))) + (defn fghij [x00__] + (ifs ((Array/get ns0/fghij|__types|0 0) x00__) (. ns0/fghij|__0 invoke x00__) + (unsupported! ...)))) - Resulting in `abcde`'s runtime-emission code in CLJS (assuming runtime type data elision i.e. no type decl or reactivity etc.) as: - - (do (def fghij|__0 (do (deftype* B [] nil (extend-type A Object (invoke ([x00__ b] ...)))) + - (do (def fghij|__types|0 (array t/int?)) + (def fghij|__0 (do (deftype* B [] nil (extend-type A Object (invoke ([x00__ b] ...)))) (new B))) - (def fghij - (let [0|types (array t/int?))] - (fn [x00__] - (ifs ((aget 0|types 0) x00__) (. fghij|__0 invoke x00__) - (unsupported! ...)))))) - - (t/extend-defn! abcde [c t/string?] ...) - ;; We probably need a few things: - #_"- A : rx/! : distinct overload types, in insertion/definition order - - B : rx/!rx : split+primitivized types correctly ordered, rx-ly referencing overload types - - C : rx/!rx : ftype based on split+primitivized types, reactively referencing them - - Q : ArrayList : a global queue which `extend-defn!` conj's to and `defn` pops - - A is only touched by `extend-defn!` on that f. - - Then B and C are reactively modified - - What about overloads to be created? Maybe have a watch on B in which if IDs are added, puts - the new ID-entries on Q. - " + (def fghij|__1 (do (deftype* C [] nil (extend-type A Object (invoke ([x00__ c] ...)))) + (new C))) + (defn fghij [x00__] + (ifs ((aget ns1/fghij|__types|0 0) x00__) (. ns1/fghij|__0 invoke x00__) + (unsupported! ...)))) + - (t/extend-defn! abcde [d t/byte? > t/char?] ...) ; in `ns2` - Resulting in `abcde`'s compile-time-emission code (assuming no :test mode) as: - - (do (reset! abcde|__types - ;; The `arg-types` below are not reconstructed if they've already been defined; - ;; they're just shown here in their complete form. - [{:id 0 :arg-types [t/int?] :output-type ...} - {:id 1 :arg-types [t/string?] :output-type ...}]) - ;; Not explicitly executed, but this is what happens reactively as `abcde|__types` is - ;; reset. - (rx-set! abcde|__expanded-types - [{:id 0 :arg-types [t/int?] :output-type ...} - {:id 1 :arg-types [t/string?] :output-type ...}]) - ;; Reactively in a watch on `abcde|__expanded-types` + - (do (uref/update! ns0/abcde|__overload-bases + (fn [overloads] + {:prev overloads + :current + (join overloads + [{:ns 'ns2 + :arg-types [t/byte?] + :output-type t/char? + :body [...] + :reactive? false}])})) + ;; Not explicitly executed, but this is what happens reactively as + ;; `abcde|__overload-bases` is `update!`ed: + ;; Reactively due to `abcde|__overload-bases` changing + (rx-set! ns0/abcde|__types + [{:id 1 :ns 'ns2 :arg-types [t/byte?] :output-type t/char? :body [...]} + {:id 0 :ns 'ns0 :arg-types [t/int?] :output-type t/long? :body [...]}]) + ;; Reactively in `:overload-queue` watch on `abcde|__types` (alist-conj! defnt/overload-queue - ['.../abcde {:id 1 :arg-types [t/string?] :output-type ...}]) - (rx-set! abcde|__type (ftype t/any? [t/int?] [t/string?])) - ;; Reactively because `abcde|__type` was set - (rx-set! fghij|__expanded-types - [{:id 0 :arg-types [t/int?] :output-type ...} - {:id 1 :arg-types [t/string?] :output-type ...}]) - ;; Reactively in a watch on `fghij|__expanded-types` + ['ns0/abcde {:id 1 :ns 'ns2 :arg-types [t/byte?] :output-type t/char? :body [...]}]) + ;; Reactively due to `abcde|__types` changing + (rx-set! ns0/abcde|__type (ftype t/any? [t/byte? :> t/char?] [t/int? :> t/long?])) + ;; Reactively due to `abcde|__type` changing + (rx-set! ns1/fghij|__types + [{:id 2 :ns 'ns1 :arg-types [t/byte?] :output-type t/char? :body [...]} + {:id 0 :ns 'ns1 :arg-types [t/int?] :output-type t/long? :body [...]} + {:id 1 :ns 'ns1 :arg-types [t/string?] :output-type t/string? :body [...]}]) + ;; Reactively in `:overload-queue` watch on `fghij|__types` (alist-conj! defnt/overload-queue - ['.../fghij {:id 1 :arg-types [t/string?] :output-type ...}]) - ;; Reactively because `fghij|__expanded-types` was set - (rx-set! fghij|__type (ftype t/any? [t/int?] [t/string?]))) + ['ns1/fghij {:id 2 :ns 'ns1 :arg-types [t/byte?] :output-type t/char? :body [...]}]) + ;; Reactively due to `fghij|__types` changing + (rx-set! fghij|__type (ftype t/any? [t/byte? :> t/char?] [t/int? :> t/long?])) + ;; Consuming the `defnt/overload-queue` (iterate then clear, not incremental pop) + (when (= lang :clj) + (intern 'ns2/abcde|__types|1 + (types-decl>arg-types (rx/norx-deref ns0/abcde|__types) 1)) + (intern 'ns2/fghij|__types|2 + (types-decl>arg-types (rx/norx-deref ns1/fghij|__types) 2)))) - Resulting in `abcde`'s runtime-emission code in CLJ as (easy to adapt for CLJS): - (do ;; Consuming the `defnt/overload-queue` (iterate then clear, not incremental pop) - (intern '.../abcde|__1 (reify* [...] (invoke ([x00__ c] ...)))) - (intern '.../abcde - (let [types|0 (types-decl>arg-types .../abcde|__types 0) - types|1 (types-decl>arg-types .../abcde|__types 1)] - (fn [x00__] - (ifs ((Array/get types|0 0) x00__) (. .../abcde|__0 invoke x00__) - ((Array/get types|0 1) x00__) (. .../abcde|__1 invoke x00__) - (unsupported! ...))))) - ;; TODO figure out how it's going to get the data to figure out the args and body of this - (intern '.../fghij|__1 (reify* [...] (invoke ([x00__ b] ...)))) - (intern '.../fghij - (let [types|0 (types-decl>arg-types .../fghij|types 0) - types|1 (types-decl>arg-types .../fghij|types 1)] - (fn [x00__] - (ifs ((Array/get types|0 0) x00__) (. .../fghij|__0 invoke x00__) - ((Array/get types|0 1) x00__) (. .../fghij|__1 invoke x00__) - (unsupported! ...))))) - (var .../abcde)) + (intern 'ns2/abcde|__1 (reify* [...] (invoke ([x00__ d] ...)))) + (intern 'ns0/abcde + (fn [x00__] + (ifs ((Array/get ns0/abcde|__types|0 0) x00__) (. ns0/abcde|__0 invoke x00__) + ((Array/get ns2/abcde|__types|1 1) x00__) (. ns2/abcde|__1 invoke x00__) + (unsupported! ...)))) + (intern 'ns2/fghij|__2 (reify* [...] (invoke ([x00__ b] ...)))) + (intern 'ns1/fghij + (fn [x00__] + (ifs ((Array/get ns2/fghij|__types|2 0) x00__) (. ns2/fghij|__2 invoke x00__) + ((Array/get ns1/fghij|__types|0 0) x00__) (. ns1/fghij|__0 invoke x00__) + ((Array/get ns1/fghij|__types|1 0) x00__) (. ns1/fghij|__1 invoke x00__) + (unsupported! ...)))) + (var ns0/abcde)) From eebc84492729199e7fb0a05c52bcfde71565177f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 28 Oct 2018 08:21:46 -0600 Subject: [PATCH 588/810] Extract quantum.untyped.core.data.vector --- .../quantum/untyped/core/data/reactive.cljc | 42 +------------------ .../quantum/untyped/core/data/vector.cljc | 39 +++++++++++++++++ 2 files changed, 41 insertions(+), 40 deletions(-) create mode 100644 src-untyped/quantum/untyped/core/data/vector.cljc diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index f0c3addf..72eea0b0 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -15,6 +15,8 @@ [clojure.core :as core] [clojure.set :as set] [quantum.untyped.core.async :as uasync] + [quantum.untyped.core.data.vector + :refer [alist alist== alist-conj! alist-count alist-empty! alist-get]] [quantum.untyped.core.error :as uerr] [quantum.untyped.core.form.generate.deftype :as udt] [quantum.untyped.core.log :as ulog] @@ -24,46 +26,6 @@ :refer [defonce-]]) #?(:clj (:import [java.util ArrayList]))) -;; TODO move -;; ===== Array-list fns ===== ;; - -(defn- alist-get - #?(:clj [^ArrayList xs ^long i] - :cljs [ xs ^number i]) - (#?(:clj .get :cljs aget) xs i)) - -(defn- alist-set! - #?(:clj [^ArrayList xs ^long i v] - :cljs [ xs ^number i v]) - (#?(:clj .set :cljs aset) xs i v)) - -(defn- alist-conj! [#?(:clj ^ArrayList xs :cljs xs) v] - (doto xs (#?(:clj .add :cljs .push) v))) - -(defn- #?(:clj alist-count :cljs ^number alist-count) [#?(:clj ^ArrayList xs :cljs xs)] - (#?(:clj .size :cljs alength) xs)) - -(defn- #?(:clj alist-empty? :cljs ^boolean alist-empty?) [#?(:clj ^ArrayList xs :cljs xs)] - (== (#?(:clj .size :cljs alength) xs) 0)) - -(defn- alist-empty! [#?(:clj ^ArrayList xs :cljs xs)] - #?(:clj (.clear xs) :cljs (set! (.-length xs) 0)) - xs) - -(defn- #?(:clj alist== :cljs ^boolean alist==) - [#?(:clj ^ArrayList x :cljs x) #?(:clj ^ArrayList y :cljs y)] - (let [len (if (nil? x) 0 (long (alist-count x)))] - (and (== len (if (nil? y) 0 (long (alist-count y)))) - (loop [i 0] - (or (== i len) - (if (identical? (alist-get x i) (alist-get y i)) - (recur (inc i)) - false)))))) - -(defn- #?(:clj ^ArrayList alist :cljs alist) - ([] #?(:clj (ArrayList.) :cljs #js [])) - ([x] #?(:clj (doto (ArrayList.) (.add x)) :cljs #js [x]))) - ;; ===== Internal functions for reactivity ===== ;; (def ^:dynamic *ref-context* nil) diff --git a/src-untyped/quantum/untyped/core/data/vector.cljc b/src-untyped/quantum/untyped/core/data/vector.cljc new file mode 100644 index 00000000..ea7de09e --- /dev/null +++ b/src-untyped/quantum/untyped/core/data/vector.cljc @@ -0,0 +1,39 @@ +(ns quantum.untyped.core.data.vector + #?(:clj (:import java.util.ArrayList))) + +(defn alist-get + #?(:clj [^ArrayList xs ^long i] + :cljs [ xs ^number i]) + (#?(:clj .get :cljs aget) xs i)) + +(defn alist-set! + #?(:clj [^ArrayList xs ^long i v] + :cljs [ xs ^number i v]) + (#?(:clj .set :cljs aset) xs i v)) + +(defn alist-conj! [#?(:clj ^ArrayList xs :cljs xs) v] + (doto xs (#?(:clj .add :cljs .push) v))) + +(defn #?(:clj alist-count :cljs ^number alist-count) [#?(:clj ^ArrayList xs :cljs xs)] + (#?(:clj .size :cljs alength) xs)) + +(defn #?(:clj alist-empty? :cljs ^boolean alist-empty?) [#?(:clj ^ArrayList xs :cljs xs)] + (== (#?(:clj .size :cljs alength) xs) 0)) + +(defn alist-empty! [#?(:clj ^ArrayList xs :cljs xs)] + #?(:clj (.clear xs) :cljs (set! (.-length xs) 0)) + xs) + +(defn #?(:clj alist== :cljs ^boolean alist==) + [#?(:clj ^ArrayList x :cljs x) #?(:clj ^ArrayList y :cljs y)] + (let [len (if (nil? x) 0 (long (alist-count x)))] + (and (== len (if (nil? y) 0 (long (alist-count y)))) + (loop [i 0] + (or (== i len) + (if (identical? (alist-get x i) (alist-get y i)) + (recur (inc i)) + false)))))) + +(defn #?(:clj ^ArrayList alist :cljs alist) + ([] #?(:clj (ArrayList.) :cljs #js [])) + ([x] #?(:clj (doto (ArrayList.) (.add x)) :cljs #js [x]))) From 92b9c52f79ceed0bcc297b03f3f9c41972f10f97 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 29 Oct 2018 20:42:16 -0600 Subject: [PATCH 589/810] Remove notions of atomicity from reactive types --- .../quantum/untyped/core/data/reactive.cljc | 57 ++--- src-untyped/quantum/untyped/core/refs.cljc | 7 +- .../test/untyped/core/data/reactive.cljc | 210 ++++++++---------- 3 files changed, 123 insertions(+), 151 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index 72eea0b0..7a535921 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -22,6 +22,7 @@ [quantum.untyped.core.log :as ulog] [quantum.untyped.core.logic :refer [ifs]] + [quantum.untyped.core.refs :as uref] [quantum.untyped.core.vars :refer [defonce-]]) #?(:clj (:import [java.util ArrayList]))) @@ -100,31 +101,28 @@ {;; IPrintWithWriter ;; (-pr-writer [a w opts] (pr-ref a w opts "Reference:")) PReactive nil - ?Equals {= ([this that] (identical? this that))} - ?Deref {deref ([this] - (notify-deref-watcher! this) - state)} - ?Atom {reset! ([a new-value] - (when-not (nil? validator) - (assert (validator new-value) "Validator rejected reference state")) - (let [old-value state] - (if (identical? old-value new-value) - new-value - (let [old-value state] - (set! state new-value) - (when-not (nil? watches) - (notify-w! a old-value new-value)) - new-value)))) - swap! (([a f] (#?(:clj .reset :cljs -reset!) a (f state))) - ([a f x] (#?(:clj .reset :cljs -reset!) a (f state x))) - ([a f x y] (#?(:clj .reset :cljs -reset!) a (f state x y))) - ([a f x y more] (#?(:clj .reset :cljs -reset!) a (apply f state x y more))))} + ?Equals {= ([this that] (identical? this that))} + ?Deref {deref ([this] + (notify-deref-watcher! this) + state)} + uref/PMutableReference + {get ([this] (norx-deref this)) + set! ([a newv] + (when-not (nil? validator) + (assert (validator newv) "Validator rejected reference state")) + (let [oldv state] + (if (identical? oldv newv) + newv + (let [oldv state] + (set! state newv) + (when-not (nil? watches) (notify-w! a oldv newv)) + newv))))} ?Watchable {add-watch! ([this k f] (add-w! this k f)) remove-watch! ([this k] (remove-w! this k))} PWatchable {getWatches ([this] watches) setWatches ([this v] (set! watches v))} - ?Meta {meta ([_] meta) - with-meta ([_ meta'] (Reference. state meta' validator watches))} + ?Meta {meta ([_] meta) + with-meta ([_ meta'] (Reference. state meta' validator watches))} #?@(:cljs [?Hash {hash ([_] (goog/getUid this))}])}) (defn ! @@ -157,7 +155,6 @@ ^boolean no-cache? ^:! on-dispose ^:! on-dispose-arr - ^:! on-set queue ^:! ^:get ^:set state ^:! ^:get ^:set watching ; i.e. 'dependents' @@ -181,6 +178,7 @@ (do (notify-deref-watcher! this) (when-not computed (run-reaction! this false)))) state)))} + uref/PMutableReference {get ([this] (norx-deref this))} ?Watchable {add-watch! ([this k f] (add-w! this k f)) remove-watch! ([this k] (let [was-empty? (empty? watches)] @@ -191,18 +189,6 @@ (.dispose this))))} PWatchable {getWatches ([this] watches) setWatches ([this v] (set! watches v))} - ?Atom - {reset! ([a newv] - (assert (fn? (.-on-set a)) "Reaction is read only; on-set is not allowed") - (let [oldv state] - (set! state newv) - ((.-on-set a) oldv newv) - (notify-w! a oldv newv) - newv)) - swap! (([a f] (#?(:clj .reset :cljs -reset!) a (f (norx-deref a)))) - ([a f x] (#?(:clj .reset :cljs -reset!) a (f (norx-deref a) x))) - ([a f x y] (#?(:clj .reset :cljs -reset!) a (f (norx-deref a) x y))) - ([a f x y more] (#?(:clj .reset :cljs -reset!) a (apply f (norx-deref a) x y more))))} PHasCaptured {getCaptured ([this] captured) setCaptured ([this v] (set! captured v))} @@ -315,7 +301,7 @@ (defn ^Reaction >!rx ([f] (>!rx f nil)) - ([f {:keys [always-recompute? enqueue-fn eq-fn no-cache? on-set on-dispose queue]}] + ([f {:keys [always-recompute? enqueue-fn eq-fn no-cache? on-dispose queue]}] (Reaction. (if (nil? always-recompute?) false always-recompute?) nil nil @@ -326,7 +312,6 @@ (if (nil? no-cache?) false no-cache?) on-dispose nil - on-set (or queue *queue*) nil nil nil))) diff --git a/src-untyped/quantum/untyped/core/refs.cljc b/src-untyped/quantum/untyped/core/refs.cljc index dff0f3aa..a7fbdd1a 100644 --- a/src-untyped/quantum/untyped/core/refs.cljc +++ b/src-untyped/quantum/untyped/core/refs.cljc @@ -30,9 +30,10 @@ (defn update! "A nonatomic update." - [x f] - (quantum.untyped.core.refs/set! x (f (get x))) - x) + ([x f] (doto x (quantum.untyped.core.refs/set! (f (get x))))) + ([x f a0] (doto x (quantum.untyped.core.refs/set! (f (get x) a0)))) + ([x f a0 a1] (doto x (quantum.untyped.core.refs/set! (f (get x) a0 a1)))) + ([x f a0 a1 & as] (doto x (quantum.untyped.core.refs/set! (apply f (get x) a0 a1 as))))) ;; ===== Unsynchronized mutability ===== ;; diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index df25ffa9..0218e86d 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -5,33 +5,35 @@ (:require [quantum.untyped.core.test :as utest :refer [deftest is is= testing]] - [quantum.untyped.core.data.reactive :as rx - :refer [! !eager-rx !run-rx !rx >!rx dispose! flush!]])) + [quantum.untyped.core.data.vector :as uvec] + [quantum.untyped.core.data.reactive :as urx + :refer [! !eager-rx !run-rx !rx >!rx dispose! flush!]] + [quantum.untyped.core.refs :as uref])) (defn with-debug [f] - (flush! rx/global-queue) - (binding [rx/*debug?* true] (f))) + (flush! urx/global-queue) + (binding [urx/*debug?* true] (f))) (utest/use-fixtures :once with-debug) -(defn- running [] @@#'rx/*running) +(defn- running [] @@#'urx/*running) (defn test-perf [] ;; (set! debug? false) ; yes but we need to think about CLJ (dotimes [_ 10] (let [a (! 0) f (fn [] (quot (long @a) 10)) - q (@#'rx/alist) + q (uvec/alist) mid (>!rx f {:queue q}) - res (rx/>track! (fn [] (inc (long @mid))) [] {:queue q})] + res (urx/>track! (fn [] (inc (long @mid))) [] {:queue q})] @res (time (dotimes [_ 100000] ; ~70ms per 100K in CLJ so 0.0007ms for one (0.7 µs or 700 ns) - (swap! a inc) - (@#'rx/flush! q))) + (uref/update! a inc) + (@#'urx/flush! q))) (dispose! res)))) (deftest basic-atom - (binding [rx/*enqueue!* @#'rx/alist-conj!] + (binding [urx/*enqueue!* uvec/alist-conj!] (let [runs (running) start (! 0) sv (!eager-rx @start) @@ -39,12 +41,12 @@ c2 (!eager-rx (inc @comp)) ct (! 0) out (! 0) - res (!eager-rx (swap! ct inc) @sv @c2 @comp) - const (!run-rx (reset! out @res))] + res (!eager-rx (uref/update! ct inc) @sv @c2 @comp) + const (!run-rx (uref/set! out @res))] (is (= @ct 1) "constrain ran") (is (= @out 2)) - (reset! start 1) - (flush! rx/global-queue) + (uref/set! start 1) + (flush! urx/global-queue) (is (= @out 3)) ; not correct; showing 2 (is (<= 2 @ct 3)) (dispose! const) @@ -56,14 +58,14 @@ c3-count (! 0) c1 (!eager-rx @start 1) c2 (!eager-rx @start) - c3 (!rx (swap! c3-count inc) + c3 (!rx (uref/update! c3-count inc) (+ @c1 @c2))] - (flush! rx/global-queue) + (flush! urx/global-queue) (is (= @c3-count 0)) (is (= @c3 1)) (is (= @c3-count 1) "t1") - (swap! start inc) - (flush! rx/global-queue) + (uref/update! start inc) + (flush! urx/global-queue) (is (= @c3-count 2) "t2") (is (= @c3 2)) (is (= @c3-count 2) "t3") @@ -74,17 +76,17 @@ (let [runs (running)] (let [*counter (! 0) *signal (! "All I do is change") - co (!run-rx @*signal (swap! *counter inc))] + co (!run-rx @*signal (uref/update! *counter inc))] (is (= 1 @*counter) "Constraint run on init") - (reset! *signal "foo") - (flush! rx/global-queue) + (uref/set! *signal "foo") + (flush! urx/global-queue) (is (= 2 @*counter) "Counter auto updated") (dispose! co)) (let [*x (! 0) *co (!rx (inc @*x))] (is (= 1 @*co) "CO has correct value on first deref") - (swap! *x inc) + (uref/update! *x inc) (is (= 2 @*co) "CO auto-updates") (dispose! *co)) (is (= (running) runs)))) @@ -98,37 +100,37 @@ b-changed (! 0) c-changed (! 0) b (!eager-rx - (swap! b-changed inc) + (uref/update! b-changed inc) (inc @a1)) c (!eager-rx - (swap! c-changed inc) + (uref/update! c-changed inc) (+ 10 @a2)) res (!run-rx (if (< @a2 1) @b @c))] (is (= @res (+ 2 @a))) (is (= @b-changed 1)) (is (= @c-changed 0)) - (reset! a -1) + (uref/set! a -1) (is (= @res (+ 2 @a))) (is (= @b-changed 2)) (is (= @c-changed 0)) - (reset! a 2) + (uref/set! a 2) (is (= @res (+ 10 @a))) (is (<= 2 @b-changed 3)) (is (= @c-changed 1)) - (reset! a 3) + (uref/set! a 3) (is (= @res (+ 10 @a))) (is (<= 2 @b-changed 3)) (is (= @c-changed 2)) - (reset! a 3) + (uref/set! a 3) (is (= @res (+ 10 @a))) (is (<= 2 @b-changed 3)) (is (= @c-changed 2)) - (reset! a -1) + (uref/set! a -1) (is (= @res (+ 2 @a))) (dispose! res) (is (= (running) runs))))) @@ -141,7 +143,7 @@ c (!eager-rx (dec @a)) d (!eager-rx (str @b)) res (! 0) - cs (!run-rx (reset! res @d))] + cs (!run-rx (uref/set! res @d))] (is (= @res "1")) (dispose! cs)) ;; should be broken according to https://github.com/lynaghk/reflex/issues/1 @@ -158,14 +160,14 @@ d (!run-rx [@b @c]) res (! 0)] (is (= @d [1 -1])) - (let [e (!run-rx (reset! res @d))] + (let [e (!run-rx (uref/set! res @d))] (is (= @res [1 -1])) (dispose! e)) (dispose! d)) (is (= (running) runs)))) (deftest test-dispose - (binding [rx/*enqueue!* @#'rx/alist-conj!] + (binding [urx/*enqueue!* uvec/alist-conj!] (dotimes [x 10] (let [runs (running) a (! 0) @@ -173,42 +175,42 @@ disposed-c (! nil) disposed-cns (! nil) count-b (! 0) - b (>!rx (fn [] (swap! count-b inc) (inc @a)) + b (>!rx (fn [] (uref/update! count-b inc) (inc @a)) {:always-recompute? true - :on-dispose (fn [r] (reset! disposed true)) - :queue rx/global-queue}) + :on-dispose (fn [r] (uref/set! disposed true)) + :queue urx/global-queue}) c (>!rx #(if (< @a 1) (inc @b) (dec @a)) {:always-recompute? true - :on-dispose (fn [r] (reset! disposed-c true)) - :queue rx/global-queue}) + :on-dispose (fn [r] (uref/set! disposed-c true)) + :queue urx/global-queue}) res (! nil) - cns (>!rx #(reset! res @c) - {:on-dispose (fn [r] (reset! disposed-cns true)) - :queue rx/global-queue})] + cns (>!rx #(uref/set! res @c) + {:on-dispose (fn [r] (uref/set! disposed-cns true)) + :queue urx/global-queue})] @cns (is (= @res 2)) (is (= (+ 4 runs) (running))) (is (= @count-b 1)) - (reset! a -1) - (flush! rx/global-queue) + (uref/set! a -1) + (flush! urx/global-queue) (is (= @res 1)) (is (= @disposed nil)) (is (= @count-b 2)) (is (= (+ 4 runs) (running)) "still running") - (reset! a 2) - (flush! rx/global-queue) + (uref/set! a 2) + (flush! urx/global-queue) (is (= @res 1)) (is (= @disposed true)) (is (= (+ 2 runs) (running)) "less running count") - (reset! disposed nil) - (reset! a -1) - (flush! rx/global-queue) + (uref/set! disposed nil) + (uref/set! a -1) + (flush! urx/global-queue) ;; This fails sometimes on node. I have no idea why. (is (= 1 @res) "should be one again") (is (= @disposed nil)) - (reset! a 2) - (flush! rx/global-queue) + (uref/set! a 2) + (flush! urx/global-queue) (is (= @res 1)) (is (= @disposed true)) (dispose! cns) @@ -224,38 +226,38 @@ disposed-c (! nil) disposed-cns (! nil) count-b (! 0) - b (!eager-rx (swap! count-b inc) (inc @a)) + b (!eager-rx (uref/update! count-b inc) (inc @a)) c (!eager-rx (if (< @a 1) (inc @b) (dec @a))) res (! nil) - cns (!rx (reset! res @c))] - (rx/add-on-dispose! b (fn [r] - (is (= r b)) - (reset! disposed true))) - (rx/add-on-dispose! c (fn [r] (reset! disposed-c true))) - (rx/add-on-dispose! cns (fn [r] (reset! disposed-cns true))) + cns (!rx (uref/set! res @c))] + (urx/add-on-dispose! b (fn [r] + (is (= r b)) + (uref/set! disposed true))) + (urx/add-on-dispose! c (fn [r] (uref/set! disposed-c true))) + (urx/add-on-dispose! cns (fn [r] (uref/set! disposed-cns true))) @cns (is (= @res 2)) (is (= (+ 4 runs) (running))) (is (= @count-b 1)) - (reset! a -1) - (flush! rx/global-queue) + (uref/set! a -1) + (flush! urx/global-queue) (is (= @res 1)) (is (= @disposed nil)) (is (= @count-b 2)) (is (= (+ 4 runs) (running)) "still running") - (reset! a 2) - (flush! rx/global-queue) + (uref/set! a 2) + (flush! urx/global-queue) (is (= @res 1)) (is (= @disposed true)) (is (= (+ 2 runs) (running)) "less running count") - (reset! disposed nil) - (reset! a -1) - (flush! rx/global-queue) + (uref/set! disposed nil) + (uref/set! a -1) + (flush! urx/global-queue) (is (= 1 @res) "should be one again") (is (= @disposed nil)) - (reset! a 2) - (flush! rx/global-queue) + (uref/set! a 2) + (flush! urx/global-queue) (is (= @res 1)) (is (= @disposed true)) (dispose! cns) @@ -263,22 +265,6 @@ (is (= @disposed-cns true)) (is (= runs (running)))))) -(deftest test-on-set - (let [runs (running) - a (! 0) - b (>!rx #(+ 5 @a) - {:on-set (fn [oldv newv] (reset! a (+ 10 newv))) - :queue rx/global-queue})] - @b - (is (= 5 @b)) - (reset! a 1) - (is (= 6 @b)) - (reset! b 1) - (is (= 11 @a)) - (is (= 16 @b)) - (dispose! b) - (is (= runs (running))))) - (deftest non-reactive-deref (let [runs (running) a (! 0) @@ -286,7 +272,7 @@ (is (= @b 5)) (is (= runs (running))) - (reset! a 1) + (uref/set! a 1) (is (= @b 6)) (is (= runs (running))))) @@ -296,15 +282,15 @@ c1 (!eager-rx (get-in @state [:data :a])) c2 (!eager-rx (get-in @state [:data :b])) rxn (!rx (let [cc1 @c1, cc2 @c2] - (swap! state assoc :derived (+ (or cc1 0) (or cc2 0))) + (uref/update! state assoc :derived (+ (or cc1 0) (or cc2 0))) nil))] @rxn (is (= (:derived @state) 0)) - (swap! state assoc :data {:a 1 :b 2}) - (flush! rx/global-queue) + (uref/update! state assoc :data {:a 1 :b 2}) + (flush! urx/global-queue) (is (= (:derived @state) 3)) - (swap! state assoc :data {:a 11 :b 22}) - (flush! rx/global-queue) + (uref/update! state assoc :data {:a 11 :b 22}) + (flush! urx/global-queue) (is (= (:derived @state) 33)) (dispose! rxn) (is (= runs (running))))) @@ -314,15 +300,15 @@ state (! 1) count (! 0) r (!run-rx - (swap! count inc) + (uref/update! count inc) (when (> @state 1) (throw (ex-info "oops" {}))))] (is (= @count 1)) (is (thrown? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) - (do (swap! state inc) - (flush! rx/global-queue)))) + (do (uref/update! state inc) + (flush! urx/global-queue)))) (is (= @count 2)) - (swap! state dec) - (flush! rx/global-queue) + (uref/update! state dec) + (flush! urx/global-queue) (is (= @count 3)) (dispose! r) (is (= runs (running))))) @@ -334,22 +320,22 @@ ref (!eager-rx (when (= @state 2) (throw (ex-info "err" {})))) r (!run-rx - (swap! count inc) + (uref/update! count inc) @ref)] (is (= @count 1)) (is (thrown? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) - (do (swap! state inc) - (flush! rx/global-queue)))) + (do (uref/update! state inc) + (flush! urx/global-queue)))) (is (= @count 2)) (is (thrown? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) @ref)) - (swap! state inc) - (flush! rx/global-queue) + (uref/update! state inc) + (flush! urx/global-queue) (is (= @count 3)) (dispose! r) (is (= runs (running))))) (deftest exception-side-effect - (binding [rx/*enqueue!* @#'rx/alist-conj!] + (binding [urx/*enqueue!* uvec/alist-conj!] (let [runs (running) state (! {:val 1}) rstate (!eager-rx @state) @@ -362,31 +348,31 @@ r3 (!run-rx (when (:error? @rstate) (throw (ex-info "Error detected!" {}))))] - (swap! state assoc :val 2) - (flush! rx/global-queue) - (swap! state assoc :error? true) + (uref/update! state assoc :val 2) + (flush! urx/global-queue) + (uref/update! state assoc :error? true) (is (thrown? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) - (flush! rx/global-queue))) - (flush! rx/global-queue) - (flush! rx/global-queue) + (flush! urx/global-queue))) + (flush! urx/global-queue) + (flush! urx/global-queue) (dispose! r1) (dispose! r2) (dispose! r3) (is (= runs (running)))))) (deftest exception-reporting - (binding [rx/*enqueue!* @#'rx/alist-conj!] + (binding [urx/*enqueue!* uvec/alist-conj!] (let [runs (running) state (! {:val 1}) rstate (!eager-rx (:val @state)) r1 (!run-rx (when (= @rstate 13) (throw (ex-info "fail" {}))))] - (swap! state assoc :val 13) + (uref/update! state assoc :val 13) (is (thrown? #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) - (flush! rx/global-queue))) - (swap! state assoc :val 2) - (flush! rx/global-queue) + (flush! urx/global-queue))) + (uref/update! state assoc :val 2) + (flush! urx/global-queue) (dispose! r1) (is (= runs (running)))))) @@ -418,7 +404,7 @@ (is= @b-ct 3) (is= @c-ct 3) - (reset! a 234) + (uref/set! a 234) @c (is= @b-ct 4) @@ -435,13 +421,13 @@ (is= @b-lazy-ct 1) (is= @c-lazy-ct 1) - (reset! a 234) ; resetting to the same state + (uref/set! a 234) ; resetting to the same state @c-lazy (is= @b-lazy-ct 2) (is= @c-lazy-ct 1) - (reset! a 123) + (uref/set! a 123) @c-lazy (is= @b-lazy-ct 3) From 3e2ff9ad63f4ee686a681d7068b8ce1aa8ae4e3c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 29 Oct 2018 20:44:12 -0600 Subject: [PATCH 590/810] Add `uc/run!` rather than `each` --- src-untyped/quantum/untyped/core/collections.cljc | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index bb7a7f7b..7eed76e2 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -2,7 +2,7 @@ "Operations on collections." (:refer-clojure :exclude [#?(:cljs array?) assoc-in cat conj! contains? count distinct distinct? first get group-by - filter flatten frequencies last map map-indexed mapcat partition-all pmap remove reverse + filter flatten frequencies last map map-indexed mapcat partition-all pmap remove reverse run! zipmap]) (:require [clojure.core :as core] @@ -371,6 +371,10 @@ (defn lcat [xs] (apply concat xs)) +(defn run! + "Like `core/run!` but uses `educe` internally." + [f xs] (->> xs (educe (fn ([] nil) ([ret] ret) ([ret x] (f x)))))) + (defn distinct? "Like `clojure.core/distinct?` except operates on reducibles." [xs] From 0e0334b5a7e0e2523765f372c44aa08c45de3e38 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 29 Oct 2018 22:44:05 -0600 Subject: [PATCH 591/810] Add `add-interceptor!` --- .../quantum/untyped/core/data/reactive.cljc | 49 ++++++++++++------- src-untyped/quantum/untyped/core/refs.cljc | 23 +++++---- .../test/untyped/core/data/reactive.cljc | 9 ++++ 3 files changed, 54 insertions(+), 27 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index 7a535921..0935fa2e 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -97,7 +97,12 @@ (alist-conj! c derefed) (.setCaptured r (alist derefed)))))) -(udt/deftype Reference [^:! state meta validator ^:! watches] +(defn- call|rf + ([ret] ret) + ([ret f] (f ret)) + ([ret k f] (f ret))) + +(udt/deftype Reference [^:! state meta validator ^:! watches ^:! interceptors] {;; IPrintWithWriter ;; (-pr-writer [a w opts] (pr-ref a w opts "Reference:")) PReactive nil @@ -114,22 +119,26 @@ (if (identical? oldv newv) newv (let [oldv state] - (set! state newv) + (set! state (if (nil? interceptors) + newv + (reduce-kv call|rf newv interceptors))) (when-not (nil? watches) (notify-w! a oldv newv)) newv))))} ?Watchable {add-watch! ([this k f] (add-w! this k f)) remove-watch! ([this k] (remove-w! this k))} - PWatchable {getWatches ([this] watches) - setWatches ([this v] (set! watches v))} + PWatchable {getWatches ([this] watches) + setWatches ([this v] (set! watches v))} + uref/PInterceptable + {add-interceptor! ([this k f] (set! interceptors (assoc interceptors k f)))} ?Meta {meta ([_] meta) - with-meta ([_ meta'] (Reference. state meta' validator watches))} + with-meta ([_ meta'] (Reference. state meta' validator watches interceptors))} #?@(:cljs [?Hash {hash ([_] (goog/getUid this))}])}) (defn ! "Reactive '!' (single-threaded mutable reference). Like `ref/!`, except that it keeps track of derefs." - ([x] (Reference. x nil nil nil)) - ([x & {:keys [meta validator]}] (Reference. x meta validator nil))) + ([x] (Reference. x nil nil nil nil)) + ([x validator] (Reference. x nil validator nil nil))) ;; ===== Reaction ("Computed Observable") ===== ;; @@ -158,7 +167,8 @@ queue ^:! ^:get ^:set state ^:! ^:get ^:set watching ; i.e. 'dependents' - ^:! watches] ; TODO consider a mutable map for `watches` + ^:! watches ; TODO consider a mutable map for `watches` + ^:! interceptors] ; TODO consider a mutable map for `interceptors` {;; IPrintWithWriter ;; (-pr-writer [a w opts] (pr-ref a w opts (str "Reaction " (hash a) ":"))) ?Equals {= ([this that] (identical? this that))} @@ -172,7 +182,9 @@ (if (and non-reactive? alwaysRecompute) (when-not computed (let [old-state state] - (set! state (f)) + (set! state (if (nil? interceptors) + (f) + (reduce-kv call|rf (f) interceptors))) (when-not (or (nil? watches) (eq-fn old-state state)) (notify-w! this old-state state)))) (do (notify-deref-watcher! this) @@ -189,9 +201,11 @@ (.dispose this))))} PWatchable {getWatches ([this] watches) setWatches ([this v] (set! watches v))} - PHasCaptured - {getCaptured ([this] captured) - setCaptured ([this v] (set! captured v))} + uref/PInterceptable + {add-interceptor! ([this k f] (set! interceptors (assoc interceptors k f)))} + PHasCaptured + {getCaptured ([this] captured) + setCaptured ([this v] (set! captured v))} PDisposable {dispose ([this] @@ -201,15 +215,16 @@ (set! alwaysRecompute #?(:clj (boolean true) :cljs true)) (set! computed #?(:clj (boolean false) :cljs false)) (doseq [w (set wg)] (#?(:clj remove-watch :cljs -remove-watch) w this)) - (when (some? (.-on-dispose this)) ((.-on-dispose this) s)) - (when-some [a (.-on-dispose-arr this)] + (set! interceptors nil) + (when (some? on-dispose) (on-dispose s)) + (when-some [a on-dispose-arr] (dotimes [i (long (alist-count a))] ((alist-get a i) this))))) addOnDispose ([this f] ;; f is called with the reaction as argument when it is no longer active - (if-some [a (.-on-dispose-arr this)] + (if-some [a on-dispose-arr] (alist-conj! a f) - (set! (.-on-dispose-arr this) (alist f))))}}) + (set! on-dispose-arr (alist f))))}}) (defn- in-context "When f is executed, if (f) derefs any reactive references, they are then added to @@ -313,7 +328,7 @@ on-dispose nil (or queue *queue*) - nil nil nil))) + nil nil nil nil))) #?(:clj (defmacro !rx "Creates a single-threaded reaction." [& body] `(>!rx (fn [] ~@body)))) diff --git a/src-untyped/quantum/untyped/core/refs.cljc b/src-untyped/quantum/untyped/core/refs.cljc index a7fbdd1a..d676dda7 100644 --- a/src-untyped/quantum/untyped/core/refs.cljc +++ b/src-untyped/quantum/untyped/core/refs.cljc @@ -17,16 +17,19 @@ (defn ?deref [x] (if (derefable? x) @x x)) (defprotocol PMutableReference - (get [this]) - (set! [this v]) - (getAndSet [this v])) + (get [this]) + (set! [this v]) + (get-and-set! [this v])) + +(defprotocol PInterceptable + (add-interceptor! [this k f])) #?(:clj (extend-protocol PMutableReference ThreadLocal - (get [this] (.get this)) - (set! [this v] (.set this v) v) - (getAndSet [this v] (let [v-prev (.get this)] (.set this v) v-prev)))) + (get [this] (.get this)) + (set! [this v] (.set this v) v) + (get-and-set! [this v] (let [v-prev (.get this)] (.set this v) v-prev)))) (defn update! "A nonatomic update." @@ -40,12 +43,12 @@ ;; TODO create for every primitive datatype as well (deftype MutableReference [#?(:clj ^:unsynchronized-mutable val :cljs ^:mutable val)] PMutableReference - (get [this] val) - (set! [this v] (set! val v) val) - (getAndSet [this v] (let [v-prev val] (set! val v) v-prev)) + (get [this] val) + (set! [this v] (set! val v) val) + (get-and-set! [this v] (let [v-prev val] (set! val v) v-prev)) #?(:clj clojure.lang.IDeref :cljs cljs.core/IDeref) - (#?(:clj deref :cljs -deref) [this] val)) + (#?(:clj deref :cljs -deref) [this] val)) (defn ! [x] (MutableReference. x)) diff --git a/test/quantum/test/untyped/core/data/reactive.cljc b/test/quantum/test/untyped/core/data/reactive.cljc index 0218e86d..ce5706d4 100644 --- a/test/quantum/test/untyped/core/data/reactive.cljc +++ b/test/quantum/test/untyped/core/data/reactive.cljc @@ -435,3 +435,12 @@ @c-lazy (is= @b-lazy-ct 3) (is= @c-lazy-ct 2)))) + +(deftest test-interceptors + (let [a (! 1)] + (uref/add-interceptor! a :inc inc) + (uref/set! a 4) + (is= @a 5) + (uref/add-interceptor! a :+23 (fn [x] (+ x 23))) + (uref/set! a 8) + (is= @a 32)) From 1024ae61e446bc104c82b3ae1309dfce265603e2 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 29 Oct 2018 22:44:12 -0600 Subject: [PATCH 592/810] Clarify docstring --- src-untyped/quantum/untyped/core/vars.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/vars.cljc b/src-untyped/quantum/untyped/core/vars.cljc index 48a4492a..20240f39 100644 --- a/src-untyped/quantum/untyped/core/vars.cljc +++ b/src-untyped/quantum/untyped/core/vars.cljc @@ -143,7 +143,7 @@ (def intern! intern) (defn intern-once! - "Interns a var corresponding to ->`sym` only if the var does not have a value." + "Interns a var corresponding to ->`sym` only if the var has not already been interned." ([ns-sym #_symbol?, sym #_symbol?, v #_t/ref?] (or (resolve (find-ns ns-sym) sym) (intern! ns-sym sym v)))) From 654ea190870dc104526d22f637d6dc5673c4ef4e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 29 Oct 2018 22:44:34 -0600 Subject: [PATCH 593/810] Flesh out more of the reactive types skeleton --- resources-dev/defnt.cljc | 9 +- .../quantum/test/untyped/core/type/defnt.cljc | 103 +++++++++++------- 2 files changed, 70 insertions(+), 42 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 454010f2..acf5014a 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -223,6 +223,10 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative we annotate like `(name ^:dyn (read ...))`, meaning figure out at runtime what the out-type of the call to `(read ...)` is, not, call `name` dynamically. - `t/defn` + - `declare` but for `t/defn` + - Currently we can declare that there is an fn, and what its output type is, and its metadata, + but we cannot currently declare type-overloads. Experience will make clearer what to do in + these cases. - `|` (pre-types) - Arity elision: if any type in an arity is `t/none?` then elide it and emit a warning - `([x bigint?] x)` @@ -1886,6 +1890,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative [ ] Types yielding generative specs [—] Types using the clojure.spec interface - Not yet; wait for it to come out of alpha -[ ] We don't need to use bootstrapped CLJS per se (though that's cool and we can look into it); we - can try to hook in to the JS version of the Closure Compiler. That's for later. +[ ] We do need to rely on bootstrapped CLJS for Figwheel-style dev-time recompilation, but we don't + need to rely on bootstrapped CLJS per se for advanced compilation. We can try to hook in to the + JS version of the Closure Compiler. All of that is for later. " diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 2c05744e..0b5019c6 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1884,17 +1884,20 @@ - `t/fn`s should either disallow reactive types or norx-deref them (at least for now) - Redefining should empty the `watching` (so no reactivity happens) but keep the reference + + ([a (t/or tt/boolean? (t/type b)) b (t/or tt/byte? (t/type d)) - c (t/or tt/short? tt/char?) - d (let [b (t/- tt/char? tt/long?)] + c (t/or tt/short? tt/string?) + d (let [b (t/- tt/int? tt/long?)] (t/or tt/char? (t/type b) (t/type c))) > (t/or (t/type b) (t/type d))]) -> ;; Imagine this with `let`s, essentially — reference sharing. This is just written out -;; Then instead of handing the analyzer forms, we can hand it types to split -;; In this way we don't have to re-analyze the arglist every time, but we do still have to analyze -;; the body which is expected +;; This is just to capture what will require type-recomputation +;; We will still have to analyze the arglist and body every time; we leave as an enhancement a +;; clever way to avoid reanalyzing the arglist every time. It seems that we will have to analyze the +;; body every time though, at least to some extent. ([a (t/rx (t/or tt/boolean? (t/arglist-type ; t/arglist-type is always t/>< (t/or tt/byte? @@ -1927,11 +1930,18 @@ (c/map+ (fn [{:keys [arg-types out-type]}] {:arg-types (mapv ?deref arg-types) :out-type (?deref out-type)})) expand-types)) - - (defn- overload-queue-watch [_ _ oldv newv] + - overloads>type-decl + - Shouldn't re-analyze + - Attaches `:overload` for newly analyzed overloads + - (defn- overload-queue-interceptor [_ _ oldv newv] (let [first-new-id (count oldv)] (->> newv - (c/filter+ (fn-> :id (>= first-new-id))) - (c/each (fn [x] (alist-conj! defnt/overload-queue x)))))) + (uc/map (fn [x] + (if (-> x :id (>= first-new-id)) + (do (alist-conj! defnt/overload-queue (:overload x)) + ;; to save memory + (dissoc x :overload)) + x)))))) - (t/defn abcde [a t/int? > t/long?] ...) ; in `ns0` - Resulting in `abcde`'s compile-time-emission code (assuming no :test mode) as: - (do ;; These are append-only @@ -1941,28 +1951,31 @@ ;; now; we will optimize later after correctness is achieved ;; Needs to maintain previous fully-derefed version so `overloads>type-decl` knows which ;; reactive overloads have changed - (intern 'ns0/abcde|__overload-bases ; CLJS compiler needs this to perform analysis + (intern 'ns0 'abcde|__overload-bases ; CLJS compiler needs this to perform analysis (rx/! {:prev nil :current - [{:ns 'ns0 - :arg-types [t/int?] - :output-type t/long? - :body [...] - :reactive? false}]})) + [{:ns 'ns0 + :args-form nil + :arg-types [t/int?] + :output-type t/long? + :output-type-form nil + :body [...] + :dependent? false + :reactive? false}]})) ;; Will not re-analyze overload if it is identical (`=`?) to the previous version of that - ;; overload + ;; overload (when derefing everything) ;; Must include the :body and :defined-in-ns of each one in order to analyze and create ;; new overloads when putting on the overload queue ;; Internally rx-derefs reactive overloads ;; CLJS compiler needs this to perform analysis - (intern 'ns0/abcde|__types (!rx (overloads>type-decl @ns0/abcde|__overload-bases))) - (add-watch ns0/abcde|__types :overload-queue overload-queue-watch) - (intern 'ns0/abcde|__type + (intern 'ns0 'abcde|__types (!rx (overload-bases>type-decl @ns0/abcde|__overload-bases))) + (uref/add-interceptor! ns0/abcde|__types :overload-queue overload-queue-interceptor) + (intern 'ns0 'abcde|__type (let [out-type t/any?] (t/rx (type-data>ftype @ns0/abcde|__types (?deref out-type))))) ;; Each of these types should be completely unreactive. (when (= lang :clj) - (intern '.../abcde|__types|0 + (intern 'ns0 'abcde|__types|0 (types-decl>arg-types (rx/norx-deref ns0/abcde|__types) 0)))) - Resulting in `abcde`'s runtime-emission code in CLJ as: - (do (def abcde|__0 (reify* [int>long] (invoke ([x00__ a] ...)))) @@ -1981,28 +1994,38 @@ ([b t/string? > (t/type b)] ...) ([c (t/input-type ns0/abcde :?) > (t/output-type ns0/abcde (t/type c))] ...)) - Resulting in `fghij`'s compile-time-emission code (assuming no :test mode) as: - - (do (intern 'ns1/fghij|__overload-bases + - (do (intern 'ns1 'fghij|__overload-bases (rx/! {:prev nil :current [(let [t0 t/string?] - {:ns 'ns1 - :arg-types [t0] - :output-type (t/type* t0) - :body [...] - :reactive? false}) + {:ns 'ns1 + :args-form nil + :arg-types [t0] + :output-type-form nil + :output-type (t/type* t0) + :body [...] + :dependent? false + :reactive? false}) (let [t0 (t/rx (t/input-type* @ns0/abcde|__type :?))] - {:ns 'ns1 - :arg-types [t0] - :output-type (t/rx (t/output-type* @ns0/abcde|__type (t/type* @t0))) - :body [...] - :reactive? true})]})) - (intern 'ns1/fghij|__types (!rx (overloads>type-decl @ns1/fghij|__overload-bases))) - (add-watch ns1/fghij|__types :overload-queue overload-queue-watch) - (intern 'ns1/fghij|__type + {:ns 'ns1 + ;; This is only present when there is at least one dependent type in the + ;; arglist / output + :args-form '{c (t/input-type ns0/abcde :?)} + :arg-types [t0] + ;; This is only present when there is at least one dependent type in the + ;; arglist / output + :output-type-form '(t/output-type ns0/abcde (t/type c)) + :output-type (t/rx (t/output-type* @ns0/abcde|__type @t0)) + :body [...] + :dependent? true + :reactive? true})]})) + (intern 'ns1 'fghij|__types (!rx (overload-bases>type-decl @ns1/fghij|__overload-bases))) + (uref/add-interceptor! ns1/fghij|__types :overload-queue overload-queue-interceptor) + (intern 'ns1 'fghij|__type (let [out-type t/any?] (t/rx (type-data>ftype @ns1/fghij|__types (?deref out-type))))) (when (= lang :clj) - (intern 'ns1/fghij|__types|0 + (intern 'ns1 'fghij|__types|0 (types-decl>arg-types (rx/norx-deref ns1/fghij|__types) 0)))) - Resulting in `fghij`'s runtime-emission code in CLJ as: - (do (def fghij|__types|0 (types-decl>arg-types ns0/fghij|__types 0)) @@ -2056,20 +2079,20 @@ (rx-set! fghij|__type (ftype t/any? [t/byte? :> t/char?] [t/int? :> t/long?])) ;; Consuming the `defnt/overload-queue` (iterate then clear, not incremental pop) (when (= lang :clj) - (intern 'ns2/abcde|__types|1 + (intern 'ns2 'abcde|__types|1 (types-decl>arg-types (rx/norx-deref ns0/abcde|__types) 1)) - (intern 'ns2/fghij|__types|2 + (intern 'ns2 'fghij|__types|2 (types-decl>arg-types (rx/norx-deref ns1/fghij|__types) 2)))) - Resulting in `abcde`'s runtime-emission code in CLJ as (easy to adapt for CLJS): - (do ;; Consuming the `defnt/overload-queue` (iterate then clear, not incremental pop) - (intern 'ns2/abcde|__1 (reify* [...] (invoke ([x00__ d] ...)))) - (intern 'ns0/abcde + (intern 'ns2 'abcde|__1 (reify* [...] (invoke ([x00__ d] ...)))) + (intern 'ns0 'abcde (fn [x00__] (ifs ((Array/get ns0/abcde|__types|0 0) x00__) (. ns0/abcde|__0 invoke x00__) ((Array/get ns2/abcde|__types|1 1) x00__) (. ns2/abcde|__1 invoke x00__) (unsupported! ...)))) - (intern 'ns2/fghij|__2 (reify* [...] (invoke ([x00__ b] ...)))) - (intern 'ns1/fghij + (intern 'ns2 'fghij|__2 (reify* [...] (invoke ([x00__ b] ...)))) + (intern 'ns1 'fghij (fn [x00__] (ifs ((Array/get ns2/fghij|__types|2 0) x00__) (. ns2/fghij|__2 invoke x00__) ((Array/get ns1/fghij|__types|0 0) x00__) (. ns1/fghij|__0 invoke x00__) From 84e6573e4a8bf44d35ced48250b61863c9c0f886 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 2 Nov 2018 00:41:42 -0600 Subject: [PATCH 594/810] `reduce-2` arg order changed --- src-untyped/quantum/untyped/core/collections.cljc | 2 +- src-untyped/quantum/untyped/core/loops.cljc | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index 7eed76e2..69680dc7 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -184,7 +184,7 @@ (def mergev (partial mergev-with (fn [i v0 v1] v1))) (defn zipmap-into [x ks vs] - (reduce-2 assoc x ks vs (fn [_ _] (throw (ex-info "Seqs' count is not the same"))))) + (reduce-2 assoc (fn [_ _] (throw (ex-info "Seqs' count is not the same"))) x ks vs)) (defn zipmap [ks vs] (zipmap-into {} ks vs)) diff --git a/src-untyped/quantum/untyped/core/loops.cljc b/src-untyped/quantum/untyped/core/loops.cljc index fd52a025..b94634cc 100644 --- a/src-untyped/quantum/untyped/core/loops.cljc +++ b/src-untyped/quantum/untyped/core/loops.cljc @@ -11,15 +11,15 @@ (defn reduce-2 "Reduces over two seqables at a time." ([f xs0 xs1] (reduce-2 f nil xs0 xs1)) - ([f init xs0 xs1] (reduce-2 f init xs0 xs1 default-on-different-count)) - ([f init xs0 xs1 on-different-count] + ([f init xs0 xs1] (reduce-2 f default-on-different-count init xs0 xs1)) + ([f on-different-count init xs0 xs1] (loop [ret init xs0' xs0 xs1' xs1] (cond (reduced? ret) @ret (or (empty? xs0') (empty? xs1')) (if (or (and (empty? xs0') (seq xs1')) (and (seq xs0') (empty? xs1'))) - (on-different-count xs0 xs1) + (unreduced (on-different-count xs0 xs1)) ret) :else (recur (f ret (first xs0') (first xs1')) (next xs0') @@ -32,7 +32,7 @@ ([f init xs0 xs1 on-different-count] (let [f' (let [*i (volatile! -1)] (fn [ret x0 x1] (f ret x0 x1 (vreset! *i (unchecked-inc (long @*i))))))] - (reduce-2 f' init xs0 xs1 on-different-count)))) + (reduce-2 f' on-different-count init xs0 xs1)))) ;; TODO incorporate into `quantum.core.loops` #?(:clj From 14359d5d7d0ade29d1a3a6282909afc6d9e17e19 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 2 Nov 2018 00:41:52 -0600 Subject: [PATCH 595/810] `seq-or-2`, `seq-and-2` --- .../quantum/untyped/core/collections/logic.cljc | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src-untyped/quantum/untyped/core/collections/logic.cljc b/src-untyped/quantum/untyped/core/collections/logic.cljc index e62784f7..e80515f9 100644 --- a/src-untyped/quantum/untyped/core/collections/logic.cljc +++ b/src-untyped/quantum/untyped/core/collections/logic.cljc @@ -9,6 +9,8 @@ :refer [>sentinel]] [quantum.untyped.core.fn :refer [rcomp]] + [quantum.untyped.core.loops + :refer [reduce-2]] [quantum.untyped.core.reducers :refer [educe]] [quantum.untyped.core.vars @@ -35,6 +37,12 @@ (defalias some seq-or) +(defn seq-or-2 + "Like `seq-or` but for 2 seqables." + [pred xs0 xs1] + (reduce-2 (fn [_ x0 x1] (and (pred x0 x1) (reduced true))) + (fn [_ _] false) false xs0 xs1)) + ;; ----- `seq-nor` ----- ;; #_(def seq-nor|rf ...) @@ -64,6 +72,12 @@ (defalias every? seq-and) +(defn seq-and-2 + "Like `seq-and` but for 2 seqables." + [pred xs0 xs1] + (reduce-2 (fn [_ x0 x1] (or (pred x0 x1) (reduced false))) + (fn [_ _] false) true xs0 xs1)) + ;; ----- `seq-and-2` ----- ;; (defn seq-and-2 From 73be6f0074e338a6e13aeb4f70c396df38784e7b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 2 Nov 2018 00:41:58 -0600 Subject: [PATCH 596/810] Add note --- src-untyped/quantum/untyped/core/data/reactive.cljc | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index 0935fa2e..42ff94da 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -102,6 +102,7 @@ ([ret f] (f ret)) ([ret k f] (f ret))) +;; Note that `interceptors` are all deref-capturing (udt/deftype Reference [^:! state meta validator ^:! watches ^:! interceptors] {;; IPrintWithWriter ;; (-pr-writer [a w opts] (pr-ref a w opts "Reference:")) @@ -153,6 +154,7 @@ (declare flush! run-reaction! update-watching!) +;; Note that `interceptors` are all deref-capturing (udt/deftype Reaction [^:! ^boolean ^:get alwaysRecompute ^:! ^:get ^:set caught From 804ae1c1b59825e2276c9d54f66122622dba542b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 2 Nov 2018 00:42:32 -0600 Subject: [PATCH 597/810] Add optimization to `t/compare` --- src-untyped/quantum/untyped/core/type/compare.cljc | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index 95b48d15..37f2ad2a 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -402,10 +402,12 @@ Does not compare cardinalities or other relations of sets, but rather only sub/superset relations." [t0 type?, t1 type? > comparison?] - (let [dispatched (-> compare|dispatch (get (type t0)) (get (type t1)))] - (if (nil? dispatched) - (err! (str "Types not handled: " {:t0 t0 :t1 t1}) {:t0 t0 :t1 t1}) - (dispatched t0 t1)))) + (if (identical? t0 t1) + =ident + (let [dispatched (-> compare|dispatch (get (type t0)) (get (type t1)))] + (if (nil? dispatched) + (err! (str "Types not handled: " {:t0 t0 :t1 t1}) {:t0 t0 :t1 t1}) + (dispatched t0 t1))))) (defns < "Computes whether the extension of type ->`t0` is a strict subset of that of ->`t1`." From bd2b90d01c4d5451739c62e40df03c8a4b9e20e5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 2 Nov 2018 00:42:50 -0600 Subject: [PATCH 598/810] Correct `t/rx` and `t/fnt?` --- src-untyped/quantum/untyped/core/type.cljc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 0ecc6fea..a11b0482 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -113,7 +113,7 @@ then the whole type will become reactive. Thus, reactivity is 'infectious'. The only macro in all of the core type predicates." - [& body] `(rx* (urx/rx ~@body) ($ ~(vec body))))) + [& body] `(rx* (urx/!rx ~@body) ($ ~(vec body))))) (defn- deref-when-reactive [x] (if (utr/reactive-type? x) @@ -847,7 +847,7 @@ (isa?|direct #?(:clj clojure.lang.IFn :cljs cljs.core/IFn))) ;; Used by `quantum.untyped.core.analyze` via `t/callable?` -(def fnt? (and fn? (>expr (fn-> c/meta :quantum.core.type/type utr/fn-type?)))) +(def fnt? (and fn? (>expr (fn-> c/meta :quantum.core.type/type type?)))) ;; TODO should we allow java.lang.Runnable, java.util.concurrent.Callable, and other ;; functional interfaces to be `callable?`? From 7552e16106c1fdb61f1737bd4a71ad7e4c28353e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 2 Nov 2018 00:43:08 -0600 Subject: [PATCH 599/810] For rx type, simplify some logic and fix printing --- .../quantum/untyped/core/type/reifications.cljc | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 13adff67..6dd9ba1f 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -7,6 +7,8 @@ [fipp.ednize :as fedn] [quantum.untyped.core.analyze.expr #?@(:cljs [:refer [Expression]])] + [quantum.untyped.core.collections.logic + :refer [seq-and-2]] [quantum.untyped.core.compare :refer [== not==]] [quantum.untyped.core.core :as ucore] @@ -329,12 +331,8 @@ name #_(t/? symbol?)] {PType nil ?Fn {invoke ([_ xs] (and (seqable? xs) ; TODO `dc/reducible?` - (reduce-2 - ;; Similar to `seq-and` - (fn [ret t x] (if (t x) true (reduced false))) - true ; vacuously - (sequence data) (sequence xs) - (fn [_ _] false))))} + (seq-and-2 (fn [t x] (t x)) + (sequence data) (sequence xs))))} ?Meta {meta ([this] meta) with-meta ([this meta'] (OrderedType. hash hash-code meta' data name))} ?Hash {hash ([this] (uhash/caching-set-ordered! hash OrderedType data)) @@ -444,6 +442,6 @@ (= rx (.-rx ^ReactiveType that)))))} ?Deref {deref ([this] (doto @rx validate-type))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (>form this))}}) + fedn/IEdn {-edn ([this] (list `reactive-type {:value (urx/norx-deref this)}))}}) (defn reactive-type? [x] (instance? ReactiveType x)) From 0849b0fe337185996fd38e17a74ffce7fecd19bd Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 2 Nov 2018 00:43:38 -0600 Subject: [PATCH 600/810] Add arg syms basis analysis --- src-untyped/quantum/untyped/core/analyze.cljc | 83 +++++++++++-------- test/quantum/test/untyped/core/analyze.cljc | 72 ++++++++++++++-- 2 files changed, 110 insertions(+), 45 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index eda378b5..54e5b1cc 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -29,7 +29,7 @@ :refer [if-not-let ifs]] [quantum.untyped.core.print :refer [ppr]] - [quantum.untyped.core.reducers :as r + [quantum.untyped.core.reducers :as ur :refer [educe join reducei]] [quantum.untyped.core.refs :as uref :refer [>!thread-local]] @@ -112,9 +112,9 @@ (uc/map-vals+ (fn->> (uc/group-by (fn [^Method x] (:kind x))) (uc/map-vals+ with-distinct-arg-class-seqs) - (r/join {}))) - (r/join {}))) - (r/join {}))))) + (ur/join {}))) + (ur/join {}))) + (ur/join {}))))) (defonce class>methods|with-cache @@ -153,7 +153,7 @@ (if (java.lang.reflect.Modifier/isStatic (.getModifiers x)) :static :instance))])) - (r/join {})))) ; TODO !hash-map + (ur/join {})))) ; TODO !hash-map #?(:clj (def class>fields|with-cache @@ -674,16 +674,16 @@ (let [arg-nodes (->> args-form (mapv #(analyze* env %))) caller|node (analyze* env caller|form) caller|type (-> arg-nodes first :type) - t (case (name caller|form) - "type" caller|type - "input-type" (t/input-type* caller|type - (->> arg-nodes rest (map :type) (map t/unvalue))) - "output-type" (t/output-type* caller|type - (->> arg-nodes rest (map :type) (map t/unvalue))))] + t (if (= (name caller|form) "type") + caller|type + (let [args (->> arg-nodes rest (map :type) (map t/unvalue))] + (case (name caller|form) + "input-type" (t/rx (t/input-type* @caller|type args)) + "output-type" (t/rx (t/output-type* @caller|type args)))))] (uast/call-node {:env env :unanalyzed-form form - :form (uform/>form t) + :form (if (utr/reactive-type? t) form (uform/>form t)) :caller caller|node :args arg-nodes :type (t/value t)})))) @@ -692,7 +692,7 @@ (->> input-nodes (uc/map+ :type) (uc/map+ t/unvalue) - r/join + ur/join (apply combinef) t/value)) @@ -782,17 +782,17 @@ The ->`form` is post- incremental macroexpansion." [env ::env, [caller|form _ & body _ :as form] _ > uast/node?] (case caller|form - do (analyze-seq|do env form) - let* (analyze-seq|let* env form) + . (analyze-seq|dot env form) + def (TODO "def") deftype* (TODO "deftype*") - reify* (TODO "reify") ; NOTE only for CLJ + do (analyze-seq|do env form) fn* (TODO "fn*") - def (TODO "def") - set! (TODO "set!") - . (analyze-seq|dot env form) if (analyze-seq|if env form) - quote (analyze-seq|quote env form) + let* (analyze-seq|let* env form) new (analyze-seq|new env form) + quote (analyze-seq|quote env form) + reify* (TODO "reify") ; NOTE only for CLJ + set! (TODO "set!") throw (analyze-seq|throw env form) try (TODO "try") var (analyze-seq|var env form) @@ -858,7 +858,7 @@ result (analyze-arg-syms* env')] ;; We need to propagate the result upward and this is arguably the cleanest control flow ;; mechanism to do it, sadly - (err! ::arg-splits-performed "All arg-splits performed" {:result result})) + (err! ::arg-syms-analyzed "All arg syms analyzed" {:result result})) (err! "Could not resolve symbol" {:sym form}))) (defns- analyze-symbol @@ -976,12 +976,12 @@ (cond-> env (-> env :opts :arglist-syms|queue empty?) (update-in [:opts :arglist-syms|queue] conj - (-> env :opts :arglist-syms|unanalyzed first)))) + (-> env :opts :arglist-syms|unanalyzed first)))) (defn- analyze-arg-syms* [env #_::env] (uref/update! !!analyze-arg-syms|iter inc) - (let [{:keys [arg-sym->arg-type-form arglist-syms|queue arglist-syms|unanalyzed out-type-form]} - (:opts env)] + (let [{:keys [arg-sym->arg-type-form arglist-syms|queue arglist-syms|unanalyzed out-type-form + split-types?]} (:opts env)] (ifs (empty? arglist-syms|unanalyzed) [{:env env :out-type-node (-> (analyze env out-type-form) (update :type t/unvalue))}] @@ -995,7 +995,9 @@ env-analyzed (-> analyzed :env (update-in [:opts :arglist-syms|queue] disj arg-sym) (update-in [:opts :arglist-syms|unanalyzed] disj arg-sym)) - t-split (-> analyzed :type type>split+primitivized)] + t-split (if split-types? + (-> analyzed :type type>split+primitivized) + [(:type analyzed)])] (if (-> t-split count (= 1)) (recur (-> env-analyzed (update-in [:opts :arg-env] #(doto % (swap! assoc arg-sym analyzed))) @@ -1010,7 +1012,19 @@ ;; `(atom (deref %))` in order to create a new env for a new split #(-> % deref atom (doto (swap! assoc arg-sym (assoc analyzed :type t))))))))) - r/join)))))) + ur/join)))))) + +(defns- >analyze-arg-syms|opts + [env ::env, arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _ + split-types? boolean?] + {:arglist-context? true + :arglist-syms|queue (uset/ordered-set + (-> arg-sym->arg-type-form keys first)) + :arglist-syms|unanalyzed (-> arg-sym->arg-type-form keys set) + :arg-env (atom env) ; Mutable so it can cache + :arg-sym->arg-type-form arg-sym->arg-type-form + :out-type-form out-type-form + :split-types? split-types?}) (defns analyze-arg-syms "Performance characteristics: @@ -1022,20 +1036,17 @@ when simplified) which would require a Cartesian product of the splits of the arg types." > vector? #_(s/vec-of (s/kv {:env ::env :out-type-node uast/node?})) ([arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _] - (analyze-arg-syms {} arg-sym->arg-type-form out-type-form)) + (analyze-arg-syms {} arg-sym->arg-type-form out-type-form true)) + ([arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _, split-types? boolean?] + (analyze-arg-syms {} arg-sym->arg-type-form out-type-form split-types?)) ([env ::env, arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _ + split-types? boolean? > (s/vec-of (s/kv {:env ::env :out-type-node uast/node?}))] (uref/set! !!analyze-arg-syms|iter 0) (try (analyze-arg-syms* - {:opts (assoc (:opts env) - :arglist-context? true - :arglist-syms|queue (uset/ordered-set - (-> arg-sym->arg-type-form keys first)) - :arglist-syms|unanalyzed (-> arg-sym->arg-type-form keys set) - :arg-env (atom env) ; Mutable so it can cache - :arg-sym->arg-type-form arg-sym->arg-type-form - :out-type-form out-type-form)}) + {:opts (merge (:opts env) + (>analyze-arg-syms|opts env arg-sym->arg-type-form out-type-form split-types?))}) (catch Throwable t - (if (and (uerr/error-map? t) (-> t :ident (= ::arg-splits-performed))) + (if (and (uerr/error-map? t) (-> t :ident (= ::arg-syms-analyzed))) (-> t :data :result) (throw t)))))) diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index 43367ad5..86128df4 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -1,19 +1,25 @@ (ns quantum.test.untyped.core.analyze (:require - [quantum.test.untyped.core.type :as tt] - [quantum.untyped.core.analyze :as self] - [quantum.untyped.core.analyze.ast :as uast] - [quantum.untyped.core.collections :as uc] - [quantum.untyped.core.data.map :as umap] + [quantum.test.untyped.core.type :as tt] + [quantum.untyped.core.analyze :as self] + [quantum.untyped.core.analyze.ast :as uast] + [quantum.untyped.core.collections :as uc] + [quantum.untyped.core.collections.logic + :refer [seq-and-2]] + [quantum.untyped.core.data.map :as umap] + [quantum.untyped.core.data.reactive :as urx] [quantum.untyped.core.fn - :refer [<-]] + :refer [<- fn']] + [quantum.untyped.core.loops + :refer [reduce-2]] [quantum.untyped.core.test :refer [deftest is is= testing throws]] - [quantum.untyped.core.type :as t])) + [quantum.untyped.core.type :as t] + [quantum.untyped.core.type.reifications :as utr])) ;; Simulates a typed fn (defn- >long-checked - {:quantum.core.type/type (t/ftype nil [t/string? :> tt/long?])} + {:quantum.core.type/type (t/rx (t/ftype nil [t/string? :> tt/long?]))} []) (defn- transform-ana [ana] @@ -23,7 +29,7 @@ ;; More dependent type tests in `quantum.test.untyped.core.type.defnt` but those are more like ;; integration tests -(deftest dependent-type-test +(deftest test|dependent-type (testing "Output type dependent on non-splittable input" (testing "Not nested within another type" #_"1. Analyze `x` = `tt/boolean?` @@ -407,3 +413,51 @@ 'c (t/isa? Character) 'd (t/value (t/isa? Character))} (t/value (t/isa? Character))]])))) + +(defn- rx=* [a b] + (if (and (utr/reactive-type? a) + (utr/reactive-type? b)) + (= (urx/norx-deref a) (urx/norx-deref b)) + (= a b))) + +(defn- rx= [a b] + (seq-and-2 + (fn [[input-types-0 output-type-0] [input-types-1 output-type-1]] + (and (rx=* output-type-1 output-type-1) + (seq-and-2 rx=* (->> input-types-0 (sort-by key) (map val)) + (->> input-types-1 (sort-by key) (map val))))) + a b)) + +(deftest test|arglist-forms>arglist-basis + (is= (-> (self/analyze-arg-syms + '{a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) + c (t/or tt/short? tt/char?) + d (let [b (t/- tt/char? tt/long?)] + (t/or tt/char? (t/type b) (t/type c)))} + '(t/or (t/type b) (t/type d)) + false) + transform-ana) + (let [c (t/or tt/short? tt/char?) + d (t/or tt/char? (t/value (t/- tt/char? tt/long?)) c) + b (t/or tt/byte? d) + a (t/or tt/boolean? b)] + [[{'a a 'b b 'c c 'd d} (t/or b d)]])) + (is (rx= (-> (self/analyze-arg-syms + '{a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) + c (t/or tt/short? tt/char?) + d (let [b (t/- tt/char? tt/long?)] + (t/or tt/char? (t/type b) (t/input-type >long-checked :?) (t/type c)))} + '(t/or (t/type b) (t/type d)) + false) + transform-ana) + (let [c (t/or tt/short? tt/char?) + d (t/or tt/char? + (t/value (t/- tt/char? tt/long?)) + (t/rx (t/input-type* + (-> #'>long-checked meta :quantum.core.type/type deref) [:?])) + c) + b (t/or tt/byte? d) + a (t/or tt/boolean? b)] + [[{'a a 'b b 'c c 'd d} (t/or b d)]])))) From 7837545f590ba77a6daf180b953d8eb993b85810 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 2 Nov 2018 00:43:57 -0600 Subject: [PATCH 601/810] Update some test notions --- .../quantum/test/untyped/core/type/defnt.cljc | 107 ++++++++++-------- 1 file changed, 57 insertions(+), 50 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 0b5019c6..22df499b 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1930,7 +1930,7 @@ (c/map+ (fn [{:keys [arg-types out-type]}] {:arg-types (mapv ?deref arg-types) :out-type (?deref out-type)})) expand-types)) - - overloads>type-decl + - overloads>overload-types - Shouldn't re-analyze - Attaches `:overload` for newly analyzed overloads - (defn- overload-queue-interceptor [_ _ oldv newv] @@ -1951,32 +1951,34 @@ ;; now; we will optimize later after correctness is achieved ;; Needs to maintain previous fully-derefed version so `overloads>type-decl` knows which ;; reactive overloads have changed - (intern 'ns0 'abcde|__overload-bases ; CLJS compiler needs this to perform analysis - (rx/! {:prev nil + (intern 'ns0 'abcde|__bases ; CLJS compiler needs this to perform analysis + (rx/! {:norx-prev nil :current - [{:ns 'ns0 - :args-form nil - :arg-types [t/int?] - :output-type t/long? - :output-type-form nil - :body [...] - :dependent? false - :reactive? false}]})) - ;; Will not re-analyze overload if it is identical (`=`?) to the previous version of that - ;; overload (when derefing everything) + [{:ns 'ns0 + :args-form nil + :arg-types-basis [t/int?] + :output-type-form nil + :output-type-basis t/long? + :body [...] + :dependent? false + :reactive? false}]})) + ;; Will not re-analyze overload basis if it is identical (`=`?) to the previous version + ;; of that overload (when derefing everything) ;; Must include the :body and :defined-in-ns of each one in order to analyze and create ;; new overloads when putting on the overload queue ;; Internally rx-derefs reactive overloads ;; CLJS compiler needs this to perform analysis - (intern 'ns0 'abcde|__types (!rx (overload-bases>type-decl @ns0/abcde|__overload-bases))) - (uref/add-interceptor! ns0/abcde|__types :overload-queue overload-queue-interceptor) + (intern 'ns0 'abcde|__types + (doto (!rx (overload-bases>type-decl @ns0/abcde|__bases)) + (uref/add-interceptor! :overload-queue overload-queue-interceptor) + urx/norx-deref)) (intern 'ns0 'abcde|__type (let [out-type t/any?] (t/rx (type-data>ftype @ns0/abcde|__types (?deref out-type))))) ;; Each of these types should be completely unreactive. (when (= lang :clj) (intern 'ns0 'abcde|__types|0 - (types-decl>arg-types (rx/norx-deref ns0/abcde|__types) 0)))) + (overload-types>arg-types (rx/norx-deref ns0/abcde|__types) 0)))) - Resulting in `abcde`'s runtime-emission code in CLJ as: - (do (def abcde|__0 (reify* [int>long] (invoke ([x00__ a] ...)))) (defn abcde [x00__] @@ -1994,42 +1996,46 @@ ([b t/string? > (t/type b)] ...) ([c (t/input-type ns0/abcde :?) > (t/output-type ns0/abcde (t/type c))] ...)) - Resulting in `fghij`'s compile-time-emission code (assuming no :test mode) as: - - (do (intern 'ns1 'fghij|__overload-bases - (rx/! {:prev nil + - (do (intern 'ns1 'fghij|__bases + (rx/! {:norx-prev nil :current [(let [t0 t/string?] - {:ns 'ns1 - :args-form nil - :arg-types [t0] - :output-type-form nil - :output-type (t/type* t0) - :body [...] - :dependent? false - :reactive? false}) + {:ns 'ns1 + :args-form nil + :arg-types-basis [t0] + :output-type|form nil + :output-type|basis t0 + ;; used for inline, and reactive, but could be nil'ed out once it's used + ;; by `overload-bases>type-decl` + :body-codelist [...] + :dependent? true + :reactive? false}) (let [t0 (t/rx (t/input-type* @ns0/abcde|__type :?))] - {:ns 'ns1 + {:ns 'ns1 ;; This is only present when there is at least one dependent type in the ;; arglist / output - :args-form '{c (t/input-type ns0/abcde :?)} - :arg-types [t0] + :args-form (om 'c '(t/input-type ns0/abcde :?)) + :arg-types-basis [t0] ;; This is only present when there is at least one dependent type in the ;; arglist / output - :output-type-form '(t/output-type ns0/abcde (t/type c)) - :output-type (t/rx (t/output-type* @ns0/abcde|__type @t0)) - :body [...] - :dependent? true - :reactive? true})]})) - (intern 'ns1 'fghij|__types (!rx (overload-bases>type-decl @ns1/fghij|__overload-bases))) - (uref/add-interceptor! ns1/fghij|__types :overload-queue overload-queue-interceptor) + :output-type|form '(t/output-type ns0/abcde (t/type c)) + :output-type|basis (t/rx (t/output-type* @ns0/abcde|__type @t0)) + :body-codelist [...] + :dependent? true + :reactive? true})]})) + (intern 'ns1 'fghij|__types + (doto (!rx (overload-bases>type-decl @ns1/fghij|__bases)) + (uref/add-interceptor! :overload-queue overload-queue-interceptor) + urx/norx-deref)) (intern 'ns1 'fghij|__type (let [out-type t/any?] (t/rx (type-data>ftype @ns1/fghij|__types (?deref out-type))))) + ;; Consuming the overload queue in `direct-dispatch` (when (= lang :clj) (intern 'ns1 'fghij|__types|0 - (types-decl>arg-types (rx/norx-deref ns1/fghij|__types) 0)))) + (overload-types>arg-types (rx/norx-deref ns1/fghij|__types) 0)))) - Resulting in `fghij`'s runtime-emission code in CLJ as: - - (do (def fghij|__types|0 (types-decl>arg-types ns0/fghij|__types 0)) - (def fghij|__0 (reify* [int>long] (invoke ([x00__ b] ...)))) + - (do (def fghij|__0 (reify* [int>long] (invoke ([x00__ b] ...)))) (def fghij|__1 (reify* [Object>Object] (invoke ([x00__ c] ...)))) (defn fghij [x00__] (ifs ((Array/get ns0/fghij|__types|0 0) x00__) (. ns0/fghij|__0 invoke x00__) @@ -2046,19 +2052,20 @@ (unsupported! ...)))) - (t/extend-defn! abcde [d t/byte? > t/char?] ...) ; in `ns2` - Resulting in `abcde`'s compile-time-emission code (assuming no :test mode) as: - - (do (uref/update! ns0/abcde|__overload-bases + - (do (uref/update! ns0/abcde|__bases (fn [overloads] - {:prev overloads + {:norx-prev overloads :current (join overloads - [{:ns 'ns2 - :arg-types [t/byte?] - :output-type t/char? - :body [...] - :reactive? false}])})) + [{:ns ns2 + :arg-types [t/byte?] + :output-type t/char? + :body-codelist [...] + :dependent? false + :reactive? false}])})) ;; Not explicitly executed, but this is what happens reactively as - ;; `abcde|__overload-bases` is `update!`ed: - ;; Reactively due to `abcde|__overload-bases` changing + ;; `abcde|__bases` is `update!`ed: + ;; Reactively due to `abcde|__bases` changing (rx-set! ns0/abcde|__types [{:id 1 :ns 'ns2 :arg-types [t/byte?] :output-type t/char? :body [...]} {:id 0 :ns 'ns0 :arg-types [t/int?] :output-type t/long? :body [...]}]) @@ -2080,9 +2087,9 @@ ;; Consuming the `defnt/overload-queue` (iterate then clear, not incremental pop) (when (= lang :clj) (intern 'ns2 'abcde|__types|1 - (types-decl>arg-types (rx/norx-deref ns0/abcde|__types) 1)) + (overload-types>arg-types (rx/norx-deref ns0/abcde|__types) 1)) (intern 'ns2 'fghij|__types|2 - (types-decl>arg-types (rx/norx-deref ns1/fghij|__types) 2)))) + (overload-types>arg-types (rx/norx-deref ns1/fghij|__types) 2)))) - Resulting in `abcde`'s runtime-emission code in CLJ as (easy to adapt for CLJS): - (do ;; Consuming the `defnt/overload-queue` (iterate then clear, not incremental pop) (intern 'ns2 'abcde|__1 (reify* [...] (invoke ([x00__ d] ...)))) From a0a2eb169a7fa7c1f384aa52d8b734293a03251e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 2 Nov 2018 00:44:33 -0600 Subject: [PATCH 602/810] Breaking change: 1st pass in implementing reactivity for `t/defn` --- .../quantum/untyped/core/type/defnt.cljc | 686 ++++++++++-------- 1 file changed, 393 insertions(+), 293 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 1710e355..b62fa8d2 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -23,10 +23,11 @@ [quantum.untyped.core.data.map :as umap] [quantum.untyped.core.data.reactive :as urx] [quantum.untyped.core.data.set :as uset] + [quantum.untyped.core.data.vector :as uvec] [quantum.untyped.core.error :as err :refer [TODO err!]] [quantum.untyped.core.fn - :refer [<- aritoid fn-> with-do]] + :refer [<- aritoid fn1 fn-> with-do with-do-let]] [quantum.untyped.core.form :as uform :refer [>form]] [quantum.untyped.core.form.evaluate :as ufeval] @@ -36,12 +37,14 @@ :refer [>name >?namespace >symbol]] [quantum.untyped.core.log :as ulog] [quantum.untyped.core.logic :as ul - :refer [fn-or fn= ifs]] + :refer [fn-or fn= if-not-let ifs]] [quantum.untyped.core.loops :refer [reduce-2]] [quantum.untyped.core.numeric.combinatorics :as ucombo] [quantum.untyped.core.reducers :as ur :refer [educe educei reducei]] + [quantum.untyped.core.refs :as uref + :refer [?deref]] [quantum.untyped.core.spec :as s] [quantum.untyped.core.specs :as uss] [quantum.untyped.core.type :as t @@ -77,6 +80,8 @@ (defonce *interfaces (atom {})) +(defonce !overload-queue (uvec/alist)) ; (t/!seq-of ::indexed-types-decl-datum) + ;; ==== Internal specs ===== ;; (s/def ::lang #{:clj :cljs}) @@ -93,27 +98,39 @@ :lang ::lang :kind ::kind})) -;; "global" because they apply to the whole fnt +;; "global" because they apply to the whole `t/fn` (s/def ::fn|globals - (s/kv {:fn|meta (s/nilable :quantum.core.specs/meta) - :fn|ns-name simple-symbol? - :fn|name ::uss/fn|name - :fn|type utr/fn-type? - :fn|types-decl-name simple-symbol? - :fn|output-type|form t/any? - :fn|output-type t/type?})) + (s/kv {:fn|meta (s/nilable :quantum.core.specs/meta) + :fn|ns-name simple-symbol? + :fn|name ::uss/fn|name + :fn|output-type t/type? + :fn|output-type|form t/any? + :fn|overload-bases-name simple-symbol? + :fn|overload-types-name simple-symbol? + :fn|type-name simple-symbol?})) + +(s/def ::overload-basis + (s/kv {:ns simple-symbol? + :args-form map? ; from binding to form + :varargs-form map? ; from binding to form + :arglist-form|unanalyzed t/any? + :arg-types|basis (s/vec-of t/type?) + :output-type|form t/any? + :output-type|basis t/type? + :body-codelist (s/vec-of t/any?) + :dependent? t/boolean? + :reactive? t/boolean?})) ;; Technically it's partially analyzed — its type definitions are analyzed (with the exception of ;; requests for type inference) while its body is not. (s/def ::unanalyzed-overload (s/kv {:arglist-form|unanalyzed t/any? - :arg-bindings (s/vec-of t/any?) - :varargs-binding t/any? - :arg-types|form (s/vec-of t/any?) + :args-form map? ; from binding to form + :varargs-vorm map? ; from binding to form :arg-types (s/vec-of t/type?) :output-type|form t/any? :output-type t/type? - :body-codelist|unanalyzed t/any?})) + :body-codelist t/any?})) ;; This is the overload after the input specs are split by their respective `t/or` constituents, ;; and after primitivization, but before readiness for incorporation into a `reify`. @@ -173,12 +190,10 @@ :overload ::overload})) (s/def ::types-decl - (s/kv {:name simple-symbol? - :form t/any? - ;; Sorted by overload-index - :data (s/vec-of ::types-decl-datum) + (s/kv {:name simple-symbol? + :form t/any? ;; Sorted by overload-index - :indexed-data (s/vec-of ::indexed-types-decl-datum)})) + :data (s/vec-of ::types-decl-datum)})) #_(:clj (c/defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] @@ -191,6 +206,8 @@ ;; TODO simplify this class computation +;; ===== Arg type/class extraction/comparison ===== ;; + #?(:clj (defns class>simplest-class "This ensures that special overloads are not created for non-primitive subclasses @@ -225,27 +242,67 @@ (err! "Body type incompatible with declared output type" err-info)) (2 3) (err! "Body type incompatible with declared output type" err-info)))) +(c/defn compare-arg-types [t0 #_t/type?, t1 #_t/type? #_> #_ucomp/comparison?] + (if-let [c0 (uana/sort-guide t0)] + (if-let [c1 (uana/sort-guide t1)] + (ifs (< c0 c1) -1 (> c0 c1) 1 0) + -1) + (if-let [c1 (uana/sort-guide t1)] + 1 + (uset/normalize-comparison (t/compare t0 t1))))) + +(c/defn compare-args-types [arg-types0 #_(s/vec-of t/type?) arg-types1 #_(s/vec-of t/type?)] + (let [ct-comparison (compare (count arg-types0) (count arg-types1))] + (if (zero? ct-comparison) + (reduce-2 + (c/fn [^long c t0 t1] + (let [c' (long (compare-arg-types t0 t1))] + (case c' + -1 (case c 1 (reduced 0) c') + 0 c + 1 (case c -1 (reduced 0) c')))) + 0 + arg-types0 arg-types1) + ct-comparison))) + +(c/defn- dedupe-type-data [on-dupe #_fn?, type-data #_(vec-of ::types-decl-datum)] + (reduce (let [*prev-datum (volatile! nil)] + (c/fn [data {:as datum :keys [arg-types]}] + (with-do + (ifs (nil? @*prev-datum) + (conj data datum) + (= uset/=ident (utcomp/compare-inputs (:arg-types @*prev-datum) arg-types)) + (on-dupe data @*prev-datum datum) + (conj data datum)) + (vreset! *prev-datum datum)))) + [] + type-data)) + +;; ===== Unanalyzed overloads ===== ;; + #?(:clj (defns- unanalyzed-overload>overload "Given an `::unanalyzed-overload`, performs type analysis on the body and computes a resulting `t/fn` overload, which is the foundation for one `reify`." [{:as unanalyzed-overload - :keys [arglist-form|unanalyzed _, arg-bindings _, varargs-binding _, arg-types _, + :keys [arglist-form|unanalyzed _, args-form _, varargs-form _, arg-types _, output-type|form _, body-codelist|unanalyzed _] declared-output-type [:output-type _]} ::unanalyzed-overload {:as opts :keys [lang _, kind _]} ::opts - {:as fn|globals :keys [fn|name _, fn|type _, fn|output-type _]} ::fn|globals + {:as fn|globals :keys [fn|name _, fn|output-type _]} ::fn|globals + fn|type t/type? > ::overload] (let [;; Not sure if `nil` is the right approach for the value recursive-ast-node-reference (when-not (= kind :extend-defn!) (uast/symbol {} fn|name nil fn|type)) - env (->> (zipmap arg-bindings arg-types) + env (->> (zipmap (keys args-form) arg-types) (uc/map' (c/fn [[arg-binding arg-type]] [arg-binding (uast/unbound nil arg-binding arg-type)])) ;; To support recursion (<- (cond-> (not= kind :extend-defn!) (assoc fn|name recursive-ast-node-reference)))) + variadic? (not (empty? varargs-form)) arg-classes (->> arg-types (uc/map type>class)) body-node (uana/analyze env (ufgen/?wrap-do body-codelist|unanalyzed)) hint-arg|fn (c/fn [i arg-binding] @@ -253,8 +310,8 @@ (ufth/>fn-arglist-tag (uc/get arg-classes i) lang - (uc/count arg-bindings) - (boolean varargs-binding)))) + (uc/count args-form) + variadic?))) actual-output-type (>actual-output-type declared-output-type body-node) body-form (-> (:form body-node) @@ -263,14 +320,39 @@ {:arglist-form|unanalyzed arglist-form|unanalyzed :arg-classes arg-classes :arg-types arg-types - :arglist-code|fn|hinted (cond-> (->> arg-bindings (uc/map-indexed hint-arg|fn)) - varargs-binding (conj '& varargs-binding)) - :arglist-code|reify|unhinted (cond-> arg-bindings varargs-binding (conj varargs-binding)) + :arglist-code|fn|hinted (cond-> (->> args-form keys (uc/map-indexed hint-arg|fn)) + variadic? (conj '& (-> varargs-form keys first))) + :arglist-code|reify|unhinted (cond-> (-> args-form keys vec) + variadic? (conj (-> varargs-form keys first))) :body-form body-form - :positional-args-ct (count arg-bindings) + :positional-args-ct (count args-form) :output-type actual-output-type :output-class (type>class actual-output-type) - :variadic? (boolean varargs-binding)}))) + :variadic? variadic?}))) + +(defns- unanalyzed-overloads>overloads + "This is of `O(n•log(n))` time complexity where n is the total number of generated/analyzed + overloads. + This is because once we must sort (`O(n•log(n))`) the overloads by comparing their arg types and + then if we find any duplicates in a linear scan (`O(n)`), we throw an error." + [unanalyzed-overloads (s/vec-of ::unanalyzed-overload), opts ::opts, fn|globals ::fn|globals + fn|type t/type? + > (s/vec-of ::overload)] + (->> unanalyzed-overloads + ;; We have to analyze everything in order to figure out all the types (or at least, analyze + ;; in order to figure out body-dependent input types) before we can compare them against + ;; each other + (uc/map #(unanalyzed-overload>overload % opts fn|globals fn|type)) + (sort-by :arg-types compare-args-types) + (dedupe-type-data + (c/fn [overloads prev-overload overload] + (err! "Duplicate input types for overload" + (umap/om :arglist-form-0 (:arglist-form|unanalyzed prev-overload) + :arg-types-0 (:arg-types prev-overload) + :body-0 (:body-form prev-overload) + :arglist-form-1 (:arglist-form|unanalyzed overload) + :arg-types-1 (:arg-types overload) + :body-1 (:body-form overload))))))) (defns- class>interface-part-name [c class? > string?] (if (= c java.lang.Object) @@ -280,44 +362,6 @@ (err! "Class cannot contain pattern" {:class c :pattern illegal-pattern}) (-> c >name (str/replace "." "|")))))) -;; ===== Arg type comparison ===== ;; - -(c/defn compare-arg-types [t0 #_t/type?, t1 #_t/type? #_> #_ucomp/comparison?] - (if-let [c0 (uana/sort-guide t0)] - (if-let [c1 (uana/sort-guide t1)] - (ifs (< c0 c1) -1 (> c0 c1) 1 0) - -1) - (if-let [c1 (uana/sort-guide t1)] - 1 - (uset/normalize-comparison (t/compare t0 t1))))) - -(c/defn compare-args-types [arg-types0 #_(s/vec-of t/type?) arg-types1 #_(s/vec-of t/type?)] - (let [ct-comparison (compare (count arg-types0) (count arg-types1))] - (if (zero? ct-comparison) - (reduce-2 - (c/fn [^long c t0 t1] - (let [c' (long (compare-arg-types t0 t1))] - (case c' - -1 (case c 1 (reduced 0) c') - 0 c - 1 (case c -1 (reduced 0) c')))) - 0 - arg-types0 arg-types1) - ct-comparison))) - -(c/defn- dedupe-type-data [on-dupe #_fn?, type-data #_(vec-of ::types-decl-datum)] - (reduce (let [*prev-datum (volatile! nil)] - (c/fn [data {:as datum :keys [arg-types]}] - (with-do - (ifs (nil? @*prev-datum) - (conj data datum) - (= uset/=ident (utcomp/compare-inputs (:arg-types @*prev-datum) arg-types)) - (on-dupe data @*prev-datum datum) - (conj data datum)) - (vreset! *prev-datum datum)))) - [] - type-data)) - ;; ===== Direct dispatch ===== ;; ;; ----- Direct dispatch: `reify` ---- ;; @@ -383,13 +427,10 @@ ;; ----- Type declarations ----- ;; -(defns >types-decl-ref [{:keys [fn|ns-name _, fn|types-decl-name _]} ::fn|globals] - (var-get (resolve (uid/qualify fn|ns-name fn|types-decl-name)))) - -(c/defn types-decl>arg-types - [*types-decl #_(atom-of (vec-of ::types-decl-datum)), overload-index #_index? +(c/defn overload-types>arg-types + [!overload-types #_(t/of urx/reactive? (vec-of ::types-decl-datum)), overload-index #_index? #_> #_(objects-of type?)] - (apply uarr/*<> (:arg-types (get @*types-decl overload-index)))) + (apply uarr/*<> (:arg-types (get (urx/norx-deref !overload-types) overload-index)))) (c/defn type-data>ftype [type-data #_(vec-of ::type-datum), fn|output-type #_t/type?] (->> type-data @@ -399,11 +440,12 @@ output-type (conj :> output-type)))) (apply t/ftype fn|output-type))) -(c/defn types-decl>ftype - [*types-decl #_(atom-of (vec-of ::types-decl-datum)), fn|output-type #_t/type? #_> #_(vec-of ...)] - (type-data>ftype @*types-decl fn|output-type)) +(c/defn overload-types>ftype + [!overload-types #_(t/of urx/reactive? (vec-of ::types-decl-datum)), fn|output-type #_t/type? + #_> #_(vec-of ...)] + (type-data>ftype (urx/norx-deref !overload-types) fn|output-type)) -(c/defn- dedupe-types-decl-data [fn|ns-name fn|name types-decl-data] +(c/defn- dedupe-overload-types-data [fn|ns-name fn|name types-decl-data] (->> types-decl-data (dedupe-type-data (c/fn [data prev-datum datum] @@ -413,70 +455,6 @@ (-> data pop (conj (assoc prev-datum :ns-sym (:ns-sym datum) :overload (:overload datum)))))))) -(defns- >types-decl - [{:as opts :keys [kind _]} ::opts - {:as fn|globals :keys [fn|ns-name _, fn|name _ fn|types-decl-name _]} ::fn|globals - overloads (s/vec-of ::overload) - > ::types-decl] - (let [types-decl-existing-data (when (= kind :extend-defn!) (deref (>types-decl-ref fn|globals))) - first-current-overload-id - (if (= kind :extend-defn!) - (count types-decl-existing-data) - 0) - types-decl-current-data ; i.e. being created right now, not swapped into the types decl atom - (->> overloads - (uc/map-indexed - (c/fn [i {:keys [arg-types output-type]}] - {:id (+ i first-current-overload-id) - :ns-sym (ns-name *ns*) - :arg-types arg-types - :output-type output-type}))) - ;; We can't just concat the currently-being-created overloads' type-decl data with the - ;; existing type-decl data because we need to maintain the type-decl data's ordering by - ;; type-specificity so the dynamic dispatch works correctly. - types-decl-indexed-data - (if (= kind :extend-defn!) - (->> (ur/join types-decl-current-data types-decl-existing-data) - (uc/map - (c/fn [{:as datum :keys [id]}] - (assoc datum :overload (get overloads (- id first-current-overload-id))))) - (sort-by identity - (c/fn [datum0 datum1] - (let [c (compare-args-types (:arg-types datum0) (:arg-types datum1))] - ;; In order to make the earlier ID appear - (if (zero? c) - (if (:overload datum0) - (if (:overload datum1) c 1) - (if (:overload datum1) -1 c)) - c)))) - (dedupe-types-decl-data fn|ns-name fn|name) - (uc/map-indexed (c/fn [i datum] (assoc datum :index i)))) - (->> types-decl-current-data - (uc/map-indexed - (c/fn [i datum] (assoc datum :index i :overload (get overloads i)))))) - types-decl-data - (if (= kind :extend-defn!) - (->> types-decl-indexed-data (uc/map #(dissoc % :index :overload))) - types-decl-current-data)] - (if (-> opts :compilation-mode (= :test)) - {:name fn|types-decl-name - :form (if (= kind :extend-defn!) - `(reset! ~(uid/qualify fn|ns-name fn|types-decl-name) - ~(->> types-decl-data (uc/map #(dissoc % :ns-sym)) >form)) - `(def ~fn|types-decl-name - (atom ~(->> types-decl-data (uc/map #(dissoc % :ns-sym)) >form)))) - :data types-decl-data - :indexed-data types-decl-indexed-data} - ;; In non-test cases, it's far cheaper to not have to convert the types to a - ;; compiler-readable form and then re-evaluate them again - (do (if (= kind :extend-defn!) - (reset! (>types-decl-ref fn|globals) types-decl-data) - (intern fn|ns-name fn|types-decl-name (atom types-decl-data))) - {:name fn|types-decl-name - :form nil - :data types-decl-data - :indexed-data types-decl-indexed-data})))) - (defns- >overload-types-decl|name ([fn|name simple-symbol?, overload|id ::overload|id > simple-symbol?] (symbol (str fn|name "|__" overload|id "|types"))) @@ -487,32 +465,131 @@ (defns- >overload-types-decl "The evaluated `form` of each overload-types-decl is an array of non-primitivized types that the dynamic dispatch uses to dispatch off input types." - [{:as fn|globals :keys [fn|ns-name _, fn|name _, fn|types-decl-name _]} ::fn|globals - arg-types (s/vec-of t/type?), overload|id ::overload|id, overload-index index? + [{:as opts :keys [compilation-mode _, lang _]} ::opts + {:as fn|globals :keys [fn|ns-name _, fn|name _, fn|overload-types-name _]} ::fn|globals + arg-types (s/vec-of t/type?), overload|id ::overload|id, overload-index index?, !overload-types _ > ::overload-types-decl] - (let [decl-name (>overload-types-decl|name fn|name overload|id) - form `(def ~(ufth/with-type-hint decl-name "[Ljava.lang.Object;") - (types-decl>arg-types - ~(uid/qualify fn|ns-name fn|types-decl-name) ~overload-index))] + (let [decl-name (-> (>overload-types-decl|name fn|name overload|id) + (ufth/with-type-hint "[Ljava.lang.Object;")) + form (if (or (not= compilation-mode :test) (= lang :clj)) + (do (intern fn|ns-name decl-name + (overload-types>arg-types !overload-types overload-index)) + nil) + `(def ~decl-name + (overload-types>arg-types + ~(uid/qualify fn|ns-name fn|overload-types-name) ~overload-index)))] {:form form :name decl-name})) -;; ----- Direct dispatch: putting it all together ----- ;; +(defns- norx-deref-overload-basis [overload-basis ::overload-basis] + (-> overload-basis + (update :arg-types|basis (uc/map urx/norx-deref)) + (update :output-type|basis urx/norx-deref))) + +(defns- >overload-bases-to-analyze + [overload-bases (s/kv {:norx-prev (s/nilable (s/vec-of ::overload-basis)) + :current (s/vec-of ::overload-basis)}) + > (s/vec-of ::overload-basis)] + (let [changed-existing-overload-bases + (reduce-2 + (c/fn [changed derefed-old-basis new-basis] + (cond-> changed + (not= derefed-old-basis (norx-deref-overload-basis new-basis)) (conj new-basis))) + [] (:norx-prev overload-bases) (:current overload-bases)) + new-overload-bases (subvec (:current overload-bases) (count (:norx-prev overload-bases)))] + (ur/join changed-existing-overload-bases new-overload-bases))) + +(defns- overload-basis>unanalyzed-overloads+ + "Split and primitivized; not yet sorted." + [{:as overload-basis + :keys [args-form _, body-codelist _, output-type|form _]} + ::overload-basis + {:as fn|globals :keys [fn|output-type _]} ::fn|globals + > (s/seq-of ::unanalyzed-overload)] + (let [overload-basis-selected + (select-keys overload-basis + [:arglist-form|unanalyzed :args-form :body-codelist :output-type|form :varargs-form])] + (->> (uana/analyze-arg-syms {} args-form output-type|form true) + (uc/map+ (c/fn [{:keys [env out-type-node]}] + (let [output-type (:type out-type-node) + arg-env (->> env :opts :arg-env deref) + arg-types (->> args-form keys (uc/map #(:type (get arg-env %))))] + (when-not (t/<= output-type fn|output-type) + (err! (str "Overload's declared output type does not satisfy function's" + "overall declared output type") + (kw-map output-type fn|output-type))) + (kw-map arg-types output-type)))) + (uc/map+ (c/fn [{:keys [arg-types output-type]}] + (merge overload-basis-selected (kw-map arg-types output-type))))))) + +(defns- overload-bases>overload-types + [overload-bases (s/kv {:norx-prev (s/nilable (s/vec-of ::overload-basis)) + :current (s/vec-of ::overload-basis)}) + existing-overload-types (s/vec-of ::types-decl-datum) + {:as fn|globals :keys [fn|overload-types-name _, fn|name _, fn|ns-name _]} ::fn|globals + > (s/vec-of ::types-decl-datum)] + (if-not-let [overload-bases-to-analyze (-> overload-bases >overload-bases-to-analyze seq)] + existing-overload-types + (let [;; These are created within this fn, then put on a queue below so that direct dispatch can + ;; use them later on in the pipeline + overloads (->> overload-bases-to-analyze + (uc/mapcat (fn1 overload-basis>unanalyzed-overloads+ fn|globals)) + unanalyzed-overloads>overloads) + first-current-overload-id (count existing-overload-types) + overload-types-current-data ; i.e. being created right now + (->> overloads + (uc/map-indexed + (c/fn [i {:keys [arg-types output-type]}] + {:id (+ i first-current-overload-id) + :ns-sym (ns-name *ns*) + :arg-types arg-types + :output-type output-type}))) + ;; We can't just concat the currently-being-created overloads' type-decl data with the + ;; existing type-decl data because we need to maintain the type-decl data's ordering by + ;; type-specificity so the dynamic dispatch works correctly. + overload-types-indexed-data + (if (empty? existing-overload-types) + (->> overload-types-current-data + (uc/map-indexed + (c/fn [i datum] (assoc datum :index i :overload (get overloads i))))) + (->> (ur/join overload-types-current-data existing-overload-types) + (uc/map + (c/fn [{:as datum :keys [id]}] + (assoc datum :overload (get overloads (- id first-current-overload-id))))) + (sort-by identity + (c/fn [datum0 datum1] + (let [c (compare-args-types (:arg-types datum0) (:arg-types datum1))] + ;; In order to make the earlier ID appear + (if (zero? c) + (if (:overload datum0) + (if (:overload datum1) c 1) + (if (:overload datum1) -1 c)) + c)))) + (dedupe-overload-types-data fn|ns-name fn|name) + (uc/map-indexed (c/fn [i datum] (assoc datum :index i))))) + _ (->> overload-types-indexed-data + (uc/run! (c/fn [x] (uvec/alist-conj! !overload-queue x)))) + overload-types-data + (if (empty? existing-overload-types) + overload-types-current-data + (->> overload-types-indexed-data (uc/map #(dissoc % :index :overload))))] + overload-types-data))) + +;; ----- Direct dispatch ----- ;; (defns- >direct-dispatch - [{:as opts :keys [gen-gensym _, lang _, kind _]} ::opts - {:as fn|globals :keys [fn|name _]} ::fn|globals - overloads (s/vec-of ::overload) - types-decl ::types-decl > ::direct-dispatch] + [{:as opts :keys [gen-gensym _, lang _, kind _]} ::opts + fn|globals ::fn|globals + !overload-types _] (case lang :clj (let [direct-dispatch-data-seq - (->> types-decl - :indexed-data - (uc/filter+ :overload) ; i.e. the "current" ones + (->> !overload-queue (uc/map (c/fn [{:as indexed-type-decl-datum :keys [arg-types id index overload]}] {:overload-types-decl - (>overload-types-decl fn|globals arg-types id index) + (>overload-types-decl + opts fn|globals arg-types id index !overload-types) :reify (overload>reify overload opts fn|globals id)}))) + _ (uvec/alist-empty! !overload-queue) form (->> direct-dispatch-data-seq (uc/mapcat (c/fn [{:as direct-dispatch-data :keys [overload-types-decl]}] @@ -534,9 +611,9 @@ (defns- >combinatoric-seq+ [{:as fn|globals :keys [fn|ns-name _ fn|name _]} ::fn|globals - indexed-types-decl-data-for-arity (s/vec-of ::indexed-types-decl-datum) + overload-types-for-arity (s/vec-of ::types-decl-datum) arglist (s/vec-of simple-symbol?)] - (->> indexed-types-decl-data-for-arity + (->> overload-types-for-arity (uc/map+ (c/fn [{:as types-decl-datum :keys [arg-types ns-sym overload]}] (let [overload|id (:id types-decl-datum) @@ -554,69 +631,65 @@ (defns- >dynamic-dispatch|body-for-arity [{:as fn|globals :keys [fn|ns-name _, fn|name _]} ::fn|globals - indexed-types-decl-data-for-arity (s/vec-of ::indexed-types-decl-datum) + overload-types-for-arity (s/vec-of ::indexed-types-decl-datum) arglist (s/vec-of simple-symbol?)] (if (empty? arglist) - (let [overload|id (-> indexed-types-decl-data-for-arity first :id)] + (let [overload|id (-> overload-types-for-arity first :id)] (>dynamic-dispatch|reify-call (>reify-name-unhinted fn|ns-name fn|name overload|id) arglist)) - (let [*i|arg (atom 0) + (let [!!i|arg (atom 0) combinef (c/fn ([] (transient [`ifs])) ([ret] (-> ret (conj! `(unsupported! '~(uid/qualify fn|ns-name fn|name) - ~arglist ~(deref *i|arg))) + ~arglist ~(deref !!i|arg))) persistent! seq)) ([ret getf x i] - (reset! *i|arg i) + (reset! !!i|arg i) (uc/conj! ret getf x)))] (uc/>combinatoric-tree (count arglist) (c/fn [a b] (t/= (:t a) (:t b))) (aritoid combinef combinef (c/fn [x [{:keys [getf i]} group]] (combinef x getf group i))) uc/conj!|rf (aritoid combinef combinef (c/fn [x [k [{:keys [getf i]}]]] (combinef x getf k i))) - (>combinatoric-seq+ fn|globals indexed-types-decl-data-for-arity arglist))))) + (>combinatoric-seq+ fn|globals overload-types-for-arity arglist))))) (defns- >dynamic-dispatch-fn|form [{:as opts :keys [gen-gensym _, lang _, kind _]} ::opts {:as fn|globals :keys [fn|meta _, fn|ns-name _, fn|name _, fn|output-type _ - fn|types-decl-name _]} ::fn|globals - types-decl ::types-decl] + fn|overload-types-name _, fn|type-name _]} ::fn|globals + !overload-types _] (let [overload-forms - (->> types-decl - :indexed-data + (->> !overload-types + urx/norx-deref (group-by (fn-> :arg-types count)) (sort-by key) ; for purposes of reproducibility and organization - (map (c/fn [[arg-ct indexed-types-decl-data-for-arity]] + (map (c/fn [[arg-ct overload-types-for-arity]] (let [arglist (ufgen/gen-args 0 arg-ct "x" gen-gensym) body (>dynamic-dispatch|body-for-arity - fn|globals indexed-types-decl-data-for-arity arglist)] + fn|globals overload-types-for-arity arglist)] (list arglist body))))) - ftype-form `(types-decl>ftype ~(uid/qualify fn|ns-name fn|types-decl-name) - ~(>form fn|output-type))] + fn|meta' (merge fn|meta {:quantum.core.type/type (uid/qualify fn|ns-name fn|type-name)})] + ;; TODO determine whether CLJS needs (update-in m [:jsdoc] conj "@param {...*} var_args") (if (= kind :extend-defn!) - `(intern (quote ~fn|ns-name) - (with-meta (quote ~fn|name) - ;; TODO determine whether CLJS needs (update-in m [:jsdoc] conj "@param {...*} var_args") - (assoc (meta (var ~(uid/qualify fn|ns-name fn|name))) - :quantum.core.type/type ~ftype-form)) - (fn* ~@overload-forms)) - `(c/defn ~fn|name ~(assoc fn|meta :quantum.core.type/type ftype-form) ~@overload-forms)))) + `(intern (quote ~fn|ns-name) (quote ~fn|name) + (with-meta (fn* ~@overload-forms) ~fn|meta')) + `(def ~fn|name (with-meta (fn* ~@overload-forms) ~fn|meta'))))) ;; ===== End dynamic dispatch ===== ;; -(defns- overloads-basis>unanalyzed-overload-seq - [{:as in {args [:args _] - varargs [:varargs _] - pre-type|form [:pre _] - [_ _, output-type|form _] [:post _]} [:arglist _] - body-codelist|unanalyzed [:body _]} _ - kind ::kind - fn|output-type|form _ ; TODO excise this var when we default `output-type|form` to `?` - fn|output-type t/type? - > (s/seq-of ::unanalyzed-overload)] +(defns- overload-basis-form>overload-basis + [opts ::opts + {:keys [fn|output-type _, fn|output-type|form _]} ::fn|globals + {:as overload-basis-form + {args [:args _] + varargs [:varargs _] + pre-type|form [:pre _] + [_ _, output-type|form _] [:post _]} [:arglist _] + body-codelist|unanalyzed [:body _]} _ + > ::overload-basis] (when pre-type|form (TODO "Need to handle pre")) (when varargs (TODO "Need to handle varargs")) (let [arglist-form|unanalyzed (cond-> args varargs (conj '& varargs) @@ -630,120 +703,147 @@ ;; otherwise the `fn|output-type|form` gets analyzed over and over nil fn|output-type|form output-type|form) - arg-bindings - (->> args - (mapv (c/fn [{[kind binding-] :binding-form}] - ;; TODO this assertion is purely temporary until destructuring is - ;; supported - (assert kind :sym) - binding-))) + arg-bindings (->> args + (mapv (c/fn [{[kind binding-] :binding-form}] + ;; TODO this assertion is purely temporary until destructuring + ;; is supported + (assert kind :sym) + binding-))) ;; TODO support varargs - varargs-binding (when varargs - ;; TODO this assertion is purely temporary until destructuring is - ;; supported - (assert (-> varargs :binding-form first (= :sym)))) - arg-types|expanded-seq+ ; split and primitivized; not yet sorted - (->> (uana/analyze-arg-syms {} (zipmap arg-bindings arg-types|form) output-type|form) - (uc/map+ - (c/fn [{:keys [env out-type-node]}] - (let [output-type (:type out-type-node) - arg-env (->> env :opts :arg-env deref) - arg-types (->> arg-bindings (uc/map #(:type (get arg-env %))))] - - (when (and ;; TODO excise clause when we default `output-type|form` to `?` - (not (identical? output-type|form fn|output-type|form)) - (not (t/<= output-type fn|output-type))) - (err! (str "Overload's declared output type does not satisfy function's" - "overall declared output type") - (kw-map output-type fn|output-type))) - (kw-map arg-types output-type)))))] - (->> arg-types|expanded-seq+ - (uc/map (c/fn [{:keys [arg-types output-type]}] - (kw-map arglist-form|unanalyzed arg-bindings varargs-binding - arg-types|form arg-types - output-type|form output-type - body-codelist|unanalyzed)))))) - -(defns- unanalyzed-overloads>overloads - "This is of `O(n•log(n))` time complexity where n is the total number of generated/analyzed - overloads. - This is because once we must sort (`O(n•log(n))`) the overloads by comparing their arg types and - then if we find any duplicates in a linear scan (`O(n)`), we throw an error." - [unanalyzed-overloads (s/vec-of ::unanalyzed-overload), opts ::opts, fn|globals ::fn|globals - > (s/vec-of ::overload)] - (->> unanalyzed-overloads - ;; We have to analyze everything in order to figure out all the types (or at least, analyze - ;; in order to figure out body-dependent input types) before we can compare them against - ;; each other - (uc/map #(unanalyzed-overload>overload % opts fn|globals)) - (sort-by :arg-types compare-args-types) - (dedupe-type-data - (c/fn [overloads prev-overload overload] - (err! "Duplicate input types for overload" - (umap/om :arglist-form-0 (:arglist-form|unanalyzed prev-overload) - :arg-types-0 (:arg-types prev-overload) - :body-0 (:body-form prev-overload) - :arglist-form-1 (:arglist-form|unanalyzed overload) - :arg-types-1 (:arg-types overload) - :body-1 (:body-form overload))))))) - -(defns fn|code [kind ::kind, lang ::lang, compilation-mode ::compilation-mode, args _] + varargs-binding (when varargs + ;; TODO this assertion is purely temporary until destructuring is + ;; supported + (assert (-> varargs :binding-form first (= :sym)))) + args-form (reduce-2 assoc (umap/om) arg-bindings arg-types|form) + [arglist-basis] (uana/analyze-arg-syms {} args-form output-type|form false) + binding->arg-type|basis (->> arglist-basis :env :opts :arg-env deref (uc/map-vals' :type))] + ;; TODO `dependent?` -> any of the arg-types or output-type use dependent types + ;; TODO `reactive?` -> any of the arg-types or output-type are reactive + {:ns (>symbol *ns*) + ;; TODO Only needed if `dependent?` or if new + :args-form args-form + :arg-types|basis (->> args-form keys (uc/map binding->arg-type|basis)) + ;; TODO Only needed if `dependent?` or if new + :varargs-form {varargs-binding nil} ; TODO `nil` isn't right + :arglist-form|unanalyzed arglist-form|unanalyzed + ;; TODO Only needed if `dependent?` or if new + :output-type|form output-type|form + :output-type|basis (-> arglist-basis :out-type-node :type) + ;; TODO Only needed if `inline? or `reactive?`, or if new + :body-codelist body-codelist|unanalyzed})) + +;; ===== Reactive auxiliary vars ===== ;; + +(defns- >!overload-bases + [{:as opts :keys [kind _]} ::opts + {:as fn|globals :keys [fn|ns-name _, fn|overload-bases-name _]} ::fn|globals + overload-bases-form _] + (let [overload-bases + (->> overload-bases-form + (uc/map (c/fn [x] (overload-basis-form>overload-basis opts fn|globals x))))] + (if (= kind :extend-defn!) + (-> (uid/qualify fn|ns-name fn|overload-bases-name) resolve var-get + (doto (uref/update! + (c/fn [{:keys [current]}] + {:norx-prev (->> current (uc/map norx-deref-overload-basis)) + :current (ur/join current overload-bases)})))) + (urx/! {:norx-prev nil :current overload-bases})))) + +(defns- >!overload-types + [{:as opts :keys [kind _]} ::opts + {:as fn|globals :keys [fn|ns-name _, fn|overload-types-name _]} ::fn|globals + !overload-bases _] + (if (= kind :extend-defn!) + (-> (uid/qualify fn|ns-name fn|overload-types-name) resolve var-get) + (with-do-let [!overload-types (urx/!rx @!overload-bases)] + (uref/add-interceptor! !overload-types :the-interceptor + (c/fn [_ _ old-overload-types new-overload-bases] + ;; `fn|globals` is closed over + (overload-bases>overload-types + new-overload-bases old-overload-types fn|globals))) + (urx/norx-deref !overload-types) + (intern fn|ns-name fn|overload-types-name !overload-types)))) + +(defns- >!fn|types + [{:as opts :keys [kind _]} ::opts + {:as fn|globals :keys [fn|ns-name _, fn|output-type _, fn|type-name _]} ::fn|globals + !overload-types _] + (if (= kind :extend-defn!) + (-> (uid/qualify fn|ns-name fn|type-name) resolve var-get) + (with-do-let [!fn|type (t/rx (type-data>ftype @!overload-types (?deref fn|output-type)))] + (intern fn|ns-name fn|type-name !fn|type)))) + +;; ===== `opts` + `fn|globals` ===== ;; + +(defns- >fn|opts + "`opts` are per invocation of `t/defn` and/or `extend-defn!`, while `globals` persist for as long + as the `t/defn` does." + [kind ::kind, lang ::lang, compilation-mode ::compilation-mode > ::opts] + (let [gen-gensym-base (ufgen/>reproducible-gensym|generator) + gen-gensym (c/fn [x] (symbol (str (gen-gensym-base x) "__")))] + (kw-map compilation-mode gen-gensym kind lang))) + +(defns- >fn|globals+?overload-bases-form + "`opts` are per invocation of `t/defn` and/or `extend-defn!`, while `globals` persist for as long + as the `t/defn` does." + [kind ::kind, args _ > ::fn|globals] (let [{:as args' :keys [:quantum.core.specs/fn|name :quantum.core.defnt/fn|extended-name :quantum.core.defnt/output-spec] - overloads-bases :quantum.core.defnt/overloads + overload-bases-form :quantum.core.defnt/overloads fn|meta :quantum.core.specs/meta} (s/validate args (case kind :defn :quantum.core.defnt/defnt :fn :quantum.core.defnt/fnt :extend-defn! :quantum.core.defnt/extend-defn!)) - fn|var (when (= kind :extend-defn!) - (or (uvar/resolve *ns* fn|extended-name) - (err! "Could not resolve fn name to extend" - {:sym fn|extended-name}))) - fn|ns-name (if (= kind :extend-defn!) - (-> fn|var >?namespace >symbol) - (>symbol *ns*)) - fn|name (if (= kind :extend-defn!) - (-> fn|extended-name >name symbol) - fn|name) - - inline? (-> (if (= kind :extend-defn!) - (-> fn|var meta :inline) - (:inline fn|meta)) - (s/validate (t/? t/boolean?))) - fn|meta (if inline? - (do (ulog/pr :warn - "requested `:inline`; ignoring until feature is implemented") - (dissoc fn|meta :inline)) - fn|meta) - fn|output-type|form (or (second output-spec) `t/any?) - ;; TODO this needs to be analyzed for dependent types referring to local vars - fn|output-type (eval fn|output-type|form) - fn|types-decl-name (symbol (str fn|name "|__types"))] - (if (empty? overloads-bases) - `(do (def ~fn|types-decl-name (atom [])) - (declare - ~(with-meta fn|name - (assoc fn|meta :quantum.core.type/type `(t/ftype ~(>form fn|output-type)))))) - (let [gen-gensym-base (ufgen/>reproducible-gensym|generator) - gen-gensym (c/fn [x] (symbol (str (gen-gensym-base x) "__"))) - opts (kw-map compilation-mode gen-gensym kind lang) - unanalyzed-overloads (->> overloads-bases - (uc/mapcat #(overloads-basis>unanalyzed-overload-seq - % kind fn|output-type|form fn|output-type))) - fn|type (type-data>ftype unanalyzed-overloads fn|output-type) - fn|globals (kw-map fn|ns-name fn|name fn|meta fn|type fn|output-type|form - fn|output-type fn|types-decl-name) - ;; Specifically overloads that were generated during this execution of this function - overloads (unanalyzed-overloads>overloads - unanalyzed-overloads opts fn|globals) - types-decl (>types-decl opts fn|globals overloads) - direct-dispatch (>direct-dispatch opts fn|globals overloads types-decl) - dynamic-dispatch (>dynamic-dispatch-fn|form opts fn|globals types-decl) + fn|var (when (= kind :extend-defn!) + (or (uvar/resolve *ns* fn|extended-name) + (err! "Could not resolve fn name to extend" + {:sym fn|extended-name}))) + fn|ns-name (if (= kind :extend-defn!) + (-> fn|var >?namespace >symbol) + (>symbol *ns*)) + fn|name (if (= kind :extend-defn!) + (-> fn|extended-name >name symbol) + fn|name) + fn|globals-name (symbol (str fn|name "|__globals"))] + (if (= kind :extend-defn!) + {:fn|globals (-> (uid/qualify fn|ns-name fn|globals-name) resolve var-get) + :overload-bases-form nil} + (let [inline? (-> (if (= kind :extend-defn!) + (-> fn|var meta :inline) + (:inline fn|meta)) + (s/validate (t/? t/boolean?))) + fn|meta (if inline? + (do (ulog/pr :warn + "requested `:inline`; ignoring until feature is implemented") + (dissoc fn|meta :inline)) + fn|meta) + fn|output-type|form (or (second output-spec) `t/any?) + ;; TODO this needs to be analyzed for dependent types referring to local vars + fn|output-type (eval fn|output-type|form) + fn|overload-bases-name (symbol (str fn|name "|__bases")) + fn|overload-types-name (symbol (str fn|name "|__types")) + fn|type-name (symbol (str fn|name "|__type"))] + {:fn|globals (kw-map fn|meta fn|name fn|ns-name fn|output-type|form fn|output-type + fn|overload-bases-name fn|overload-types-name fn|type-name) + :overload-bases-form overload-bases-form})))) + +;; ===== Whole `t/(de)fn` creation ===== ;; + +(defns fn|code [kind ::kind, lang ::lang, compilation-mode ::compilation-mode, args _] + (let [opts (>fn|opts kind lang compilation-mode) + {:keys [fn|globals overload-bases-form]} (>fn|globals+?overload-bases-form kind args) + !overload-bases (>!overload-bases opts fn|globals overload-bases-form) + !overload-types (>!overload-types opts fn|globals !overload-bases) + !fn|type (>!fn|types opts fn|globals !overload-types)] + (if (empty? (urx/norx-deref !overload-bases)) + `(declare ~(:fn|name fn|globals)) + (let [direct-dispatch (>direct-dispatch opts fn|globals !overload-types) + dynamic-dispatch (>dynamic-dispatch-fn|form opts fn|globals !overload-types) fn-codelist - (->> `[~@(when (not= kind :extend-defn!) [`(declare ~fn|name)]) ; For recursion - ~@(some-> (:form types-decl) vector) + (->> `[;; For recursion + ~@(when (not= kind :extend-defn!) [`(declare ~(:fn|name fn|globals))]) ~@(:form direct-dispatch) ~dynamic-dispatch] (remove nil?))] From 6764573672952723c6b5d405b315f1ac9091b4c4 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 2 Nov 2018 01:21:26 -0600 Subject: [PATCH 603/810] Ensure interceptors are called correctly --- .../quantum/untyped/core/data/reactive.cljc | 36 +++++++++++-------- 1 file changed, 22 insertions(+), 14 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index 42ff94da..20c1beef 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -97,10 +97,11 @@ (alist-conj! c derefed) (.setCaptured r (alist derefed)))))) -(defn- call|rf - ([ret] ret) - ([ret f] (f ret)) - ([ret k f] (f ret))) +;; TODO use `loop` with array for interceptors rather than creating a closure every time +(defn- gen-call|rf [r oldv] + (fn ([newv'] newv') + ([newv' [k f]] (f r k oldv newv')) + ([newv' k f] (f r k oldv newv')))) ;; Note that `interceptors` are all deref-capturing (udt/deftype Reference [^:! state meta validator ^:! watches ^:! interceptors] @@ -113,7 +114,7 @@ state)} uref/PMutableReference {get ([this] (norx-deref this)) - set! ([a newv] + set! ([this newv] (when-not (nil? validator) (assert (validator newv) "Validator rejected reference state")) (let [oldv state] @@ -122,8 +123,9 @@ (let [oldv state] (set! state (if (nil? interceptors) newv - (reduce-kv call|rf newv interceptors))) - (when-not (nil? watches) (notify-w! a oldv newv)) + ;; TODO room for optimization here — e.g. use array for interceptors, with `loop` + (reduce-kv (gen-call|rf this oldv) newv interceptors))) + (when-not (nil? watches) (notify-w! this oldv newv)) newv))))} ?Watchable {add-watch! ([this k f] (add-w! this k f)) remove-watch! ([this k] (remove-w! this k))} @@ -170,7 +172,7 @@ ^:! ^:get ^:set state ^:! ^:get ^:set watching ; i.e. 'dependents' ^:! watches ; TODO consider a mutable map for `watches` - ^:! interceptors] ; TODO consider a mutable map for `interceptors` + ^:! ^:get interceptors] ; TODO consider a mutable map for `interceptors` {;; IPrintWithWriter ;; (-pr-writer [a w opts] (pr-ref a w opts (str "Reaction " (hash a) ":"))) ?Equals {= ([this that] (identical? this that))} @@ -184,9 +186,10 @@ (if (and non-reactive? alwaysRecompute) (when-not computed (let [old-state state] - (set! state (if (nil? interceptors) - (f) - (reduce-kv call|rf (f) interceptors))) + (set! state + (if (nil? interceptors) + (f) + (reduce-kv (gen-call|rf this old-state) (f) interceptors))) (when-not (or (nil? watches) (eq-fn old-state state)) (notify-w! this old-state state)))) (do (notify-deref-watcher! this) @@ -244,12 +247,17 @@ reaction is also added to the list of watches on each of the references that `f` derefs." [f ^Reaction rx] (.setCaptured rx nil) - (let [res (in-context rx f) - c (.getCaptured rx)] + (let [oldv (.getState rx) + newv (in-context rx f) + interceptors (.getInterceptors rx) + newv' (if (nil? interceptors) + newv + (reduce-kv (gen-call|rf rx oldv) newv interceptors)) + c (.getCaptured rx)] (.setComputed rx true) ;; Optimize common case where derefs occur in same order (when-not (alist== c (.getWatching rx)) (update-watching! rx c)) - res)) + newv)) (defn- try-capture! [^Reaction rx f] (uerr/catch-all From f03870810351bcde46b3721176ca3d6c0635bd50 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 2 Nov 2018 01:21:39 -0600 Subject: [PATCH 604/810] Fix some logic issues --- .../quantum/untyped/core/type/defnt.cljc | 27 ++++++++++--------- .../quantum/test/untyped/core/type/defnt.cljc | 2 +- 2 files changed, 15 insertions(+), 14 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index b62fa8d2..56a8d626 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -112,21 +112,19 @@ (s/def ::overload-basis (s/kv {:ns simple-symbol? :args-form map? ; from binding to form - :varargs-form map? ; from binding to form + :varargs-form (s/nilable map?) ; from binding to form :arglist-form|unanalyzed t/any? :arg-types|basis (s/vec-of t/type?) :output-type|form t/any? :output-type|basis t/type? - :body-codelist (s/vec-of t/any?) - :dependent? t/boolean? - :reactive? t/boolean?})) + :body-codelist (s/vec-of t/any?)})) ;; Technically it's partially analyzed — its type definitions are analyzed (with the exception of ;; requests for type inference) while its body is not. (s/def ::unanalyzed-overload (s/kv {:arglist-form|unanalyzed t/any? :args-form map? ; from binding to form - :varargs-vorm map? ; from binding to form + :varargs-vorm (s/nilable map?) ; from binding to form :arg-types (s/vec-of t/type?) :output-type|form t/any? :output-type t/type? @@ -661,22 +659,24 @@ {:as fn|globals :keys [fn|meta _, fn|ns-name _, fn|name _, fn|output-type _ fn|overload-types-name _, fn|type-name _]} ::fn|globals !overload-types _] - (let [overload-forms + (let [overload-forms (->> !overload-types urx/norx-deref + :current (group-by (fn-> :arg-types count)) (sort-by key) ; for purposes of reproducibility and organization (map (c/fn [[arg-ct overload-types-for-arity]] + (quantum.untyped.core.print/ppr overload-types-for-arity) (let [arglist (ufgen/gen-args 0 arg-ct "x" gen-gensym) body (>dynamic-dispatch|body-for-arity fn|globals overload-types-for-arity arglist)] (list arglist body))))) fn|meta' (merge fn|meta {:quantum.core.type/type (uid/qualify fn|ns-name fn|type-name)})] - ;; TODO determine whether CLJS needs (update-in m [:jsdoc] conj "@param {...*} var_args") - (if (= kind :extend-defn!) - `(intern (quote ~fn|ns-name) (quote ~fn|name) - (with-meta (fn* ~@overload-forms) ~fn|meta')) - `(def ~fn|name (with-meta (fn* ~@overload-forms) ~fn|meta'))))) + ;; TODO determine whether CLJS needs (update-in m [:jsdoc] conj "@param {...*} var_args") + (if (= kind :extend-defn!) + `(intern (quote ~fn|ns-name) (quote ~fn|name) + (with-meta (fn* ~@overload-forms) ~fn|meta')) + `(def ~fn|name (with-meta (fn* ~@overload-forms) ~fn|meta'))))) ;; ===== End dynamic dispatch ===== ;; @@ -724,7 +724,7 @@ :args-form args-form :arg-types|basis (->> args-form keys (uc/map binding->arg-type|basis)) ;; TODO Only needed if `dependent?` or if new - :varargs-form {varargs-binding nil} ; TODO `nil` isn't right + :varargs-form (when varargs {varargs-binding nil}) ; TODO `nil` isn't right :arglist-form|unanalyzed arglist-form|unanalyzed ;; TODO Only needed if `dependent?` or if new :output-type|form output-type|form @@ -758,6 +758,7 @@ (with-do-let [!overload-types (urx/!rx @!overload-bases)] (uref/add-interceptor! !overload-types :the-interceptor (c/fn [_ _ old-overload-types new-overload-bases] + (println "interceptor") ;; `fn|globals` is closed over (overload-bases>overload-types new-overload-bases old-overload-types fn|globals))) @@ -786,7 +787,7 @@ (defns- >fn|globals+?overload-bases-form "`opts` are per invocation of `t/defn` and/or `extend-defn!`, while `globals` persist for as long as the `t/defn` does." - [kind ::kind, args _ > ::fn|globals] + [kind ::kind, args _ > (s/kv {:fn|globals ::fn|globals :overload-bases-form t/any?})] (let [{:as args' :keys [:quantum.core.specs/fn|name :quantum.core.defnt/fn|extended-name diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 22df499b..e52f6ffa 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -5,7 +5,7 @@ [clojure.core :as core] [quantum.test.untyped.core.type :as tt] [quantum.untyped.core.type.defnt :as self - :refer [types-decl>arg-types types-decl>ftype unsupported!]] + :refer [unsupported!]] [quantum.untyped.core.data.array :refer [*<>]] [quantum.untyped.core.form From 8fa06961ef9fca099d033dc4e56a02341b87994c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 2 Nov 2018 01:39:22 -0600 Subject: [PATCH 605/810] `reduce-2` `on-different-count` should have different arity --- src-untyped/quantum/untyped/core/collections.cljc | 2 +- .../quantum/untyped/core/collections/logic.cljc | 10 ++++------ src-untyped/quantum/untyped/core/loops.cljc | 4 ++-- src/quantum/core/collections/logic.cljc | 4 ++-- test/quantum/test/untyped/core/analyze.cljc | 2 +- 5 files changed, 10 insertions(+), 12 deletions(-) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index 69680dc7..30fd47b2 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -184,7 +184,7 @@ (def mergev (partial mergev-with (fn [i v0 v1] v1))) (defn zipmap-into [x ks vs] - (reduce-2 assoc (fn [_ _] (throw (ex-info "Seqs' count is not the same"))) x ks vs)) + (reduce-2 assoc (fn [_ _ _] (throw (ex-info "Seqs' count is not the same"))) x ks vs)) (defn zipmap [ks vs] (zipmap-into {} ks vs)) diff --git a/src-untyped/quantum/untyped/core/collections/logic.cljc b/src-untyped/quantum/untyped/core/collections/logic.cljc index e80515f9..b8511810 100644 --- a/src-untyped/quantum/untyped/core/collections/logic.cljc +++ b/src-untyped/quantum/untyped/core/collections/logic.cljc @@ -41,7 +41,7 @@ "Like `seq-or` but for 2 seqables." [pred xs0 xs1] (reduce-2 (fn [_ x0 x1] (and (pred x0 x1) (reduced true))) - (fn [_ _] false) false xs0 xs1)) + (fn [_ _ _] false) false xs0 xs1)) ;; ----- `seq-nor` ----- ;; @@ -76,16 +76,14 @@ "Like `seq-and` but for 2 seqables." [pred xs0 xs1] (reduce-2 (fn [_ x0 x1] (or (pred x0 x1) (reduced false))) - (fn [_ _] false) true xs0 xs1)) + (fn [_ _ _] false) true xs0 xs1)) -;; ----- `seq-and-2` ----- ;; - -(defn seq-and-2 +(defn seq-and-pair "`seq-and` for pairwise comparisons." ([pred xs #_seqable?] (reduce (fn [a b] (or (pred a b) (reduced false))) (first xs) (rest xs)))) -(defalias every?-2 seq-and-2) +(defalias every?-pair seq-and-pair) ;; ----- `seq-nand` ----- ;; diff --git a/src-untyped/quantum/untyped/core/loops.cljc b/src-untyped/quantum/untyped/core/loops.cljc index b94634cc..8ee57fe4 100644 --- a/src-untyped/quantum/untyped/core/loops.cljc +++ b/src-untyped/quantum/untyped/core/loops.cljc @@ -6,7 +6,7 @@ (ucore/log-this-ns) -(defn default-on-different-count [xs0 xs1] nil) +(defn default-on-different-count [ret xs0 xs1] ret) (defn reduce-2 "Reduces over two seqables at a time." @@ -19,7 +19,7 @@ (or (empty? xs0') (empty? xs1')) (if (or (and (empty? xs0') (seq xs1')) (and (seq xs0') (empty? xs1'))) - (unreduced (on-different-count xs0 xs1)) + (unreduced (on-different-count ret xs0 xs1)) ret) :else (recur (f ret (first xs0') (first xs1')) (next xs0') diff --git a/src/quantum/core/collections/logic.cljc b/src/quantum/core/collections/logic.cljc index d6be5a51..916fe22f 100644 --- a/src/quantum/core/collections/logic.cljc +++ b/src/quantum/core/collections/logic.cljc @@ -32,9 +32,9 @@ (defalias not-every? seq-nand) -(defn seq-and-2 +(defn seq-and-pair "`seq-and` for pairwise comparisons." ([pred xs] (reduce (fn [a b] (or (pred a b) (reduced false))) (first xs) (rest xs)))) -(defalias every?-2 seq-and-2) +(defalias every?-pair seq-and-pair) diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index 86128df4..5b1659ee 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -9,7 +9,7 @@ [quantum.untyped.core.data.map :as umap] [quantum.untyped.core.data.reactive :as urx] [quantum.untyped.core.fn - :refer [<- fn']] + :refer [<-]] [quantum.untyped.core.loops :refer [reduce-2]] [quantum.untyped.core.test From e9e50e6bbc98df3173bfa8a913174254f8709481 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 2 Nov 2018 09:31:16 -0600 Subject: [PATCH 606/810] Pass `opts` and `fn|type` correctly --- .../quantum/untyped/core/type/defnt.cljc | 25 +++++++++++-------- 1 file changed, 15 insertions(+), 10 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 56a8d626..4f2538ff 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -289,7 +289,7 @@ ::unanalyzed-overload {:as opts :keys [lang _, kind _]} ::opts {:as fn|globals :keys [fn|name _, fn|output-type _]} ::fn|globals - fn|type t/type? + fn|type (s/nilable utr/fn-type?) > ::overload] (let [;; Not sure if `nil` is the right approach for the value recursive-ast-node-reference @@ -333,8 +333,8 @@ overloads. This is because once we must sort (`O(n•log(n))`) the overloads by comparing their arg types and then if we find any duplicates in a linear scan (`O(n)`), we throw an error." - [unanalyzed-overloads (s/vec-of ::unanalyzed-overload), opts ::opts, fn|globals ::fn|globals - fn|type t/type? + [opts ::opts, fn|globals ::fn|globals, fn|type (s/nilable utr/fn-type?) + unanalyzed-overloads (s/vec-of ::unanalyzed-overload) > (s/vec-of ::overload)] (->> unanalyzed-overloads ;; We have to analyze everything in order to figure out all the types (or at least, analyze @@ -502,7 +502,7 @@ :keys [args-form _, body-codelist _, output-type|form _]} ::overload-basis {:as fn|globals :keys [fn|output-type _]} ::fn|globals - > (s/seq-of ::unanalyzed-overload)] + #_> #_(s/+-of ::unanalyzed-overload)] (let [overload-basis-selected (select-keys overload-basis [:arglist-form|unanalyzed :args-form :body-codelist :output-type|form :varargs-form])] @@ -522,8 +522,10 @@ (defns- overload-bases>overload-types [overload-bases (s/kv {:norx-prev (s/nilable (s/vec-of ::overload-basis)) :current (s/vec-of ::overload-basis)}) - existing-overload-types (s/vec-of ::types-decl-datum) + existing-overload-types (s/nilable (s/vec-of ::types-decl-datum)) + opts ::opts {:as fn|globals :keys [fn|overload-types-name _, fn|name _, fn|ns-name _]} ::fn|globals + fn|type (s/nilable utr/fn-type?) > (s/vec-of ::types-decl-datum)] (if-not-let [overload-bases-to-analyze (-> overload-bases >overload-bases-to-analyze seq)] existing-overload-types @@ -531,7 +533,7 @@ ;; use them later on in the pipeline overloads (->> overload-bases-to-analyze (uc/mapcat (fn1 overload-basis>unanalyzed-overloads+ fn|globals)) - unanalyzed-overloads>overloads) + (unanalyzed-overloads>overloads opts fn|globals fn|type)) first-current-overload-id (count existing-overload-types) overload-types-current-data ; i.e. being created right now (->> overloads @@ -750,18 +752,21 @@ (urx/! {:norx-prev nil :current overload-bases})))) (defns- >!overload-types + "Whatever `opts` and `fn|globals` are passed are what the `t/defn` will always use even when being + extended in a different namespace." [{:as opts :keys [kind _]} ::opts - {:as fn|globals :keys [fn|ns-name _, fn|overload-types-name _]} ::fn|globals + {:as fn|globals :keys [fn|ns-name _, fn|overload-types-name _, fn|type-name _]} ::fn|globals !overload-bases _] (if (= kind :extend-defn!) (-> (uid/qualify fn|ns-name fn|overload-types-name) resolve var-get) (with-do-let [!overload-types (urx/!rx @!overload-bases)] (uref/add-interceptor! !overload-types :the-interceptor (c/fn [_ _ old-overload-types new-overload-bases] - (println "interceptor") - ;; `fn|globals` is closed over + ;; `opts` and `fn|globals` are closed over (overload-bases>overload-types - new-overload-bases old-overload-types fn|globals))) + new-overload-bases old-overload-types opts fn|globals + (or (some-> (uid/qualify fn|ns-name fn|type-name) resolve var-get urx/norx-deref) + t/none?)))) (urx/norx-deref !overload-types) (intern fn|ns-name fn|overload-types-name !overload-types)))) From e6b079f8d0f7ef8d7a50cf8690699463f2c905c9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 2 Nov 2018 10:21:04 -0600 Subject: [PATCH 607/810] Return correct value after interceptors are applied --- .../quantum/untyped/core/data/reactive.cljc | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index 20c1beef..9aa7fb51 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -236,7 +236,7 @@ 'obj.captured' (*ref-context*). See function notify-deref-watcher! to know how *ref-context* is updated." - [obj f] (binding [*ref-context* obj] (f))) + [^Reaction rx] (binding [*ref-context* rx] ((.-f rx)))) (defn- deref-capture! "Returns `(in-context f r)`. Calls `update-watching!` on `rx` with any `deref`ed reactive @@ -245,10 +245,10 @@ Inside `update-watching!` along with adding the references in 'rx.watching' of reaction, the reaction is also added to the list of watches on each of the references that `f` derefs." - [f ^Reaction rx] + [^Reaction rx] (.setCaptured rx nil) (let [oldv (.getState rx) - newv (in-context rx f) + newv (in-context rx) interceptors (.getInterceptors rx) newv' (if (nil? interceptors) newv @@ -257,12 +257,12 @@ (.setComputed rx true) ;; Optimize common case where derefs occur in same order (when-not (alist== c (.getWatching rx)) (update-watching! rx c)) - newv)) + newv')) -(defn- try-capture! [^Reaction rx f] +(defn- try-capture! [^Reaction rx] (uerr/catch-all (do (.setCaught rx nil) - (deref-capture! f rx)) + (deref-capture! rx)) e (do (.setState rx e) (.setCaught rx e) @@ -271,8 +271,8 @@ (defn- run-reaction! [^Reaction rx check?] (let [old-state (.getState rx) new-state (if check? - (try-capture! rx (.-f rx)) - (deref-capture! (.-f rx) rx))] + (try-capture! rx) + (deref-capture! rx))] (when-not (.-no-cache? rx) (.setState rx new-state) (when-not (or (nil? (.getWatches rx)) From 8faf0a3fc3bf6a37333e81c1a4617e84be2380b5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 2 Nov 2018 10:21:40 -0600 Subject: [PATCH 608/810] Fix some compilation and output `overload-types` when `:test` --- .../quantum/untyped/core/type/defnt.cljc | 58 ++++++++----------- .../quantum/test/untyped/core/type/defnt.cljc | 9 +-- 2 files changed, 27 insertions(+), 40 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 4f2538ff..09b49252 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -80,7 +80,7 @@ (defonce *interfaces (atom {})) -(defonce !overload-queue (uvec/alist)) ; (t/!seq-of ::indexed-types-decl-datum) +(defonce !overload-queue (uvec/alist)) ; (t/!seq-of ::types-decl-datum-with-overload) ;; ==== Internal specs ===== ;; @@ -174,18 +174,11 @@ :output-type t/type?})) (s/def ::types-decl-datum - (s/kv {:id ::overload|id - :ns-sym simple-symbol? - :arg-types (s/vec-of t/type?) - :output-type t/type?})) - -(s/def ::indexed-types-decl-datum (s/kv {:id ::overload|id :ns-sym simple-symbol? :arg-types (s/vec-of t/type?) :output-type t/type? - :index index? ; overload-index (position in the overall types-decl) - :overload ::overload})) + :index index?})) ; overload-index (position in the overall types-decl) (s/def ::types-decl (s/kv {:name simple-symbol? @@ -546,7 +539,7 @@ ;; We can't just concat the currently-being-created overloads' type-decl data with the ;; existing type-decl data because we need to maintain the type-decl data's ordering by ;; type-specificity so the dynamic dispatch works correctly. - overload-types-indexed-data + overload-types-data-with-overloads (if (empty? existing-overload-types) (->> overload-types-current-data (uc/map-indexed @@ -565,14 +558,11 @@ (if (:overload datum1) -1 c)) c)))) (dedupe-overload-types-data fn|ns-name fn|name) - (uc/map-indexed (c/fn [i datum] (assoc datum :index i))))) - _ (->> overload-types-indexed-data - (uc/run! (c/fn [x] (uvec/alist-conj! !overload-queue x)))) - overload-types-data - (if (empty? existing-overload-types) - overload-types-current-data - (->> overload-types-indexed-data (uc/map #(dissoc % :index :overload))))] - overload-types-data))) + (uc/map-indexed (c/fn [i datum] (assoc datum :index i)))))] + (->> overload-types-data-with-overloads + (uc/map (c/fn [datum] + (uvec/alist-conj! !overload-queue datum) + (dissoc datum :overload))))))) ;; ----- Direct dispatch ----- ;; @@ -615,11 +605,9 @@ arglist (s/vec-of simple-symbol?)] (->> overload-types-for-arity (uc/map+ - (c/fn [{:as types-decl-datum :keys [arg-types ns-sym overload]}] - (let [overload|id (:id types-decl-datum) - overload-types-decl|name - (>overload-types-decl|name ns-sym fn|name overload|id) - reify|name|qualified (>reify-name-unhinted ns-sym fn|name overload|id)] + (c/fn [{:as types-decl-datum :keys [arg-types ns-sym] overload|id :id}] + (let [overload-types-decl|name (>overload-types-decl|name ns-sym fn|name overload|id) + reify|name|qualified (>reify-name-unhinted ns-sym fn|name overload|id)] [(>dynamic-dispatch|reify-call reify|name|qualified arglist) (->> arg-types (uc/map-indexed @@ -631,7 +619,7 @@ (defns- >dynamic-dispatch|body-for-arity [{:as fn|globals :keys [fn|ns-name _, fn|name _]} ::fn|globals - overload-types-for-arity (s/vec-of ::indexed-types-decl-datum) + overload-types-for-arity (s/vec-of ::types-decl-datum) arglist (s/vec-of simple-symbol?)] (if (empty? arglist) (let [overload|id (-> overload-types-for-arity first :id)] @@ -656,19 +644,17 @@ (aritoid combinef combinef (c/fn [x [k [{:keys [getf i]}]]] (combinef x getf k i))) (>combinatoric-seq+ fn|globals overload-types-for-arity arglist))))) -(defns- >dynamic-dispatch-fn|form - [{:as opts :keys [gen-gensym _, lang _, kind _]} ::opts +(defns- >dynamic-dispatch-fn|codelist + [{:as opts :keys [compilation-mode _, gen-gensym _, lang _, kind _]} ::opts {:as fn|globals :keys [fn|meta _, fn|ns-name _, fn|name _, fn|output-type _ fn|overload-types-name _, fn|type-name _]} ::fn|globals !overload-types _] (let [overload-forms (->> !overload-types urx/norx-deref - :current (group-by (fn-> :arg-types count)) (sort-by key) ; for purposes of reproducibility and organization (map (c/fn [[arg-ct overload-types-for-arity]] - (quantum.untyped.core.print/ppr overload-types-for-arity) (let [arglist (ufgen/gen-args 0 arg-ct "x" gen-gensym) body (>dynamic-dispatch|body-for-arity fn|globals overload-types-for-arity arglist)] @@ -676,9 +662,13 @@ fn|meta' (merge fn|meta {:quantum.core.type/type (uid/qualify fn|ns-name fn|type-name)})] ;; TODO determine whether CLJS needs (update-in m [:jsdoc] conj "@param {...*} var_args") (if (= kind :extend-defn!) - `(intern (quote ~fn|ns-name) (quote ~fn|name) - (with-meta (fn* ~@overload-forms) ~fn|meta')) - `(def ~fn|name (with-meta (fn* ~@overload-forms) ~fn|meta'))))) + [`(intern (quote ~fn|ns-name) (quote ~fn|name) + (with-meta (fn* ~@overload-forms) ~fn|meta'))] + (let [dispatch-form `(def ~fn|name (with-meta (fn* ~@overload-forms) ~fn|meta'))] + (if (= compilation-mode :test) + [(->> !overload-types urx/norx-deref >form (uc/map (fn1 dissoc :ns-sym))) + dispatch-form] + dispatch-form))))) ;; ===== End dynamic dispatch ===== ;; @@ -845,13 +835,13 @@ !fn|type (>!fn|types opts fn|globals !overload-types)] (if (empty? (urx/norx-deref !overload-bases)) `(declare ~(:fn|name fn|globals)) - (let [direct-dispatch (>direct-dispatch opts fn|globals !overload-types) - dynamic-dispatch (>dynamic-dispatch-fn|form opts fn|globals !overload-types) + (let [direct-dispatch (>direct-dispatch opts fn|globals !overload-types) + dynamic-dispatch (>dynamic-dispatch-fn|codelist opts fn|globals !overload-types) fn-codelist (->> `[;; For recursion ~@(when (not= kind :extend-defn!) [`(declare ~(:fn|name fn|globals))]) ~@(:form direct-dispatch) - ~dynamic-dispatch] + ~@dynamic-dispatch] (remove nil?))] (case kind :fn (TODO "Haven't done t/fn yet") diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index e52f6ffa..00005b42 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -19,8 +19,7 @@ [quantum.untyped.core.spec :as s] [quantum.untyped.core.test :as utest :refer [deftest is is= is-code= testing throws]] - [quantum.untyped.core.type :as t - :refer [?]] + [quantum.untyped.core.type :as t] [quantum.untyped.core.type.reifications :as utr]) (:import [clojure.lang ASeq ISeq LazySeq Named Reduced Seqable] @@ -55,14 +54,11 @@ (let [actual (binding [self/*compilation-mode* :test] (macroexpand ' - (self/defn pid|test [> (? t/string?)] + (self/defn pid|test [> (t/? t/string?)] (->> ^:val (java.lang.management.ManagementFactory/getRuntimeMXBean) (.getName))))) expected ($ (do (declare ~'pid|test) - (def ~'pid|test|__types - (atom [{:id 0 :arg-types [] :output-type (t/or (t/value nil) (t/isa? String))}])) - (def ~(O<> 'pid|test|__0|types) (types-decl>arg-types pid|test|__types 0)) (def ~(tag (cstr `>Object) 'pid|test|__0) (reify* [>Object] (~(O 'invoke) [~'_0__] @@ -70,6 +66,7 @@ (tag "java.lang.management.RuntimeMXBean" '(. java.lang.management.ManagementFactory getRuntimeMXBean)) 'getName))))) + [{:id 0 :index 0 :arg-types [] :output-type (t/or (t/value nil) (t/isa? String))}] (defn ~'pid|test {:quantum.core.type/type (types-decl>ftype pid|test|__types t/any?)} ([] (. pid|test|__0 ~'invoke)))))] From 84f6b948633ce6864ac89389980584c6ee9584d7 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 2 Nov 2018 11:02:53 -0600 Subject: [PATCH 609/810] First test passes with reactive types overhaul :D --- src-untyped/quantum/untyped/core/analyze.cljc | 3 +- src-untyped/quantum/untyped/core/form.cljc | 39 +++++++++++-------- src-untyped/quantum/untyped/core/test.cljc | 6 ++- .../quantum/untyped/core/type/defnt.cljc | 10 ++--- .../quantum/test/untyped/core/type/defnt.cljc | 6 +-- 5 files changed, 36 insertions(+), 28 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 54e5b1cc..27ebcc7b 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -1018,8 +1018,7 @@ [env ::env, arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _ split-types? boolean?] {:arglist-context? true - :arglist-syms|queue (uset/ordered-set - (-> arg-sym->arg-type-form keys first)) + :arglist-syms|queue (uset/ordered-set (-> arg-sym->arg-type-form keys first)) :arglist-syms|unanalyzed (-> arg-sym->arg-type-form keys set) :arg-env (atom env) ; Mutable so it can cache :arg-sym->arg-type-form arg-sym->arg-type-form diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index 01e57750..67cf0fbe 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -128,22 +128,27 @@ "Ensures that two pieces of code are equivalent. This means ensuring that seqs, vectors, and maps are only allowed to be compared with each other, and that metadata (minus line and column metadata) is equivalent." - ([code0 code1] - (if (uvar/metable? code0) - (and (uvar/metable? code1) - (= (-> code0 meta (or {}) (dissoc :line :column)) - (-> code1 meta (or {}) (dissoc :line :column))) + ([c0 c1] + (if (uvar/metable? c0) + (and (uvar/metable? c1) + (= (-> c0 meta (or {}) (dissoc :line :column)) + (-> c1 meta (or {}) (dissoc :line :column))) (let [similar-class? - (cond (seq? code0) (seq? code1) - (seq? code1) (seq? code0) - (vector? code0) (vector? code1) - (vector? code1) (vector? code0) - (map? code0) (map? code1) - (map? code1) (map? code0) - :else ::not-applicable)] + (cond (seq? c0) (seq? c1) + (seq? c1) (seq? c0) + (vector? c0) (vector? c1) + (vector? c1) (vector? c0) + (map? c0) (map? c1) + (map? c1) (map? c0) + (set? c0) (set? c1) + (set? c1) (set? c0) + :else ::not-applicable)] (if (= similar-class? ::not-applicable) - (= code0 code1) - (and similar-class? (seq= (seq code0) (seq code1) code=))))) - (and (not (uvar/metable? code1)) - (= code0 code1)))) - ([code0 code1 & codes] (and (code= code0 code1) (every? #(code= code0 %) codes)))) + (= c0 c1) + (and similar-class? + (if (or (set? c0) (map? c0)) + (seq= (sort c0) (sort c1) code=) + (seq= (seq c0) (seq c1) code=)))))) + (and (not (uvar/metable? c1)) + (= c0 c1)))) + ([c0 c1 & cs] (and (code= c0 c1) (every? #(code= c0 %) cs)))) diff --git a/src-untyped/quantum/untyped/core/test.cljc b/src-untyped/quantum/untyped/core/test.cljc index 770209c3..f12c074f 100644 --- a/src-untyped/quantum/untyped/core/test.cljc +++ b/src-untyped/quantum/untyped/core/test.cljc @@ -38,6 +38,8 @@ (vector? c1) (vector? c0) (map? c0) (map? c1) (map? c1) (map? c0) + (set? c0) (set? c1) + (set? c1) (set? c0) (+map-entry? c0) (+map-entry? c1) (+map-entry? c1) (+map-entry? c0) :else ::not-applicable)] @@ -47,7 +49,9 @@ (and (or similar-class? (do (pr! "FAIL: should be similar class" (pr-str c0) (pr-str c1)) false)) - (or (uc/seq= (seq c0) (seq c1) code=) + (or (if (or (set? c0) (map? c0)) + (uc/seq= (sort c0) (sort c1) code=) + (uc/seq= (seq c0) (seq c1) code=)) (do (pr! "FAIL: `(seq= code0 code1 code=)`" (pr-str c0) (pr-str c1)) false)))))) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 09b49252..bf2861ff 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -277,12 +277,12 @@ `t/fn` overload, which is the foundation for one `reify`." [{:as unanalyzed-overload :keys [arglist-form|unanalyzed _, args-form _, varargs-form _, arg-types _, - output-type|form _, body-codelist|unanalyzed _] + output-type|form _, body-codelist _] declared-output-type [:output-type _]} ::unanalyzed-overload {:as opts :keys [lang _, kind _]} ::opts {:as fn|globals :keys [fn|name _, fn|output-type _]} ::fn|globals - fn|type (s/nilable utr/fn-type?) + fn|type t/type? > ::overload] (let [;; Not sure if `nil` is the right approach for the value recursive-ast-node-reference @@ -295,7 +295,7 @@ (assoc fn|name recursive-ast-node-reference)))) variadic? (not (empty? varargs-form)) arg-classes (->> arg-types (uc/map type>class)) - body-node (uana/analyze env (ufgen/?wrap-do body-codelist|unanalyzed)) + body-node (uana/analyze env (ufgen/?wrap-do body-codelist)) hint-arg|fn (c/fn [i arg-binding] (ufth/with-type-hint arg-binding (ufth/>fn-arglist-tag @@ -326,7 +326,7 @@ overloads. This is because once we must sort (`O(n•log(n))`) the overloads by comparing their arg types and then if we find any duplicates in a linear scan (`O(n)`), we throw an error." - [opts ::opts, fn|globals ::fn|globals, fn|type (s/nilable utr/fn-type?) + [opts ::opts, fn|globals ::fn|globals, fn|type t/type? unanalyzed-overloads (s/vec-of ::unanalyzed-overload) > (s/vec-of ::overload)] (->> unanalyzed-overloads @@ -518,7 +518,7 @@ existing-overload-types (s/nilable (s/vec-of ::types-decl-datum)) opts ::opts {:as fn|globals :keys [fn|overload-types-name _, fn|name _, fn|ns-name _]} ::fn|globals - fn|type (s/nilable utr/fn-type?) + fn|type t/type? > (s/vec-of ::types-decl-datum)] (if-not-let [overload-bases-to-analyze (-> overload-bases >overload-bases-to-analyze seq)] existing-overload-types diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 00005b42..ae6a3f32 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -67,9 +67,9 @@ '(. java.lang.management.ManagementFactory getRuntimeMXBean)) 'getName))))) [{:id 0 :index 0 :arg-types [] :output-type (t/or (t/value nil) (t/isa? String))}] - (defn ~'pid|test - {:quantum.core.type/type (types-decl>ftype pid|test|__types t/any?)} - ([] (. pid|test|__0 ~'invoke)))))] + (def ~'pid|test + (with-meta (fn* ([] (. pid|test|__0 ~'invoke))) + {:quantum.core.type/type pid|test|__type}))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) From f52b9b2f2a54c1ba2bb4ba51ee8771ce4723aca4 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 2 Nov 2018 11:08:22 -0600 Subject: [PATCH 610/810] Another test bites the dust! --- .../quantum/test/untyped/core/type/defnt.cljc | 87 ++++++++----------- 1 file changed, 35 insertions(+), 52 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index ae6a3f32..e5bc6d45 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -87,80 +87,63 @@ (case (env-lang) :clj ($ (do (declare ~'identity|uninlined) - (def ~'identity|uninlined|__types - (atom [{:id 0 :arg-types [(t/isa? Boolean)] :output-type (t/isa? Boolean)} - {:id 1 :arg-types [(t/isa? Byte)] :output-type (t/isa? Byte)} - {:id 2 :arg-types [(t/isa? Short)] :output-type (t/isa? Short)} - {:id 3 :arg-types [(t/isa? Character)] :output-type (t/isa? Character)} - {:id 4 :arg-types [(t/isa? Integer)] :output-type (t/isa? Integer)} - {:id 5 :arg-types [(t/isa? Long)] :output-type (t/isa? Long)} - {:id 6 :arg-types [(t/isa? Float)] :output-type (t/isa? Float)} - {:id 7 :arg-types [(t/isa? Double)] :output-type (t/isa? Double)} - {:id 8 :arg-types [t/any?] :output-type t/any?}])) ;; [x t/any?] - (def ~(O<> 'identity|uninlined|__0|types) - (types-decl>arg-types identity|uninlined|__types 0)) (def ~(tag (cstr `boolean>boolean) 'identity|uninlined|__0) (reify* [boolean>boolean] (~(B 'invoke) [~'_0__ ~(B 'x)] ~'x))) - (def ~(O<> 'identity|uninlined|__1|types) - (types-decl>arg-types identity|uninlined|__types 1)) (def ~(tag (cstr `byte>byte) 'identity|uninlined|__1) (reify* [byte>byte] (~(Y 'invoke) [~'_1__ ~(Y 'x)] ~'x))) - (def ~(O<> 'identity|uninlined|__2|types) - (types-decl>arg-types identity|uninlined|__types 2)) (def ~(tag (cstr `short>short) 'identity|uninlined|__2) (reify* [short>short] (~(S 'invoke) [~'_2__ ~(S 'x)] ~'x))) - (def ~(O<> 'identity|uninlined|__3|types) - (types-decl>arg-types identity|uninlined|__types 3)) (def ~(tag (cstr `char>char) 'identity|uninlined|__3) (reify* [char>char] (~(C 'invoke) [~'_3__ ~(C 'x)] ~'x))) - (def ~(O<> 'identity|uninlined|__4|types) - (types-decl>arg-types identity|uninlined|__types 4)) (def ~(tag (cstr `int>int) 'identity|uninlined|__4) (reify* [int>int] (~(I 'invoke) [~'_4__ ~(I 'x)] ~'x))) - (def ~(O<> 'identity|uninlined|__5|types) - (types-decl>arg-types identity|uninlined|__types 5)) (def ~(tag (cstr `long>long) 'identity|uninlined|__5) (reify* [long>long] (~(L 'invoke) [~'_5__ ~(L 'x)] ~'x))) - (def ~(O<> 'identity|uninlined|__6|types) - (types-decl>arg-types identity|uninlined|__types 6)) (def ~(tag (cstr `float>float) 'identity|uninlined|__6) (reify* [float>float] (~(F 'invoke) [~'_6__ ~(F 'x)] ~'x))) - (def ~(O<> 'identity|uninlined|__7|types) - (types-decl>arg-types identity|uninlined|__types 7)) (def ~(tag (cstr `double>double) 'identity|uninlined|__7) (reify* [double>double] (~(D 'invoke) [~'_7__ ~(D 'x)] ~'x))) - (def ~(O<> 'identity|uninlined|__8|types) - (types-decl>arg-types identity|uninlined|__types 8)) (def ~(tag (cstr `Object>Object) 'identity|uninlined|__8) (reify* [Object>Object] (~(O 'invoke) [~'_8__ ~(O 'x)] ~(O 'x)))) - (defn ~'identity|uninlined - {:quantum.core.type/type (types-decl>ftype identity|uninlined|__types t/any?)} - ([~'x00__] - (ifs - ((Array/get identity|uninlined|__0|types 0) ~'x00__) - (. identity|uninlined|__0 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__1|types 0) ~'x00__) - (. identity|uninlined|__1 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__2|types 0) ~'x00__) - (. identity|uninlined|__2 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__3|types 0) ~'x00__) - (. identity|uninlined|__3 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__4|types 0) ~'x00__) - (. identity|uninlined|__4 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__5|types 0) ~'x00__) - (. identity|uninlined|__5 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__6|types 0) ~'x00__) - (. identity|uninlined|__6 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__7|types 0) ~'x00__) - (. identity|uninlined|__7 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__8|types 0) ~'x00__) - (. identity|uninlined|__8 ~'invoke ~'x00__) - ;; TODO no need for `unsupported!` because it will always get a valid branch - (unsupported! `identity|uninlined [~'x00__] 0)))))) + [{:id 0 :index 0 :arg-types [(t/isa? Boolean)] :output-type (t/isa? Boolean)} + {:id 1 :index 1 :arg-types [(t/isa? Byte)] :output-type (t/isa? Byte)} + {:id 2 :index 2 :arg-types [(t/isa? Short)] :output-type (t/isa? Short)} + {:id 3 :index 3 :arg-types [(t/isa? Character)] :output-type (t/isa? Character)} + {:id 4 :index 4 :arg-types [(t/isa? Integer)] :output-type (t/isa? Integer)} + {:id 5 :index 5 :arg-types [(t/isa? Long)] :output-type (t/isa? Long)} + {:id 6 :index 6 :arg-types [(t/isa? Float)] :output-type (t/isa? Float)} + {:id 7 :index 7 :arg-types [(t/isa? Double)] :output-type (t/isa? Double)} + {:id 8 :index 8 :arg-types [t/any?] :output-type t/any?}] + (def ~'identity|uninlined + (with-meta + (fn* ([~'x00__] + (ifs + ((Array/get identity|uninlined|__0|types 0) ~'x00__) + (. identity|uninlined|__0 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__1|types 0) ~'x00__) + (. identity|uninlined|__1 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__2|types 0) ~'x00__) + (. identity|uninlined|__2 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__3|types 0) ~'x00__) + (. identity|uninlined|__3 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__4|types 0) ~'x00__) + (. identity|uninlined|__4 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__5|types 0) ~'x00__) + (. identity|uninlined|__5 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__6|types 0) ~'x00__) + (. identity|uninlined|__6 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__7|types 0) ~'x00__) + (. identity|uninlined|__7 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__8|types 0) ~'x00__) + (. identity|uninlined|__8 ~'invoke ~'x00__) + ;; TODO no need for `unsupported!` because it will always get a valid + ;; branch + (unsupported! `identity|uninlined [~'x00__] 0)))) + {:quantum.core.type/type identity|uninlined|__type})))) :cljs ;; Direct dispatch will be simple functions, not `reify`s ($ (do (defn ~'identity|uninlined [~'x] ~'x))))] From 62ce0406b1726c08af234d610c51846dd122e888 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 2 Nov 2018 18:24:26 -0600 Subject: [PATCH 611/810] Another test passes! --- .../quantum/test/untyped/core/type/defnt.cljc | 22 +++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index e5bc6d45..85b3735e 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -165,31 +165,31 @@ (case (env-lang) :clj ($ (do (declare ~'name) - (def ~'name|__types - (atom [{:id 0 :arg-types [(t/isa? String)] :output-type (t/isa? String)} - {:id 1 :arg-types [(t/isa? Named)] :output-type (t/* (t/isa? String))}])) ;; [x t/string?] - (def ~(O<> 'name|__0|types) (types-decl>arg-types name|__types 0)) (def ~(tag (cstr `Object>Object) 'name|__0) (reify* [Object>Object] (~(O 'invoke) [~'_0__ ~(O 'x)] ~(ST 'x)))) ;; [x (t/isa? Named)] > (t/* t/string?) - (def ~(O<> 'name|__1|types) (types-decl>arg-types name|__types 1)) (def ~(tag (cstr `Object>Object) 'name|__1) (reify* [Object>Object] (~(O 'invoke) [~'_1__ ~(O 'x)] (t/validate ~(ST (list '. (tag "clojure.lang.Named" 'x) 'getName)) ~'(t/* t/string?))))) - (defn ~'name - {:quantum.core.type/type (types-decl>ftype name|__types (t/isa? String))} - ([~'x00__] - (ifs ((Array/get name|__0|types 0) ~'x00__) (. name|__0 ~'invoke ~'x00__) - ((Array/get name|__1|types 0) ~'x00__) (. name|__1 ~'invoke ~'x00__) - (unsupported! `name [~'x00__] 0)))))) + [{:id 0 :index 0 :arg-types [(t/isa? String)] :output-type (t/isa? String)} + {:id 1 :index 1 :arg-types [(t/isa? Named)] :output-type (t/* (t/isa? String))}] + + (def ~'name + (with-meta + (fn* + ([~'x00__] + (ifs ((Array/get name|__0|types 0) ~'x00__) (. name|__0 ~'invoke ~'x00__) + ((Array/get name|__1|types 0) ~'x00__) (. name|__1 ~'invoke ~'x00__) + (unsupported! `name [~'x00__] 0)))) + {:quantum.core.type/type name|__type})))) :cljs ($ (do (defn ~'name [~'x00__] (ifs (t/string? x) x From 767efe1fa57c860f99927bf591043381337bb82a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 2 Nov 2018 18:27:15 -0600 Subject: [PATCH 612/810] Another test passes! --- .../quantum/test/untyped/core/type/defnt.cljc | 64 ++++++++----------- 1 file changed, 28 insertions(+), 36 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 85b3735e..83bbcc77 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -219,69 +219,61 @@ (case (env-lang) :clj ($ (do (declare ~'some?) - (def ~'some?|__types - (atom [{:id 0 :arg-types [(t/value nil)] :output-type (t/value false)} - {:id 1 :arg-types [(t/isa? Boolean)] :output-type (t/value true)} - {:id 2 :arg-types [(t/isa? Byte)] :output-type (t/value true)} - {:id 3 :arg-types [(t/isa? Short)] :output-type (t/value true)} - {:id 4 :arg-types [(t/isa? Character)] :output-type (t/value true)} - {:id 5 :arg-types [(t/isa? Integer)] :output-type (t/value true)} - {:id 6 :arg-types [(t/isa? Long)] :output-type (t/value true)} - {:id 7 :arg-types [(t/isa? Float)] :output-type (t/value true)} - {:id 8 :arg-types [(t/isa? Double)] :output-type (t/value true)} - {:id 9 :arg-types [t/any?] :output-type (t/value true)}])) ;; [x t/nil?] - (def ~(O<> 'some?|__0|types) (types-decl>arg-types some?|__types 0)) (def ~(tag (cstr `Object>boolean) 'some?|__0) (reify* [Object>boolean] (~(B 'invoke) [~'_0__ ~(O 'x)] false))) ;; [x t/any?] - (def ~(O<> 'some?|__1|types) (types-decl>arg-types some?|__types 1)) (def ~(tag (cstr `boolean>boolean) 'some?|__1) (reify* [boolean>boolean] (~(B 'invoke) [~'_1__ ~(B 'x)] true))) - (def ~(O<> 'some?|__2|types) (types-decl>arg-types some?|__types 2)) (def ~(tag (cstr `byte>boolean) 'some?|__2) (reify* [byte>boolean] (~(B 'invoke) [~'_2__ ~(Y 'x)] true))) - (def ~(O<> 'some?|__3|types) (types-decl>arg-types some?|__types 3)) (def ~(tag (cstr `short>boolean) 'some?|__3) (reify* [short>boolean] (~(B 'invoke) [~'_3__ ~(S 'x)] true))) - (def ~(O<> 'some?|__4|types) (types-decl>arg-types some?|__types 4)) (def ~(tag (cstr `char>boolean) 'some?|__4) (reify* [char>boolean] (~(B 'invoke) [~'_4__ ~(C 'x)] true))) - (def ~(O<> 'some?|__5|types) (types-decl>arg-types some?|__types 5)) (def ~(tag (cstr `int>boolean) 'some?|__5) (reify* [int>boolean] (~(B 'invoke) [~'_5__ ~(I 'x)] true))) - (def ~(O<> 'some?|__6|types) (types-decl>arg-types some?|__types 6)) (def ~(tag (cstr `long>boolean) 'some?|__6) (reify* [long>boolean] (~(B 'invoke) [~'_6__ ~(L 'x)] true))) - (def ~(O<> 'some?|__7|types) (types-decl>arg-types some?|__types 7)) (def ~(tag (cstr `float>boolean) 'some?|__7) (reify* [float>boolean] (~(B 'invoke) [~'_7__ ~(F 'x)] true))) - (def ~(O<> 'some?|__8|types) (types-decl>arg-types some?|__types 8)) (def ~(tag (cstr `double>boolean) 'some?|__8) (reify* [double>boolean] (~(B 'invoke) [~'_8__ ~(D 'x)] true))) - (def ~(O<> 'some?|__9|types) (types-decl>arg-types some?|__types 9)) (def ~(tag (cstr `Object>boolean) 'some?|__9) (reify* [Object>boolean] (~(B 'invoke) [~'_9__ ~(O 'x)] true))) - (defn ~'some? - {:quantum.core.type/type (types-decl>ftype some?|__types (t/isa? Boolean))} - ([~'x00__] - (ifs ((Array/get some?|__0|types 0) ~'x00__) (. some?|__0 ~'invoke ~'x00__) - ;; TODO eliminate these checks below because they're not needed - ((Array/get some?|__1|types 0) ~'x00__) (. some?|__1 ~'invoke ~'x00__) - ((Array/get some?|__2|types 0) ~'x00__) (. some?|__2 ~'invoke ~'x00__) - ((Array/get some?|__3|types 0) ~'x00__) (. some?|__3 ~'invoke ~'x00__) - ((Array/get some?|__4|types 0) ~'x00__) (. some?|__4 ~'invoke ~'x00__) - ((Array/get some?|__5|types 0) ~'x00__) (. some?|__5 ~'invoke ~'x00__) - ((Array/get some?|__6|types 0) ~'x00__) (. some?|__6 ~'invoke ~'x00__) - ((Array/get some?|__7|types 0) ~'x00__) (. some?|__7 ~'invoke ~'x00__) - ((Array/get some?|__8|types 0) ~'x00__) (. some?|__8 ~'invoke ~'x00__) - ((Array/get some?|__9|types 0) ~'x00__) (. some?|__9 ~'invoke ~'x00__) - (unsupported! `some? [~'x00__] 0)))))) + [{:id 0 :index 0 :arg-types [(t/value nil)] :output-type (t/value false)} + {:id 1 :index 1 :arg-types [(t/isa? Boolean)] :output-type (t/value true)} + {:id 2 :index 2 :arg-types [(t/isa? Byte)] :output-type (t/value true)} + {:id 3 :index 3 :arg-types [(t/isa? Short)] :output-type (t/value true)} + {:id 4 :index 4 :arg-types [(t/isa? Character)] :output-type (t/value true)} + {:id 5 :index 5 :arg-types [(t/isa? Integer)] :output-type (t/value true)} + {:id 6 :index 6 :arg-types [(t/isa? Long)] :output-type (t/value true)} + {:id 7 :index 7 :arg-types [(t/isa? Float)] :output-type (t/value true)} + {:id 8 :index 8 :arg-types [(t/isa? Double)] :output-type (t/value true)} + {:id 9 :index 9 :arg-types [t/any?] :output-type (t/value true)}] + + (def ~'some? + (with-meta + (fn* + ([~'x00__] + (ifs ((Array/get some?|__0|types 0) ~'x00__) (. some?|__0 ~'invoke ~'x00__) + ;; TODO eliminate these checks below because they're not needed + ((Array/get some?|__1|types 0) ~'x00__) (. some?|__1 ~'invoke ~'x00__) + ((Array/get some?|__2|types 0) ~'x00__) (. some?|__2 ~'invoke ~'x00__) + ((Array/get some?|__3|types 0) ~'x00__) (. some?|__3 ~'invoke ~'x00__) + ((Array/get some?|__4|types 0) ~'x00__) (. some?|__4 ~'invoke ~'x00__) + ((Array/get some?|__5|types 0) ~'x00__) (. some?|__5 ~'invoke ~'x00__) + ((Array/get some?|__6|types 0) ~'x00__) (. some?|__6 ~'invoke ~'x00__) + ((Array/get some?|__7|types 0) ~'x00__) (. some?|__7 ~'invoke ~'x00__) + ((Array/get some?|__8|types 0) ~'x00__) (. some?|__8 ~'invoke ~'x00__) + ((Array/get some?|__9|types 0) ~'x00__) (. some?|__9 ~'invoke ~'x00__) + (unsupported! `some? [~'x00__] 0)))) + {:quantum.core.type/type some?__type})))) :cljs ($ (do (defn ~'some?| [~'x] (ifs (nil? x) false From 40022ab5e09d7039816b96ba7421922e9eed1c27 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 3 Nov 2018 06:35:04 -0600 Subject: [PATCH 613/810] Another test passes! --- .../quantum/test/untyped/core/type/defnt.cljc | 585 +++++++++--------- 1 file changed, 292 insertions(+), 293 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 83bbcc77..1996e4d1 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -118,6 +118,7 @@ {:id 6 :index 6 :arg-types [(t/isa? Float)] :output-type (t/isa? Float)} {:id 7 :index 7 :arg-types [(t/isa? Double)] :output-type (t/isa? Double)} {:id 8 :index 8 :arg-types [t/any?] :output-type t/any?}] + (def ~'identity|uninlined (with-meta (fn* ([~'x00__] @@ -273,7 +274,7 @@ ((Array/get some?|__8|types 0) ~'x00__) (. some?|__8 ~'invoke ~'x00__) ((Array/get some?|__9|types 0) ~'x00__) (. some?|__9 ~'invoke ~'x00__) (unsupported! `some? [~'x00__] 0)))) - {:quantum.core.type/type some?__type})))) + {:quantum.core.type/type some?|__type})))) :cljs ($ (do (defn ~'some?| [~'x] (ifs (nil? x) false @@ -300,8 +301,6 @@ :clj ($ (do ;; [x (t/isa? Reduced)] - (def ~(O<> 'reduced?|test|__0|input0|types) - (*<> (t/isa? Reduced))) (def ~'reduced?|test|__0|0 (reify* [Object>boolean] (~(B 'invoke) [~'_0__ ~(O 'x)] @@ -309,8 +308,6 @@ ;; [x t/any?] - (def ~(O<> 'reduced?|test|__1|input0|types) - (*<> t/any?)) (def ~'reduced?|test|__1|0 (reify* [Object>boolean boolean>boolean byte>boolean short>boolean char>boolean int>boolean long>boolean float>boolean double>boolean] @@ -324,18 +321,18 @@ (~(B 'invoke) [~'_8__ ~(F 'x)] false) (~(B 'invoke) [~'_9__ ~(D 'x)] false))) - (defn ~'reduced?|test - {:quantum.core.type/type - (t/fn t/any? - ~'[(t/isa? Reduced)] - ~'[t/any?])} - ([~'x00__] + (def ~'reduced?|test + (with-meta (fn* ([~'x00__] (ifs ((Array/get ~'reduced?|test|__0|input0|types 0) ~'x00__) - (.invoke ~(tag (cstr `Object>boolean) 'reduced?|test|__0|0) ~'x00__) + (.invoke reduced?|test|__0|0 ~'x00__) ;; TODO eliminate this check because it's not needed (`t/any?`) ((Array/get ~'reduced?|test|__1|input0|types 0) ~'x00__) - (.invoke ~(tag (cstr `Object>boolean) 'reduced?|test|__1|0) ~'x00__) - (unsupported! `reduced?|test [~'x00__] 0)))))) + (.invoke reduced?|test|__1|0 ~'x00__) + (unsupported! `reduced?|test [~'x00__] 0)))) + {:quantum.core.type/type + (t/fn t/any? + ~'[(t/isa? Reduced)] + ~'[t/any?])})))) :cljs ($ (do (defn ~'reduced?|test [~'x] (ifs (instance? Reduced x) true false)))))] @@ -522,192 +519,242 @@ (is (identical? (>int* (byte 1)) (clojure.lang.RT/uncheckedIntCast (byte 1))))))))) ;; Because "Method code too large" error -(def >|ftype-form - ($ (t/ftype #?(:clj (t/isa? Boolean) :cljs tt/boolean?) - #?@(:clj [[(t/isa? Byte) (t/isa? Byte) :> (t/isa? Boolean)] - [(t/isa? Byte) (t/isa? Short) :> (t/isa? Boolean)] - [(t/isa? Byte) (t/isa? Character) :> (t/isa? Boolean)] - [(t/isa? Byte) (t/isa? Integer) :> (t/isa? Boolean)] - [(t/isa? Byte) (t/isa? Long) :> (t/isa? Boolean)] - [(t/isa? Byte) (t/isa? Float) :> (t/isa? Boolean)] - [(t/isa? Byte) (t/isa? Double) :> (t/isa? Boolean)] - [(t/isa? Short) (t/isa? Byte) :> (t/isa? Boolean)] - [(t/isa? Short) (t/isa? Short) :> (t/isa? Boolean)] - [(t/isa? Short) (t/isa? Character) :> (t/isa? Boolean)] - [(t/isa? Short) (t/isa? Integer) :> (t/isa? Boolean)] - [(t/isa? Short) (t/isa? Long) :> (t/isa? Boolean)] - [(t/isa? Short) (t/isa? Float) :> (t/isa? Boolean)] - [(t/isa? Short) (t/isa? Double) :> (t/isa? Boolean)] - [(t/isa? Character) (t/isa? Byte) :> (t/isa? Boolean)] - [(t/isa? Character) (t/isa? Short) :> (t/isa? Boolean)] - [(t/isa? Character) (t/isa? Character) :> (t/isa? Boolean)] - [(t/isa? Character) (t/isa? Integer) :> (t/isa? Boolean)] - [(t/isa? Character) (t/isa? Long) :> (t/isa? Boolean)] - [(t/isa? Character) (t/isa? Float) :> (t/isa? Boolean)] - [(t/isa? Character) (t/isa? Double) :> (t/isa? Boolean)] - [(t/isa? Integer) (t/isa? Byte) :> (t/isa? Boolean)] - [(t/isa? Integer) (t/isa? Short) :> (t/isa? Boolean)] - [(t/isa? Integer) (t/isa? Character) :> (t/isa? Boolean)] - [(t/isa? Integer) (t/isa? Integer) :> (t/isa? Boolean)] - [(t/isa? Integer) (t/isa? Long) :> (t/isa? Boolean)] - [(t/isa? Integer) (t/isa? Float) :> (t/isa? Boolean)] - [(t/isa? Integer) (t/isa? Double) :> (t/isa? Boolean)] - [(t/isa? Long) (t/isa? Byte) :> (t/isa? Boolean)] - [(t/isa? Long) (t/isa? Short) :> (t/isa? Boolean)] - [(t/isa? Long) (t/isa? Character) :> (t/isa? Boolean)] - [(t/isa? Long) (t/isa? Integer) :> (t/isa? Boolean)] - [(t/isa? Long) (t/isa? Long) :> (t/isa? Boolean)] - [(t/isa? Long) (t/isa? Float) :> (t/isa? Boolean)] - [(t/isa? Long) (t/isa? Double) :> (t/isa? Boolean)] - [(t/isa? Float) (t/isa? Byte) :> (t/isa? Boolean)] - [(t/isa? Float) (t/isa? Short) :> (t/isa? Boolean)] - [(t/isa? Float) (t/isa? Character) :> (t/isa? Boolean)] - [(t/isa? Float) (t/isa? Integer) :> (t/isa? Boolean)] - [(t/isa? Float) (t/isa? Long) :> (t/isa? Boolean)] - [(t/isa? Float) (t/isa? Float) :> (t/isa? Boolean)] - [(t/isa? Float) (t/isa? Double) :> (t/isa? Boolean)] - [(t/isa? Double) (t/isa? Byte) :> (t/isa? Boolean)] - [(t/isa? Double) (t/isa? Short) :> (t/isa? Boolean)] - [(t/isa? Double) (t/isa? Character) :> (t/isa? Boolean)] - [(t/isa? Double) (t/isa? Integer) :> (t/isa? Boolean)] - [(t/isa? Double) (t/isa? Long) :> (t/isa? Boolean)] - [(t/isa? Double) (t/isa? Float) :> (t/isa? Boolean)] - [(t/isa? Double) (t/isa? Double) :> (t/isa? Boolean)]] - :cljs [[tt/double? tt/double? :> (t/assume tt/boolean?)]])))) +(def >|types-form + ($ [{:id 0 :index 0 :arg-types [(t/isa? Byte) (t/isa? Byte) ] + :output-type (t/isa? Boolean)} + {:id 1 :index 1 :arg-types [(t/isa? Byte) (t/isa? Short) ] + :output-type (t/isa? Boolean)} + {:id 2 :index 2 :arg-types [(t/isa? Byte) (t/isa? Character)] + :output-type (t/isa? Boolean)} + {:id 3 :index 3 :arg-types [(t/isa? Byte) (t/isa? Integer) ] + :output-type (t/isa? Boolean)} + {:id 4 :index 4 :arg-types [(t/isa? Byte) (t/isa? Long) ] + :output-type (t/isa? Boolean)} + {:id 5 :index 5 :arg-types [(t/isa? Byte) (t/isa? Float) ] + :output-type (t/isa? Boolean)} + {:id 6 :index 6 :arg-types [(t/isa? Byte) (t/isa? Double) ] + :output-type (t/isa? Boolean)} + {:id 7 :index 7 :arg-types [(t/isa? Short) (t/isa? Byte) ] + :output-type (t/isa? Boolean)} + {:id 8 :index 8 :arg-types [(t/isa? Short) (t/isa? Short) ] + :output-type (t/isa? Boolean)} + {:id 9 :index 9 :arg-types [(t/isa? Short) (t/isa? Character)] + :output-type (t/isa? Boolean)} + {:id 10 :index 10 :arg-types [(t/isa? Short) (t/isa? Integer) ] + :output-type (t/isa? Boolean)} + {:id 11 :index 11 :arg-types [(t/isa? Short) (t/isa? Long) ] + :output-type (t/isa? Boolean)} + {:id 12 :index 12 :arg-types [(t/isa? Short) (t/isa? Float) ] + :output-type (t/isa? Boolean)} + {:id 13 :index 13 :arg-types [(t/isa? Short) (t/isa? Double) ] + :output-type (t/isa? Boolean)} + {:id 14 :index 14 :arg-types [(t/isa? Character) (t/isa? Byte) ] + :output-type (t/isa? Boolean)} + {:id 15 :index 15 :arg-types [(t/isa? Character) (t/isa? Short) ] + :output-type (t/isa? Boolean)} + {:id 16 :index 16 :arg-types [(t/isa? Character) (t/isa? Character)] + :output-type (t/isa? Boolean)} + {:id 17 :index 17 :arg-types [(t/isa? Character) (t/isa? Integer) ] + :output-type (t/isa? Boolean)} + {:id 18 :index 18 :arg-types [(t/isa? Character) (t/isa? Long) ] + :output-type (t/isa? Boolean)} + {:id 19 :index 19 :arg-types [(t/isa? Character) (t/isa? Float) ] + :output-type (t/isa? Boolean)} + {:id 20 :index 20 :arg-types [(t/isa? Character) (t/isa? Double) ] + :output-type (t/isa? Boolean)} + {:id 21 :index 21 :arg-types [(t/isa? Integer) (t/isa? Byte) ] + :output-type (t/isa? Boolean)} + {:id 22 :index 22 :arg-types [(t/isa? Integer) (t/isa? Short) ] + :output-type (t/isa? Boolean)} + {:id 23 :index 23 :arg-types [(t/isa? Integer) (t/isa? Character)] + :output-type (t/isa? Boolean)} + {:id 24 :index 24 :arg-types [(t/isa? Integer) (t/isa? Integer) ] + :output-type (t/isa? Boolean)} + {:id 25 :index 25 :arg-types [(t/isa? Integer) (t/isa? Long) ] + :output-type (t/isa? Boolean)} + {:id 26 :index 26 :arg-types [(t/isa? Integer) (t/isa? Float) ] + :output-type (t/isa? Boolean)} + {:id 27 :index 27 :arg-types [(t/isa? Integer) (t/isa? Double) ] + :output-type (t/isa? Boolean)} + {:id 28 :index 28 :arg-types [(t/isa? Long) (t/isa? Byte) ] + :output-type (t/isa? Boolean)} + {:id 29 :index 29 :arg-types [(t/isa? Long) (t/isa? Short) ] + :output-type (t/isa? Boolean)} + {:id 30 :index 30 :arg-types [(t/isa? Long) (t/isa? Character)] + :output-type (t/isa? Boolean)} + {:id 31 :index 31 :arg-types [(t/isa? Long) (t/isa? Integer) ] + :output-type (t/isa? Boolean)} + {:id 32 :index 32 :arg-types [(t/isa? Long) (t/isa? Long) ] + :output-type (t/isa? Boolean)} + {:id 33 :index 33 :arg-types [(t/isa? Long) (t/isa? Float) ] + :output-type (t/isa? Boolean)} + {:id 34 :index 34 :arg-types [(t/isa? Long) (t/isa? Double) ] + :output-type (t/isa? Boolean)} + {:id 35 :index 35 :arg-types [(t/isa? Float) (t/isa? Byte) ] + :output-type (t/isa? Boolean)} + {:id 36 :index 36 :arg-types [(t/isa? Float) (t/isa? Short) ] + :output-type (t/isa? Boolean)} + {:id 37 :index 37 :arg-types [(t/isa? Float) (t/isa? Character)] + :output-type (t/isa? Boolean)} + {:id 38 :index 38 :arg-types [(t/isa? Float) (t/isa? Integer) ] + :output-type (t/isa? Boolean)} + {:id 39 :index 39 :arg-types [(t/isa? Float) (t/isa? Long) ] + :output-type (t/isa? Boolean)} + {:id 40 :index 40 :arg-types [(t/isa? Float) (t/isa? Float) ] + :output-type (t/isa? Boolean)} + {:id 41 :index 41 :arg-types [(t/isa? Float) (t/isa? Double) ] + :output-type (t/isa? Boolean)} + {:id 42 :index 42 :arg-types [(t/isa? Double) (t/isa? Byte) ] + :output-type (t/isa? Boolean)} + {:id 43 :index 43 :arg-types [(t/isa? Double) (t/isa? Short) ] + :output-type (t/isa? Boolean)} + {:id 44 :index 44 :arg-types [(t/isa? Double) (t/isa? Character)] + :output-type (t/isa? Boolean)} + {:id 45 :index 45 :arg-types [(t/isa? Double) (t/isa? Integer) ] + :output-type (t/isa? Boolean)} + {:id 46 :index 46 :arg-types [(t/isa? Double) (t/isa? Long) ] + :output-type (t/isa? Boolean)} + {:id 47 :index 47 :arg-types [(t/isa? Double) (t/isa? Float) ] + :output-type (t/isa? Boolean)} + {:id 48 :index 48 :arg-types [(t/isa? Double) (t/isa? Double) ] + :output-type (t/isa? Boolean)}])) (def >|dynamic-dispatch-form - ($ (defn ~'> {:quantum.core.type/type ~>|ftype-form} - ([~'x00__ ~'x10__] - (ifs - ((Array/get ~'>|__0|types 0) ~'x00__) - (ifs - ((Array/get ~'>|__0|types 1) ~'x10__) - (. ~(tag (cstr `byte+byte>boolean) '>|__0) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__1|types 1) ~'x10__) - (. ~(tag (cstr `byte+short>boolean) '>|__1) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__2|types 1) ~'x10__) - (. ~(tag (cstr `byte+char>boolean) '>|__2) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__3|types 1) ~'x10__) - (. ~(tag (cstr `byte+int>boolean) '>|__3) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__4|types 1) ~'x10__) - (. ~(tag (cstr `byte+long>boolean) '>|__4) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__5|types 1) ~'x10__) - (. ~(tag (cstr `byte+float>boolean) '>|__5) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__6|types 1) ~'x10__) - (. ~(tag (cstr `byte+double>boolean) '>|__6) ~'invoke ~'x00__ ~'x10__) - (unsupported! `> [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|__7|types 0) ~'x00__) - (ifs - ((Array/get ~'>|__7|types 1) ~'x10__) - (. ~(tag (cstr `short+byte>boolean) '>|__7) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__8|types 1) ~'x10__) - (. ~(tag (cstr `short+short>boolean) '>|__8) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__9|types 1) ~'x10__) - (. ~(tag (cstr `short+char>boolean) '>|__9) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__10|types 1) ~'x10__) - (. ~(tag (cstr `short+int>boolean) '>|__10) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__11|types 1) ~'x10__) - (. ~(tag (cstr `short+long>boolean) '>|__11) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__12|types 1) ~'x10__) - (. ~(tag (cstr `short+float>boolean) '>|__12) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__13|types 1) ~'x10__) - (. ~(tag (cstr `short+double>boolean) '>|__13) ~'invoke ~'x00__ ~'x10__) - (unsupported! `> [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|__14|types 0) ~'x00__) - (ifs - ((Array/get ~'>|__14|types 1) ~'x10__) - (. ~(tag (cstr `char+byte>boolean) '>|__14) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__15|types 1) ~'x10__) - (. ~(tag (cstr `char+short>boolean) '>|__15) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__16|types 1) ~'x10__) - (. ~(tag (cstr `char+char>boolean) '>|__16) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__17|types 1) ~'x10__) - (. ~(tag (cstr `char+int>boolean) '>|__17) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__18|types 1) ~'x10__) - (. ~(tag (cstr `char+long>boolean) '>|__18) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__19|types 1) ~'x10__) - (. ~(tag (cstr `char+float>boolean) '>|__19) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__20|types 1) ~'x10__) - (. ~(tag (cstr `char+double>boolean) '>|__20) ~'invoke ~'x00__ ~'x10__) - (unsupported! `> [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|__21|types 0) ~'x00__) - (ifs - ((Array/get ~'>|__21|types 1) ~'x10__) - (. ~(tag (cstr `int+byte>boolean) '>|__21) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__22|types 1) ~'x10__) - (. ~(tag (cstr `int+short>boolean) '>|__22) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__23|types 1) ~'x10__) - (. ~(tag (cstr `int+char>boolean) '>|__23) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__24|types 1) ~'x10__) - (. ~(tag (cstr `int+int>boolean) '>|__24) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__25|types 1) ~'x10__) - (. ~(tag (cstr `int+long>boolean) '>|__25) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__26|types 1) ~'x10__) - (. ~(tag (cstr `int+float>boolean) '>|__26) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__27|types 1) ~'x10__) - (. ~(tag (cstr `int+double>boolean) '>|__27) ~'invoke ~'x00__ ~'x10__) - (unsupported! `> [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|__28|types 0) ~'x00__) - (ifs - ((Array/get ~'>|__28|types 1) ~'x10__) - (. ~(tag (cstr `long+byte>boolean) '>|__28) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__29|types 1) ~'x10__) - (. ~(tag (cstr `long+short>boolean) '>|__29) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__30|types 1) ~'x10__) - (. ~(tag (cstr `long+char>boolean) '>|__30) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__31|types 1) ~'x10__) - (. ~(tag (cstr `long+int>boolean) '>|__31) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__32|types 1) ~'x10__) - (. ~(tag (cstr `long+long>boolean) '>|__32) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__33|types 1) ~'x10__) - (. ~(tag (cstr `long+float>boolean) '>|__33) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__34|types 1) ~'x10__) - (. ~(tag (cstr `long+double>boolean) '>|__34) ~'invoke ~'x00__ ~'x10__) - (unsupported! `> [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|__35|types 0) ~'x00__) - (ifs - ((Array/get ~'>|__35|types 1) ~'x10__) - (. ~(tag (cstr `float+byte>boolean) '>|__35) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__36|types 1) ~'x10__) - (. ~(tag (cstr `float+short>boolean) '>|__36) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__37|types 1) ~'x10__) - (. ~(tag (cstr `float+char>boolean) '>|__37) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__38|types 1) ~'x10__) - (. ~(tag (cstr `float+int>boolean) '>|__38) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__39|types 1) ~'x10__) - (. ~(tag (cstr `float+long>boolean) '>|__39) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__40|types 1) ~'x10__) - (. ~(tag (cstr `float+float>boolean) '>|__40) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__41|types 1) ~'x10__) - (. ~(tag (cstr `float+double>boolean) '>|__41) ~'invoke ~'x00__ ~'x10__) - (unsupported! `> [~'x00__ ~'x10__] 1)) - ((Array/get ~'>|__42|types 0) ~'x00__) - (ifs - ((Array/get ~'>|__42|types 1) ~'x10__) - (. ~(tag (cstr `double+byte>boolean) '>|__42) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__43|types 1) ~'x10__) - (. ~(tag (cstr `double+short>boolean) '>|__43) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__44|types 1) ~'x10__) - (. ~(tag (cstr `double+char>boolean) '>|__44) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__45|types 1) ~'x10__) - (. ~(tag (cstr `double+int>boolean) '>|__45) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__46|types 1) ~'x10__) - (. ~(tag (cstr `double+long>boolean) '>|__46) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__47|types 1) ~'x10__) - (. ~(tag (cstr `double+float>boolean) '>|__47) ~'invoke ~'x00__ ~'x10__) - ((Array/get ~'>|__48|types 1) ~'x10__) - (. ~(tag (cstr `double+double>boolean) '>|__48) ~'invoke ~'x00__ ~'x10__) - (unsupported! `> [~'x00__ ~'x10__] 1)) - (unsupported! `> [~'x00__ ~'x10__] 0)))))) + ($ (def ~'> + (with-meta + (fn* ([~'x00__ ~'x10__] + (ifs + ((Array/get >|__0|types 0) ~'x00__) + (ifs + ((Array/get >|__0|types 1) ~'x10__) + (. >|__0 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__1|types 1) ~'x10__) + (. >|__1 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__2|types 1) ~'x10__) + (. >|__2 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__3|types 1) ~'x10__) + (. >|__3 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__4|types 1) ~'x10__) + (. >|__4 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__5|types 1) ~'x10__) + (. >|__5 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__6|types 1) ~'x10__) + (. >|__6 ~'invoke ~'x00__ ~'x10__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + ((Array/get >|__7|types 0) ~'x00__) + (ifs + ((Array/get >|__7|types 1) ~'x10__) + (. >|__7 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__8|types 1) ~'x10__) + (. >|__8 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__9|types 1) ~'x10__) + (. >|__9 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__10|types 1) ~'x10__) + (. >|__10 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__11|types 1) ~'x10__) + (. >|__11 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__12|types 1) ~'x10__) + (. >|__12 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__13|types 1) ~'x10__) + (. >|__13 ~'invoke ~'x00__ ~'x10__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + ((Array/get >|__14|types 0) ~'x00__) + (ifs + ((Array/get >|__14|types 1) ~'x10__) + (. >|__14 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__15|types 1) ~'x10__) + (. >|__15 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__16|types 1) ~'x10__) + (. >|__16 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__17|types 1) ~'x10__) + (. >|__17 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__18|types 1) ~'x10__) + (. >|__18 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__19|types 1) ~'x10__) + (. >|__19 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__20|types 1) ~'x10__) + (. >|__20 ~'invoke ~'x00__ ~'x10__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + ((Array/get >|__21|types 0) ~'x00__) + (ifs + ((Array/get >|__21|types 1) ~'x10__) + (. >|__21 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__22|types 1) ~'x10__) + (. >|__22 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__23|types 1) ~'x10__) + (. >|__23 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__24|types 1) ~'x10__) + (. >|__24 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__25|types 1) ~'x10__) + (. >|__25 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__26|types 1) ~'x10__) + (. >|__26 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__27|types 1) ~'x10__) + (. >|__27 ~'invoke ~'x00__ ~'x10__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + ((Array/get >|__28|types 0) ~'x00__) + (ifs + ((Array/get >|__28|types 1) ~'x10__) + (. >|__28 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__29|types 1) ~'x10__) + (. >|__29 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__30|types 1) ~'x10__) + (. >|__30 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__31|types 1) ~'x10__) + (. >|__31 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__32|types 1) ~'x10__) + (. >|__32 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__33|types 1) ~'x10__) + (. >|__33 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__34|types 1) ~'x10__) + (. >|__34 ~'invoke ~'x00__ ~'x10__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + ((Array/get >|__35|types 0) ~'x00__) + (ifs + ((Array/get >|__35|types 1) ~'x10__) + (. >|__35 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__36|types 1) ~'x10__) + (. >|__36 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__37|types 1) ~'x10__) + (. >|__37 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__38|types 1) ~'x10__) + (. >|__38 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__39|types 1) ~'x10__) + (. >|__39 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__40|types 1) ~'x10__) + (. >|__40 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__41|types 1) ~'x10__) + (. >|__41 ~'invoke ~'x00__ ~'x10__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + ((Array/get >|__42|types 0) ~'x00__) + (ifs + ((Array/get >|__42|types 1) ~'x10__) + (. >|__42 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__43|types 1) ~'x10__) + (. >|__43 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__44|types 1) ~'x10__) + (. >|__44 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__45|types 1) ~'x10__) + (. >|__45 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__46|types 1) ~'x10__) + (. >|__46 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__47|types 1) ~'x10__) + (. >|__47 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__48|types 1) ~'x10__) + (. >|__48 ~'invoke ~'x00__ ~'x10__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + (unsupported! `> [~'x00__ ~'x10__] 0)))) + {:quantum.core.type/type >|__type})))) (deftest test|> (let [actual - (macroexpand ' - (self/defn #_:inline > > tt/boolean? - #?(:clj ([a tt/comparable-primitive? b tt/comparable-primitive? > tt/boolean?] - (Numeric/gt a b)) - :cljs ([a tt/double? b tt/double? > (t/assume tt/boolean?)] - (cljs.core/> a b))))) + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/defn #_:inline > > tt/boolean? + #?(:clj ([a tt/comparable-primitive? b tt/comparable-primitive? > tt/boolean?] + (Numeric/gt a b)) + :cljs ([a tt/double? b tt/double? > (t/assume tt/boolean?)] + (cljs.core/> a b)))))) expected (case (env-lang) :clj @@ -715,203 +762,155 @@ ;; [a t/comparable-primitive? b t/comparable-primitive? > tt/boolean?] - (def ~(O<> '>|__0|types) (*<> (t/isa? Byte) (t/isa? Byte))) - (def ~'>|__0 + (def ~(tag (cstr `byte+byte>boolean) '>|__0) (reify* [byte+byte>boolean] (~(B 'invoke) [~'_0__ ~(Y 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__1|types) (*<> (t/isa? Byte) (t/isa? Short))) - (def ~'>|__1 + (def ~(tag (cstr `byte+short>boolean) '>|__1) (reify* [byte+short>boolean] (~(B 'invoke) [~'_1__ ~(Y 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__2|types) (*<> (t/isa? Byte) (t/isa? Character))) - (def ~'>|__2 + (def ~(tag (cstr `byte+char>boolean) '>|__2) (reify* [byte+char>boolean] (~(B 'invoke) [~'_2__ ~(Y 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__3|types) (*<> (t/isa? Byte) (t/isa? Integer))) - (def ~'>|__3 + (def ~(tag (cstr `byte+int>boolean) '>|__3) (reify* [byte+int>boolean] (~(B 'invoke) [~'_3__ ~(Y 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__4|types) (*<> (t/isa? Byte) (t/isa? Long))) - (def ~'>|__4 + (def ~(tag (cstr `byte+long>boolean) '>|__4) (reify* [byte+long>boolean] (~(B 'invoke) [~'_4__ ~(Y 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__5|types) (*<> (t/isa? Byte) (t/isa? Float))) - (def ~'>|__5 + (def ~(tag (cstr `byte+float>boolean) '>|__5) (reify* [byte+float>boolean] (~(B 'invoke) [~'_5__ ~(Y 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__6|types) (*<> (t/isa? Byte) (t/isa? Double))) - (def ~'>|__6 + (def ~(tag (cstr `byte+double>boolean) '>|__6) (reify* [byte+double>boolean] (~(B 'invoke) [~'_6__ ~(Y 'a) ~(D 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__7|types) (*<> (t/isa? Short) (t/isa? Byte))) - (def ~'>|__7 + (def ~(tag (cstr `short+byte>boolean) '>|__7) (reify* [short+byte>boolean] (~(B 'invoke) [~'_7__ ~(S 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__8|types) (*<> (t/isa? Short) (t/isa? Short))) - (def ~'>|__8 + (def ~(tag (cstr `short+short>boolean) '>|__8) (reify* [short+short>boolean] (~(B 'invoke) [~'_8__ ~(S 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__9|types) (*<> (t/isa? Short) (t/isa? Character))) - (def ~'>|__9 + (def ~(tag (cstr `short+char>boolean) '>|__9) (reify* [short+char>boolean] (~(B 'invoke) [~'_9__ ~(S 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__10|types) (*<> (t/isa? Short) (t/isa? Integer))) - (def ~'>|__10 + (def ~(tag (cstr `short+int>boolean) '>|__10) (reify* [short+int>boolean] (~(B 'invoke) [~'_10__ ~(S 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__11|types) (*<> (t/isa? Short) (t/isa? Long))) - (def ~'>|__11 + (def ~(tag (cstr `short+long>boolean) '>|__11) (reify* [short+long>boolean] (~(B 'invoke) [~'_11__ ~(S 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__12|types) (*<> (t/isa? Short) (t/isa? Float))) - (def ~'>|__12 + (def ~(tag (cstr `short+float>boolean) '>|__12) (reify* [short+float>boolean] (~(B 'invoke) [~'_12__ ~(S 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__13|types) (*<> (t/isa? Short) (t/isa? Double))) - (def ~'>|__13 + (def ~(tag (cstr `short+double>boolean) '>|__13) (reify* [short+double>boolean] (~(B 'invoke) [~'_13__ ~(S 'a) ~(D 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__14|types) (*<> (t/isa? Character) (t/isa? Byte))) - (def ~'>|__14 + (def ~(tag (cstr `char+byte>boolean) '>|__14) (reify* [char+byte>boolean] (~(B 'invoke) [~'_14__ ~(C 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__15|types) (*<> (t/isa? Character) (t/isa? Short))) - (def ~'>|__15 + (def ~(tag (cstr `char+short>boolean) '>|__15) (reify* [char+short>boolean] (~(B 'invoke) [~'_15__ ~(C 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__16|types) (*<> (t/isa? Character) (t/isa? Character))) - (def ~'>|__16 + (def ~(tag (cstr `char+char>boolean) '>|__16) (reify* [char+char>boolean] (~(B 'invoke) [~'_16__ ~(C 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__17|types) (*<> (t/isa? Character) (t/isa? Integer))) - (def ~'>|__17 + (def ~(tag (cstr `char+int>boolean) '>|__17) (reify* [char+int>boolean] (~(B 'invoke) [~'_17__ ~(C 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__18|types) (*<> (t/isa? Character) (t/isa? Long))) - (def ~'>|__18 + (def ~(tag (cstr `char+long>boolean) '>|__18) (reify* [char+long>boolean] (~(B 'invoke) [~'_18__ ~(C 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__19|types) (*<> (t/isa? Character) (t/isa? Float))) - (def ~'>|__19 + (def ~(tag (cstr `char+float>boolean) '>|__19) (reify* [char+float>boolean] (~(B 'invoke) [~'_19__ ~(C 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__20|types) (*<> (t/isa? Character) (t/isa? Double))) - (def ~'>|__20 + (def ~(tag (cstr `char+double>boolean) '>|__20) (reify* [char+double>boolean] (~(B 'invoke) [~'_20__ ~(C 'a) ~(D 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__21|types) (*<> (t/isa? Integer) (t/isa? Byte))) - (def ~'>|__21 + (def ~(tag (cstr `int+byte>boolean) '>|__21) (reify* [int+byte>boolean] (~(B 'invoke) [~'_21__ ~(I 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__22|types) (*<> (t/isa? Integer) (t/isa? Short))) - (def ~'>|__22 + (def ~(tag (cstr `int+short>boolean) '>|__22) (reify* [int+short>boolean] (~(B 'invoke) [~'_22__ ~(I 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__23|types) (*<> (t/isa? Integer) (t/isa? Character))) - (def ~'>|__23 + (def ~(tag (cstr `int+char>boolean) '>|__23) (reify* [int+char>boolean] (~(B 'invoke) [~'_23__ ~(I 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__24|types) (*<> (t/isa? Integer) (t/isa? Integer))) - (def ~'>|__24 + (def ~(tag (cstr `int+int>boolean) '>|__24) (reify* [int+int>boolean] (~(B 'invoke) [~'_24__ ~(I 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__25|types) (*<> (t/isa? Integer) (t/isa? Long))) - (def ~'>|__25 + (def ~(tag (cstr `int+long>boolean) '>|__25) (reify* [int+long>boolean] (~(B 'invoke) [~'_25__ ~(I 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__26|types) (*<> (t/isa? Integer) (t/isa? Float))) - (def ~'>|__26 + (def ~(tag (cstr `int+float>boolean) '>|__26) (reify* [int+float>boolean] (~(B 'invoke) [~'_26__ ~(I 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__27|types) (*<> (t/isa? Integer) (t/isa? Double))) - (def ~'>|__27 + (def ~(tag (cstr `int+double>boolean) '>|__27) (reify* [int+double>boolean] (~(B 'invoke) [~'_27__ ~(I 'a) ~(D 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__28|types) (*<> (t/isa? Long) (t/isa? Byte))) - (def ~'>|__28 + (def ~(tag (cstr `long+byte>boolean) '>|__28) (reify* [long+byte>boolean] (~(B 'invoke) [~'_28__ ~(L 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__29|types) (*<> (t/isa? Long) (t/isa? Short))) - (def ~'>|__29 + (def ~(tag (cstr `long+short>boolean) '>|__29) (reify* [long+short>boolean] (~(B 'invoke) [~'_29__ ~(L 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__30|types) (*<> (t/isa? Long) (t/isa? Character))) - (def ~'>|__30 + (def ~(tag (cstr `long+char>boolean) '>|__30) (reify* [long+char>boolean] (~(B 'invoke) [~'_30__ ~(L 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__31|types) (*<> (t/isa? Long) (t/isa? Integer))) - (def ~'>|__31 + (def ~(tag (cstr `long+int>boolean) '>|__31) (reify* [long+int>boolean] (~(B 'invoke) [~'_31__ ~(L 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__32|types) (*<> (t/isa? Long) (t/isa? Long))) - (def ~'>|__32 + (def ~(tag (cstr `long+long>boolean) '>|__32) (reify* [long+long>boolean] (~(B 'invoke) [~'_32__ ~(L 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__33|types) (*<> (t/isa? Long) (t/isa? Float))) - (def ~'>|__33 + (def ~(tag (cstr `long+float>boolean) '>|__33) (reify* [long+float>boolean] (~(B 'invoke) [~'_33__ ~(L 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__34|types) (*<> (t/isa? Long) (t/isa? Double))) - (def ~'>|__34 + (def ~(tag (cstr `long+double>boolean) '>|__34) (reify* [long+double>boolean] (~(B 'invoke) [~'_34__ ~(L 'a) ~(D 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__35|types) (*<> (t/isa? Float) (t/isa? Byte))) - (def ~'>|__35 + (def ~(tag (cstr `float+byte>boolean) '>|__35) (reify* [float+byte>boolean] (~(B 'invoke) [~'_35__ ~(F 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__36|types) (*<> (t/isa? Float) (t/isa? Short))) - (def ~'>|__36 + (def ~(tag (cstr `float+short>boolean) '>|__36) (reify* [float+short>boolean] (~(B 'invoke) [~'_36__ ~(F 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__37|types) (*<> (t/isa? Float) (t/isa? Character))) - (def ~'>|__37 + (def ~(tag (cstr `float+char>boolean) '>|__37) (reify* [float+char>boolean] (~(B 'invoke) [~'_37__ ~(F 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__38|types) (*<> (t/isa? Float) (t/isa? Integer))) - (def ~'>|__38 + (def ~(tag (cstr `float+int>boolean) '>|__38) (reify* [float+int>boolean] (~(B 'invoke) [~'_38__ ~(F 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__39|types) (*<> (t/isa? Float) (t/isa? Long))) - (def ~'>|__39 + (def ~(tag (cstr `float+long>boolean) '>|__39) (reify* [float+long>boolean] (~(B 'invoke) [~'_39__ ~(F 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__40|types) (*<> (t/isa? Float) (t/isa? Float))) - (def ~'>|__40 + (def ~(tag (cstr `float+float>boolean) '>|__40) (reify* [float+float>boolean] (~(B 'invoke) [~'_40__ ~(F 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__41|types) (*<> (t/isa? Float) (t/isa? Double))) - (def ~'>|__41 + (def ~(tag (cstr `float+double>boolean) '>|__41) (reify* [float+double>boolean] (~(B 'invoke) [~'_41__ ~(F 'a) ~(D 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__42|types) (*<> (t/isa? Double) (t/isa? Byte))) - (def ~'>|__42 + (def ~(tag (cstr `double+byte>boolean) '>|__42) (reify* [double+byte>boolean] (~(B 'invoke) [~'_42__ ~(D 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__43|types) (*<> (t/isa? Double) (t/isa? Short))) - (def ~'>|__43 + (def ~(tag (cstr `double+short>boolean) '>|__43) (reify* [double+short>boolean] (~(B 'invoke) [~'_43__ ~(D 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__44|types) (*<> (t/isa? Double) (t/isa? Character))) - (def ~'>|__44 + (def ~(tag (cstr `double+char>boolean) '>|__44) (reify* [double+char>boolean] (~(B 'invoke) [~'_44__ ~(D 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__45|types) (*<> (t/isa? Double) (t/isa? Integer))) - (def ~'>|__45 + (def ~(tag (cstr `double+int>boolean) '>|__45) (reify* [double+int>boolean] (~(B 'invoke) [~'_45__ ~(D 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__46|types) (*<> (t/isa? Double) (t/isa? Long))) - (def ~'>|__46 + (def ~(tag (cstr `double+long>boolean) '>|__46) (reify* [double+long>boolean] (~(B 'invoke) [~'_46__ ~(D 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__47|types) (*<> (t/isa? Double) (t/isa? Float))) - (def ~'>|__47 + (def ~(tag (cstr `double+float>boolean) '>|__47) (reify* [double+float>boolean] (~(B 'invoke) [~'_47__ ~(D 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(O<> '>|__48|types) (*<> (t/isa? Double) (t/isa? Double))) - (def ~'>|__48 + (def ~(tag (cstr `double+double>boolean) '>|__48) (reify* [double+double>boolean] (~(B 'invoke) [~'_48__ ~(D 'a) ~(D 'b)] ~'(. Numeric gt a b)))) + ~>|types-form ~>|dynamic-dispatch-form)) :cljs ($ (do (defn ~'> From 5ac38c0005b9b8a357d9f9db4b6477d9fa73f271 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 3 Nov 2018 06:44:10 -0600 Subject: [PATCH 614/810] And another! --- .../quantum/test/untyped/core/type/defnt.cljc | 101 +++++++++--------- 1 file changed, 50 insertions(+), 51 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 1996e4d1..cdef1036 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -929,89 +929,88 @@ (deftest test|>long* (let [actual - (macroexpand ' - (self/defn #_:inline >long* - {:source "clojure.lang.RT.uncheckedLongCast"} - > tt/long? - ([x (t/- tt/primitive? tt/boolean?)] (Primitive/uncheckedLongCast x)) - ([x (t/ref (t/isa? Number))] (.longValue x)))) + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/defn #_:inline >long* + {:source "clojure.lang.RT.uncheckedLongCast"} + > tt/long? + ([x (t/- tt/primitive? tt/boolean?)] (Primitive/uncheckedLongCast x)) + ([x (t/ref (t/isa? Number))] (.longValue x))))) expected (case (env-lang) :clj ($ (do (declare ~'>long*) ;; [x (t/- tt/primitive? tt/boolean?)] - (def ~(O<> '>long*|__0|input0|types) - (*<> (t/isa? java.lang.Byte) - (t/isa? java.lang.Short) - (t/isa? java.lang.Character) - (t/isa? java.lang.Integer) - (t/isa? java.lang.Long) - (t/isa? java.lang.Float) - (t/isa? java.lang.Double))) - (def ~'>long*|__0|0 + (def ~(tag (cstr `byte>long) '>long*|__0) (reify* [byte>long] (~(L 'invoke) [~'_0__ ~(Y 'x)] ~'(. Primitive uncheckedLongCast x)))) - (def ~'>long*|__0|1 + (def ~(tag (cstr `short>long) '>long*|__1) (reify* [short>long] (~(L 'invoke) [~'_1__ ~(S 'x)] ~'(. Primitive uncheckedLongCast x)))) - (def ~'>long*|__0|2 + (def ~(tag (cstr `char>long) '>long*|__2) (reify* [char>long] (~(L 'invoke) [~'_2__ ~(C 'x)] ~'(. Primitive uncheckedLongCast x)))) - (def ~'>long*|__0|3 + (def ~(tag (cstr `int>long) '>long*|__3) (reify* [int>long] (~(L 'invoke) [~'_3__ ~(I 'x)] ~'(. Primitive uncheckedLongCast x)))) - (def ~'>long*|__0|4 + (def ~(tag (cstr `long>long) '>long*|__4) (reify* [long>long] (~(L 'invoke) [~'_4__ ~(L 'x)] ~'(. Primitive uncheckedLongCast x)))) - (def ~'>long*|__0|5 + (def ~(tag (cstr `float>long) '>long*|__5) (reify* [float>long] (~(L 'invoke) [~'_5__ ~(F 'x)] ~'(. Primitive uncheckedLongCast x)))) - (def ~'>long*|__0|6 + (def ~(tag (cstr `double>long) '>long*|__6) (reify* [double>long] (~(L 'invoke) [~'_6__ ~(D 'x)] ~'(. Primitive uncheckedLongCast x)))) ;; [x (t/ref (t/isa? Number))] - (def ~(O<> '>long*|__1|input0|types) - (*<> ~(with-meta `(t/isa? Number) {:quantum.core.type/ref? true}))) - (def ~'>long*|__1|0 + (def ~(tag (cstr `Object>long) '>long*|__7) (reify* [Object>long] (~(L 'invoke) [~'_7__ ~(O 'x)] - (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(. x longValue))))) - - (defn ~'>long* - {:source "clojure.lang.RT.uncheckedLongCast" - :quantum.core.type/type - (t/fn ~'long? - ~'[(t/- tt/primitive? tt/boolean?)] - ~'[(t/ref (t/isa? Number))])} - ([~'x00__] - (ifs - ((Array/get ~'>long*|__0|input0|types 0) ~'x00__) - (.invoke ~(tag (cstr `byte>long) '>long*|__0|0) ~'x00__) - ((Array/get ~'>long*|__0|input0|types 1) ~'x00__) - (.invoke ~(tag (cstr `short>long) '>long*|__0|1) ~'x00__) - ((Array/get ~'>long*|__0|input0|types 2) ~'x00__) - (.invoke ~(tag (cstr `char>long) '>long*|__0|2) ~'x00__) - ((Array/get ~'>long*|__0|input0|types 3) ~'x00__) - (.invoke ~(tag (cstr `int>long) '>long*|__0|3) ~'x00__) - ((Array/get ~'>long*|__0|input0|types 4) ~'x00__) - (.invoke ~(tag (cstr `long>long) '>long*|__0|4) ~'x00__) - ((Array/get ~'>long*|__0|input0|types 5) ~'x00__) - (.invoke ~(tag (cstr `float>long) '>long*|__0|5) ~'x00__) - ((Array/get ~'>long*|__0|input0|types 6) ~'x00__) - (.invoke ~(tag (cstr `double>long) '>long*|__0|6) ~'x00__) - ((Array/get ~'>long*|__1|input0|types 0) ~'x00__) - (.invoke ~(tag (cstr `Object>long) '>long*|__1|0) ~'x00__) - (unsupported! `>long* [~'x00__] 0)))))))] + (. ~(tag "java.lang.Number" 'x) ~'longValue)))) + + [{:id 0 :index 0 :arg-types [(t/isa? Byte)] :output-type (t/isa? Long)} + {:id 1 :index 1 :arg-types [(t/isa? Short)] :output-type (t/isa? Long)} + {:id 2 :index 2 :arg-types [(t/isa? Character)] :output-type (t/isa? Long)} + {:id 3 :index 3 :arg-types [(t/isa? Integer)] :output-type (t/isa? Long)} + {:id 4 :index 4 :arg-types [(t/isa? Long)] :output-type (t/isa? Long)} + {:id 5 :index 5 :arg-types [(t/isa? Float)] :output-type (t/isa? Long)} + {:id 6 :index 6 :arg-types [(t/isa? Double)] :output-type (t/isa? Long)} + {:id 7 :index 7 :arg-types [(t/ref (t/isa? Number))] + :output-type (t/isa? Long)}] + + (def ~'>long* + (with-meta + (fn* ([~'x00__] + (ifs + ((Array/get >long*|__0|types 0) ~'x00__) + (. >long*|__0 ~'invoke ~'x00__) + ((Array/get >long*|__1|types 0) ~'x00__) + (. >long*|__1 ~'invoke ~'x00__) + ((Array/get >long*|__2|types 0) ~'x00__) + (. >long*|__2 ~'invoke ~'x00__) + ((Array/get >long*|__3|types 0) ~'x00__) + (. >long*|__3 ~'invoke ~'x00__) + ((Array/get >long*|__4|types 0) ~'x00__) + (. >long*|__4 ~'invoke ~'x00__) + ((Array/get >long*|__5|types 0) ~'x00__) + (. >long*|__5 ~'invoke ~'x00__) + ((Array/get >long*|__6|types 0) ~'x00__) + (. >long*|__6 ~'invoke ~'x00__) + ((Array/get >long*|__7|types 0) ~'x00__) + (. >long*|__7 ~'invoke ~'x00__) + (unsupported! `>long* [~'x00__] 0)))) + {:source "clojure.lang.RT.uncheckedLongCast" + :quantum.core.type/type >long*|__type})))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) From 2db16c4898ac0bd63bd63901f8d10912295f516b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 3 Nov 2018 06:49:01 -0600 Subject: [PATCH 615/810] And another --- .../quantum/test/untyped/core/type/defnt.cljc | 43 ++++++++++--------- 1 file changed, 23 insertions(+), 20 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index cdef1036..198654cb 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1030,37 +1030,40 @@ (deftest ref-output-type-test "Tests whether refs are output when requested instead of primitives" (let [actual - (macroexpand ' - (self/defn ref-output-type - ([x tt/boolean? > (t/ref tt/boolean?)] (Boolean. x)) - ([x tt/byte? > (t/ref tt/byte?)] (Byte. x)))) + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/defn ref-output-type + ([x tt/boolean? > (t/ref tt/boolean?)] (Boolean. x)) + ([x tt/byte? > (t/ref tt/byte?)] (Byte. x))))) expected ($ (do (declare ~'ref-output-type) ;; [x tt/boolean? > (t/ref tt/boolean?)] - (def ~(O<> 'ref-output-type|__0|types) (*<> (t/isa? java.lang.Boolean))) - (def ~'ref-output-type|__0 + (def ~(tag (cstr `boolean>Object) 'ref-output-type|__0) (reify* [boolean>Object] (~(O 'invoke) [~'_0__ ~(B 'x)] (new ~'Boolean ~'x)))) ;; [x tt/byte? > (t/ref tt/byte?)] - (def ~(O<> 'ref-output-type|__1|types) (*<> (t/isa? java.lang.Byte))) - (def ~'ref-output-type|__1 + (def ~(tag (cstr `byte>Object) 'ref-output-type|__1) (reify* [byte>Object] (~(O 'invoke) [~'_1__ ~(Y 'x)] (new ~'Byte ~'x)))) - (defn ~'ref-output-type - {:quantum.core.type/type - (t/ftype t/any? - [(t/isa? Boolean) :> (t/ref (t/isa? Boolean))] - [(t/isa? Byte) :> (t/ref (t/isa? Byte))])} - ([~'x00__] - (ifs - ((Array/get ~'ref-output-type|__0|types 0) ~'x00__) - (. ~(tag (cstr `boolean>Object) 'ref-output-type|__0) ~'invoke ~'x00__) - ((Array/get ~'ref-output-type|__1|types 0) ~'x00__) - (. ~(tag (cstr `byte>Object) 'ref-output-type|__1) ~'invoke ~'x00__) - (unsupported! `ref-output-type [~'x00__] 0))))))] + [{:id 0 :index 0 :arg-types [(t/isa? Boolean)] + :output-type (t/ref (t/isa? Boolean))} + {:id 1 :index 1 :arg-types [(t/isa? Byte)] + :output-type (t/ref (t/isa? Byte))}] + + (def ~'ref-output-type + (with-meta + (fn* + ([~'x00__] + (ifs + ((Array/get ref-output-type|__0|types 0) ~'x00__) + (. ref-output-type|__0 ~'invoke ~'x00__) + ((Array/get ref-output-type|__1|types 0) ~'x00__) + (. ref-output-type|__1 ~'invoke ~'x00__) + (unsupported! `ref-output-type [~'x00__] 0)))) + {:quantum.core.type/type ref-output-type|__type}))))] (testing "code equivalence" (is-code= actual expected))))) (self/defn >big-integer > (t/isa? java.math.BigInteger) From 2c837697bba5832c412e7234a33825dbb9404cef Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 3 Nov 2018 11:20:20 -0600 Subject: [PATCH 616/810] `t/none?` is now `t/<>` all except `t/U`; `rx-type?` --- src-untyped/quantum/untyped/core/type.cljc | 77 ++++++++------- .../untyped/core/type/reifications.cljc | 6 +- test/quantum/test/untyped/core/analyze.cljc | 4 +- .../test/untyped/core/type/compare.cljc | 94 +++++++++---------- 4 files changed, 95 insertions(+), 86 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index a11b0482..1e35ef3b 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -94,15 +94,17 @@ ;; ----- UniversalSetType (`t/U`) ----- ;; +;; `t/>` everything else (uvar/defalias utr/universal-set) ;; ----- EmptySetType (`t/∅`) ----- ;; +;; `t/<>` everything else except `universal-set`, to which it is `t/<` (uvar/defalias utr/empty-set) ;; ----- ReactiveType (`t/rx`) ----- ;; -(defns rx* [r urx/reactive?, body-codelist _ > utr/reactive-type?] +(defns rx* [r urx/reactive?, body-codelist _ > utr/rx-type?] (ReactiveType. uhash/default uhash/default nil body-codelist nil r)) #?(:clj @@ -116,7 +118,7 @@ [& body] `(rx* (urx/!rx ~@body) ($ ~(vec body))))) (defn- deref-when-reactive [x] - (if (utr/reactive-type? x) + (if (utr/rx-type? x) @x x)) @@ -124,8 +126,8 @@ "Only works for commutative functions." [f c/fn?, type-args (fn-> count (c/> 1)) > utr/type?] ;; For efficiency, so as much as possible gets run outside a reaction - (if-let [rx-args (->> type-args (filter utr/reactive-type?) seq)] - (if-let [norx-args (->> type-args (remove utr/reactive-type?) seq)] + (if-let [rx-args (->> type-args (filter utr/rx-type?) seq)] + (if-let [norx-args (->> type-args (remove utr/rx-type?) seq)] (let [t (f norx-args)] (rx (f (cons t (map deref rx-args))))) (rx (f (map deref rx-args)))) @@ -134,15 +136,15 @@ ;; ----- NotType (`t/not` / `t/!`) ----- ;; (defns not [t utr/type? > utr/type?] - (ifs (utr/reactive-type? t) (rx (not @t)) - (= t universal-set) empty-set - (= t empty-set) universal-set - (= t val|by-class?) nil? - (utr/not-type? t) (utr/not-type>inner-type t) + (ifs (utr/rx-type? t) (rx (not @t)) + (= t universal-set) empty-set + (= t empty-set) universal-set + (= t val|by-class?) nil? + (utr/not-type? t) (utr/not-type>inner-type t) ;; DeMorgan's Law - (utr/or-type? t) (->> t utr/or-type>args (uc/lmap not) (apply and)) + (utr/or-type? t) (->> t utr/or-type>args (uc/lmap not) (apply and)) ;; DeMorgan's Law - (utr/and-type? t) (->> t utr/and-type>args (uc/lmap not) (apply or )) + (utr/and-type? t) (->> t utr/and-type>args (uc/lmap not) (apply or )) (NotType. uhash/default uhash/default nil t))) (uvar/defalias ! not) @@ -216,7 +218,7 @@ "Creates a type representing an unordered collection." ([> utr/unordered-type?] (unordered [])) ([data _ > utr/unordered-type?] - (ifs (utr/reactive-type? data) + (ifs (utr/rx-type? data) (rx (UnorderedType. uhash/default uhash/default nil {@data 1} nil)) (utr/type? data) (UnorderedType. uhash/default uhash/default nil {data 1} nil) @@ -224,7 +226,7 @@ (err! "Finite type info must be sequential" {:type (c/type data)}) (c/not (seq-and utr/type? data)) (err! "Not every element of finite type data is a type") - (seq-or utr/reactive-type? data) + (seq-or utr/rx-type? data) (rx (UnorderedType. uhash/default uhash/default nil (->> data (uc/map+ deref-when-reactive) uc/frequencies) nil)) (UnorderedType. uhash/default uhash/default nil (frequencies data) nil))) @@ -234,7 +236,7 @@ "Creates a type representing an ordered collection." ([> utr/ordered-type?] (ordered [])) ([data _ > utr/ordered-type?] - (ifs (utr/reactive-type? data) + (ifs (utr/rx-type? data) (rx (OrderedType. uhash/default uhash/default nil [@data] nil)) (utr/type? data) (OrderedType. uhash/default uhash/default nil [data] nil) @@ -242,7 +244,7 @@ (err! "Finite type info must be sequential" {:type (c/type data)}) (c/not (seq-and utr/type? data)) (err! "Not every element of finite type data is a type") - (seq-or utr/reactive-type? data) + (seq-or utr/rx-type? data) (rx (OrderedType. uhash/default uhash/default nil (->> data (uc/map deref-when-reactive)) nil)) (OrderedType. uhash/default uhash/default nil data nil))) @@ -287,19 +289,19 @@ (OrType. uhash/default uhash/default nil args (atom nil))))) -(defns - +(defn - ;; TODO `defns` when variadic args are actually handled correctly "Computes the difference of `t0` from `t1`: (& t0 (! t1)) If `t0` = `t1`, `∅` If `t0` < `t1`, `∅` If `t0` <> `t1`, `t0` If `t0` > | >< `t1`, `t0` with all elements of `t1` removed" - ([t0 utr/type? > utr/type?] t0) - ([t0 utr/type?, t1 utr/type? > utr/type?] - (if (utr/reactive-type? t0) - (if (utr/reactive-type? t1) + ([t0 #_utr/type? #_> #_utr/type?] t0) + ([t0 #_utr/type?, t1 #_utr/type? #_> #_utr/type?] + (if (utr/rx-type? t0) + (if (utr/rx-type? t1) (rx (- @t0 @t1)) (rx (- @t0 t1))) - (if (utr/reactive-type? t1) + (if (utr/rx-type? t1) (rx (- t0 @t1)) (let [c (c/int (compare t0 t1))] (case c @@ -319,7 +321,7 @@ OrType (condp == c1 ClassType (-|or t0 t1) ValueType (-|or t0 t1))))))))) - ([t0 utr/type?, t1 utr/type? & ts _ > utr/type?] (reduce - (- t0 t1) ts))) + ([t0 #_utr/type?, t1 #_utr/type? & ts #_ _ #_> #_utr/type?] (reduce - (- t0 t1) ts))) (def type? (isa? PType)) (def not-type? (isa? NotType)) @@ -339,29 +341,29 @@ "Denotes that, whatever the declared output type (to which `assume` is applied) of a function may be, it is assumed that the output satisfies that type." [t utr/type? > utr/type?] - (assert (c/not (utr/reactive-type? t))) + (assert (c/not (utr/rx-type? t))) (update-meta t assoc :quantum.core.type/assume? true)) (defns unassume [t utr/type? > utr/type?] - (assert (c/not (utr/reactive-type? t))) + (assert (c/not (utr/rx-type? t))) (update-meta t dissoc :quantum.core.type/assume?)) (defns * "Denote on a type that it must be enforced at runtime. For use with `defnt`." [t utr/type? > utr/type?] - (assert (c/not (utr/reactive-type? t))) + (assert (c/not (utr/rx-type? t))) (update-meta t assoc :quantum.core.type/runtime? true)) (defns ref "Denote on a type that it must not be expanded to use primitive values. For use with `defnt`." [t utr/type? > utr/type?] - (assert (c/not (utr/reactive-type? t))) + (assert (c/not (utr/rx-type? t))) (update-meta t assoc :quantum.core.type/ref? true)) (defns unref [t utr/type? > utr/type?] - (assert (c/not (utr/reactive-type? t))) + (assert (c/not (utr/rx-type? t))) (update-meta t dissoc :quantum.core.type/ref?)) ;; ===== Logical ===== ;; @@ -380,6 +382,13 @@ (defns complementary? [t0 utr/type? t1 utr/type?] (= t0 (not t1))) +(defn- logical-compare + "This is so `t/empty-set` doesn't get left in `t/or`s or `t/and`s." + [t0 #_utr/type?, t1 #_utr/type? #_> #_uset/comparison?] + (if (c/= t0 empty-set) + (if (c/= t1 empty-set) =ident ident (compare t0 t1)))) + (defns- create-logical-type|inner|or [{:as accum :keys [t' utr/type?]} _, t* utr/type?, c* uset/comparison?] (if #?(:clj (c/or (c/and (c/= t' object?) (c/= t* nil?)) @@ -422,7 +431,7 @@ [args' _, t utr/type?, kind #{:or :and}, comparison-denotes-supersession? c/fn?] (let [args+comparisons|without-superseded (->> args' - (uc/map+ (juxt identity #(compare t %))) + (uc/map+ (juxt identity #(logical-compare t %))) ;; remove all args whose extensions are superseded by `t` (uc/remove+ (fn-> second comparison-denotes-supersession?)) join) ; TODO elide `join` @@ -548,11 +557,11 @@ (reduced nil)))))))) (defn- input-or-output-type-handle-reactive [f t args] - (if (utr/reactive-type? t) - (if (seq-or utr/reactive-type? args) + (if (utr/rx-type? t) + (if (seq-or utr/rx-type? args) (rx (f @t (map deref-when-reactive args))) (rx (f @t args))) - (if (seq-or utr/reactive-type? args) + (if (seq-or utr/rx-type? args) (rx (f t (map deref-when-reactive args))) (f t args)))) @@ -564,7 +573,7 @@ (defns input-type* "Outputs the type of a specified input to a typed fn." - [t (us/or* utr/fn-type? utr/reactive-type?) args _ #_(us/seq-of (us/or* #{:_ :?} type?)) + [t (us/or* utr/fn-type? utr/rx-type?) args _ #_(us/seq-of (us/or* #{:_ :?} type?)) | (->> args (filter #(c/= % :?)) count (c/= 1)) > type?] (input-or-output-type-handle-reactive input-type*|norx t args)) @@ -590,9 +599,9 @@ (defns output-type* "Outputs the output type of a typed fn." - ([t (us/or* utr/fn-type? utr/reactive-type?)] + ([t (us/or* utr/fn-type? utr/rx-type?)] (->> t utr/fn-type>arities (uc/mapcat+ val) (uc/map :output-type) (apply or))) - ([t (us/or* utr/fn-type? utr/reactive-type?) args (us/seq-of (us/or* #{:_} type?)) > type?] + ([t (us/or* utr/fn-type? utr/rx-type?) args (us/seq-of (us/or* #{:_} type?)) > type?] (input-or-output-type-handle-reactive output-type*|norx t args))) (defn output-type diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 6dd9ba1f..0a829ab9 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -416,10 +416,10 @@ ;; ----- ReactiveType ----- ;; -(declare reactive-type?) +(declare rx-type?) (defn- validate-type [x] - (or (and (type? x) (not (reactive-type? x))) + (or (and (type? x) (not (rx-type? x))) (err! "Found invalid value when derefing `ReactiveType`" {:kind (core/type x)}))) @@ -444,4 +444,4 @@ fedn/IOverride nil fedn/IEdn {-edn ([this] (list `reactive-type {:value (urx/norx-deref this)}))}}) -(defn reactive-type? [x] (instance? ReactiveType x)) +(defn rx-type? [x] (instance? ReactiveType x)) diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index 5b1659ee..d3583e0e 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -415,8 +415,8 @@ (t/value (t/isa? Character))]])))) (defn- rx=* [a b] - (if (and (utr/reactive-type? a) - (utr/reactive-type? b)) + (if (and (utr/rx-type? a) + (utr/rx-type? b)) (= (urx/norx-deref a) (urx/norx-deref b)) (= a b))) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 33c8ea18..38aaf379 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -19,10 +19,10 @@ [quantum.untyped.core.analyze.expr :as xp :refer [>expr]] [quantum.untyped.core.collections :as c] - [quantum.untyped.core.compare :as ucomp - :refer [ident >ident]] + [quantum.untyped.core.compare :as ucomp] [quantum.untyped.core.data.hash :as uhash] - [quantum.untyped.core.data.set :as uset] + [quantum.untyped.core.data.set :as uset + :refer [ident >ident]] [quantum.untyped.core.defnt :refer [defns]] [quantum.untyped.core.fn @@ -90,8 +90,8 @@ [a*# (type>type-combos ~a) b*# (type>type-combos ~b)] ;; Symmetry - (is= c# (t/compare a*# b*#)) - (is= (ucomp/invert c#) (t/compare b*# a*#)))))) + (is= c# (t/compare a*# b*#)) + (is= (uset/invert-comparison c#) (t/compare b*# a*#)))))) #?(:clj (defmacro test-comparison|fn @@ -101,10 +101,10 @@ [[c|in #_t/comparisons, c|out #_t/comparisons] #__, a #_t/type? b #_t/type?] `(let [c|out# ~c|out, c|in# ~c|in, a# ~a, b# ~b] ;; Symmetry - (is= c|in# (t/compare|in a# b#)) - (is= (ucomp/invert c|in#) (t/compare|in b# a#)) - (is= c|out# (t/compare|out a# b#)) - (is= (ucomp/invert c|out#) (t/compare|out b# a#))))) + (is= c|in# (t/compare|in a# b#)) + (is= (uset/invert-comparison c|in#) (t/compare|in b# a#)) + (is= c|out# (t/compare|out a# b#)) + (is= (uset/invert-comparison c|out#) (t/compare|out b# a#))))) (def comparison-combinations ["#{<}" @@ -167,20 +167,20 @@ (test-comparison =ident t/empty-set t/empty-set)) (testing "+ NotType" (testing "Inner ClassType" - (test-comparison ident t/empty-set (! a))) (testing "Inner ValueType" - (test-comparison ident t/empty-set (! (t/value 1))))) (testing "+ OrType" - (test-comparison <0 ><1))) + (test-comparison <>ident t/empty-set (| ><0 ><1))) (testing "+ AndType") (testing "+ Expression") (testing "+ ProtocolType" (doseq [t protocol-types] - (test-comparison ident t/empty-set t))) (testing "+ ClassType") (testing "+ ValueType" - (test-comparison ident t/empty-set (t/value t/empty-set)) + (test-comparison <>ident t/empty-set (t/value 0)))) (testing "NotType" (testing "+ NotType" (test-comparison =ident (! a) (! a)) @@ -731,7 +731,7 @@ ;; TODO incorporate into the other test? (deftest test|fn - #_"When we compare a t/fn to another t/fn, we are comparing set extensionality, as always. + #_"When we compare a t/ftype to another t/ftype, we are comparing set extensionality, as always. If we take the Wiener–Hausdorff–Kuratowski definition of a function as our definition of choice, then we may model a function as a set of ordered pairs, each of whose first element consists of an ordered tuple of inputs, and whose second element consists of one output. Thus @@ -739,10 +739,10 @@ to compare the extension of their inputs and the extension of their outputs separately. That said, it's not clear how useful this sort of comparison is. - Furthermore, is it the case that `(t/< [[] t/any?] (t/fn t/any? []))`? Intuitively it doesn't - seem like it should be, but under the WHK model it nevertheless seems to be the case. + Furthermore, is it the case that `(t/< [[] t/any?] (t/ftype t/any? []))`? Intuitively it + doesn't seem like it should be, but under the WHK model it nevertheless seems to be the case. - So we opt to make `t/fn`s `t/compare`-able only with what its underlying function object is + So we opt to make `t/ftype`s `t/compare`-able only with what its underlying function object is `t/compare`-able with, and introduce instead a `t/compare|input` and `t/compare|output`. See `quantum.test.untyped.core.type.compare` for how these sorts of comparisons are supposed to behave. @@ -785,39 +785,39 @@ (testing "same-arity input types <" (testing "output <" (test-comparison|fn [ t/boolean?]) - (t/fn t/any? [] [t/any? :> t/long?]))) + (t/ftype t/any? [t/boolean? :> t/boolean?]) + (t/ftype t/any? [] [t/any? :> t/long?]))) (testing "output =") (testing "output >" (test-comparison|fn [ ident] - (t/fn t/any? [t/boolean?]) - (t/fn t/any? [:> t/boolean?] [t/any? :> t/boolean?]))) + (t/ftype t/any? [t/boolean?]) + (t/ftype t/any? [:> t/boolean?] [t/any? :> t/boolean?]))) (testing "output ><") (testing "output <>")) (testing "same-arity input types =" (testing "output <" (test-comparison|fn [ t/boolean?]) - (t/fn t/any? [] [t/any?]))) + (t/ftype t/any? [:> t/boolean?]) + (t/ftype t/any? [] [t/any?]))) (testing "output =" (test-comparison|fn [ " (test-comparison|fn [ ident] - (t/fn t/any? []) - (t/fn t/any? [:> t/boolean?] [t/any? :> t/long?]))) + (t/ftype t/any? []) + (t/ftype t/any? [:> t/boolean?] [t/any? :> t/long?]))) (testing "output ><") (testing "output <>")) (testing "same-arity input types >" (testing "output <" (test-comparison|fn [> t/boolean?]) - (t/fn t/any? [] [t/boolean?]))) + (t/ftype t/any? [t/any? :> t/boolean?]) + (t/ftype t/any? [] [t/boolean?]))) (testing "output =" (test-comparison|fn [>") (testing "output ><") (testing "output <>")) @@ -837,33 +837,33 @@ (testing "same-arity input types <" (testing "output <" (test-comparison|fn [ t/boolean?]) - (t/fn t/any? [t/any?]))) + (t/ftype t/any? [t/boolean? :> t/boolean?]) + (t/ftype t/any? [t/any?]))) (testing "output =" (test-comparison|fn [ " (test-comparison|fn [ ident] - (t/fn t/any? [t/boolean?]) - (t/fn t/any? [t/any? :> t/boolean?]))) + (t/ftype t/any? [t/boolean?]) + (t/ftype t/any? [t/any? :> t/boolean?]))) (testing "output ><" (test-comparison|fn [ i|><0]) - (t/fn t/any? [t/any? :> i|><1]))) + (t/ftype t/any? [t/boolean? :> i|><0]) + (t/ftype t/any? [t/any? :> i|><1]))) (testing "output <>" (test-comparison|fn [ ident] - (t/fn t/any? [t/boolean? :> ><0]) - (t/fn t/any? [t/any? :> ><1])))) + (t/ftype t/any? [t/boolean? :> ><0]) + (t/ftype t/any? [t/any? :> ><1])))) (testing "same-arity input types =" (testing "output <" (test-comparison|fn [ =ident >ident] - (t/fn t/any? []) - (t/fn t/any? [:> t/boolean?]))) + (t/ftype t/any? []) + (t/ftype t/any? [:> t/boolean?]))) (testing "output =" (test-comparison|fn [ =ident =ident] - (t/fn t/any? []) - (t/fn t/any? []))) + (t/ftype t/any? []) + (t/ftype t/any? []))) (testing "output >") (testing "output ><") (testing "output <>")) From 5b5ada8eeb843ce3b51f84688ad46e8b425b5af2 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 3 Nov 2018 11:20:33 -0600 Subject: [PATCH 617/810] Add note on reactivity in analyzer --- src-untyped/quantum/untyped/core/analyze.cljc | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 27ebcc7b..8b7ef4ad 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -12,6 +12,7 @@ :refer [istr]] [quantum.untyped.core.data :refer [kw-map]] + [quantum.untyped.core.data.reactive :as urx] [quantum.untyped.core.data.set :as uset] [quantum.untyped.core.defnt :refer [defns defns- fns]] @@ -683,7 +684,7 @@ (uast/call-node {:env env :unanalyzed-form form - :form (if (utr/reactive-type? t) form (uform/>form t)) + :form (if (utr/rx-type? t) form (uform/>form t)) :caller caller|node :args arg-nodes :type (t/value t)})))) @@ -719,9 +720,17 @@ [env ::env, [caller|form _ & args-form _ :as form] _ > uast/call-node?] (let [caller|node (analyze* env caller|form) caller|type (:type caller|node) + ;; We just `norx-deref` the `caller|type` primarily for `t/defn`s but it could be unsafe + ;; TODO assess what will happen if we reactively derefed. It's currently being derefed in an + ;; interceptor on `!overload-types`. If it were reactively derefed then I believe it + ;; would make it so every time any `t/defn` function was even mentioned in a body, if + ;; any of those `t/defn`s changed whatsoever, the body would be re-analyzed and + ;; overloads would be re-created (though currently it only checks whether the input + ;; or output types have changed... not things in the body). + caller|type (cond-> caller|type (utr/rx-type? caller|type) urx/norx-deref) inputs-ct (count args-form)] - ;; TODO fix this line of code and extend t/compare so the comparison checks below - ;; will work with t/fn + ;; TODO fix this line of code and extend t/compare so the comparison checks below will + ;; work with t/fn (case (if (utr/fn-type? caller|type) -1 (t/compare caller|type t/callable?)) From 430ee8ff93df6015642e50d1cd255bccaee58d22 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 3 Nov 2018 11:20:55 -0600 Subject: [PATCH 618/810] Ensure interceptors capture as well --- .../quantum/untyped/core/data/reactive.cljc | 29 +++++++++---------- 1 file changed, 13 insertions(+), 16 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index 9aa7fb51..7dceee6b 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -231,33 +231,30 @@ (alist-conj! a f) (set! on-dispose-arr (alist f))))}}) -(defn- in-context - "When f is executed, if (f) derefs any reactive references, they are then added to - 'obj.captured' (*ref-context*). - - See function notify-deref-watcher! to know how *ref-context* is updated." - [^Reaction rx] (binding [*ref-context* rx] ((.-f rx)))) - (defn- deref-capture! - "Returns `(in-context f r)`. Calls `update-watching!` on `rx` with any `deref`ed reactive - references captured during `in-context`, if any differ from the `watching` field of `rx`. Sets + "When `f` is executed, if `(f)` and/or `interceptors` deref any reactive references, they are then + added to `(.-captured rx)` (i.e. `*ref-context*`). Then calls `update-watching!` on `rx` with any + `deref`ed reactive references captured, if any differ from the `watching` field of `rx`. Sets the `computed` flag on `rx` to true. - Inside `update-watching!` along with adding the references in 'rx.watching' of reaction, the - reaction is also added to the list of watches on each of the references that `f` derefs." + Inside `update-watching!` along with adding the references in `(-.watching rx)` of reaction, the + reaction is also added to the list of watches on each of the references that `f`+`interceptors` + deref. + + See `notify-deref-watcher!` to know how `*ref-context*` is updated." [^Reaction rx] (.setCaptured rx nil) (let [oldv (.getState rx) - newv (in-context rx) interceptors (.getInterceptors rx) - newv' (if (nil? interceptors) - newv - (reduce-kv (gen-call|rf rx oldv) newv interceptors)) + newv (binding [*ref-context* rx] + (if (nil? interceptors) + ((.-f rx)) + (reduce-kv (gen-call|rf rx oldv) ((.-f rx)) interceptors))) c (.getCaptured rx)] (.setComputed rx true) ;; Optimize common case where derefs occur in same order (when-not (alist== c (.getWatching rx)) (update-watching! rx c)) - newv')) + newv)) (defn- try-capture! [^Reaction rx] (uerr/catch-all From fc3ed7b63d41eb798e5aa2fa1d9e80b63b3e16b9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 3 Nov 2018 11:21:17 -0600 Subject: [PATCH 619/810] Finish up empty set comparison --- .../quantum/untyped/core/type/compare.cljc | 21 ++++++++----------- 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index 37f2ad2a..a937350c 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -130,21 +130,18 @@ ;; ----- EmptySet ----- ;; -(defns- compare|empty+not [t0 type?, t1 not-type? > comparison?] - (let [t1|inner (utr/not-type>inner-type t1)] - (if (= t1|inner universal-set) =ident ) +(def- compare|empty+or fn<>) +(def- compare|empty+and fn<>) (def- compare|empty+expr compare|todo) -(def- compare|empty+protocol fn<) -(def- compare|empty+class fn<) -(def- compare|empty+value fn<) +(def- compare|empty+protocol fn<>) +(def- compare|empty+class fn<>) +(def- compare|empty+value fn<>) ;; ----- NotType ----- ;; (defns- compare|not+not [t0 not-type?, t1 not-type? > comparison?] - (let [c (compare (utr/not-type>inner-type t0) (utr/not-type>inner-type t1))] + (let [c (int (compare (utr/not-type>inner-type t0) (utr/not-type>inner-type t1)))] (case c 0 =ident -1 >ident @@ -164,7 +161,7 @@ (let [t0|inner (utr/not-type>inner-type t0)] (if (= t0|inner empty-set) >ident - (case (compare t0|inner t1) + (case (int (compare t0|inner t1)) ( 1 0) <>ident (-1 2) >ident)))) @@ -174,7 +171,7 @@ (if (= t0|inner empty-set) >ident ;; nothing is ever < ValueType (and therefore never ><) - (case (compare t0|inner t1) + (case (int (compare t0|inner t1)) (1 0) <>ident 3 >ident)))) From 126599d5414bbf4710eecdeacfb5fea14d3b8e61 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 3 Nov 2018 11:21:30 -0600 Subject: [PATCH 620/810] Fix `defnt` compilation issue in non-test mode --- src-untyped/quantum/untyped/core/type/defnt.cljc | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index bf2861ff..225c4b75 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -662,13 +662,14 @@ fn|meta' (merge fn|meta {:quantum.core.type/type (uid/qualify fn|ns-name fn|type-name)})] ;; TODO determine whether CLJS needs (update-in m [:jsdoc] conj "@param {...*} var_args") (if (= kind :extend-defn!) - [`(intern (quote ~fn|ns-name) (quote ~fn|name) - (with-meta (fn* ~@overload-forms) ~fn|meta'))] - (let [dispatch-form `(def ~fn|name (with-meta (fn* ~@overload-forms) ~fn|meta'))] + [`(let* [v# (intern (quote ~fn|ns-name) (quote ~fn|name) + ~(with-meta `(fn* ~@overload-forms) fn|meta'))] + (alter-meta! v# merge ~fn|meta'))] + (let [dispatch-form `(uvar/defmeta ~fn|name ~fn|meta' (fn* ~@overload-forms))] (if (= compilation-mode :test) [(->> !overload-types urx/norx-deref >form (uc/map (fn1 dissoc :ns-sym))) dispatch-form] - dispatch-form))))) + [dispatch-form]))))) ;; ===== End dynamic dispatch ===== ;; From dc4107b8f8e73fb814ddb8c9ff9cd64f14ab6059 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 3 Nov 2018 11:22:19 -0600 Subject: [PATCH 621/810] Remove reflection --- test/quantum/test/untyped/core/type.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index f530cc9a..5d30d833 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -155,7 +155,7 @@ (testing "hash(eq) equality" (is= (hash a) (hash b))) #?(:clj (testing "hash(code) equality" - (is= (.hashCode a) (.hashCode b)))) + (is= (.hashCode ^Object a) (.hashCode ^Object b)))) (testing "collection equality" (is= 1 (count (hash-set a b)))))) From 9025486fbfaaaf38af7e2f17d11ddbc074ebc008 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 3 Nov 2018 11:22:27 -0600 Subject: [PATCH 622/810] `defmeta` --- src-untyped/quantum/untyped/core/vars.cljc | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src-untyped/quantum/untyped/core/vars.cljc b/src-untyped/quantum/untyped/core/vars.cljc index 20240f39..01c5dc2d 100644 --- a/src-untyped/quantum/untyped/core/vars.cljc +++ b/src-untyped/quantum/untyped/core/vars.cljc @@ -65,6 +65,12 @@ [name & decls] (list* `defmacro (with-meta name (assoc (meta name) :private true)) decls))) +#?(:clj +(defmacro defmeta + "Like `def`, but applies metadata to the var *and* the bound object." + [sym meta-val x] + `(def ~(vary-meta sym merge meta-val) ~(vary-meta x merge meta-val)))) + ;; ===== Aliases ===== ;; #?(:clj (ucore/defaliases ucore defalias defaliases defaliases')) From 00888a63e093dfb6c71292f72f1d8a060d42687b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 3 Nov 2018 11:22:40 -0600 Subject: [PATCH 623/810] Other tests pass; use `defmeta` --- .../quantum/test/untyped/core/type/defnt.cljc | 518 +++++++++--------- 1 file changed, 259 insertions(+), 259 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 198654cb..7b02a135 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -20,7 +20,9 @@ [quantum.untyped.core.test :as utest :refer [deftest is is= is-code= testing throws]] [quantum.untyped.core.type :as t] - [quantum.untyped.core.type.reifications :as utr]) + [quantum.untyped.core.type.reifications :as utr] + [quantum.untyped.core.vars + :refer [defmeta]]) (:import [clojure.lang ASeq ISeq LazySeq Named Reduced Seqable] [quantum.core.data Array] @@ -67,9 +69,9 @@ '(. java.lang.management.ManagementFactory getRuntimeMXBean)) 'getName))))) [{:id 0 :index 0 :arg-types [] :output-type (t/or (t/value nil) (t/isa? String))}] - (def ~'pid|test - (with-meta (fn* ([] (. pid|test|__0 ~'invoke))) - {:quantum.core.type/type pid|test|__type}))))] + (defmeta ~'pid|test + {:quantum.core.type/type pid|test|__type} + (fn* ([] (. pid|test|__0 ~'invoke))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) @@ -119,32 +121,31 @@ {:id 7 :index 7 :arg-types [(t/isa? Double)] :output-type (t/isa? Double)} {:id 8 :index 8 :arg-types [t/any?] :output-type t/any?}] - (def ~'identity|uninlined - (with-meta - (fn* ([~'x00__] - (ifs - ((Array/get identity|uninlined|__0|types 0) ~'x00__) - (. identity|uninlined|__0 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__1|types 0) ~'x00__) - (. identity|uninlined|__1 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__2|types 0) ~'x00__) - (. identity|uninlined|__2 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__3|types 0) ~'x00__) - (. identity|uninlined|__3 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__4|types 0) ~'x00__) - (. identity|uninlined|__4 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__5|types 0) ~'x00__) - (. identity|uninlined|__5 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__6|types 0) ~'x00__) - (. identity|uninlined|__6 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__7|types 0) ~'x00__) - (. identity|uninlined|__7 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__8|types 0) ~'x00__) - (. identity|uninlined|__8 ~'invoke ~'x00__) - ;; TODO no need for `unsupported!` because it will always get a valid - ;; branch - (unsupported! `identity|uninlined [~'x00__] 0)))) - {:quantum.core.type/type identity|uninlined|__type})))) + (defmeta ~'identity|uninlined + {:quantum.core.type/type identity|uninlined|__type} + (fn* ([~'x00__] + (ifs + ((Array/get identity|uninlined|__0|types 0) ~'x00__) + (. identity|uninlined|__0 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__1|types 0) ~'x00__) + (. identity|uninlined|__1 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__2|types 0) ~'x00__) + (. identity|uninlined|__2 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__3|types 0) ~'x00__) + (. identity|uninlined|__3 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__4|types 0) ~'x00__) + (. identity|uninlined|__4 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__5|types 0) ~'x00__) + (. identity|uninlined|__5 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__6|types 0) ~'x00__) + (. identity|uninlined|__6 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__7|types 0) ~'x00__) + (. identity|uninlined|__7 ~'invoke ~'x00__) + ((Array/get identity|uninlined|__8|types 0) ~'x00__) + (. identity|uninlined|__8 ~'invoke ~'x00__) + ;; TODO no need for `unsupported!` because it will always get a valid + ;; branch + (unsupported! `identity|uninlined [~'x00__] 0))))))) :cljs ;; Direct dispatch will be simple functions, not `reify`s ($ (do (defn ~'identity|uninlined [~'x] ~'x))))] @@ -183,14 +184,12 @@ [{:id 0 :index 0 :arg-types [(t/isa? String)] :output-type (t/isa? String)} {:id 1 :index 1 :arg-types [(t/isa? Named)] :output-type (t/* (t/isa? String))}] - (def ~'name - (with-meta - (fn* - ([~'x00__] - (ifs ((Array/get name|__0|types 0) ~'x00__) (. name|__0 ~'invoke ~'x00__) - ((Array/get name|__1|types 0) ~'x00__) (. name|__1 ~'invoke ~'x00__) - (unsupported! `name [~'x00__] 0)))) - {:quantum.core.type/type name|__type})))) + (defmeta ~'name + {:quantum.core.type/type name|__type} + (fn* ([~'x00__] + (ifs ((Array/get name|__0|types 0) ~'x00__) (. name|__0 ~'invoke ~'x00__) + ((Array/get name|__1|types 0) ~'x00__) (. name|__1 ~'invoke ~'x00__) + (unsupported! `name [~'x00__] 0))))))) :cljs ($ (do (defn ~'name [~'x00__] (ifs (t/string? x) x @@ -258,23 +257,22 @@ {:id 8 :index 8 :arg-types [(t/isa? Double)] :output-type (t/value true)} {:id 9 :index 9 :arg-types [t/any?] :output-type (t/value true)}] - (def ~'some? - (with-meta - (fn* - ([~'x00__] - (ifs ((Array/get some?|__0|types 0) ~'x00__) (. some?|__0 ~'invoke ~'x00__) - ;; TODO eliminate these checks below because they're not needed - ((Array/get some?|__1|types 0) ~'x00__) (. some?|__1 ~'invoke ~'x00__) - ((Array/get some?|__2|types 0) ~'x00__) (. some?|__2 ~'invoke ~'x00__) - ((Array/get some?|__3|types 0) ~'x00__) (. some?|__3 ~'invoke ~'x00__) - ((Array/get some?|__4|types 0) ~'x00__) (. some?|__4 ~'invoke ~'x00__) - ((Array/get some?|__5|types 0) ~'x00__) (. some?|__5 ~'invoke ~'x00__) - ((Array/get some?|__6|types 0) ~'x00__) (. some?|__6 ~'invoke ~'x00__) - ((Array/get some?|__7|types 0) ~'x00__) (. some?|__7 ~'invoke ~'x00__) - ((Array/get some?|__8|types 0) ~'x00__) (. some?|__8 ~'invoke ~'x00__) - ((Array/get some?|__9|types 0) ~'x00__) (. some?|__9 ~'invoke ~'x00__) - (unsupported! `some? [~'x00__] 0)))) - {:quantum.core.type/type some?|__type})))) + (defmeta ~'some? + {:quantum.core.type/type some?|__type} + (fn* + ([~'x00__] + (ifs ((Array/get some?|__0|types 0) ~'x00__) (. some?|__0 ~'invoke ~'x00__) + ;; TODO eliminate these checks below because they're not needed + ((Array/get some?|__1|types 0) ~'x00__) (. some?|__1 ~'invoke ~'x00__) + ((Array/get some?|__2|types 0) ~'x00__) (. some?|__2 ~'invoke ~'x00__) + ((Array/get some?|__3|types 0) ~'x00__) (. some?|__3 ~'invoke ~'x00__) + ((Array/get some?|__4|types 0) ~'x00__) (. some?|__4 ~'invoke ~'x00__) + ((Array/get some?|__5|types 0) ~'x00__) (. some?|__5 ~'invoke ~'x00__) + ((Array/get some?|__6|types 0) ~'x00__) (. some?|__6 ~'invoke ~'x00__) + ((Array/get some?|__7|types 0) ~'x00__) (. some?|__7 ~'invoke ~'x00__) + ((Array/get some?|__8|types 0) ~'x00__) (. some?|__8 ~'invoke ~'x00__) + ((Array/get some?|__9|types 0) ~'x00__) (. some?|__9 ~'invoke ~'x00__) + (unsupported! `some? [~'x00__] 0))))))) :cljs ($ (do (defn ~'some?| [~'x] (ifs (nil? x) false @@ -321,18 +319,18 @@ (~(B 'invoke) [~'_8__ ~(F 'x)] false) (~(B 'invoke) [~'_9__ ~(D 'x)] false))) - (def ~'reduced?|test - (with-meta (fn* ([~'x00__] + (defmeta ~'reduced?|test + {:quantum.core.type/type + (t/fn t/any? + ~'[(t/isa? Reduced)] + ~'[t/any?])} + (fn* ([~'x00__] (ifs ((Array/get ~'reduced?|test|__0|input0|types 0) ~'x00__) (.invoke reduced?|test|__0|0 ~'x00__) ;; TODO eliminate this check because it's not needed (`t/any?`) ((Array/get ~'reduced?|test|__1|input0|types 0) ~'x00__) (.invoke reduced?|test|__1|0 ~'x00__) - (unsupported! `reduced?|test [~'x00__] 0)))) - {:quantum.core.type/type - (t/fn t/any? - ~'[(t/isa? Reduced)] - ~'[t/any?])})))) + (unsupported! `reduced?|test [~'x00__] 0))))))) :cljs ($ (do (defn ~'reduced?|test [~'x] (ifs (instance? Reduced x) true false)))))] @@ -620,131 +618,130 @@ :output-type (t/isa? Boolean)}])) (def >|dynamic-dispatch-form - ($ (def ~'> - (with-meta - (fn* ([~'x00__ ~'x10__] - (ifs - ((Array/get >|__0|types 0) ~'x00__) - (ifs - ((Array/get >|__0|types 1) ~'x10__) - (. >|__0 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__1|types 1) ~'x10__) - (. >|__1 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__2|types 1) ~'x10__) - (. >|__2 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__3|types 1) ~'x10__) - (. >|__3 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__4|types 1) ~'x10__) - (. >|__4 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__5|types 1) ~'x10__) - (. >|__5 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__6|types 1) ~'x10__) - (. >|__6 ~'invoke ~'x00__ ~'x10__) - (unsupported! `> [~'x00__ ~'x10__] 1)) - ((Array/get >|__7|types 0) ~'x00__) - (ifs - ((Array/get >|__7|types 1) ~'x10__) - (. >|__7 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__8|types 1) ~'x10__) - (. >|__8 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__9|types 1) ~'x10__) - (. >|__9 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__10|types 1) ~'x10__) - (. >|__10 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__11|types 1) ~'x10__) - (. >|__11 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__12|types 1) ~'x10__) - (. >|__12 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__13|types 1) ~'x10__) - (. >|__13 ~'invoke ~'x00__ ~'x10__) - (unsupported! `> [~'x00__ ~'x10__] 1)) - ((Array/get >|__14|types 0) ~'x00__) - (ifs - ((Array/get >|__14|types 1) ~'x10__) - (. >|__14 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__15|types 1) ~'x10__) - (. >|__15 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__16|types 1) ~'x10__) - (. >|__16 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__17|types 1) ~'x10__) - (. >|__17 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__18|types 1) ~'x10__) - (. >|__18 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__19|types 1) ~'x10__) - (. >|__19 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__20|types 1) ~'x10__) - (. >|__20 ~'invoke ~'x00__ ~'x10__) - (unsupported! `> [~'x00__ ~'x10__] 1)) - ((Array/get >|__21|types 0) ~'x00__) - (ifs - ((Array/get >|__21|types 1) ~'x10__) - (. >|__21 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__22|types 1) ~'x10__) - (. >|__22 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__23|types 1) ~'x10__) - (. >|__23 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__24|types 1) ~'x10__) - (. >|__24 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__25|types 1) ~'x10__) - (. >|__25 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__26|types 1) ~'x10__) - (. >|__26 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__27|types 1) ~'x10__) - (. >|__27 ~'invoke ~'x00__ ~'x10__) - (unsupported! `> [~'x00__ ~'x10__] 1)) - ((Array/get >|__28|types 0) ~'x00__) - (ifs - ((Array/get >|__28|types 1) ~'x10__) - (. >|__28 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__29|types 1) ~'x10__) - (. >|__29 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__30|types 1) ~'x10__) - (. >|__30 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__31|types 1) ~'x10__) - (. >|__31 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__32|types 1) ~'x10__) - (. >|__32 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__33|types 1) ~'x10__) - (. >|__33 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__34|types 1) ~'x10__) - (. >|__34 ~'invoke ~'x00__ ~'x10__) - (unsupported! `> [~'x00__ ~'x10__] 1)) - ((Array/get >|__35|types 0) ~'x00__) - (ifs - ((Array/get >|__35|types 1) ~'x10__) - (. >|__35 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__36|types 1) ~'x10__) - (. >|__36 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__37|types 1) ~'x10__) - (. >|__37 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__38|types 1) ~'x10__) - (. >|__38 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__39|types 1) ~'x10__) - (. >|__39 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__40|types 1) ~'x10__) - (. >|__40 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__41|types 1) ~'x10__) - (. >|__41 ~'invoke ~'x00__ ~'x10__) - (unsupported! `> [~'x00__ ~'x10__] 1)) - ((Array/get >|__42|types 0) ~'x00__) - (ifs - ((Array/get >|__42|types 1) ~'x10__) - (. >|__42 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__43|types 1) ~'x10__) - (. >|__43 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__44|types 1) ~'x10__) - (. >|__44 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__45|types 1) ~'x10__) - (. >|__45 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__46|types 1) ~'x10__) - (. >|__46 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__47|types 1) ~'x10__) - (. >|__47 ~'invoke ~'x00__ ~'x10__) - ((Array/get >|__48|types 1) ~'x10__) - (. >|__48 ~'invoke ~'x00__ ~'x10__) - (unsupported! `> [~'x00__ ~'x10__] 1)) - (unsupported! `> [~'x00__ ~'x10__] 0)))) - {:quantum.core.type/type >|__type})))) + ($ (defmeta ~'> + {:quantum.core.type/type >|__type} + (fn* ([~'x00__ ~'x10__] + (ifs + ((Array/get >|__0|types 0) ~'x00__) + (ifs + ((Array/get >|__0|types 1) ~'x10__) + (. >|__0 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__1|types 1) ~'x10__) + (. >|__1 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__2|types 1) ~'x10__) + (. >|__2 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__3|types 1) ~'x10__) + (. >|__3 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__4|types 1) ~'x10__) + (. >|__4 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__5|types 1) ~'x10__) + (. >|__5 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__6|types 1) ~'x10__) + (. >|__6 ~'invoke ~'x00__ ~'x10__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + ((Array/get >|__7|types 0) ~'x00__) + (ifs + ((Array/get >|__7|types 1) ~'x10__) + (. >|__7 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__8|types 1) ~'x10__) + (. >|__8 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__9|types 1) ~'x10__) + (. >|__9 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__10|types 1) ~'x10__) + (. >|__10 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__11|types 1) ~'x10__) + (. >|__11 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__12|types 1) ~'x10__) + (. >|__12 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__13|types 1) ~'x10__) + (. >|__13 ~'invoke ~'x00__ ~'x10__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + ((Array/get >|__14|types 0) ~'x00__) + (ifs + ((Array/get >|__14|types 1) ~'x10__) + (. >|__14 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__15|types 1) ~'x10__) + (. >|__15 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__16|types 1) ~'x10__) + (. >|__16 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__17|types 1) ~'x10__) + (. >|__17 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__18|types 1) ~'x10__) + (. >|__18 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__19|types 1) ~'x10__) + (. >|__19 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__20|types 1) ~'x10__) + (. >|__20 ~'invoke ~'x00__ ~'x10__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + ((Array/get >|__21|types 0) ~'x00__) + (ifs + ((Array/get >|__21|types 1) ~'x10__) + (. >|__21 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__22|types 1) ~'x10__) + (. >|__22 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__23|types 1) ~'x10__) + (. >|__23 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__24|types 1) ~'x10__) + (. >|__24 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__25|types 1) ~'x10__) + (. >|__25 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__26|types 1) ~'x10__) + (. >|__26 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__27|types 1) ~'x10__) + (. >|__27 ~'invoke ~'x00__ ~'x10__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + ((Array/get >|__28|types 0) ~'x00__) + (ifs + ((Array/get >|__28|types 1) ~'x10__) + (. >|__28 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__29|types 1) ~'x10__) + (. >|__29 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__30|types 1) ~'x10__) + (. >|__30 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__31|types 1) ~'x10__) + (. >|__31 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__32|types 1) ~'x10__) + (. >|__32 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__33|types 1) ~'x10__) + (. >|__33 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__34|types 1) ~'x10__) + (. >|__34 ~'invoke ~'x00__ ~'x10__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + ((Array/get >|__35|types 0) ~'x00__) + (ifs + ((Array/get >|__35|types 1) ~'x10__) + (. >|__35 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__36|types 1) ~'x10__) + (. >|__36 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__37|types 1) ~'x10__) + (. >|__37 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__38|types 1) ~'x10__) + (. >|__38 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__39|types 1) ~'x10__) + (. >|__39 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__40|types 1) ~'x10__) + (. >|__40 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__41|types 1) ~'x10__) + (. >|__41 ~'invoke ~'x00__ ~'x10__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + ((Array/get >|__42|types 0) ~'x00__) + (ifs + ((Array/get >|__42|types 1) ~'x10__) + (. >|__42 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__43|types 1) ~'x10__) + (. >|__43 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__44|types 1) ~'x10__) + (. >|__44 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__45|types 1) ~'x10__) + (. >|__45 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__46|types 1) ~'x10__) + (. >|__46 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__47|types 1) ~'x10__) + (. >|__47 ~'invoke ~'x00__ ~'x10__) + ((Array/get >|__48|types 1) ~'x10__) + (. >|__48 ~'invoke ~'x00__ ~'x10__) + (unsupported! `> [~'x00__ ~'x10__] 1)) + (unsupported! `> [~'x00__ ~'x10__] 0))))))) (deftest test|> (let [actual @@ -988,29 +985,28 @@ {:id 7 :index 7 :arg-types [(t/ref (t/isa? Number))] :output-type (t/isa? Long)}] - (def ~'>long* - (with-meta - (fn* ([~'x00__] - (ifs - ((Array/get >long*|__0|types 0) ~'x00__) - (. >long*|__0 ~'invoke ~'x00__) - ((Array/get >long*|__1|types 0) ~'x00__) - (. >long*|__1 ~'invoke ~'x00__) - ((Array/get >long*|__2|types 0) ~'x00__) - (. >long*|__2 ~'invoke ~'x00__) - ((Array/get >long*|__3|types 0) ~'x00__) - (. >long*|__3 ~'invoke ~'x00__) - ((Array/get >long*|__4|types 0) ~'x00__) - (. >long*|__4 ~'invoke ~'x00__) - ((Array/get >long*|__5|types 0) ~'x00__) - (. >long*|__5 ~'invoke ~'x00__) - ((Array/get >long*|__6|types 0) ~'x00__) - (. >long*|__6 ~'invoke ~'x00__) - ((Array/get >long*|__7|types 0) ~'x00__) - (. >long*|__7 ~'invoke ~'x00__) - (unsupported! `>long* [~'x00__] 0)))) - {:source "clojure.lang.RT.uncheckedLongCast" - :quantum.core.type/type >long*|__type})))))] + (defmeta ~'>long* + {:source "clojure.lang.RT.uncheckedLongCast" + :quantum.core.type/type >long*|__type} + (fn* ([~'x00__] + (ifs + ((Array/get >long*|__0|types 0) ~'x00__) + (. >long*|__0 ~'invoke ~'x00__) + ((Array/get >long*|__1|types 0) ~'x00__) + (. >long*|__1 ~'invoke ~'x00__) + ((Array/get >long*|__2|types 0) ~'x00__) + (. >long*|__2 ~'invoke ~'x00__) + ((Array/get >long*|__3|types 0) ~'x00__) + (. >long*|__3 ~'invoke ~'x00__) + ((Array/get >long*|__4|types 0) ~'x00__) + (. >long*|__4 ~'invoke ~'x00__) + ((Array/get >long*|__5|types 0) ~'x00__) + (. >long*|__5 ~'invoke ~'x00__) + ((Array/get >long*|__6|types 0) ~'x00__) + (. >long*|__6 ~'invoke ~'x00__) + ((Array/get >long*|__7|types 0) ~'x00__) + (. >long*|__7 ~'invoke ~'x00__) + (unsupported! `>long* [~'x00__] 0))))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) @@ -1053,18 +1049,17 @@ {:id 1 :index 1 :arg-types [(t/isa? Byte)] :output-type (t/ref (t/isa? Byte))}] - (def ~'ref-output-type - (with-meta - (fn* - ([~'x00__] - (ifs - ((Array/get ref-output-type|__0|types 0) ~'x00__) - (. ref-output-type|__0 ~'invoke ~'x00__) - ((Array/get ref-output-type|__1|types 0) ~'x00__) - (. ref-output-type|__1 ~'invoke ~'x00__) - (unsupported! `ref-output-type [~'x00__] 0)))) - {:quantum.core.type/type ref-output-type|__type}))))] - (testing "code equivalence" (is-code= actual expected))))) + (defmeta ~'ref-output-type + {:quantum.core.type/type ref-output-type|__type} + (fn* ([~'x00__] + (ifs + ((Array/get ref-output-type|__0|types 0) ~'x00__) + (. ref-output-type|__0 ~'invoke ~'x00__) + ((Array/get ref-output-type|__1|types 0) ~'x00__) + (. ref-output-type|__1 ~'invoke ~'x00__) + (unsupported! `ref-output-type [~'x00__] 0)))))))] + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" (eval actual))))) (self/defn >big-integer > (t/isa? java.math.BigInteger) ([x tt/ratio? > (t/* (t/isa? java.math.BigInteger))] (.bigIntegerValue x))) @@ -1072,29 +1067,32 @@ ;; NOTE would use `>long` but that's already an interface (deftest test|>long-checked (let [actual - (macroexpand ' - (self/defn >long-checked - {:source "clojure.lang.RT.longCast"} - > tt/long? - ;; TODO multi-arity `t/-` - ([x (t/- tt/primitive? tt/boolean? tt/float? tt/double?)] (>long* x)) - ([x (t/and (t/or tt/double? tt/float?) - ;; TODO add this back in - #_(t/fn [x (t/or t/double? t/float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] - (>long* x)) - ([x (t/and (t/isa? clojure.lang.BigInt) - ;; TODO add this back in - #_(t/fn [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] - (.lpart x)) - ([x (t/and (t/isa? java.math.BigInteger) - ;; TODO add this back in - #_(t/fn [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] - (.longValue x)) - ([x tt/ratio?] (-> x >big-integer >long-checked)) - ([x (t/value true)] 1) - ([x (t/value false)] 0) - ([x t/string?] (Long/parseLong x)) - ([x t/string?, radix tt/int?] (Long/parseLong x radix)))) + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/defn >long-checked + {:source "clojure.lang.RT.longCast"} + > tt/long? + ;; TODO multi-arity `t/-` + ([x (t/- tt/primitive? tt/boolean? tt/float? tt/double?)] (>long* x)) + ([x (t/and (t/or tt/double? tt/float?) + ;; TODO add this back in + #_(t/fn [x (t/or t/double? t/float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE))))] + (>long* x)) + ([x (t/and (t/isa? clojure.lang.BigInt) + ;; TODO add this back in + #_(t/fn [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] + (.lpart x)) + ([x (t/and (t/isa? java.math.BigInteger) + ;; TODO add this back in + #_(t/fn [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64)))] + (.longValue x)) + ;; FIXME it doesn't know what `>long-checked`'s type is i.e. what it + ;; has defined so far + ([x tt/ratio?] (-> x >big-integer >long-checked)) + ([x (t/value true)] 1) + ([x (t/value false)] 0) + ([x t/string?] (Long/parseLong x)) + ([x t/string?, radix tt/int?] (Long/parseLong x radix))))) expected (case (env-lang) :clj ($ (do #_[x (t/- tt/boolean? tt/boolean? float? double?)] @@ -1286,16 +1284,17 @@ (deftest test|!str (let [actual - (macroexpand ' - (self/defn !str > #?(:clj (t/isa? StringBuilder) - :cljs (t/isa? StringBuffer)) - ([] #?(:clj (StringBuilder.) :cljs (StringBuffer.))) - ;; If we had combined this arity, `t/or`ing the `t/string?` means it wouldn't have been - ;; handled any differently than `t/char-seq?` - #?(:clj ([x t/string?] (StringBuilder. x))) - ([x #?(:clj (t/or tt/char-seq? tt/int?) - :cljs t/val?)] - #?(:clj (StringBuilder. x) :cljs (StringBuffer. x))))) + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/defn !str > #?(:clj (t/isa? StringBuilder) + :cljs (t/isa? StringBuffer)) + ([] #?(:clj (StringBuilder.) :cljs (StringBuffer.))) + ;; If we had combined this arity, `t/or`ing the `t/string?` means it wouldn't have been + ;; handled any differently than `t/char-seq?` + #?(:clj ([x t/string?] (StringBuilder. x))) + ([x #?(:clj (t/or tt/char-seq? tt/int?) + :cljs t/val?)] + #?(:clj (StringBuilder. x) :cljs (StringBuffer. x)))))) expected (case (env-lang) :clj ($ (do (def ~'!str|__0|0 @@ -1359,10 +1358,11 @@ (deftest defn-reference-test (testing "`t/defn` references itself" (let [actual - (macroexpand ' - (self/defn defn-self-reference - ([] nil) - ([x tt/long?] (defn-self-reference)))) + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/defn defn-self-reference + ([> tt/double?] 2.0) + ([x tt/long?] (defn-self-reference))))) expected (case (env-lang) :clj ($ (do (declare ~'defn-self-reference) From 5fbe90ebeca1c95cb8607d72e8f1f7f477ec8b2d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 3 Nov 2018 12:24:42 -0600 Subject: [PATCH 624/810] Correctly split reactive types --- resources-dev/defnt.cljc | 1 - src-untyped/quantum/untyped/core/analyze.cljc | 26 +- test/quantum/test/untyped/core/analyze.cljc | 232 +++++++++--------- 3 files changed, 134 insertions(+), 125 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index acf5014a..30b7540e 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -52,7 +52,6 @@ TODO: - t/or should probably order by `t/compare` descending - - TODO `ftype` should accommodate reactive types - TODO `or` and `and` should be `=` regardless of order - To fix this, sort when it's created? - (rx/dispose! ) when the `t/defn` is redefined (?) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 8b7ef4ad..74f36da2 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -172,8 +172,6 @@ #(cond-> % line (assoc :line line) column (assoc :column column))))) -(def special-symbols '#{do let* deftype* fn* def . if quote new throw}) ; TODO make more complete - ;; TODO move (deftype WatchableMutable [^:unsynchronized-mutable v ^:unsynchronized-mutable ^clojure.lang.IFn watch] @@ -792,18 +790,18 @@ [env ::env, [caller|form _ & body _ :as form] _ > uast/node?] (case caller|form . (analyze-seq|dot env form) - def (TODO "def") - deftype* (TODO "deftype*") + def (TODO "def" {:form form}) + deftype* (TODO "deftype*" {:form form}) do (analyze-seq|do env form) - fn* (TODO "fn*") + fn* (TODO "fn*" {:form form}) if (analyze-seq|if env form) let* (analyze-seq|let* env form) new (analyze-seq|new env form) quote (analyze-seq|quote env form) - reify* (TODO "reify") ; NOTE only for CLJ - set! (TODO "set!") + reify* (TODO "reify" {:form form}) ; NOTE only for CLJ + set! (TODO "set!" {:form form}) throw (analyze-seq|throw env form) - try (TODO "try") + try (TODO "try" {:form form}) var (analyze-seq|var env form) (if (-> env :opts :arglist-context?) (if-let [caller-form-dependent-type-call? @@ -968,15 +966,17 @@ ;; TODO move? (defns type>split - "Only `t/or`s are splittable for now" + "Only `t/or`s are splittable for now. + Reactive types are non-reactively derefed in order to make splitting possible." [t t/type? > (s/vec-of t/type?)] - (if (utr/or-type? t) - (utr/or-type>args t) - [t])) + (let [t' (cond-> t (utr/rx-type? t) urx/norx-deref)] + (if (utr/or-type? t') + (utr/or-type>args t') + [t']))) (defns type>split+primitivized [t t/type? > (s/vec-of t/type?)] (let [primitive-subtypes - (->> (t/type>primitive-subtypes t false) + (->> (t/type>primitive-subtypes (cond-> t (utr/rx-type? t) urx/norx-deref) false) (sort-by sort-guide) ; For cleanliness and reproducibility in tests vec)] (uc/distinct (join primitive-subtypes (type>split t))))) diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index d3583e0e..12ec45ef 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -18,9 +18,9 @@ [quantum.untyped.core.type.reifications :as utr])) ;; Simulates a typed fn -(defn- >long-checked - {:quantum.core.type/type (t/rx (t/ftype nil [t/string? :> tt/long?]))} - []) +(defn- >long-checked {:quantum.core.type/type (t/rx (t/ftype nil [t/string? :> tt/long?]))} []) + +(defn- dummy {:quantum.core.type/type (t/rx (t/or tt/short? tt/char?))} []) (defn- transform-ana [ana] (->> ana @@ -305,114 +305,124 @@ -> (Cutting obvious corners) `(t/or (t/isa? Byte) (t/isa? Character))` - No splitting necessary because out-type - All input types are in env and output-type was analyzed. DONE" - (is= (-> (self/analyze-arg-syms - '{a (t/or tt/boolean? (t/type b)) - b (t/or tt/byte? (t/type d)) - c (t/or tt/short? tt/char?) - d (let [b (t/- tt/char? tt/long?)] - (t/or tt/char? (t/type b) (t/type c)))} - '(t/or (t/type b) (t/type d))) - transform-ana) - [[{'a (t/isa? Boolean) - 'b (t/isa? Byte) - 'c (t/isa? Short) - 'd (t/isa? Short)} - (t/or (t/isa? Byte) (t/isa? Short))] - [{'a (t/isa? Byte) - 'b (t/isa? Byte) - 'c (t/isa? Short) - 'd (t/isa? Short)} - (t/or (t/isa? Byte) (t/isa? Short))] - [{'a (t/isa? Boolean) - 'b (t/isa? Short) - 'c (t/isa? Short) - 'd (t/isa? Short)} - (t/isa? Short)] - [{'a (t/isa? Short) - 'b (t/isa? Short) - 'c (t/isa? Short) - 'd (t/isa? Short)} - (t/isa? Short)] - [{'a (t/isa? Boolean) - 'b (t/isa? Byte) - 'c (t/isa? Short) - 'd (t/isa? Character)} - (t/or (t/isa? Byte) (t/isa? Character))] - [{'a (t/isa? Byte) - 'b (t/isa? Byte) - 'c (t/isa? Short) - 'd (t/isa? Character)} - (t/or (t/isa? Byte) (t/isa? Character))] - [{'a (t/isa? Boolean) - 'b (t/isa? Character) - 'c (t/isa? Short) - 'd (t/isa? Character)} - (t/isa? Character)] - [{'a (t/isa? Character) - 'b (t/isa? Character) - 'c (t/isa? Short) - 'd (t/isa? Character)} - (t/isa? Character)] - [{'a (t/isa? Boolean) - 'b (t/isa? Byte) - 'c (t/isa? Short) - 'd (t/value (t/isa? Character))} - (t/or (t/isa? Byte) (t/value (t/isa? Character)))] - [{'a (t/isa? Byte) - 'b (t/isa? Byte) - 'c (t/isa? Short) - 'd (t/value (t/isa? Character))} - (t/or (t/isa? Byte) (t/value (t/isa? Character)))] - [{'a (t/isa? Boolean) - 'b (t/value (t/isa? Character)) - 'c (t/isa? Short) - 'd (t/value (t/isa? Character))} - (t/value (t/isa? Character))] - [{'a (t/value (t/isa? Character)) - 'b (t/value (t/isa? Character)) - 'c (t/isa? Short) - 'd (t/value (t/isa? Character))} - (t/value (t/isa? Character))] - [{'a (t/isa? Boolean) - 'b (t/isa? Byte) - 'c (t/isa? Character) - 'd (t/isa? Character)} - (t/or (t/isa? Byte) (t/isa? Character))] - [{'a (t/isa? Byte) - 'b (t/isa? Byte) - 'c (t/isa? Character) - 'd (t/isa? Character)} - (t/or (t/isa? Byte) (t/isa? Character))] - [{'a (t/isa? Boolean) - 'b (t/isa? Character) - 'c (t/isa? Character) - 'd (t/isa? Character)} - (t/isa? Character)] - [{'a (t/isa? Character) - 'b (t/isa? Character) - 'c (t/isa? Character) - 'd (t/isa? Character)} - (t/isa? Character)] - [{'a (t/isa? Boolean) - 'b (t/isa? Byte) - 'c (t/isa? Character) - 'd (t/value (t/isa? Character))} - (t/or (t/isa? Byte) (t/value (t/isa? Character)))] - [{'a (t/isa? Byte) - 'b (t/isa? Byte) - 'c (t/isa? Character) - 'd (t/value (t/isa? Character))} - (t/or (t/isa? Byte) (t/value (t/isa? Character)))] - [{'a (t/isa? Boolean) - 'b (t/value (t/isa? Character)) - 'c (t/isa? Character) - 'd (t/value (t/isa? Character))} - (t/value (t/isa? Character))] - [{'a (t/value (t/isa? Character)) - 'b (t/value (t/isa? Character)) - 'c (t/isa? Character) - 'd (t/value (t/isa? Character))} - (t/value (t/isa? Character))]])))) + (let [ret [[{'a (t/isa? Boolean) + 'b (t/isa? Byte) + 'c (t/isa? Short) + 'd (t/isa? Short)} + (t/or (t/isa? Byte) (t/isa? Short))] + [{'a (t/isa? Byte) + 'b (t/isa? Byte) + 'c (t/isa? Short) + 'd (t/isa? Short)} + (t/or (t/isa? Byte) (t/isa? Short))] + [{'a (t/isa? Boolean) + 'b (t/isa? Short) + 'c (t/isa? Short) + 'd (t/isa? Short)} + (t/isa? Short)] + [{'a (t/isa? Short) + 'b (t/isa? Short) + 'c (t/isa? Short) + 'd (t/isa? Short)} + (t/isa? Short)] + [{'a (t/isa? Boolean) + 'b (t/isa? Byte) + 'c (t/isa? Short) + 'd (t/isa? Character)} + (t/or (t/isa? Byte) (t/isa? Character))] + [{'a (t/isa? Byte) + 'b (t/isa? Byte) + 'c (t/isa? Short) + 'd (t/isa? Character)} + (t/or (t/isa? Byte) (t/isa? Character))] + [{'a (t/isa? Boolean) + 'b (t/isa? Character) + 'c (t/isa? Short) + 'd (t/isa? Character)} + (t/isa? Character)] + [{'a (t/isa? Character) + 'b (t/isa? Character) + 'c (t/isa? Short) + 'd (t/isa? Character)} + (t/isa? Character)] + [{'a (t/isa? Boolean) + 'b (t/isa? Byte) + 'c (t/isa? Short) + 'd (t/value (t/isa? Character))} + (t/or (t/isa? Byte) (t/value (t/isa? Character)))] + [{'a (t/isa? Byte) + 'b (t/isa? Byte) + 'c (t/isa? Short) + 'd (t/value (t/isa? Character))} + (t/or (t/isa? Byte) (t/value (t/isa? Character)))] + [{'a (t/isa? Boolean) + 'b (t/value (t/isa? Character)) + 'c (t/isa? Short) + 'd (t/value (t/isa? Character))} + (t/value (t/isa? Character))] + [{'a (t/value (t/isa? Character)) + 'b (t/value (t/isa? Character)) + 'c (t/isa? Short) + 'd (t/value (t/isa? Character))} + (t/value (t/isa? Character))] + [{'a (t/isa? Boolean) + 'b (t/isa? Byte) + 'c (t/isa? Character) + 'd (t/isa? Character)} + (t/or (t/isa? Byte) (t/isa? Character))] + [{'a (t/isa? Byte) + 'b (t/isa? Byte) + 'c (t/isa? Character) + 'd (t/isa? Character)} + (t/or (t/isa? Byte) (t/isa? Character))] + [{'a (t/isa? Boolean) + 'b (t/isa? Character) + 'c (t/isa? Character) + 'd (t/isa? Character)} + (t/isa? Character)] + [{'a (t/isa? Character) + 'b (t/isa? Character) + 'c (t/isa? Character) + 'd (t/isa? Character)} + (t/isa? Character)] + [{'a (t/isa? Boolean) + 'b (t/isa? Byte) + 'c (t/isa? Character) + 'd (t/value (t/isa? Character))} + (t/or (t/isa? Byte) (t/value (t/isa? Character)))] + [{'a (t/isa? Byte) + 'b (t/isa? Byte) + 'c (t/isa? Character) + 'd (t/value (t/isa? Character))} + (t/or (t/isa? Byte) (t/value (t/isa? Character)))] + [{'a (t/isa? Boolean) + 'b (t/value (t/isa? Character)) + 'c (t/isa? Character) + 'd (t/value (t/isa? Character))} + (t/value (t/isa? Character))] + [{'a (t/value (t/isa? Character)) + 'b (t/value (t/isa? Character)) + 'c (t/isa? Character) + 'd (t/value (t/isa? Character))} + (t/value (t/isa? Character))]]] + (is= (-> (self/analyze-arg-syms + '{a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) + c (t/or tt/short? tt/char?) + d (let [b (t/- tt/char? tt/long?)] + (t/or tt/char? (t/type b) (t/type c)))} + '(t/or (t/type b) (t/type d))) + transform-ana) + ret) + (is= (-> (self/analyze-arg-syms + '{a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) + c (t/input-type dummy :?) + d (let [b (t/- tt/char? tt/long?)] + (t/or tt/char? (t/type b) (t/type c)))} + '(t/or (t/type b) (t/type d))) + transform-ana) + ret))))) (defn- rx=* [a b] (if (and (utr/rx-type? a) From 602912e8f05eea0c8ee56032ce662cd931c2b41e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 3 Nov 2018 22:55:22 -0600 Subject: [PATCH 625/810] Finish up accounting for reactive types in `t/defn` - Changes primarily made to support passing `fn|type` to body analysis - Other bugfixes and enhancements to `t/defn` --- resources-dev/defnt.cljc | 5 +- src-untyped/quantum/untyped/core/analyze.cljc | 15 +- .../quantum/untyped/core/collections.cljc | 56 +- .../quantum/untyped/core/data/reactive.cljc | 2 + .../quantum/untyped/core/type/defnt.cljc | 489 ++++++++++++------ .../quantum/test/untyped/core/type/defnt.cljc | 2 +- 6 files changed, 380 insertions(+), 189 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 30b7540e..64262f01 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -55,7 +55,10 @@ TODO: - TODO `or` and `and` should be `=` regardless of order - To fix this, sort when it's created? - (rx/dispose! ) when the `t/defn` is redefined (?) - - Dependents should not get recompiled if the type has not changed but only the implementation has + - Dependents should not get recompiled if the type has not changed but only the implementation has, + except if inline + - Handle `|` (pre-type) + - Should not accept `t/none?` as an input type #_" Note that `;; TODO TYPED` is the annotation we're using for this initiative diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 74f36da2..c5922908 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -166,6 +166,10 @@ (defonce !!analyze-depth (>!thread-local 0)) +(uvar/defonce !!dependent? + "Denotes whether a dependent type was found to be used in the current arglist context." + (>!thread-local false)) + (defn add-file-context-from [to from] (let [{:keys [line column]} (meta from)] (update-meta to @@ -679,6 +683,7 @@ (case (name caller|form) "input-type" (t/rx (t/input-type* @caller|type args)) "output-type" (t/rx (t/output-type* @caller|type args)))))] + (uref/set! !!dependent? true) (uast/call-node {:env env :unanalyzed-form form @@ -993,7 +998,8 @@ split-types?]} (:opts env)] (ifs (empty? arglist-syms|unanalyzed) [{:env env - :out-type-node (-> (analyze env out-type-form) (update :type t/unvalue))}] + :out-type-node (-> (analyze env out-type-form) (update :type t/unvalue)) + :dependent? @!!dependent?}] (>= (uref/get !!analyze-arg-syms|iter) analyze-arg-syms|max-iter) (err! "Max number of iterations reached for `analyze-arg-syms`" {:n (uref/get !!analyze-arg-syms|iter)}) @@ -1035,14 +1041,16 @@ :split-types? split-types?}) (defns analyze-arg-syms - "Performance characteristics: + "`dependent?` denotes whether any of of the arg-types or output-type use dependent types. + + Performance characteristics: - While an internally recursive function, the maximum stack depth is the number of arguments in the provided arglist. - The maximum number of generated arglists is equal to the product of the cardinalities of the deduced types of the inputs. In other words, in the worst case scenario each of the arg types might be a 'splittable' type like `t/or` (whose cardinality is the number of arguments to it when simplified) which would require a Cartesian product of the splits of the arg types." - > vector? #_(s/vec-of (s/kv {:env ::env :out-type-node uast/node?})) + > vector? #_(s/vec-of (s/kv {:env ::env :out-type-node uast/node? :dependent? boolean?})) ([arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _] (analyze-arg-syms {} arg-sym->arg-type-form out-type-form true)) ([arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _, split-types? boolean?] @@ -1051,6 +1059,7 @@ split-types? boolean? > (s/vec-of (s/kv {:env ::env :out-type-node uast/node?}))] (uref/set! !!analyze-arg-syms|iter 0) + (uref/set! !!dependent? false) (try (analyze-arg-syms* {:opts (merge (:opts env) (>analyze-arg-syms|opts env arg-sym->arg-type-form out-type-form split-types?))}) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index 30fd47b2..9b96e757 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -1,9 +1,9 @@ (ns quantum.untyped.core.collections "Operations on collections." (:refer-clojure :exclude - [#?(:cljs array?) assoc-in cat conj! contains? count distinct distinct? first get group-by + [#?(:cljs array?) assoc-in cat conj! contains? count distinct distinct? drop first get group-by filter flatten frequencies last map map-indexed mapcat partition-all pmap remove reverse run! - zipmap]) + take zipmap]) (:require [clojure.core :as core] [fast-zip.core :as zip] @@ -228,31 +228,6 @@ (and (val? elem) (index-of x elem)) :else (uerr/not-supported! `containsv? x)))) -(defn subview - "Returns a subview of ->`xs`, [->`a` to ->`b`), in O(1) time." - ([xs ^long a] (subview xs a (count xs))) - ([xs ^long a ^long b] - (cond (vector? xs) (subvec xs a b) - #?@(:clj [(string? xs) (.subSequence ^String xs a b)]) - :else (uerr/not-supported! `subview xs)))) - -(defn slice - "Makes a subcopy of ->`x`, [->`a`, ->`b`), in the most efficient way possible. - Differs from `subview` in that it does not simply return a view in O(1) time. - Some copies are more efficient than others — some might be O(N); others O(log(N))." - ([xs ^long a] (slice xs a (count xs))) - ([xs ^long a ^long b] - (if (string? xs) - (.substring ^String xs a b) - (->> xs (drop a) (take b))))) - -(defn subview-or-slice - ([xs a] (subview-or-slice xs a (count xs))) - ([xs a b] - (if (or (vector? xs) (string? xs)) ; `subviewable?` - (subview xs a b) - (slice a b)))) - ;; NOTE: The below functions, built on transducers, inasmuch as they require a 0- or 1-arity ;; reducing function to behave correctly (e.g. `partition-all+`), are unsafe for use with ;; core/reduce. Prefer `educe` instead. @@ -296,6 +271,33 @@ (def-transducer>eager partition-all core/partition-all 1) (def-transducer>eager distinct core/distinct 0) +(def-transducer>eager take core/take 1) +(def-transducer>eager drop core/drop 1) + +(defn subview + "Returns a subview of ->`xs`, [->`a` to ->`b`), in O(1) time." + ([xs ^long a] (subview xs a (count xs))) + ([xs ^long a ^long b] + (cond (vector? xs) (subvec xs a b) + #?@(:clj [(string? xs) (.subSequence ^String xs a b)]) + :else (uerr/not-supported! `subview xs)))) + +(defn slice + "Makes a subcopy of ->`x`, [->`a`, ->`b`), in the most efficient way possible. + Differs from `subview` in that it does not simply return a view in O(1) time. + Some copies are more efficient than others — some might be O(N); others O(log(N))." + ([xs ^long a] (slice xs a (count xs))) + ([xs ^long a ^long b] + (if (string? xs) + (.substring ^String xs a b) + (->> xs (drop a) (take b))))) + +(defn subview-or-slice + ([xs a] (subview-or-slice xs a (count xs))) + ([xs a b] + (if (or (vector? xs) (string? xs)) ; `subviewable?` + (subview xs a b) + (slice a b)))) ;; ===== COERCIVE ===== ;; diff --git a/src-untyped/quantum/untyped/core/data/reactive.cljc b/src-untyped/quantum/untyped/core/data/reactive.cljc index 7dceee6b..4403a247 100644 --- a/src-untyped/quantum/untyped/core/data/reactive.cljc +++ b/src-untyped/quantum/untyped/core/data/reactive.cljc @@ -46,6 +46,8 @@ #?(:clj (.deref ^clojure.lang.IDeref rx) :cljs (-deref ^non-native rx)))) +(defn ?norx-deref [x] (if (uref/derefable? x) (norx-deref x) x)) + (defprotocol PWatchable (getWatches [this]) (setWatches [this v])) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 225c4b75..c6cd8e02 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -16,12 +16,16 @@ :refer [defns defns- fns]] [quantum.untyped.core.collections :as uc :refer [>set >vec]] - [quantum.untyped.core.compare :as ucomp] + [quantum.untyped.core.collections.logic + :refer [seq-or]] + [quantum.untyped.core.compare :as ucomp + :refer [not==]] [quantum.untyped.core.data :refer [kw-map]] [quantum.untyped.core.data.array :as uarr] [quantum.untyped.core.data.map :as umap] - [quantum.untyped.core.data.reactive :as urx] + [quantum.untyped.core.data.reactive :as urx + :refer [?norx-deref norx-deref]] [quantum.untyped.core.data.set :as uset] [quantum.untyped.core.data.vector :as uvec] [quantum.untyped.core.error :as err @@ -109,6 +113,20 @@ :fn|overload-types-name simple-symbol? :fn|type-name simple-symbol?})) + +(s/def ::overload-basis|types|split + (s/vec-of (s/kv {:arg-types (s/vec-of t/type?) :output-type t/type?}))) + +(s/def ::overload-basis|norx + ;; None of these types should be reactive + (s/kv {:arg-types|basis t/type? + :output-type|basis t/type? + ;; This is non-nil only for arglists with dependent types + :types|split (s/nilable ::overload-basis|types|split) + :body-codelist (s/vec-of t/any?) + :dependent? boolean? + :reactive? boolean?})) + (s/def ::overload-basis (s/kv {:ns simple-symbol? :args-form map? ; from binding to form @@ -117,7 +135,15 @@ :arg-types|basis (s/vec-of t/type?) :output-type|form t/any? :output-type|basis t/type? - :body-codelist (s/vec-of t/any?)})) + ;; This is non-nil only for arglists with dependent types + :types|split (s/nilable ::overload-basis|types|split) + :body-codelist (s/vec-of t/any?) + :dependent? boolean? + :reactive? boolean?})) + +(s/def ::overload-bases-data + (s/kv {:prev-norx (s/nilable (s/vec-of ::overload-basis|norx)) + :current (s/vec-of ::overload-basis)})) ;; Technically it's partially analyzed — its type definitions are analyzed (with the exception of ;; requests for type inference) while its body is not. @@ -128,7 +154,8 @@ :arg-types (s/vec-of t/type?) :output-type|form t/any? :output-type t/type? - :body-codelist t/any?})) + :body-codelist t/any? + :i|basis index?})) ;; This is the overload after the input specs are split by their respective `t/or` constituents, ;; and after primitivization, but before readiness for incorporation into a `reify`. @@ -180,11 +207,10 @@ :output-type t/type? :index index?})) ; overload-index (position in the overall types-decl) -(s/def ::types-decl - (s/kv {:name simple-symbol? - :form t/any? - ;; Sorted by overload-index - :data (s/vec-of ::types-decl-datum)})) +(s/def ::fn|types + (s/kv {:fn|output-type-norx t/type? + :fn|type-norx t/type? + :overload-types (s/vec-of ::types-decl-datum)})) #_(:clj (c/defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] @@ -219,14 +245,12 @@ (not (-> t meta :quantum.core.type/ref?))) t/class>most-primitive-class)))))) -(defns- >actual-output-type [declared-output-type t/type?, body-node uast/node? > t/type?] +(defns- with-validate-output-type [declared-output-type t/type?, body-node uast/node? > t/type?] (let [err-info {:form (:form body-node) :type (:type body-node) :declared-output-type declared-output-type}] (case (t/compare (:type body-node) declared-output-type) - ;; If the deduced body type is `t/<=` declared output type then we pick the body type - (-1 0) (cond-> (:type body-node) - (-> declared-output-type meta :quantum.core.type/ref?) t/ref) + (-1 0) declared-output-type 1 (if (or (-> declared-output-type meta :quantum.core.type/runtime?) (-> declared-output-type meta :quantum.core.type/assume?)) declared-output-type @@ -303,10 +327,10 @@ lang (uc/count args-form) variadic?))) - actual-output-type (>actual-output-type declared-output-type body-node) + output-type (with-validate-output-type declared-output-type body-node) body-form (-> (:form body-node) - (cond-> (-> actual-output-type meta :quantum.core.type/runtime?) + (cond-> (-> output-type meta :quantum.core.type/runtime?) (>with-runtime-output-type output-type|form)))] {:arglist-form|unanalyzed arglist-form|unanalyzed :arg-classes arg-classes @@ -317,34 +341,10 @@ variadic? (conj (-> varargs-form keys first))) :body-form body-form :positional-args-ct (count args-form) - :output-type actual-output-type - :output-class (type>class actual-output-type) + :output-type output-type + :output-class (type>class output-type) :variadic? variadic?}))) -(defns- unanalyzed-overloads>overloads - "This is of `O(n•log(n))` time complexity where n is the total number of generated/analyzed - overloads. - This is because once we must sort (`O(n•log(n))`) the overloads by comparing their arg types and - then if we find any duplicates in a linear scan (`O(n)`), we throw an error." - [opts ::opts, fn|globals ::fn|globals, fn|type t/type? - unanalyzed-overloads (s/vec-of ::unanalyzed-overload) - > (s/vec-of ::overload)] - (->> unanalyzed-overloads - ;; We have to analyze everything in order to figure out all the types (or at least, analyze - ;; in order to figure out body-dependent input types) before we can compare them against - ;; each other - (uc/map #(unanalyzed-overload>overload % opts fn|globals fn|type)) - (sort-by :arg-types compare-args-types) - (dedupe-type-data - (c/fn [overloads prev-overload overload] - (err! "Duplicate input types for overload" - (umap/om :arglist-form-0 (:arglist-form|unanalyzed prev-overload) - :arg-types-0 (:arg-types prev-overload) - :body-0 (:body-form prev-overload) - :arglist-form-1 (:arglist-form|unanalyzed overload) - :arg-types-1 (:arg-types overload) - :body-1 (:body-form overload))))))) - (defns- class>interface-part-name [c class? > string?] (if (= c java.lang.Object) "Object" @@ -421,7 +421,7 @@ (c/defn overload-types>arg-types [!overload-types #_(t/of urx/reactive? (vec-of ::types-decl-datum)), overload-index #_index? #_> #_(objects-of type?)] - (apply uarr/*<> (:arg-types (get (urx/norx-deref !overload-types) overload-index)))) + (apply uarr/*<> (:arg-types (get (norx-deref !overload-types) overload-index)))) (c/defn type-data>ftype [type-data #_(vec-of ::type-datum), fn|output-type #_t/type?] (->> type-data @@ -434,7 +434,7 @@ (c/defn overload-types>ftype [!overload-types #_(t/of urx/reactive? (vec-of ::types-decl-datum)), fn|output-type #_t/type? #_> #_(vec-of ...)] - (type-data>ftype (urx/norx-deref !overload-types) fn|output-type)) + (type-data>ftype (norx-deref !overload-types) fn|output-type)) (c/defn- dedupe-overload-types-data [fn|ns-name fn|name types-decl-data] (->> types-decl-data @@ -444,7 +444,9 @@ (str "Overwriting type overload for `" (uid/qualify fn|ns-name fn|name) "`") {:arg-types-prev (:arg-types prev-datum) :arg-types (:arg-types datum)}) (-> data pop - (conj (assoc prev-datum :ns-sym (:ns-sym datum) :overload (:overload datum)))))))) + (conj (assoc prev-datum :ns-sym (:ns-sym datum) + :overload (:overload datum) + :replacing-id (:id datum)))))))) (defns- >overload-types-decl|name ([fn|name simple-symbol?, overload|id ::overload|id > simple-symbol?] @@ -471,98 +473,184 @@ ~(uid/qualify fn|ns-name fn|overload-types-name) ~overload-index)))] {:form form :name decl-name})) -(defns- norx-deref-overload-basis [overload-basis ::overload-basis] - (-> overload-basis - (update :arg-types|basis (uc/map urx/norx-deref)) - (update :output-type|basis urx/norx-deref))) - -(defns- >overload-bases-to-analyze - [overload-bases (s/kv {:norx-prev (s/nilable (s/vec-of ::overload-basis)) - :current (s/vec-of ::overload-basis)}) - > (s/vec-of ::overload-basis)] - (let [changed-existing-overload-bases - (reduce-2 - (c/fn [changed derefed-old-basis new-basis] - (cond-> changed - (not= derefed-old-basis (norx-deref-overload-basis new-basis)) (conj new-basis))) - [] (:norx-prev overload-bases) (:current overload-bases)) - new-overload-bases (subvec (:current overload-bases) (count (:norx-prev overload-bases)))] - (ur/join changed-existing-overload-bases new-overload-bases))) - -(defns- overload-basis>unanalyzed-overloads+ +(defns- overload-basis-data>types+ "Split and primitivized; not yet sorted." - [{:as overload-basis - :keys [args-form _, body-codelist _, output-type|form _]} - ::overload-basis - {:as fn|globals :keys [fn|output-type _]} ::fn|globals - #_> #_(s/+-of ::unanalyzed-overload)] - (let [overload-basis-selected - (select-keys overload-basis - [:arglist-form|unanalyzed :args-form :body-codelist :output-type|form :varargs-form])] - (->> (uana/analyze-arg-syms {} args-form output-type|form true) - (uc/map+ (c/fn [{:keys [env out-type-node]}] - (let [output-type (:type out-type-node) - arg-env (->> env :opts :arg-env deref) - arg-types (->> args-form keys (uc/map #(:type (get arg-env %))))] - (when-not (t/<= output-type fn|output-type) - (err! (str "Overload's declared output type does not satisfy function's" - "overall declared output type") - (kw-map output-type fn|output-type))) - (kw-map arg-types output-type)))) - (uc/map+ (c/fn [{:keys [arg-types output-type]}] - (merge overload-basis-selected (kw-map arg-types output-type))))))) - -(defns- overload-bases>overload-types - [overload-bases (s/kv {:norx-prev (s/nilable (s/vec-of ::overload-basis)) - :current (s/vec-of ::overload-basis)}) + [{:keys [fn|output-type _]} ::fn|globals, args-form _, body-codelist _, output-type|form _] + (->> (uana/analyze-arg-syms {} args-form output-type|form true) + (uc/map+ (c/fn [{:keys [env out-type-node]}] + (let [arg-env (->> env :opts :arg-env deref) + arg-types (->> args-form keys (uc/map #(:type (get arg-env %)))) + output-type (:type out-type-node)] + (when-not (t/<= output-type fn|output-type) + (err! (str "Overload's declared output type does not satisfy function's" + "overall declared output type") + (kw-map output-type fn|output-type))) + (kw-map arg-types output-type)))))) + +(defns- overload-basis|changed? + [overload-basis ::overload-basis, prev-basis ::overload-basis|norx > boolean?] + (or (not= (:body-codelist overload-basis) (:body-codelist prev-basis)) + (if (:types|split overload-basis) + (not= (:types|split overload-basis) (:types|split prev-basis)) + (or ;; We don't check changedness via `=` when checking type bases because it's possible + ;; that a change in a reactive type might result in a change in how types are split, + ;; which is hidden by a lack of change in basis type value. + (not== (-> overload-basis :output-type|basis deref) (:output-type|basis prev-basis)) + (->> overload-basis + :arg-types|basis + (uc/map-indexed+ + (c/fn [i|t t] (not== (deref t) (-> prev-basis :arg-types|basis (get i|t))))) + (seq-or true?)))))) + +(defns- establish-dependency-relations-on-new-overload-bases! + "This establishes a dependency relation on both the `fn|output-type` and on new reactive types + defined in `!overload-bases`. + + Currently only intended to be used by `!overload-types`." + [fn|output-type t/type?, {:keys [prev-norx _, current _]} ::overload-bases-data] + (?deref fn|output-type) + (->> current + (uc/drop+ (count prev-norx)) + (uc/run! (c/fn [{:keys [arg-types|basis output-type|basis]}] + (->> arg-types|basis (uc/run! ?deref)) + (?deref output-type|basis))))) + +(defns- >changed-unanalyzed-overloads + "A 'changed' overload here means either 1) an overload from an overload basis whose type signature + has changed, and after being split, does not have the same type signature as that of an existing + overload, 2) an overload from a newly declared overload basis whose type signature is unique for + the `t/defn` in question, or 3) an overload from a newly declared overload basis whose type + signature is the same as one that already exists for the `t/defn` in question (in which case its + implementation will overwrite the existing one). + + 'Cheaply' O(m•n) where `m` is the number split types resulting from changed overload bases, and + `n` is the size of the existing overload types. 'Cheap' because only a `=` check is performed `n` + times for each `m`. All other computations are done only once for each `m`." + [fn|globals ::fn|globals + {:keys [prev-norx _, current _]} ::overload-bases-data existing-overload-types (s/nilable (s/vec-of ::types-decl-datum)) - opts ::opts - {:as fn|globals :keys [fn|overload-types-name _, fn|name _, fn|ns-name _]} ::fn|globals - fn|type t/type? + > (s/vec-of ::unanalyzed-overload)] + (let [first-new-basis-index (count prev-norx)] + (->> current + (uc/map-indexed+ + (c/fn [i|basis + {:as basis + :keys [args-form body-codelist|unanalyzed output-type|form types|split]}] + (let [new-overload-basis? (>= i|basis first-new-basis-index) + prev-basis (get prev-norx i|basis) + changed? (overload-basis|changed? basis prev-basis)] + (when (or new-overload-basis? changed?) + (let [type-signature-equal-to-existing? + (c/fn [{:keys [arg-types output-type]}] + (seq-or #(and (= output-type (:output-type %)) + (= arg-types (:arg-types %))) + existing-overload-types))] + (->> (or types|split (overload-basis-data>types+ + fn|globals args-form body-codelist|unanalyzed output-type|form)) + (cond->> (and (not new-overload-basis?) + (= (:body-codelist basis) (:body-codelist prev-basis))) + (uc/remove+ type-signature-equal-to-existing?)) + (uc/map+ (c/fn [type-datum] + (-> (select-keys basis + [:arglist-form|unanalyzed :args-form :body-codelist + :output-type|form :varargs-form]) + (merge type-datum) + (assoc :i|basis)))))))))) + (uc/filter+ identity) + uc/cat))) + +(defns- validate-unique-types-for-unanalyzed-overloads + "Prior to validation we must first sort the overloads by comparing their arg types. Then if we + find any type signature duplicates in a linear scan, we throw an error." + [unanalyzed-overloads (s/vec-of ::unanalyzed-overload) + > (s/vec-of ::unanalyzed-overload)] + (->> unanalyzed-overloads + (dedupe-type-data + (c/fn [overloads prev-overload overload] + (err! "Duplicate input types for overload" + (umap/om :arglist-form-0 (:arglist-form|unanalyzed prev-overload) + :arg-types-0 (:arg-types prev-overload) + :body-0 (:body-form prev-overload) + :arglist-form-1 (:arglist-form|unanalyzed overload) + :arg-types-1 (:arg-types overload) + :body-1 (:body-form overload))))))) + +(defns- overload-bases-data>overload-types + "Each overload type is structurally (`=`) unique and if an overload is introduced which is `t/=` + but not `=` then that overload will be rejected." + [overload-bases-data ::overload-bases-data + existing-fn-types (s/nilable ::fn|types) + opts ::opts + {:as fn|globals + :keys [fn|name _, fn|ns-name _, fn|output-type _, fn|overload-types-name _]} ::fn|globals > (s/vec-of ::types-decl-datum)] - (if-not-let [overload-bases-to-analyze (-> overload-bases >overload-bases-to-analyze seq)] - existing-overload-types - (let [;; These are created within this fn, then put on a queue below so that direct dispatch can - ;; use them later on in the pipeline - overloads (->> overload-bases-to-analyze - (uc/mapcat (fn1 overload-basis>unanalyzed-overloads+ fn|globals)) - (unanalyzed-overloads>overloads opts fn|globals fn|type)) - first-current-overload-id (count existing-overload-types) - overload-types-current-data ; i.e. being created right now - (->> overloads - (uc/map-indexed - (c/fn [i {:keys [arg-types output-type]}] - {:id (+ i first-current-overload-id) - :ns-sym (ns-name *ns*) - :arg-types arg-types - :output-type output-type}))) - ;; We can't just concat the currently-being-created overloads' type-decl data with the - ;; existing type-decl data because we need to maintain the type-decl data's ordering by - ;; type-specificity so the dynamic dispatch works correctly. - overload-types-data-with-overloads - (if (empty? existing-overload-types) - (->> overload-types-current-data - (uc/map-indexed - (c/fn [i datum] (assoc datum :index i :overload (get overloads i))))) - (->> (ur/join overload-types-current-data existing-overload-types) - (uc/map - (c/fn [{:as datum :keys [id]}] - (assoc datum :overload (get overloads (- id first-current-overload-id))))) - (sort-by identity - (c/fn [datum0 datum1] - (let [c (compare-args-types (:arg-types datum0) (:arg-types datum1))] - ;; In order to make the earlier ID appear - (if (zero? c) - (if (:overload datum0) - (if (:overload datum1) c 1) - (if (:overload datum1) -1 c)) - c)))) - (dedupe-overload-types-data fn|ns-name fn|name) - (uc/map-indexed (c/fn [i datum] (assoc datum :index i)))))] - (->> overload-types-data-with-overloads - (uc/map (c/fn [datum] - (uvec/alist-conj! !overload-queue datum) - (dissoc datum :overload))))))) + (establish-dependency-relations-on-new-overload-bases! fn|output-type overload-bases-data) + (let [fn|output-type-norx|prev (:fn|output-type-norx existing-fn-types) + fn|output-type-norx (?deref fn|output-type) + existing-overload-types (:overload-types existing-fn-types)] + (when (and existing-fn-types + (t/not= fn|output-type-norx fn|output-type-norx|prev)) + (TODO "`fn|output-type` changed; not sure what to do at this point" + {:fn|output-type|prev fn|output-type-norx|prev + :fn|output-type|new fn|output-type-norx})) + (if-not-let [changed-unanalyzed-overloads + (seq (>changed-unanalyzed-overloads + fn|globals overload-bases-data existing-overload-types))] + existing-fn-types + (let [sorted-changed-unanalyzed-overloads + (->> changed-unanalyzed-overloads + (sort-by :arg-types compare-args-types) + validate-unique-types-for-unanalyzed-overloads) + first-current-overload-id (count existing-overload-types) + new-overload? (c/fn [type-datum] (>= (:id type-datum) first-current-overload-id)) + sorted-changed-overload-types + (->> sorted-changed-unanalyzed-overloads + (uc/map-indexed + (c/fn [i {:keys [arg-types output-type]}] + {:id (+ i first-current-overload-id) + :ns-sym (ns-name *ns*) + :arg-types arg-types + :output-type output-type}))) + ;; We need to maintain the `overload-types` ordering by type-specificity so the dynamic + ;; dispatch and fn-type work correctly. + overload-types-with-replacing-ids + (if (empty? existing-overload-types) + (->> sorted-changed-overload-types + (uc/map-indexed (c/fn [i datum] (assoc datum :index i)))) + ;; (assoc datum :overload + ;; (get changed-overloads (- id first-current-overload-id))) + (->> (ur/join existing-overload-types sorted-changed-overload-types) + (sort-by identity + (c/fn [datum0 datum1] + (let [c (compare-args-types (:arg-types datum0) (:arg-types datum1))] + ;; In order to make the earlier ID appear + (if (zero? c) + (if (new-overload? datum0) + (if (new-overload? datum1) c 1) + (if (new-overload? datum1) -1 c)) + c)))) + (dedupe-overload-types-data fn|ns-name fn|name) + (uc/map-indexed (c/fn [i datum] (assoc datum :index i))))) + ;; For recursive purposes + fn|type-norx (type-data>ftype overload-types-with-replacing-ids fn|output-type-norx) + ;; We should analyze everything first in order to figure out body-dependent input types + ;; before we can compare them against each other, but we're ignoring body-dependent input + ;; types for now + sorted-changed-overloads + (->> sorted-changed-unanalyzed-overloads + (uc/map #(unanalyzed-overload>overload % opts fn|globals fn|type-norx))) + overload-types + (->> overload-types-with-replacing-ids + (uc/map + (c/fn [datum] + (let [id (or (:replacing-id datum) (:id datum))] + (when (>= id first-current-overload-id) + (let [overload (get sorted-changed-overloads + (- id first-current-overload-id))] + ;; So that direct dispatch can use them later on in the pipeline + (uvec/alist-conj! !overload-queue (assoc datum :overload overload))))) + (dissoc datum :replacing-id))))] + (kw-map fn|output-type-norx fn|type-norx overload-types))))) ;; ----- Direct dispatch ----- ;; @@ -651,7 +739,7 @@ !overload-types _] (let [overload-forms (->> !overload-types - urx/norx-deref + norx-deref (group-by (fn-> :arg-types count)) (sort-by key) ; for purposes of reproducibility and organization (map (c/fn [[arg-ct overload-types-for-arity]] @@ -667,7 +755,7 @@ (alter-meta! v# merge ~fn|meta'))] (let [dispatch-form `(uvar/defmeta ~fn|name ~fn|meta' (fn* ~@overload-forms))] (if (= compilation-mode :test) - [(->> !overload-types urx/norx-deref >form (uc/map (fn1 dissoc :ns-sym))) + [(->> !overload-types norx-deref >form (uc/map (fn1 dissoc :ns-sym))) dispatch-form] [dispatch-form]))))) @@ -675,7 +763,7 @@ (defns- overload-basis-form>overload-basis [opts ::opts - {:keys [fn|output-type _, fn|output-type|form _]} ::fn|globals + {:as fn|globals :keys [fn|output-type _, fn|output-type|form _]} ::fn|globals {:as overload-basis-form {args [:args _] varargs [:varargs _] @@ -709,25 +797,100 @@ (assert (-> varargs :binding-form first (= :sym)))) args-form (reduce-2 assoc (umap/om) arg-bindings arg-types|form) [arglist-basis] (uana/analyze-arg-syms {} args-form output-type|form false) - binding->arg-type|basis (->> arglist-basis :env :opts :arg-env deref (uc/map-vals' :type))] - ;; TODO `dependent?` -> any of the arg-types or output-type use dependent types - ;; TODO `reactive?` -> any of the arg-types or output-type are reactive + binding->arg-type|basis (->> arglist-basis :env :opts :arg-env deref (uc/map-vals' :type)) + arg-types|basis (->> args-form keys (uc/map binding->arg-type|basis)) + output-type|basis (-> arglist-basis :out-type-node :type) + dependent? (:dependent? arglist-basis) + reactive? (or (utr/rx-type? output-type|basis) + (seq-or utr/rx-type? arg-types|basis))] {:ns (>symbol *ns*) ;; TODO Only needed if `dependent?` or if new :args-form args-form - :arg-types|basis (->> args-form keys (uc/map binding->arg-type|basis)) + :arg-types|basis arg-types|basis ;; TODO Only needed if `dependent?` or if new :varargs-form (when varargs {varargs-binding nil}) ; TODO `nil` isn't right :arglist-form|unanalyzed arglist-form|unanalyzed ;; TODO Only needed if `dependent?` or if new :output-type|form output-type|form - :output-type|basis (-> arglist-basis :out-type-node :type) + :output-type|basis output-type|basis + ;; We store this only for arglists with dependent types. If the arglist is reactive, then + ;; downstream, if the reactive types change, the new split types can be compared with the + ;; previous split types. If non-reactive, then the split types of this overload basis can be + ;; compared to existing overload bases. + :types|split (when dependent? + (->> (overload-basis-data>types+ fn|globals args-form + body-codelist|unanalyzed output-type|form) + ur/join)) ;; TODO Only needed if `inline? or `reactive?`, or if new - :body-codelist body-codelist|unanalyzed})) + :body-codelist body-codelist|unanalyzed + :dependent? dependent? + :reactive? reactive?})) ;; ===== Reactive auxiliary vars ===== ;; +(defns- incorporate-overload-bases + "O(m•n) where `m` = # of existing overload bases and `n` = # of new overload bases." + [existing-bases (s/vec-of ::overload-basis), new-bases (s/vec-of ::overload-basis) + > (s/vec-of ::overload-basis)] + (reduce + (c/fn [bases new-basis] + (if-let [i|existing + (->> existing-bases + (uc/map-indexed+ + (c/fn [i existing-basis] + (if-let [same-code? + (and (= (:arglist-form|unanalyzed existing-basis) + (:arglist-form|unanalyzed new-basis)) + (= (:body-codelist existing-basis) + (:body-codelist new-basis)))] + i + ;; This only checks for `=` because `t/=` will be deduped later on in + ;; overloads, not overload bases + ;; TODO this doesn't take into account `|` types + (if-let [same-unreactive-type? + (and (not (:reactive? existing-basis)) + (not (:reactive? new-basis)) + (if (and (:dependent? existing-basis) + (:dependent? new-basis)) + (= (:types|split existing-basis) + (:types|split new-basis)) + (and (= (:output-type existing-basis) + (:output-type new-basis)) + (= (:arg-types existing-basis) + (:arg-types new-basis)))))] + i + ;; TODO enhance this; figure out how to effectively compare reactive + ;; and dependent types, if that's even possible + ;; TODO maybe we don't even want this; maybe this should be based on + ;; an atom that's configurable. It does override/nullify some + ;; safety behavior in `overload-basis|changed?` + (when-let [probably-same-reactive-type? + (and (= (:reactive? existing-basis) + (:reactive? new-basis)) + (= (:dependent? existing-basis) + (:dependent? new-basis)) + (= (:types|split existing-basis) + (:types|split new-basis)) + (= (-> existing-basis :output-type ?norx-deref) + (-> new-basis :output-type ?norx-deref)) + (= (-> existing-basis :arg-types ?norx-deref) + (-> new-basis :arg-types ?norx-deref)))] + (ulog/pr :warn + (str "Assuming that new reactive overload basis is a subsequent " + "version of existing reactive overload basis") + {:new (:arglist-form|unanalyzed existing-basis) + :existing (:arglist-form|unanalyzed existing-basis)}) + i))))) + (uc/filter+ some?) + uc/first)] + (assoc bases i|existing new-basis) + (conj bases new-basis)))) + existing-bases + new-bases) + (defns- >!overload-bases + "`!overload-bases` is a reactive atom updated by `t/extend-defn!`, which cannot be deleted from + but which can be updated and appended to." [{:as opts :keys [kind _]} ::opts {:as fn|globals :keys [fn|ns-name _, fn|overload-bases-name _]} ::fn|globals overload-bases-form _] @@ -736,15 +899,29 @@ (uc/map (c/fn [x] (overload-basis-form>overload-basis opts fn|globals x))))] (if (= kind :extend-defn!) (-> (uid/qualify fn|ns-name fn|overload-bases-name) resolve var-get - (doto (uref/update! - (c/fn [{:keys [current]}] - {:norx-prev (->> current (uc/map norx-deref-overload-basis)) - :current (ur/join current overload-bases)})))) - (urx/! {:norx-prev nil :current overload-bases})))) + (doto + (uref/update! + (c/fn [{:keys [current]}] + {:prev-norx + (->> current + (uc/map + (c/fn [basis] + {:arg-types|basis (->> basis :arg-types|basis (uc/map norx-deref)) + :output-type|basis (-> basis :output-type|basis norx-deref) + :types|split (:types|split basis) + :body-codelist (:body-codelist basis) + :dependent? (:dependent? basis) + :reactive? (:reactive? basis)}))) + :current (incorporate-overload-bases current overload-bases)})))) + (urx/! {:prev-norx nil :current overload-bases})))) (defns- >!overload-types - "Whatever `opts` and `fn|globals` are passed are what the `t/defn` will always use even when being - extended in a different namespace." + "`!overload-types` is a reaction which depends on the `!overload-bases` atom and all reactive + types declared in any arglist of the `t/defn` in question, as well as the overall output type + (if reactive) of the `t/defn`. + + Whatever the values of `opts` and `fn|globals` are at the time of `t/defn` definition, that's + what they'll be for the lifetime of the function." [{:as opts :keys [kind _]} ::opts {:as fn|globals :keys [fn|ns-name _, fn|overload-types-name _, fn|type-name _]} ::fn|globals !overload-bases _] @@ -752,13 +929,11 @@ (-> (uid/qualify fn|ns-name fn|overload-types-name) resolve var-get) (with-do-let [!overload-types (urx/!rx @!overload-bases)] (uref/add-interceptor! !overload-types :the-interceptor - (c/fn [_ _ old-overload-types new-overload-bases] + (c/fn [_ _ old-overload-types overload-bases-data] ;; `opts` and `fn|globals` are closed over - (overload-bases>overload-types - new-overload-bases old-overload-types opts fn|globals - (or (some-> (uid/qualify fn|ns-name fn|type-name) resolve var-get urx/norx-deref) - t/none?)))) - (urx/norx-deref !overload-types) + (overload-bases-data>overload-types + overload-bases-data old-overload-types opts fn|globals))) + (norx-deref !overload-types) (intern fn|ns-name fn|overload-types-name !overload-types)))) (defns- >!fn|types @@ -767,7 +942,7 @@ !overload-types _] (if (= kind :extend-defn!) (-> (uid/qualify fn|ns-name fn|type-name) resolve var-get) - (with-do-let [!fn|type (t/rx (type-data>ftype @!overload-types (?deref fn|output-type)))] + (with-do-let [!fn|type (t/rx* (urx/>!rx #(:fn|type-norx @!overload-types) {:eq-fn t/=} nil))] (intern fn|ns-name fn|type-name !fn|type)))) ;; ===== `opts` + `fn|globals` ===== ;; @@ -834,7 +1009,7 @@ !overload-bases (>!overload-bases opts fn|globals overload-bases-form) !overload-types (>!overload-types opts fn|globals !overload-bases) !fn|type (>!fn|types opts fn|globals !overload-types)] - (if (empty? (urx/norx-deref !overload-bases)) + (if (empty? (norx-deref !overload-bases)) `(declare ~(:fn|name fn|globals)) (let [direct-dispatch (>direct-dispatch opts fn|globals !overload-types) dynamic-dispatch (>dynamic-dispatch-fn|codelist opts fn|globals !overload-types) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 7b02a135..1cc29f7a 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1362,7 +1362,7 @@ (macroexpand ' (self/defn defn-self-reference ([> tt/double?] 2.0) - ([x tt/long?] (defn-self-reference))))) + ([x tt/long? > tt/double?] (defn-self-reference))))) expected (case (env-lang) :clj ($ (do (declare ~'defn-self-reference) From 4198b8bf64c862b201186066b46a87b216ef40f3 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 4 Nov 2018 08:46:58 -0700 Subject: [PATCH 626/810] Fixed some bugs and first test passes! --- src-untyped/quantum/untyped/core/analyze.cljc | 2 +- .../quantum/untyped/core/type/defnt.cljc | 77 +++++++++---------- 2 files changed, 36 insertions(+), 43 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index c5922908..2a193344 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -999,7 +999,7 @@ (ifs (empty? arglist-syms|unanalyzed) [{:env env :out-type-node (-> (analyze env out-type-form) (update :type t/unvalue)) - :dependent? @!!dependent?}] + :dependent? (uref/get !!dependent?)}] (>= (uref/get !!analyze-arg-syms|iter) analyze-arg-syms|max-iter) (err! "Max number of iterations reached for `analyze-arg-syms`" {:n (uref/get !!analyze-arg-syms|iter)}) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index c6cd8e02..f09141d0 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -419,23 +419,18 @@ ;; ----- Type declarations ----- ;; (c/defn overload-types>arg-types - [!overload-types #_(t/of urx/reactive? (vec-of ::types-decl-datum)), overload-index #_index? + [!fn|types #_(t/of urx/reactive? ::fn|types), overload-index #_index? #_> #_(objects-of type?)] - (apply uarr/*<> (:arg-types (get (norx-deref !overload-types) overload-index)))) + (apply uarr/*<> (-> !fn|types norx-deref :overload-types (get overload-index) :arg-types))) -(c/defn type-data>ftype [type-data #_(vec-of ::type-datum), fn|output-type #_t/type?] - (->> type-data +(c/defn overload-types>ftype [overload-types #_(vec-of ::type-datum), fn|output-type #_t/type?] + (->> overload-types (uc/lmap (c/fn [{:keys [arg-types pre-type output-type]}] (cond-> arg-types pre-type (conj :| pre-type) output-type (conj :> output-type)))) (apply t/ftype fn|output-type))) -(c/defn overload-types>ftype - [!overload-types #_(t/of urx/reactive? (vec-of ::types-decl-datum)), fn|output-type #_t/type? - #_> #_(vec-of ...)] - (type-data>ftype (norx-deref !overload-types) fn|output-type)) - (c/defn- dedupe-overload-types-data [fn|ns-name fn|name types-decl-data] (->> types-decl-data (dedupe-type-data @@ -460,13 +455,13 @@ dynamic dispatch uses to dispatch off input types." [{:as opts :keys [compilation-mode _, lang _]} ::opts {:as fn|globals :keys [fn|ns-name _, fn|name _, fn|overload-types-name _]} ::fn|globals - arg-types (s/vec-of t/type?), overload|id ::overload|id, overload-index index?, !overload-types _ + arg-types (s/vec-of t/type?), overload|id ::overload|id, overload-index index?, !fn|types _ > ::overload-types-decl] (let [decl-name (-> (>overload-types-decl|name fn|name overload|id) (ufth/with-type-hint "[Ljava.lang.Object;")) form (if (or (not= compilation-mode :test) (= lang :clj)) (do (intern fn|ns-name decl-name - (overload-types>arg-types !overload-types overload-index)) + (overload-types>arg-types !fn|types overload-index)) nil) `(def ~decl-name (overload-types>arg-types @@ -506,7 +501,7 @@ "This establishes a dependency relation on both the `fn|output-type` and on new reactive types defined in `!overload-bases`. - Currently only intended to be used by `!overload-types`." + Currently only intended to be used by `!fn|types`." [fn|output-type t/type?, {:keys [prev-norx _, current _]} ::overload-bases-data] (?deref fn|output-type) (->> current @@ -538,7 +533,7 @@ :keys [args-form body-codelist|unanalyzed output-type|form types|split]}] (let [new-overload-basis? (>= i|basis first-new-basis-index) prev-basis (get prev-norx i|basis) - changed? (overload-basis|changed? basis prev-basis)] + changed? (when prev-basis (overload-basis|changed? basis prev-basis))] (when (or new-overload-basis? changed?) (let [type-signature-equal-to-existing? (c/fn [{:keys [arg-types output-type]}] @@ -555,14 +550,14 @@ [:arglist-form|unanalyzed :args-form :body-codelist :output-type|form :varargs-form]) (merge type-datum) - (assoc :i|basis)))))))))) + (assoc :i|basis i|basis)))))))))) (uc/filter+ identity) uc/cat))) (defns- validate-unique-types-for-unanalyzed-overloads "Prior to validation we must first sort the overloads by comparing their arg types. Then if we find any type signature duplicates in a linear scan, we throw an error." - [unanalyzed-overloads (s/vec-of ::unanalyzed-overload) + [unanalyzed-overloads (s/seq-of ::unanalyzed-overload) > (s/vec-of ::unanalyzed-overload)] (->> unanalyzed-overloads (dedupe-type-data @@ -575,7 +570,7 @@ :arg-types-1 (:arg-types overload) :body-1 (:body-form overload))))))) -(defns- overload-bases-data>overload-types +(defns- overload-bases-data>fn|types "Each overload type is structurally (`=`) unique and if an overload is introduced which is `t/=` but not `=` then that overload will be rejected." [overload-bases-data ::overload-bases-data @@ -583,7 +578,7 @@ opts ::opts {:as fn|globals :keys [fn|name _, fn|ns-name _, fn|output-type _, fn|overload-types-name _]} ::fn|globals - > (s/vec-of ::types-decl-datum)] + > ::fn|types] (establish-dependency-relations-on-new-overload-bases! fn|output-type overload-bases-data) (let [fn|output-type-norx|prev (:fn|output-type-norx existing-fn-types) fn|output-type-norx (?deref fn|output-type) @@ -632,7 +627,7 @@ (dedupe-overload-types-data fn|ns-name fn|name) (uc/map-indexed (c/fn [i datum] (assoc datum :index i))))) ;; For recursive purposes - fn|type-norx (type-data>ftype overload-types-with-replacing-ids fn|output-type-norx) + fn|type-norx (overload-types>ftype overload-types-with-replacing-ids fn|output-type-norx) ;; We should analyze everything first in order to figure out body-dependent input types ;; before we can compare them against each other, but we're ignoring body-dependent input ;; types for now @@ -655,17 +650,14 @@ ;; ----- Direct dispatch ----- ;; (defns- >direct-dispatch - [{:as opts :keys [gen-gensym _, lang _, kind _]} ::opts - fn|globals ::fn|globals - !overload-types _] + [{:as opts :keys [gen-gensym _, lang _, kind _]} ::opts, fn|globals ::fn|globals, !fn|types _] (case lang :clj (let [direct-dispatch-data-seq (->> !overload-queue (uc/map (c/fn [{:as indexed-type-decl-datum :keys [arg-types id index overload]}] {:overload-types-decl - (>overload-types-decl - opts fn|globals arg-types id index !overload-types) + (>overload-types-decl opts fn|globals arg-types id index !fn|types) :reify (overload>reify overload opts fn|globals id)}))) _ (uvec/alist-empty! !overload-queue) form (->> direct-dispatch-data-seq @@ -736,10 +728,11 @@ [{:as opts :keys [compilation-mode _, gen-gensym _, lang _, kind _]} ::opts {:as fn|globals :keys [fn|meta _, fn|ns-name _, fn|name _, fn|output-type _ fn|overload-types-name _, fn|type-name _]} ::fn|globals - !overload-types _] + !fn|types _] (let [overload-forms - (->> !overload-types + (->> !fn|types norx-deref + :overload-types (group-by (fn-> :arg-types count)) (sort-by key) ; for purposes of reproducibility and organization (map (c/fn [[arg-ct overload-types-for-arity]] @@ -755,7 +748,7 @@ (alter-meta! v# merge ~fn|meta'))] (let [dispatch-form `(uvar/defmeta ~fn|name ~fn|meta' (fn* ~@overload-forms))] (if (= compilation-mode :test) - [(->> !overload-types norx-deref >form (uc/map (fn1 dissoc :ns-sym))) + [(->> !fn|types norx-deref :overload-types >form (uc/map (fn1 dissoc :ns-sym))) dispatch-form] [dispatch-form]))))) @@ -915,10 +908,10 @@ :current (incorporate-overload-bases current overload-bases)})))) (urx/! {:prev-norx nil :current overload-bases})))) -(defns- >!overload-types - "`!overload-types` is a reaction which depends on the `!overload-bases` atom and all reactive - types declared in any arglist of the `t/defn` in question, as well as the overall output type - (if reactive) of the `t/defn`. +(defns- >!fn|types + "`!fn|types` is a reaction which depends on the `!overload-bases` atom and all reactive types + declared in any arglist of the `t/defn` in question, as well as the overall output type (if + reactive) of the `t/defn`. Whatever the values of `opts` and `fn|globals` are at the time of `t/defn` definition, that's what they'll be for the lifetime of the function." @@ -927,22 +920,22 @@ !overload-bases _] (if (= kind :extend-defn!) (-> (uid/qualify fn|ns-name fn|overload-types-name) resolve var-get) - (with-do-let [!overload-types (urx/!rx @!overload-bases)] - (uref/add-interceptor! !overload-types :the-interceptor + (with-do-let [!fn|types (urx/!rx @!overload-bases)] + (uref/add-interceptor! !fn|types :the-interceptor (c/fn [_ _ old-overload-types overload-bases-data] ;; `opts` and `fn|globals` are closed over - (overload-bases-data>overload-types + (overload-bases-data>fn|types overload-bases-data old-overload-types opts fn|globals))) - (norx-deref !overload-types) - (intern fn|ns-name fn|overload-types-name !overload-types)))) + (norx-deref !fn|types) + (intern fn|ns-name fn|overload-types-name !fn|types)))) -(defns- >!fn|types +(defns- >!fn|type [{:as opts :keys [kind _]} ::opts {:as fn|globals :keys [fn|ns-name _, fn|output-type _, fn|type-name _]} ::fn|globals - !overload-types _] + !fn|types _] (if (= kind :extend-defn!) (-> (uid/qualify fn|ns-name fn|type-name) resolve var-get) - (with-do-let [!fn|type (t/rx* (urx/>!rx #(:fn|type-norx @!overload-types) {:eq-fn t/=} nil))] + (with-do-let [!fn|type (t/rx* (urx/>!rx #(:fn|type-norx @!fn|types) {:eq-fn t/=}) nil)] (intern fn|ns-name fn|type-name !fn|type)))) ;; ===== `opts` + `fn|globals` ===== ;; @@ -1007,12 +1000,12 @@ (let [opts (>fn|opts kind lang compilation-mode) {:keys [fn|globals overload-bases-form]} (>fn|globals+?overload-bases-form kind args) !overload-bases (>!overload-bases opts fn|globals overload-bases-form) - !overload-types (>!overload-types opts fn|globals !overload-bases) - !fn|type (>!fn|types opts fn|globals !overload-types)] + !fn|types (>!fn|types opts fn|globals !overload-bases) + !fn|type (>!fn|type opts fn|globals !fn|types)] (if (empty? (norx-deref !overload-bases)) `(declare ~(:fn|name fn|globals)) - (let [direct-dispatch (>direct-dispatch opts fn|globals !overload-types) - dynamic-dispatch (>dynamic-dispatch-fn|codelist opts fn|globals !overload-types) + (let [direct-dispatch (>direct-dispatch opts fn|globals !fn|types) + dynamic-dispatch (>dynamic-dispatch-fn|codelist opts fn|globals !fn|types) fn-codelist (->> `[;; For recursion ~@(when (not= kind :extend-defn!) [`(declare ~(:fn|name fn|globals))]) From 24040c37fa15b972fc33d93b6479b941589e093b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 4 Nov 2018 08:50:22 -0700 Subject: [PATCH 627/810] A number of tests pass --- .../quantum/test/untyped/core/type/defnt.cljc | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 1cc29f7a..e6765373 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -246,16 +246,16 @@ (def ~(tag (cstr `Object>boolean) 'some?|__9) (reify* [Object>boolean] (~(B 'invoke) [~'_9__ ~(O 'x)] true))) - [{:id 0 :index 0 :arg-types [(t/value nil)] :output-type (t/value false)} - {:id 1 :index 1 :arg-types [(t/isa? Boolean)] :output-type (t/value true)} - {:id 2 :index 2 :arg-types [(t/isa? Byte)] :output-type (t/value true)} - {:id 3 :index 3 :arg-types [(t/isa? Short)] :output-type (t/value true)} - {:id 4 :index 4 :arg-types [(t/isa? Character)] :output-type (t/value true)} - {:id 5 :index 5 :arg-types [(t/isa? Integer)] :output-type (t/value true)} - {:id 6 :index 6 :arg-types [(t/isa? Long)] :output-type (t/value true)} - {:id 7 :index 7 :arg-types [(t/isa? Float)] :output-type (t/value true)} - {:id 8 :index 8 :arg-types [(t/isa? Double)] :output-type (t/value true)} - {:id 9 :index 9 :arg-types [t/any?] :output-type (t/value true)}] + [{:id 0 :index 0 :arg-types [(t/value nil)] :output-type (t/isa? Boolean)} + {:id 1 :index 1 :arg-types [(t/isa? Boolean)] :output-type (t/isa? Boolean)} + {:id 2 :index 2 :arg-types [(t/isa? Byte)] :output-type (t/isa? Boolean)} + {:id 3 :index 3 :arg-types [(t/isa? Short)] :output-type (t/isa? Boolean)} + {:id 4 :index 4 :arg-types [(t/isa? Character)] :output-type (t/isa? Boolean)} + {:id 5 :index 5 :arg-types [(t/isa? Integer)] :output-type (t/isa? Boolean)} + {:id 6 :index 6 :arg-types [(t/isa? Long)] :output-type (t/isa? Boolean)} + {:id 7 :index 7 :arg-types [(t/isa? Float)] :output-type (t/isa? Boolean)} + {:id 8 :index 8 :arg-types [(t/isa? Double)] :output-type (t/isa? Boolean)} + {:id 9 :index 9 :arg-types [t/any?] :output-type (t/isa? Boolean)}] (defmeta ~'some? {:quantum.core.type/type some?|__type} From b79fefada8c2a01a6a8b582bef55dbf3229ff994 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 4 Nov 2018 08:55:37 -0700 Subject: [PATCH 628/810] Another test passes --- .../quantum/test/untyped/core/type/defnt.cljc | 36 +++++++++++-------- 1 file changed, 21 insertions(+), 15 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index e6765373..e942d1e1 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1366,28 +1366,34 @@ expected (case (env-lang) :clj ($ (do (declare ~'defn-self-reference) - (def ~'defn-self-reference|__0|0 - (reify* [>Object] - (~(O 'invoke) [~'_0__] nil))) - (def ~(O<> 'defn-self-reference|__1|input0|types) - (*<> (t/isa? java.lang.Long))) - (def ~'defn-self-reference|__1|0 - (reify* [long>Object] + + ;; [> tt/double?] + + (def ~'defn-self-reference|__0 + (reify* [>double] + (~(O 'invoke) [~'_0__] 2.0))) + + ;; [x tt/long? > tt/double?] + + (def ~'defn-self-reference|__1 + (reify* [long>double] (~(O 'invoke) [~'_1__ ~'x] (~'defn-self-reference)))) - (defn ~'defn-self-reference - {:quantum.core.type/type - (t/ftype t/any? [] [tt/long?])} - ([] (.invoke ~'defn-self-reference|__0|0)) + + [{:id 0 :index 0 :arg-types [] :output-type (t/isa? Double)} + {:id 1 :index 1 :arg-types [(t/isa? Long) :output-type (t/isa? Double)]}] + + (defmeta ~'defn-self-reference + {:quantum.core.type/type defn-self-reference|__type} + ([] (. ~'defn-self-reference|__0 invoke)) ([~'x00__] (ifs - ((Array/get ~'defn-self-reference|__1|input0|types 0) ~'x00__) - (.invoke ~(tag (cstr `long>Object) 'defn-self-reference|__1|0) - ~'x00__) + ((Array/get ~'defn-self-reference|__1|types 0) ~'x00__) + (. defn-self-reference|__1 invoke ~'x00__) (unsupported! `defn-self-reference [~'x00__] 0)))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) - (eval '(do (is= (defn-self-reference) nil)))))) + (eval '(do (is= (defn-self-reference) 2.0)))))) (testing "`t/defn` references other `t/defn`" (let [actual (macroexpand ' From e206850deec81e895fa304a252e6f3f3a4e8c1b2 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 4 Nov 2018 09:08:36 -0700 Subject: [PATCH 629/810] Another test passes! --- .../quantum/untyped/core/analyze/ast.cljc | 1 + test/quantum/test/untyped/core/type/defnt.cljc | 18 +++++++++++------- 2 files changed, 12 insertions(+), 7 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 2bfe7e1a..c93562c9 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -25,6 +25,7 @@ [form t] (if (or (not (t/with-metable? form)) (utr/fn-type? t) + (utr/rx-type? t) ;; TODO for now (uxp/iexpr? t)) nil diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index e942d1e1..f91646d1 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1396,17 +1396,21 @@ (eval '(do (is= (defn-self-reference) 2.0)))))) (testing "`t/defn` references other `t/defn`" (let [actual - (macroexpand ' - (self/defn defn-reference - ([] (>long* 1)))) + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/defn defn-reference + ([> tt/long?] (>long* 1))))) expected (case (env-lang) :clj ($ (do (declare ~'defn-reference) - (def ~'defn-reference|__0|0 + (def ~(tag (cstr `>long) 'defn-reference|__0) (reify* [>long] (~(L 'invoke) [~'_0__] ~'(>long* 1)))) - (defn ~'defn-reference - {:quantum.core.type/type (t/fn t/any? [])} - ([] (.invoke ~(tag (cstr `>long) 'defn-reference|__0|0)))))))] + + [{:id 0 :index 0 :arg-types [] :output-type (t/isa? Long)}] + + (defmeta ~'defn-reference + {:quantum.core.type/type defn-reference|__type} + (fn* ([] (. defn-reference|__0 ~'invoke)))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) From 50d0c3654f636ae5fd076bfcd26e7730e5e049f9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 4 Nov 2018 09:17:48 -0700 Subject: [PATCH 630/810] Another test passes --- .../quantum/test/untyped/core/type/defnt.cljc | 120 +++++++++--------- 1 file changed, 61 insertions(+), 59 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index f91646d1..80fdf49e 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1799,65 +1799,67 @@ ;; ===== `extend-defn!` tests ===== ;; -(binding [self/*compilation-mode* :test] - (macroexpand ' - (self/defn extensible - ([a t/double?])))) - -;; Code -(do (declare ~'extensible) - - ;; We could keep a global map of defn-symbol to mapping, but if someone deletes the namespace - ;; the `t/defn` is interned in, that mapping should go away too. - ;; We only show this types decl because testing/debug is on. Otherwise the macro would just - ;; `intern` the var and define it there rather than re-evaluating the types. - (def ~'extensible|__types - (atom [{:id 0 :arg-types [(t/isa? Double)] :output-type t/any?}])) - - (def ~'extensible|__0|types (self/types-decl>arg-types ~'extensible|__types 0)) - (def ~'extensible|__0 (reify* [double>Object] (invoke [_0__ a] nil))) - - ;; Could have done `intern`+`fn*` but JS needs some special things for it to work that may - ;; change over time - (defn extensible - {:quantum.core.type/type (self/types-decl>ftype extensible|__types t/any?)} - ([~'x00__] - (ifs ((Array/get ~'extensible|__0|types 0) ~'x00__) - (. extensible|__0 invoke x00__) - (unsupported! `extensible [~'x00__] 0))))) - -(testing "Insertion" - (binding [self/*compilation-mode* :test] - (macroexpand ' - (self/extend-defn! extensible - ([a t/boolean?])))) - - (do ;; We only show this types decl because testing/debug is on. Otherwise the macro would just - ;; `reset!` the types decl outside the code rather than re-evaluating the types. - ;; To find where to put the overload, we find the first place where the inputs are `t/<`. - ;; TODO test that when testing/debug mode is off, it doesn't emit this code - (reset! quantum.test.untyped.core.type.defnt/extensible|__types - [{:name ~(tag ... 'extensible|__1) :arg-types [(t/isa? Boolean)] :output-type t/any?} - {:name ~(tag ... 'extensible|__0) :arg-types [(t/isa? Double)] :output-type t/any?}]) - - ;; It's labeled as `extensible|__1` but internally that's not how it's ordered; it's just - ;; incrementing based on the size of the types-decl - ;; Currently we can't undefine overloads which I think is fine - (def ~'extensible|__1|types - (self/types-decl>arg-types quantum.test.untyped.core.type.defnt/extensible|__types 0)) - (def ~'extensible|__1 (reify* [boolean>Object] (invoke [_0__ a] nil))) - ;; The dynamic dispatch is currently redefined with every `extend-defn!` - ;; We expect that `t/defn` extension will take place in only one thread - (intern 'quantum.test.untyped.core.type.defnt - (with-meta 'extensible - (assoc (meta (var quantum.test.untyped.core.type.defnt/extensible)) - :quantum.core.type/type (self/types-decl>ftype extensible|__types t/any?))) - (fn* ([~'x00__] - (ifs ((Array/get ~'extensible|__1|types 0) ~'x00__) - (. extensible|__1 invoke x00__) - ((Array/get ~'extensible|__0|types 0) ~'x00__) - (. extensible|__0 invoke x00__) - (unsupported! `extensible [~'x00__] 0))))))) +(deftest extend-defn!|test + (testing "definition" + (let [actual + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/defn extensible + ([a t/double?])))) + expected + (case (env-lang) + :clj ($ (do (declare ~'extensible) + (def ~(tag (cstr `double>Object) 'extensible|__0) + (reify* [double>Object] (~(O 'invoke) [~'_0__ ~(D 'a)] nil))) + + [{:id 0 :index 0 :arg-types [(t/isa? Double)] :output-type t/any?}] + + (defmeta ~'extensible + {:quantum.core.type/type extensible|__type} + (fn* ([~'x00__] + (ifs ((Array/get extensible|__0|types 0) ~'x00__) + (. extensible|__0 ~'invoke ~'x00__) + (unsupported! `extensible [~'x00__] 0))))))))] + (testing "code equivalence" (is-code= actual expected)) + (eval actual))) + (testing "extension" + (let [actual + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/extend-defn! extensible + ([a t/boolean?])))) + expected + (case (env-lang) + :clj ($ (do ...)))] + (testing "code equivalence" (is-code= actual expected)) + #_(eval actual)) + + (do ;; We only show this types decl because testing/debug is on. Otherwise the macro would just + ;; `reset!` the types decl outside the code rather than re-evaluating the types. + ;; To find where to put the overload, we find the first place where the inputs are `t/<`. + ;; TODO test that when testing/debug mode is off, it doesn't emit this code + (reset! quantum.test.untyped.core.type.defnt/extensible|__types + [{:name ~(tag ... 'extensible|__1) :arg-types [(t/isa? Boolean)] :output-type t/any?} + {:name ~(tag ... 'extensible|__0) :arg-types [(t/isa? Double)] :output-type t/any?}]) + + ;; It's labeled as `extensible|__1` but internally that's not how it's ordered; it's just + ;; incrementing based on the size of the types-decl + ;; Currently we can't undefine overloads which I think is fine + (def ~'extensible|__1|types + (self/types-decl>arg-types quantum.test.untyped.core.type.defnt/extensible|__types 0)) + (def ~'extensible|__1 (reify* [boolean>Object] (invoke [_0__ a] nil))) + ;; The dynamic dispatch is currently redefined with every `extend-defn!` + ;; We expect that `t/defn` extension will take place in only one thread + (intern 'quantum.test.untyped.core.type.defnt + (with-meta 'extensible + (assoc (meta (var quantum.test.untyped.core.type.defnt/extensible)) + :quantum.core.type/type (self/types-decl>ftype extensible|__types t/any?))) + (fn* ([~'x00__] + (ifs ((Array/get ~'extensible|__1|types 0) ~'x00__) + (. extensible|__1 invoke x00__) + ((Array/get ~'extensible|__0|types 0) ~'x00__) + (. extensible|__0 invoke x00__) + (unsupported! `extensible [~'x00__] 0)))))))) ;; ===== Reactive types ===== ;; From 5ad55570fcbec227544d2da9665300d93a0245a1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 4 Nov 2018 09:40:44 -0700 Subject: [PATCH 631/810] Fix a few errors in `extend-defn!` --- .../quantum/untyped/core/data/set.cljc | 2 +- .../quantum/untyped/core/type/defnt.cljc | 63 ++++++++++--------- 2 files changed, 36 insertions(+), 29 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/set.cljc b/src-untyped/quantum/untyped/core/data/set.cljc index af782d5c..7cf419f5 100644 --- a/src-untyped/quantum/untyped/core/data/set.cljc +++ b/src-untyped/quantum/untyped/core/data/set.cljc @@ -85,7 +85,7 @@ (defn comparison< [c] (identical? c = [c] (or (identical? c >ident) (identical? c =ident))) (defn comparison> [c] (identical? c >ident)) (defn comparison>< [c] (identical? c > with-do with-do-let]] @@ -877,9 +877,9 @@ (uc/filter+ some?) uc/first)] (assoc bases i|existing new-basis) - (conj bases new-basis)))) + (conj bases new-basis))) existing-bases - new-bases) + new-bases)) (defns- >!overload-bases "`!overload-bases` is a reactive atom updated by `t/extend-defn!`, which cannot be deleted from @@ -899,14 +899,15 @@ (->> current (uc/map (c/fn [basis] - {:arg-types|basis (->> basis :arg-types|basis (uc/map norx-deref)) - :output-type|basis (-> basis :output-type|basis norx-deref) + {:arg-types|basis (->> basis :arg-types|basis (uc/map ?norx-deref)) + :output-type|basis (-> basis :output-type|basis ?norx-deref) :types|split (:types|split basis) :body-codelist (:body-codelist basis) :dependent? (:dependent? basis) :reactive? (:reactive? basis)}))) :current (incorporate-overload-bases current overload-bases)})))) - (urx/! {:prev-norx nil :current overload-bases})))) + (with-do-let [!overload-bases (urx/! {:prev-norx nil :current overload-bases})] + (intern fn|ns-name fn|overload-bases-name !overload-bases))))) (defns- >!fn|types "`!fn|types` is a reaction which depends on the `!overload-bases` atom and all reactive types @@ -989,32 +990,38 @@ fn|output-type (eval fn|output-type|form) fn|overload-bases-name (symbol (str fn|name "|__bases")) fn|overload-types-name (symbol (str fn|name "|__types")) - fn|type-name (symbol (str fn|name "|__type"))] - {:fn|globals (kw-map fn|meta fn|name fn|ns-name fn|output-type|form fn|output-type - fn|overload-bases-name fn|overload-types-name fn|type-name) - :overload-bases-form overload-bases-form})))) + fn|type-name (symbol (str fn|name "|__type")) + fn|globals + (kw-map fn|meta fn|name fn|ns-name fn|output-type|form fn|output-type + fn|overload-bases-name fn|overload-types-name fn|type-name)] + (intern fn|ns-name fn|globals-name fn|globals) + (kw-map fn|globals overload-bases-form))))) ;; ===== Whole `t/(de)fn` creation ===== ;; (defns fn|code [kind ::kind, lang ::lang, compilation-mode ::compilation-mode, args _] - (let [opts (>fn|opts kind lang compilation-mode) - {:keys [fn|globals overload-bases-form]} (>fn|globals+?overload-bases-form kind args) - !overload-bases (>!overload-bases opts fn|globals overload-bases-form) - !fn|types (>!fn|types opts fn|globals !overload-bases) - !fn|type (>!fn|type opts fn|globals !fn|types)] - (if (empty? (norx-deref !overload-bases)) - `(declare ~(:fn|name fn|globals)) - (let [direct-dispatch (>direct-dispatch opts fn|globals !fn|types) - dynamic-dispatch (>dynamic-dispatch-fn|codelist opts fn|globals !fn|types) - fn-codelist - (->> `[;; For recursion - ~@(when (not= kind :extend-defn!) [`(declare ~(:fn|name fn|globals))]) - ~@(:form direct-dispatch) - ~@dynamic-dispatch] - (remove nil?))] - (case kind - :fn (TODO "Haven't done t/fn yet") - (:defn :extend-defn!) `(do ~@fn-codelist)))))) + (uerr/catch-all + (let [opts (>fn|opts kind lang compilation-mode) + {:keys [fn|globals overload-bases-form]} (>fn|globals+?overload-bases-form kind args) + !overload-bases (>!overload-bases opts fn|globals overload-bases-form) + !fn|types (>!fn|types opts fn|globals !overload-bases) + !fn|type (>!fn|type opts fn|globals !fn|types)] + (if (empty? (norx-deref !overload-bases)) + `(declare ~(:fn|name fn|globals)) + (let [direct-dispatch (>direct-dispatch opts fn|globals !fn|types) + dynamic-dispatch (>dynamic-dispatch-fn|codelist opts fn|globals !fn|types) + fn-codelist + (->> `[;; For recursion + ~@(when (not= kind :extend-defn!) [`(declare ~(:fn|name fn|globals))]) + ~@(:form direct-dispatch) + ~@dynamic-dispatch] + (remove nil?))] + (case kind + :fn (TODO "Haven't done t/fn yet") + (:defn :extend-defn!) `(do ~@fn-codelist))))) + t + (do (ulog/pr :error t) + (throw t)))) #?(:clj (defmacro fn From 548deca6eab0057a5751d4b0c92bc604b1aaf0c3 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 4 Nov 2018 10:18:26 -0700 Subject: [PATCH 632/810] The first `extend-defn!` test passes :D --- .../quantum/untyped/core/type/defnt.cljc | 24 ++++++---- .../quantum/test/untyped/core/type/defnt.cljc | 48 ++++++++----------- 2 files changed, 34 insertions(+), 38 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 728e44c8..f76269af 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -490,11 +490,13 @@ (or ;; We don't check changedness via `=` when checking type bases because it's possible ;; that a change in a reactive type might result in a change in how types are split, ;; which is hidden by a lack of change in basis type value. - (not== (-> overload-basis :output-type|basis deref) (:output-type|basis prev-basis)) + (not== (-> overload-basis :output-type|basis ?norx-deref) + (:output-type|basis prev-basis)) (->> overload-basis :arg-types|basis (uc/map-indexed+ - (c/fn [i|t t] (not== (deref t) (-> prev-basis :arg-types|basis (get i|t))))) + (c/fn [i|t t] (not== (?norx-deref t) + (-> prev-basis :arg-types|basis (get i|t))))) (seq-or true?)))))) (defns- establish-dependency-relations-on-new-overload-bases! @@ -740,16 +742,19 @@ body (>dynamic-dispatch|body-for-arity fn|globals overload-types-for-arity arglist)] (list arglist body))))) - fn|meta' (merge fn|meta {:quantum.core.type/type (uid/qualify fn|ns-name fn|type-name)})] + fn|meta' (merge fn|meta {:quantum.core.type/type (uid/qualify fn|ns-name fn|type-name)}) + overload-types|form + (when (= compilation-mode :test) + (->> !fn|types norx-deref :overload-types >form (uc/map (fn1 dissoc :ns-sym))))] ;; TODO determine whether CLJS needs (update-in m [:jsdoc] conj "@param {...*} var_args") (if (= kind :extend-defn!) - [`(let* [v# (intern (quote ~fn|ns-name) (quote ~fn|name) - ~(with-meta `(fn* ~@overload-forms) fn|meta'))] - (alter-meta! v# merge ~fn|meta'))] + [overload-types|form + `(doto (intern (quote ~fn|ns-name) (quote ~fn|name) + ~(with-meta `(fn* ~@overload-forms) fn|meta')) + (alter-meta! merge ~fn|meta'))] (let [dispatch-form `(uvar/defmeta ~fn|name ~fn|meta' (fn* ~@overload-forms))] (if (= compilation-mode :test) - [(->> !fn|types norx-deref :overload-types >form (uc/map (fn1 dissoc :ns-sym))) - dispatch-form] + [overload-types|form dispatch-form] [dispatch-form]))))) ;; ===== End dynamic dispatch ===== ;; @@ -975,7 +980,7 @@ fn|globals-name (symbol (str fn|name "|__globals"))] (if (= kind :extend-defn!) {:fn|globals (-> (uid/qualify fn|ns-name fn|globals-name) resolve var-get) - :overload-bases-form nil} + :overload-bases-form overload-bases-form} (let [inline? (-> (if (= kind :extend-defn!) (-> fn|var meta :inline) (:inline fn|meta)) @@ -1078,4 +1083,5 @@ #?(:clj (defmacro extend-defn! + "Currently undefining overloads is not possible." [& args] (fn|code :extend-defn! (ufeval/env-lang) *compilation-mode* args))) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 80fdf49e..dc258b56 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1830,36 +1830,26 @@ ([a t/boolean?])))) expected (case (env-lang) - :clj ($ (do ...)))] + :clj ($ (do (def ~(tag (cstr `boolean>Object) 'extensible|__1) + (reify* [boolean>Object] + (~(O 'invoke) [~'_0__ ~(B 'a)] nil))) + + [{:id 1 :index 0 :arg-types [(t/isa? Boolean)] :output-type t/any?} + {:id 0 :index 1 :arg-types [(t/isa? Double)] :output-type t/any?}] + + (doto (intern '~(ns-name *ns*) '~'extensible + ~(with-meta + `(fn* ([~'x00__] + (ifs ((Array/get extensible|__1|types 0) ~'x00__) + (. extensible|__1 ~'invoke ~'x00__) + ((Array/get extensible|__0|types 0) ~'x00__) + (. extensible|__0 ~'invoke ~'x00__) + (unsupported! `extensible [~'x00__] 0)))) + `{:quantum.core.type/type extensible|__type})) + (alter-meta! merge {:quantum.core.type/type extensible|__type})))))] (testing "code equivalence" (is-code= actual expected)) - #_(eval actual)) - - (do ;; We only show this types decl because testing/debug is on. Otherwise the macro would just - ;; `reset!` the types decl outside the code rather than re-evaluating the types. - ;; To find where to put the overload, we find the first place where the inputs are `t/<`. - ;; TODO test that when testing/debug mode is off, it doesn't emit this code - (reset! quantum.test.untyped.core.type.defnt/extensible|__types - [{:name ~(tag ... 'extensible|__1) :arg-types [(t/isa? Boolean)] :output-type t/any?} - {:name ~(tag ... 'extensible|__0) :arg-types [(t/isa? Double)] :output-type t/any?}]) - - ;; It's labeled as `extensible|__1` but internally that's not how it's ordered; it's just - ;; incrementing based on the size of the types-decl - ;; Currently we can't undefine overloads which I think is fine - (def ~'extensible|__1|types - (self/types-decl>arg-types quantum.test.untyped.core.type.defnt/extensible|__types 0)) - (def ~'extensible|__1 (reify* [boolean>Object] (invoke [_0__ a] nil))) - ;; The dynamic dispatch is currently redefined with every `extend-defn!` - ;; We expect that `t/defn` extension will take place in only one thread - (intern 'quantum.test.untyped.core.type.defnt - (with-meta 'extensible - (assoc (meta (var quantum.test.untyped.core.type.defnt/extensible)) - :quantum.core.type/type (self/types-decl>ftype extensible|__types t/any?))) - (fn* ([~'x00__] - (ifs ((Array/get ~'extensible|__1|types 0) ~'x00__) - (. extensible|__1 invoke x00__) - ((Array/get ~'extensible|__0|types 0) ~'x00__) - (. extensible|__0 invoke x00__) - (unsupported! `extensible [~'x00__] 0)))))))) + (eval actual)) + )) ;; ===== Reactive types ===== ;; From 62c8d8da759b7805c78429801b7504522d8d6e98 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 4 Nov 2018 10:32:14 -0700 Subject: [PATCH 633/810] New test passes --- .../quantum/untyped/core/type/defnt.cljc | 36 +++++++++++-------- .../quantum/test/untyped/core/type/defnt.cljc | 23 ++++++++++++ 2 files changed, 44 insertions(+), 15 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index f76269af..8edccb56 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -771,10 +771,7 @@ > ::overload-basis] (when pre-type|form (TODO "Need to handle pre")) (when varargs (TODO "Need to handle varargs")) - (let [arglist-form|unanalyzed (cond-> args varargs (conj '& varargs) - pre-type|form (conj '| pre-type|form) - output-type|form (conj '> output-type|form)) - arg-types|form (->> args (mapv (c/fn [{[kind #_#{:any :spec}, t #_t/form?] :spec}] + (let [arg-types|form (->> args (mapv (c/fn [{[kind #_#{:any :spec}, t #_t/form?] :spec}] (case kind :any `t/any? :spec t)))) output-type|form (case output-type|form _ `t/any? @@ -807,7 +804,10 @@ :arg-types|basis arg-types|basis ;; TODO Only needed if `dependent?` or if new :varargs-form (when varargs {varargs-binding nil}) ; TODO `nil` isn't right - :arglist-form|unanalyzed arglist-form|unanalyzed + :arglist-form|unanalyzed (cond-> (uc/cat args-form) + varargs (conj '& varargs) + pre-type|form (conj '| pre-type|form) + output-type|form (conj '> output-type|form)) ;; TODO Only needed if `dependent?` or if new :output-type|form output-type|form :output-type|basis output-type|basis @@ -841,7 +841,10 @@ (:arglist-form|unanalyzed new-basis)) (= (:body-codelist existing-basis) (:body-codelist new-basis)))] - i + (do (ulog/pr :warn + "Overwriting existing overload with same arglist and body" + {:arglist|form (:arglist-form|unanalyzed new-basis)}) + i) ;; This only checks for `=` because `t/=` will be deduped later on in ;; overloads, not overload bases ;; TODO this doesn't take into account `|` types @@ -852,11 +855,14 @@ (:dependent? new-basis)) (= (:types|split existing-basis) (:types|split new-basis)) - (and (= (:output-type existing-basis) - (:output-type new-basis)) - (= (:arg-types existing-basis) - (:arg-types new-basis)))))] - i + (and (= (:output-type|basis existing-basis) + (:output-type|basis new-basis)) + (= (:arg-types|basis existing-basis) + (:arg-types|basis new-basis)))))] + (do (ulog/pr :warn "Overwriting existing overload with same types" + {:arglist|form|prev (:arglist-form|unanalyzed existing-basis) + :arglist|form (:arglist-form|unanalyzed new-basis)}) + i) ;; TODO enhance this; figure out how to effectively compare reactive ;; and dependent types, if that's even possible ;; TODO maybe we don't even want this; maybe this should be based on @@ -869,10 +875,10 @@ (:dependent? new-basis)) (= (:types|split existing-basis) (:types|split new-basis)) - (= (-> existing-basis :output-type ?norx-deref) - (-> new-basis :output-type ?norx-deref)) - (= (-> existing-basis :arg-types ?norx-deref) - (-> new-basis :arg-types ?norx-deref)))] + (= (-> existing-basis :output-type|basis ?norx-deref) + (-> new-basis :output-type|basis ?norx-deref)) + (= (-> existing-basis :arg-types|basis ?norx-deref) + (-> new-basis :arg-types|basis ?norx-deref)))] (ulog/pr :warn (str "Assuming that new reactive overload basis is a subsequent " "version of existing reactive overload basis") diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index dc258b56..a06c610d 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1848,6 +1848,29 @@ `{:quantum.core.type/type extensible|__type})) (alter-meta! merge {:quantum.core.type/type extensible|__type})))))] (testing "code equivalence" (is-code= actual expected)) + (eval actual))) + (testing "re-extension" + ;; TODO figure out whether we just want to have nothing happen, or whether we want to re-evaluate + (let [actual + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/extend-defn! extensible ([a t/boolean?])))) + expected + (case (env-lang) + :clj ($ (do [{:id 1 :index 0 :arg-types [(t/isa? Boolean)] :output-type t/any?} + {:id 0 :index 1 :arg-types [(t/isa? Double)] :output-type t/any?}] + + (doto (intern '~(ns-name *ns*) '~'extensible + ~(with-meta + `(fn* ([~'x00__] + (ifs ((Array/get extensible|__1|types 0) ~'x00__) + (. extensible|__1 ~'invoke ~'x00__) + ((Array/get extensible|__0|types 0) ~'x00__) + (. extensible|__0 ~'invoke ~'x00__) + (unsupported! `extensible [~'x00__] 0)))) + `{:quantum.core.type/type extensible|__type})) + (alter-meta! merge {:quantum.core.type/type extensible|__type})))))] + (testing "code equivalence" (is-code= actual expected)) (eval actual)) )) From 0538eeb6045c2aac885abc3c7925fed724fca3f8 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 6 Nov 2018 10:54:50 -0700 Subject: [PATCH 634/810] Correct input type sorting --- src-untyped/quantum/untyped/core/type/defnt.cljc | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 8edccb56..7465f312 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -272,10 +272,7 @@ (reduce-2 (c/fn [^long c t0 t1] (let [c' (long (compare-arg-types t0 t1))] - (case c' - -1 (case c 1 (reduced 0) c') - 0 c - 1 (case c -1 (reduced 0) c')))) + (if (zero? c') c' (reduced c')))) 0 arg-types0 arg-types1) ct-comparison))) From ce2779a718e24e2b11d994186b90e19eb0e7c64e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 6 Nov 2018 10:55:15 -0700 Subject: [PATCH 635/810] Complex dependent type test passes! --- test/quantum/test/untyped/core/analyze.cljc | 2 +- .../quantum/test/untyped/core/type/defnt.cljc | 478 ++++++++++++++---- 2 files changed, 374 insertions(+), 106 deletions(-) diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index 12ec45ef..6ef95601 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -20,7 +20,7 @@ ;; Simulates a typed fn (defn- >long-checked {:quantum.core.type/type (t/rx (t/ftype nil [t/string? :> tt/long?]))} []) -(defn- dummy {:quantum.core.type/type (t/rx (t/or tt/short? tt/char?))} []) +(defn- dummy {:quantum.core.type/type (t/rx (t/ftype nil [(t/or tt/short? tt/char?)]))} []) (defn- transform-ana [ana] (->> ana diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index a06c610d..56fe0d2a 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1426,30 +1426,7 @@ nil))) (deftest dependent-type-test - (testing "t/type" - (let [actual - (macroexpand ' - (self/defn type-test - #_"1. Analyze `a` = `(t/type (>long-checked \"23\"))` - 1. Analyze `(>long-checked \"23\")` - -> `(t/value 23)` - -> Put `out` in env as `(t/value 23)`" - [out (t/type (>long-checked "23"))] - (self/fn type-test-inner - ([a (t/or tt/boolean? (t/type b)) - b (t/or tt/byte? (t/type d)) - c (t/or tt/short? tt/char?) - d (let [b (t/- tt/char? tt/long?)] - (t/or tt/char? (t/type b) (t/type c))) - > (t/or (t/type b) (t/type d))] b)))) - expected - (case (env-lang) - :clj - ($ (do ...)))] - (testing "code equivalence" (is-code= actual expected)) - (testing "functionality" - (eval actual) - (eval '(do ...))))) + (testing "t/type") ;; tested in `extend-defn!` test (testing "t/input-type" (let [actual (macroexpand ' @@ -1799,91 +1776,382 @@ ;; ===== `extend-defn!` tests ===== ;; +(def dependent-extensible|direct-dispatch|codelist + `[(def ~(tag (cstr `boolean+byte+short+short>Object) 'dependent-extensible|__0) + (reify* [boolean+byte+short+short>Object] + (~(O 'invoke) [~'_0__ ~(B 'a) ~(Y 'b) ~(S 'c) ~(S 'd)] 1))) + (def ~(tag (cstr `boolean+byte+short+char>Object) 'dependent-extensible|__1) + (reify* [boolean+byte+short+char>Object] + (~(O 'invoke) [~'_1__ ~(B 'a) ~(Y 'b) ~(S 'c) ~(C 'd)] 1))) + (def ~(tag (cstr `boolean+byte+short+Object>Object) 'dependent-extensible|__2) + (reify* [boolean+byte+short+Object>Object] + (~(O 'invoke) [~'_2__ ~(B 'a) ~(Y 'b) ~(S 'c) ~(O 'd)] 1))) + (def ~(tag (cstr `boolean+byte+Object+char>Object) 'dependent-extensible|__3) + (reify* [boolean+byte+Object+char>Object] + (~(O 'invoke) [~'_3__ ~(B 'a) ~(Y 'b) ~(O 'c) ~(C 'd)] 1))) + (def ~(tag (cstr `boolean+byte+Object+Object>Object) 'dependent-extensible|__4) + (reify* [boolean+byte+Object+Object>Object] + (~(O 'invoke) [~'_4__ ~(B 'a) ~(Y 'b) ~(O 'c) ~(O 'd)] 1))) + (def ~(tag (cstr `boolean+byte+Object+Object>Object) 'dependent-extensible|__5) + (reify* [boolean+byte+Object+Object>Object] + (~(O 'invoke) [~'_5__ ~(B 'a) ~(Y 'b) ~(O 'c) ~(O 'd)] 1))) + (def ~(tag (cstr `boolean+short+short+short>Object) 'dependent-extensible|__6) + (reify* [boolean+short+short+short>Object] + (~(O 'invoke) [~'_6__ ~(B 'a) ~(S 'b) ~(S 'c) ~(S 'd)] 1))) + (def ~(tag (cstr `boolean+char+short+char>Object) 'dependent-extensible|__7) + (reify* [boolean+char+short+char>Object] + (~(O 'invoke) [~'_7__ ~(B 'a) ~(C 'b) ~(S 'c) ~(C 'd)] 1))) + (def ~(tag (cstr `boolean+char+Object+char>Object) 'dependent-extensible|__8) + (reify* [boolean+char+Object+char>Object] + (~(O 'invoke) [~'_8__ ~(B 'a) ~(C 'b) ~(O 'c) ~(C 'd)] 1))) + (def ~(tag (cstr `boolean+Object+short+Object>Object) 'dependent-extensible|__9) + (reify* [boolean+Object+short+Object>Object] + (~(O 'invoke) [~'_9__ ~(B 'a) ~(O 'b) ~(S 'c) ~(O 'd)] 1))) + (def ~(tag (cstr `boolean+Object+Object+Object>Object) 'dependent-extensible|__10) + (reify* [boolean+Object+Object+Object>Object] + (~(O 'invoke) [~'_10__ ~(B 'a) ~(O 'b) ~(O 'c) ~(O 'd)] 1))) + (def ~(tag (cstr `boolean+Object+Object+Object>Object) 'dependent-extensible|__11) + (reify* [boolean+Object+Object+Object>Object] + (~(O 'invoke) [~'_11__ ~(B 'a) ~(O 'b) ~(O 'c) ~(O 'd)] 1))) + (def ~(tag (cstr `byte+byte+short+short>Object) 'dependent-extensible|__12) + (reify* [byte+byte+short+short>Object] + (~(O 'invoke) [~'_12__ ~(Y 'a) ~(Y 'b) ~(S 'c) ~(S 'd)] 1))) + (def ~(tag (cstr `byte+byte+short+char>Object) 'dependent-extensible|__13) + (reify* [byte+byte+short+char>Object] + (~(O 'invoke) [~'_13__ ~(Y 'a) ~(Y 'b) ~(S 'c) ~(C 'd)] 1))) + (def ~(tag (cstr `byte+byte+short+Object>Object) 'dependent-extensible|__14) + (reify* [byte+byte+short+Object>Object] + (~(O 'invoke) [~'_14__ ~(Y 'a) ~(Y 'b) ~(S 'c) ~(O 'd)] 1))) + (def ~(tag (cstr `byte+byte+Object+char>Object) 'dependent-extensible|__15) + (reify* [byte+byte+Object+char>Object] + (~(O 'invoke) [~'_15__ ~(Y 'a) ~(Y 'b) ~(O 'c) ~(C 'd)] 1))) + (def ~(tag (cstr `byte+byte+Object+Object>Object) 'dependent-extensible|__16) + (reify* [byte+byte+Object+Object>Object] + (~(O 'invoke) [~'_16__ ~(Y 'a) ~(Y 'b) ~(O 'c) ~(O 'd)] 1))) + (def ~(tag (cstr `byte+byte+Object+Object>Object) 'dependent-extensible|__17) + (reify* [byte+byte+Object+Object>Object] + (~(O 'invoke) [~'_17__ ~(Y 'a) ~(Y 'b) ~(O 'c) ~(O 'd)] 1))) + (def ~(tag (cstr `short+short+short+short>Object) 'dependent-extensible|__18) + (reify* [short+short+short+short>Object] + (~(O 'invoke) [~'_18__ ~(S 'a) ~(S 'b) ~(S 'c) ~(S 'd)] 1))) + (def ~(tag (cstr `char+char+short+char>Object) 'dependent-extensible|__19) + (reify* [char+char+short+char>Object] + (~(O 'invoke) [~'_19__ ~(C 'a) ~(C 'b) ~(S 'c) ~(C 'd)] 1))) + (def ~(tag (cstr `char+char+Object+char>Object) 'dependent-extensible|__20) + (reify* [char+char+Object+char>Object] + (~(O 'invoke) [~'_20__ ~(C 'a) ~(C 'b) ~(O 'c) ~(C 'd)] 1))) + (def ~(tag (cstr `Object+Object+short+Object>Object) 'dependent-extensible|__21) + (reify* [Object+Object+short+Object>Object] + (~(O 'invoke) [~'_21__ ~(O 'a) ~(O 'b) ~(S 'c) ~(O 'd)] 1))) + (def ~(tag (cstr `Object+Object+Object+Object>Object) 'dependent-extensible|__22) + (reify* [Object+Object+Object+Object>Object] + (~(O 'invoke) [~'_22__ ~(O 'a) ~(O 'b) ~(O 'c) ~(O 'd)] 1))) + (def ~(tag (cstr `Object+Object+Object+Object>Object) 'dependent-extensible|__23) + (reify* [Object+Object+Object+Object>Object] + (~(O 'invoke) [~'_23__ ~(O 'a) ~(O 'b) ~(O 'c) ~(O 'd)] 1)))]) + (deftest extend-defn!|test - (testing "definition" - (let [actual - (binding [self/*compilation-mode* :test] - (macroexpand ' - (self/defn extensible - ([a t/double?])))) - expected - (case (env-lang) - :clj ($ (do (declare ~'extensible) - (def ~(tag (cstr `double>Object) 'extensible|__0) - (reify* [double>Object] (~(O 'invoke) [~'_0__ ~(D 'a)] nil))) - - [{:id 0 :index 0 :arg-types [(t/isa? Double)] :output-type t/any?}] - - (defmeta ~'extensible - {:quantum.core.type/type extensible|__type} - (fn* ([~'x00__] - (ifs ((Array/get extensible|__0|types 0) ~'x00__) - (. extensible|__0 ~'invoke ~'x00__) - (unsupported! `extensible [~'x00__] 0))))))))] - (testing "code equivalence" (is-code= actual expected)) - (eval actual))) - (testing "extension" - (let [actual - (binding [self/*compilation-mode* :test] - (macroexpand ' - (self/extend-defn! extensible - ([a t/boolean?])))) - expected - (case (env-lang) - :clj ($ (do (def ~(tag (cstr `boolean>Object) 'extensible|__1) - (reify* [boolean>Object] - (~(O 'invoke) [~'_0__ ~(B 'a)] nil))) - - [{:id 1 :index 0 :arg-types [(t/isa? Boolean)] :output-type t/any?} - {:id 0 :index 1 :arg-types [(t/isa? Double)] :output-type t/any?}] - - (doto (intern '~(ns-name *ns*) '~'extensible - ~(with-meta - `(fn* ([~'x00__] - (ifs ((Array/get extensible|__1|types 0) ~'x00__) - (. extensible|__1 ~'invoke ~'x00__) - ((Array/get extensible|__0|types 0) ~'x00__) - (. extensible|__0 ~'invoke ~'x00__) - (unsupported! `extensible [~'x00__] 0)))) - `{:quantum.core.type/type extensible|__type})) - (alter-meta! merge {:quantum.core.type/type extensible|__type})))))] - (testing "code equivalence" (is-code= actual expected)) - (eval actual))) - (testing "re-extension" - ;; TODO figure out whether we just want to have nothing happen, or whether we want to re-evaluate - (let [actual - (binding [self/*compilation-mode* :test] - (macroexpand ' - (self/extend-defn! extensible ([a t/boolean?])))) - expected - (case (env-lang) - :clj ($ (do [{:id 1 :index 0 :arg-types [(t/isa? Boolean)] :output-type t/any?} - {:id 0 :index 1 :arg-types [(t/isa? Double)] :output-type t/any?}] - - (doto (intern '~(ns-name *ns*) '~'extensible - ~(with-meta - `(fn* ([~'x00__] - (ifs ((Array/get extensible|__1|types 0) ~'x00__) - (. extensible|__1 ~'invoke ~'x00__) - ((Array/get extensible|__0|types 0) ~'x00__) - (. extensible|__0 ~'invoke ~'x00__) - (unsupported! `extensible [~'x00__] 0)))) - `{:quantum.core.type/type extensible|__type})) - (alter-meta! merge {:quantum.core.type/type extensible|__type})))))] - (testing "code equivalence" (is-code= actual expected)) - (eval actual)) - )) + (testing "simple test" + (testing "definition" + (let [actual + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/defn extensible + ([a t/double?])))) + expected + (case (env-lang) + :clj ($ (do (declare ~'extensible) + (def ~(tag (cstr `double>Object) 'extensible|__0) + (reify* [double>Object] (~(O 'invoke) [~'_0__ ~(D 'a)] nil))) + + [{:id 0 :index 0 :arg-types [(t/isa? Double)] :output-type t/any?}] + + (defmeta ~'extensible + {:quantum.core.type/type extensible|__type} + (fn* ([~'x00__] + (ifs ((Array/get extensible|__0|types 0) ~'x00__) + (. extensible|__0 ~'invoke ~'x00__) + (unsupported! `extensible [~'x00__] 0))))))))] + (testing "code equivalence" (is-code= actual expected)) + (eval actual))) + (testing "extension" + (let [actual + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/extend-defn! extensible + ([a t/boolean?])))) + expected + (case (env-lang) + :clj ($ (do (def ~(tag (cstr `boolean>Object) 'extensible|__1) + (reify* [boolean>Object] + (~(O 'invoke) [~'_0__ ~(B 'a)] nil))) + + [{:id 1 :index 0 :arg-types [(t/isa? Boolean)] :output-type t/any?} + {:id 0 :index 1 :arg-types [(t/isa? Double)] :output-type t/any?}] + + (doto (intern '~(ns-name *ns*) '~'extensible + ~(with-meta + `(fn* ([~'x00__] + (ifs ((Array/get extensible|__1|types 0) ~'x00__) + (. extensible|__1 ~'invoke ~'x00__) + ((Array/get extensible|__0|types 0) ~'x00__) + (. extensible|__0 ~'invoke ~'x00__) + (unsupported! `extensible [~'x00__] 0)))) + `{:quantum.core.type/type extensible|__type})) + (alter-meta! merge + {:quantum.core.type/type extensible|__type})))))] + (testing "code equivalence" (is-code= actual expected)) + (eval actual))) + (testing "re-extension" + ;; TODO figure out whether we just want to have nothing happen, or whether we want to + ;; re-evaluate + (let [actual + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/extend-defn! extensible ([a t/boolean?])))) + expected + (case (env-lang) + :clj ($ (do [{:id 1 :index 0 :arg-types [(t/isa? Boolean)] :output-type t/any?} + {:id 0 :index 1 :arg-types [(t/isa? Double)] :output-type t/any?}] + + (doto (intern '~(ns-name *ns*) '~'extensible + ~(with-meta + `(fn* ([~'x00__] + (ifs ((Array/get extensible|__1|types 0) ~'x00__) + (. extensible|__1 ~'invoke ~'x00__) + ((Array/get extensible|__0|types 0) ~'x00__) + (. extensible|__0 ~'invoke ~'x00__) + (unsupported! `extensible [~'x00__] 0)))) + `{:quantum.core.type/type extensible|__type})) + (alter-meta! merge + {:quantum.core.type/type extensible|__type})))))] + (testing "code equivalence" (is-code= actual expected)) + (eval actual)))) + (testing "dependent type" + (testing "definition" + (let [actual + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/defn dependent-extensible + [a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) + c (t/or tt/short? tt/string?) + d (let [b (t/- tt/int? tt/long?)] + (t/or tt/char? (t/type b) (t/type c))) + > (t/or (t/type b) (t/type d) tt/long?)] 1))) + expected + (case (env-lang) + :clj + ($ (do (declare ~'dependent-extensible) + ~@dependent-extensible|direct-dispatch|codelist + [{:id 0 :index 0 + :arg-types [(t/isa? Boolean) (t/isa? Byte) (t/isa? Short) (t/isa? Short)] + :output-type (t/or (t/isa? Byte) (t/isa? Short) (t/isa? Long))} + {:id 1 :index 1 + :arg-types [(t/isa? Boolean) (t/isa? Byte) (t/isa? Short) (t/isa? Character)] + :output-type (t/or (t/isa? Byte) (t/isa? Character) (t/isa? Long))} + {:id 2 :index 2 + :arg-types [(t/isa? Boolean) (t/isa? Byte) (t/isa? Short) + (t/value (t/isa? Integer))] + :output-type (t/or (t/isa? Byte) (t/value (t/isa? Integer)) (t/isa? Long))} + {:id 3 :index 3 + :output-type (t/or (t/isa? Byte) (t/isa? Character) (t/isa? Long)) + :arg-types [(t/isa? Boolean) (t/isa? Byte) (t/isa? String) (t/isa? Character)]} + {:id 4 :index 4 + :arg-types [(t/isa? Boolean) (t/isa? Byte) (t/isa? String) + (t/value (t/isa? Integer))] + :output-type (t/or (t/isa? Byte) (t/value (t/isa? Integer)) (t/isa? Long))} + {:id 5 :index 5 + :arg-types [(t/isa? Boolean) (t/isa? Byte) (t/isa? String) (t/isa? String)] + :output-type (t/or (t/isa? Byte) (t/isa? String) (t/isa? Long))} + {:id 6 :index 6 + :arg-types [(t/isa? Boolean) (t/isa? Short) (t/isa? Short) (t/isa? Short)] + :output-type (t/or (t/isa? Short) (t/isa? Long))} + {:id 7 :index 7 + :arg-types [(t/isa? Boolean) (t/isa? Character) (t/isa? Short) + (t/isa? Character)] + :output-type (t/or (t/isa? Character) (t/isa? Long))} + {:id 8 :index 8 + :arg-types [(t/isa? Boolean) (t/isa? Character) (t/isa? String) + (t/isa? Character)] + :output-type (t/or (t/isa? Character) (t/isa? Long))} + {:id 9 :index 9 + :arg-types [(t/isa? Boolean) (t/value (t/isa? Integer)) (t/isa? Short) + (t/value (t/isa? Integer))] + :output-type (t/or (t/value (t/isa? Integer)) (t/isa? Long))} + {:id 10 :index 10 + :arg-types [(t/isa? Boolean) (t/value (t/isa? Integer)) (t/isa? String) + (t/value (t/isa? Integer))] + :output-type (t/or (t/value (t/isa? Integer)) (t/isa? Long))} + {:id 11 :index 11 + :arg-types [(t/isa? Boolean) (t/isa? String) (t/isa? String) (t/isa? String)] + :output-type (t/or (t/isa? String) (t/isa? Long))} + {:id 12 :index 12 + :arg-types [(t/isa? Byte) (t/isa? Byte) (t/isa? Short) (t/isa? Short)] + :output-type (t/or (t/isa? Byte) (t/isa? Short) (t/isa? Long))} + {:id 13 :index 13 + :arg-types [(t/isa? Byte) (t/isa? Byte) (t/isa? Short) (t/isa? Character)] + :output-type (t/or (t/isa? Byte) (t/isa? Character) (t/isa? Long))} + {:id 14 :index 14 + :arg-types [(t/isa? Byte) (t/isa? Byte) (t/isa? Short) + (t/value (t/isa? Integer))] + :output-type (t/or (t/isa? Byte) (t/value (t/isa? Integer)) (t/isa? Long))} + {:id 15 :index 15 + :arg-types [(t/isa? Byte) (t/isa? Byte) (t/isa? String) (t/isa? Character)] + :output-type (t/or (t/isa? Byte) (t/isa? Character) (t/isa? Long))} + {:id 16 :index 16 + :arg-types [(t/isa? Byte) (t/isa? Byte) (t/isa? String) + (t/value (t/isa? Integer))] + :output-type (t/or (t/isa? Byte) (t/value (t/isa? Integer)) (t/isa? Long))} + {:id 17 :index 17 + :arg-types [(t/isa? Byte) (t/isa? Byte) (t/isa? String) (t/isa? String)] + :output-type (t/or (t/isa? Byte) (t/isa? String) (t/isa? Long))} + {:id 18 :index 18 + :arg-types [(t/isa? Short) (t/isa? Short) (t/isa? Short) (t/isa? Short)] + :output-type (t/or (t/isa? Short) (t/isa? Long))} + {:id 19 :index 19 + :arg-types [(t/isa? Character) (t/isa? Character) (t/isa? Short) + (t/isa? Character)] + :output-type (t/or (t/isa? Character) (t/isa? Long))} + {:id 20 :index 20 + :arg-types [(t/isa? Character) (t/isa? Character) (t/isa? String) + (t/isa? Character)] + :output-type (t/or (t/isa? Character) (t/isa? Long))} + {:id 21 :index 21 + :arg-types [(t/value (t/isa? Integer)) (t/value (t/isa? Integer)) + (t/isa? Short) (t/value (t/isa? Integer))] + :output-type (t/or (t/value (t/isa? Integer)) (t/isa? Long))} + {:id 22 :index 22 + :arg-types [(t/value (t/isa? Integer)) (t/value (t/isa? Integer)) + (t/isa? String) (t/value (t/isa? Integer))] + :output-type (t/or (t/value (t/isa? Integer)) (t/isa? Long))} + {:id 23 :index 23 + :arg-types [(t/isa? String) (t/isa? String) (t/isa? String) (t/isa? String)] + :output-type (t/or (t/isa? String) (t/isa? Long))}] + (defmeta ~'dependent-extensible + {:quantum.core.type/type dependent-extensible|__type} + (fn* ([~'x00__ ~'x10__ ~'x20__ ~'x30__] + (ifs ((Array/get dependent-extensible|__0|types 0) ~'x00__) + (ifs ((Array/get dependent-extensible|__0|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__0|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__0|types 3) ~'x30__) + (. dependent-extensible|__0 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + ((Array/get dependent-extensible|__1|types 3) ~'x30__) + (. dependent-extensible|__1 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + ((Array/get dependent-extensible|__2|types 3) ~'x30__) + (. dependent-extensible|__2 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + ((Array/get dependent-extensible|__3|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__3|types 3) ~'x30__) + (. dependent-extensible|__3 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + ((Array/get dependent-extensible|__4|types 3) ~'x30__) + (. dependent-extensible|__4 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + ((Array/get dependent-extensible|__5|types 3) ~'x30__) + (. dependent-extensible|__5 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + ((Array/get dependent-extensible|__6|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__6|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__6|types 3) ~'x30__) + (. dependent-extensible|__6 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + ((Array/get dependent-extensible|__7|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__7|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__7|types 3) ~'x30__) + (. dependent-extensible|__7 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + ((Array/get dependent-extensible|__8|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__8|types 3) ~'x30__) + (. dependent-extensible|__8 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + ((Array/get dependent-extensible|__9|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__9|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__9|types 3) ~'x30__) + (. dependent-extensible|__9 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + ((Array/get dependent-extensible|__10|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__10|types 3) ~'x30__) + (. dependent-extensible|__10 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + ((Array/get dependent-extensible|__11|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__11|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__11|types 3) ~'x30__) + (. dependent-extensible|__11 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 1)) + ((Array/get dependent-extensible|__12|types 0) ~'x00__) + (ifs ((Array/get dependent-extensible|__12|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__12|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__12|types 3) ~'x30__) + (. dependent-extensible|__12 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + ((Array/get dependent-extensible|__13|types 3) ~'x30__) + (. dependent-extensible|__13 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + ((Array/get dependent-extensible|__14|types 3) ~'x30__) + (. dependent-extensible|__14 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + ((Array/get dependent-extensible|__15|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__15|types 3) ~'x30__) + (. dependent-extensible|__15 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + ((Array/get dependent-extensible|__16|types 3) ~'x30__) + (. dependent-extensible|__16 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + ((Array/get dependent-extensible|__17|types 3) ~'x30__) + (. dependent-extensible|__17 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 1)) + ((Array/get dependent-extensible|__18|types 0) ~'x00__) + (ifs ((Array/get dependent-extensible|__18|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__18|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__18|types 3) ~'x30__) + (. dependent-extensible|__18 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 1)) + ((Array/get dependent-extensible|__19|types 0) ~'x00__) + (ifs ((Array/get dependent-extensible|__19|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__19|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__19|types 3) ~'x30__) + (. dependent-extensible|__19 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + ((Array/get dependent-extensible|__20|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__20|types 3) ~'x30__) + (. dependent-extensible|__20 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 1)) + ((Array/get dependent-extensible|__21|types 0) ~'x00__) + (ifs ((Array/get dependent-extensible|__21|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__21|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__21|types 3) ~'x30__) + (. dependent-extensible|__21 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + ((Array/get dependent-extensible|__22|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__22|types 3) ~'x30__) + (. dependent-extensible|__22 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 1)) + ((Array/get dependent-extensible|__23|types 0) ~'x00__) + (ifs ((Array/get dependent-extensible|__23|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__23|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__23|types 3) ~'x30__) + (. dependent-extensible|__23 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 1)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 0))))))))] + (testing "code equivalence" (is-code= actual expected)) + (eval actual))))) + +(self/extend-defn! dependent-extensible + ([] 5)) ;; ===== Reactive types ===== ;; -- We need to store the forms of the overloads that are reactive and re-split the whole overload - every time to get dependent types right without messing up existing logic too much - - Also this is easier anyway. We'll have to see about performance -- `t/fn`s should either disallow reactive types or norx-deref them (at least for now) -- Redefining should empty the `watching` (so no reactivity happens) but keep the reference - - - ([a (t/or tt/boolean? (t/type b)) b (t/or tt/byte? (t/type d)) c (t/or tt/short? tt/string?) From 4400ac02cc5828c5b425e55ab06942ef7e12acda Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 6 Nov 2018 20:57:14 -0700 Subject: [PATCH 636/810] Ensure single-split reactive types get norx-derefed --- src-untyped/quantum/untyped/core/analyze.cljc | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 2a193344..0d983a1a 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -1015,7 +1015,8 @@ [(:type analyzed)])] (if (-> t-split count (= 1)) (recur (-> env-analyzed - (update-in [:opts :arg-env] #(doto % (swap! assoc arg-sym analyzed))) + (update-in [:opts :arg-env] + #(doto % (swap! assoc arg-sym (assoc analyzed :type (first t-split))))) enqueue-first-unanalyzed-if-queue-empty)) (->> t-split (uc/mapcat+ From c768bb10d36dd0b7468723e3ecedf0fccf7c1302 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 6 Nov 2018 20:57:29 -0700 Subject: [PATCH 637/810] Add more to tests --- .../quantum/test/untyped/core/type/defnt.cljc | 297 ++++++++++-------- 1 file changed, 169 insertions(+), 128 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 56fe0d2a..acb93696 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1850,6 +1850,122 @@ (reify* [Object+Object+Object+Object>Object] (~(O 'invoke) [~'_23__ ~(O 'a) ~(O 'b) ~(O 'c) ~(O 'd)] 1)))]) +(def dependent-extensible|fn|form + `(fn* ([~'x00__ ~'x10__ ~'x20__ ~'x30__] + (ifs ((Array/get dependent-extensible|__0|types 0) ~'x00__) + (ifs ((Array/get dependent-extensible|__0|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__0|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__0|types 3) ~'x30__) + (. dependent-extensible|__0 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + ((Array/get dependent-extensible|__1|types 3) ~'x30__) + (. dependent-extensible|__1 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + ((Array/get dependent-extensible|__2|types 3) ~'x30__) + (. dependent-extensible|__2 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + ((Array/get dependent-extensible|__3|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__3|types 3) ~'x30__) + (. dependent-extensible|__3 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + ((Array/get dependent-extensible|__4|types 3) ~'x30__) + (. dependent-extensible|__4 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + ((Array/get dependent-extensible|__5|types 3) ~'x30__) + (. dependent-extensible|__5 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + ((Array/get dependent-extensible|__6|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__6|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__6|types 3) ~'x30__) + (. dependent-extensible|__6 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + ((Array/get dependent-extensible|__7|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__7|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__7|types 3) ~'x30__) + (. dependent-extensible|__7 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + ((Array/get dependent-extensible|__8|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__8|types 3) ~'x30__) + (. dependent-extensible|__8 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + ((Array/get dependent-extensible|__9|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__9|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__9|types 3) ~'x30__) + (. dependent-extensible|__9 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + ((Array/get dependent-extensible|__10|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__10|types 3) ~'x30__) + (. dependent-extensible|__10 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + ((Array/get dependent-extensible|__11|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__11|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__11|types 3) ~'x30__) + (. dependent-extensible|__11 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 1)) + ((Array/get dependent-extensible|__12|types 0) ~'x00__) + (ifs ((Array/get dependent-extensible|__12|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__12|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__12|types 3) ~'x30__) + (. dependent-extensible|__12 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + ((Array/get dependent-extensible|__13|types 3) ~'x30__) + (. dependent-extensible|__13 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + ((Array/get dependent-extensible|__14|types 3) ~'x30__) + (. dependent-extensible|__14 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + ((Array/get dependent-extensible|__15|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__15|types 3) ~'x30__) + (. dependent-extensible|__15 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + ((Array/get dependent-extensible|__16|types 3) ~'x30__) + (. dependent-extensible|__16 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + ((Array/get dependent-extensible|__17|types 3) ~'x30__) + (. dependent-extensible|__17 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 1)) + ((Array/get dependent-extensible|__18|types 0) ~'x00__) + (ifs ((Array/get dependent-extensible|__18|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__18|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__18|types 3) ~'x30__) + (. dependent-extensible|__18 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 1)) + ((Array/get dependent-extensible|__19|types 0) ~'x00__) + (ifs ((Array/get dependent-extensible|__19|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__19|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__19|types 3) ~'x30__) + (. dependent-extensible|__19 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + ((Array/get dependent-extensible|__20|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__20|types 3) ~'x30__) + (. dependent-extensible|__20 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 1)) + ((Array/get dependent-extensible|__21|types 0) ~'x00__) + (ifs ((Array/get dependent-extensible|__21|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__21|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__21|types 3) ~'x30__) + (. dependent-extensible|__21 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + ((Array/get dependent-extensible|__22|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__22|types 3) ~'x30__) + (. dependent-extensible|__22 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 1)) + ((Array/get dependent-extensible|__23|types 0) ~'x00__) + (ifs ((Array/get dependent-extensible|__23|types 1) ~'x10__) + (ifs ((Array/get dependent-extensible|__23|types 2) ~'x20__) + (ifs ((Array/get dependent-extensible|__23|types 3) ~'x30__) + (. dependent-extensible|__23 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 1)) + (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 0))))) + (deftest extend-defn!|test (testing "simple test" (testing "definition" @@ -1930,15 +2046,16 @@ (testing "dependent type" (testing "definition" (let [actual - (binding [self/*compilation-mode* :test] - (macroexpand ' - (self/defn dependent-extensible - [a (t/or tt/boolean? (t/type b)) - b (t/or tt/byte? (t/type d)) - c (t/or tt/short? tt/string?) - d (let [b (t/- tt/int? tt/long?)] - (t/or tt/char? (t/type b) (t/type c))) - > (t/or (t/type b) (t/type d) tt/long?)] 1))) + (doto (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/defn dependent-extensible + [a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) + c (t/or tt/short? tt/string?) + d (let [b (t/- tt/int? tt/long?)] + (t/or tt/char? (t/type b) (t/type c))) + > (t/or (t/type b) (t/type d) tt/long?)] 1))) + eval) expected (case (env-lang) :clj @@ -2030,125 +2147,49 @@ :output-type (t/or (t/isa? String) (t/isa? Long))}] (defmeta ~'dependent-extensible {:quantum.core.type/type dependent-extensible|__type} - (fn* ([~'x00__ ~'x10__ ~'x20__ ~'x30__] - (ifs ((Array/get dependent-extensible|__0|types 0) ~'x00__) - (ifs ((Array/get dependent-extensible|__0|types 1) ~'x10__) - (ifs ((Array/get dependent-extensible|__0|types 2) ~'x20__) - (ifs ((Array/get dependent-extensible|__0|types 3) ~'x30__) - (. dependent-extensible|__0 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - ((Array/get dependent-extensible|__1|types 3) ~'x30__) - (. dependent-extensible|__1 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - ((Array/get dependent-extensible|__2|types 3) ~'x30__) - (. dependent-extensible|__2 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) - ((Array/get dependent-extensible|__3|types 2) ~'x20__) - (ifs ((Array/get dependent-extensible|__3|types 3) ~'x30__) - (. dependent-extensible|__3 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - ((Array/get dependent-extensible|__4|types 3) ~'x30__) - (. dependent-extensible|__4 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - ((Array/get dependent-extensible|__5|types 3) ~'x30__) - (. dependent-extensible|__5 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) - ((Array/get dependent-extensible|__6|types 1) ~'x10__) - (ifs ((Array/get dependent-extensible|__6|types 2) ~'x20__) - (ifs ((Array/get dependent-extensible|__6|types 3) ~'x30__) - (. dependent-extensible|__6 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) - ((Array/get dependent-extensible|__7|types 1) ~'x10__) - (ifs ((Array/get dependent-extensible|__7|types 2) ~'x20__) - (ifs ((Array/get dependent-extensible|__7|types 3) ~'x30__) - (. dependent-extensible|__7 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) - ((Array/get dependent-extensible|__8|types 2) ~'x20__) - (ifs ((Array/get dependent-extensible|__8|types 3) ~'x30__) - (. dependent-extensible|__8 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) - ((Array/get dependent-extensible|__9|types 1) ~'x10__) - (ifs ((Array/get dependent-extensible|__9|types 2) ~'x20__) - (ifs ((Array/get dependent-extensible|__9|types 3) ~'x30__) - (. dependent-extensible|__9 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) - ((Array/get dependent-extensible|__10|types 2) ~'x20__) - (ifs ((Array/get dependent-extensible|__10|types 3) ~'x30__) - (. dependent-extensible|__10 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) - ((Array/get dependent-extensible|__11|types 1) ~'x10__) - (ifs ((Array/get dependent-extensible|__11|types 2) ~'x20__) - (ifs ((Array/get dependent-extensible|__11|types 3) ~'x30__) - (. dependent-extensible|__11 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 1)) - ((Array/get dependent-extensible|__12|types 0) ~'x00__) - (ifs ((Array/get dependent-extensible|__12|types 1) ~'x10__) - (ifs ((Array/get dependent-extensible|__12|types 2) ~'x20__) - (ifs ((Array/get dependent-extensible|__12|types 3) ~'x30__) - (. dependent-extensible|__12 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - ((Array/get dependent-extensible|__13|types 3) ~'x30__) - (. dependent-extensible|__13 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - ((Array/get dependent-extensible|__14|types 3) ~'x30__) - (. dependent-extensible|__14 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) - ((Array/get dependent-extensible|__15|types 2) ~'x20__) - (ifs ((Array/get dependent-extensible|__15|types 3) ~'x30__) - (. dependent-extensible|__15 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - ((Array/get dependent-extensible|__16|types 3) ~'x30__) - (. dependent-extensible|__16 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - ((Array/get dependent-extensible|__17|types 3) ~'x30__) - (. dependent-extensible|__17 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 1)) - ((Array/get dependent-extensible|__18|types 0) ~'x00__) - (ifs ((Array/get dependent-extensible|__18|types 1) ~'x10__) - (ifs ((Array/get dependent-extensible|__18|types 2) ~'x20__) - (ifs ((Array/get dependent-extensible|__18|types 3) ~'x30__) - (. dependent-extensible|__18 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 1)) - ((Array/get dependent-extensible|__19|types 0) ~'x00__) - (ifs ((Array/get dependent-extensible|__19|types 1) ~'x10__) - (ifs ((Array/get dependent-extensible|__19|types 2) ~'x20__) - (ifs ((Array/get dependent-extensible|__19|types 3) ~'x30__) - (. dependent-extensible|__19 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) - ((Array/get dependent-extensible|__20|types 2) ~'x20__) - (ifs ((Array/get dependent-extensible|__20|types 3) ~'x30__) - (. dependent-extensible|__20 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 1)) - ((Array/get dependent-extensible|__21|types 0) ~'x00__) - (ifs ((Array/get dependent-extensible|__21|types 1) ~'x10__) - (ifs ((Array/get dependent-extensible|__21|types 2) ~'x20__) - (ifs ((Array/get dependent-extensible|__21|types 3) ~'x30__) - (. dependent-extensible|__21 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) - ((Array/get dependent-extensible|__22|types 2) ~'x20__) - (ifs ((Array/get dependent-extensible|__22|types 3) ~'x30__) - (. dependent-extensible|__22 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 1)) - ((Array/get dependent-extensible|__23|types 0) ~'x00__) - (ifs ((Array/get dependent-extensible|__23|types 1) ~'x10__) - (ifs ((Array/get dependent-extensible|__23|types 2) ~'x20__) - (ifs ((Array/get dependent-extensible|__23|types 3) ~'x30__) - (. dependent-extensible|__23 ~'invoke ~'x00__ ~'x10__ ~'x20__ ~'x30__) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 3)) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 2)) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 1)) - (unsupported! `dependent-extensible [~'x00__ ~'x10__ ~'x20__ ~'x30__] 0))))))))] - (testing "code equivalence" (is-code= actual expected)) - (eval actual))))) - -(self/extend-defn! dependent-extensible - ([] 5)) + ~dependent-extensible|fn|form))))] + (testing "code equivalence" (is-code= actual expected))))) + (testing "reactive type" + (testing "definition" + (let [actual + (doto (binding [self/*compilation-mode* :test] + [(macroexpand ' + (self/defn simple-reactive-dependee ([a tt/char?] 1))) + (macroexpand ' + (self/defn simple-reactive-dependent + ([a (t/input-type simple-reactive-dependee :?)] "abc")))]) + eval) + expected + (case (env-lang) + :clj ($ [(do (declare ~'simple-reactive-dependee) + (def ~(tag (cstr `char>Object) 'simple-reactive-dependee|__0) + (reify* [char>Object] (~(O 'invoke) [~'_0__ ~(C 'a)] 1))) + [{:id 0 :index 0 :arg-types [(t/isa? Character)] :output-type t/any?}] + (defmeta ~'simple-reactive-dependee + {:quantum.core.type/type simple-reactive-dependee|__type} + (fn* ([~'x00__] + (ifs ((Array/get simple-reactive-dependee|__0|types 0) ~'x00__) + (. simple-reactive-dependee|__0 ~'invoke ~'x00__) + (unsupported! `simple-reactive-dependee [~'x00__] 0)))))) + (do (declare ~'simple-reactive-dependent) + (def ~(tag (cstr `char>Object) 'simple-reactive-dependent|__0) + (reify* [char>Object] (~(O 'invoke) [~'_0__ ~(C 'a)] "abc"))) + [{:id 0 :index 0 :arg-types [(t/isa? Character)] :output-type t/any?}] + (defmeta ~'simple-reactive-dependent + {:quantum.core.type/type simple-reactive-dependent|__type} + (fn* ([~'x00__] + (ifs ((Array/get simple-reactive-dependent|__0|types 0) ~'x00__) + (. simple-reactive-dependent|__0 ~'invoke ~'x00__) + (unsupported! `simple-reactive-dependent [~'x00__] 0))))))]))] + (testing "code equivalence" (is-code= actual expected)))) + (testing "advanced (with dependent types) definition" + (let [actual + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/defn reactive-extensible + ([a (t/input-type dependent-extensible :?)]))))]))) + ;; TODO make this into an actual test + (self/extend-defn! dependent-extensible ([] 5))) ;; ===== Reactive types ===== ;; From 6b183a037e8a30fe0f0a0e6f022800a4c1ed7788 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 6 Nov 2018 21:03:29 -0700 Subject: [PATCH 638/810] Fix spec --- src-untyped/quantum/untyped/core/type/defnt.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 7465f312..b6e81fb1 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -119,7 +119,7 @@ (s/def ::overload-basis|norx ;; None of these types should be reactive - (s/kv {:arg-types|basis t/type? + (s/kv {:arg-types|basis (s/vec-of t/type?) :output-type|basis t/type? ;; This is non-nil only for arglists with dependent types :types|split (s/nilable ::overload-basis|types|split) From bfff9a38323a880af0e4fdca8f671cf5c1e428c7 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 6 Nov 2018 21:13:12 -0700 Subject: [PATCH 639/810] Support `t/defn` declaration --- src-untyped/quantum/untyped/core/type/defnt.cljc | 8 ++++++-- src-untyped/quantum/untyped/core/vars.cljc | 7 +++++-- test/quantum/test/untyped/core/type/defnt.cljc | 3 ++- 3 files changed, 13 insertions(+), 5 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index b6e81fb1..8e201ac0 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -590,7 +590,10 @@ (if-not-let [changed-unanalyzed-overloads (seq (>changed-unanalyzed-overloads fn|globals overload-bases-data existing-overload-types))] - existing-fn-types + (or existing-fn-types + {:fn|output-type-norx t/none? + :fn|type-norx (t/ftype fn|output-type-norx) + :overload-types []}) (let [sorted-changed-unanalyzed-overloads (->> changed-unanalyzed-overloads (sort-by :arg-types compare-args-types) @@ -749,7 +752,8 @@ `(doto (intern (quote ~fn|ns-name) (quote ~fn|name) ~(with-meta `(fn* ~@overload-forms) fn|meta')) (alter-meta! merge ~fn|meta'))] - (let [dispatch-form `(uvar/defmeta ~fn|name ~fn|meta' (fn* ~@overload-forms))] + (let [dispatch-form `(uvar/defmeta ~fn|name ~fn|meta' + ~(when-not (empty? overload-forms) `(fn* ~@overload-forms)))] (if (= compilation-mode :test) [overload-types|form dispatch-form] [dispatch-form]))))) diff --git a/src-untyped/quantum/untyped/core/vars.cljc b/src-untyped/quantum/untyped/core/vars.cljc index 01c5dc2d..2dfb350c 100644 --- a/src-untyped/quantum/untyped/core/vars.cljc +++ b/src-untyped/quantum/untyped/core/vars.cljc @@ -67,9 +67,12 @@ #?(:clj (defmacro defmeta - "Like `def`, but applies metadata to the var *and* the bound object." + "Like `def`, but applies metadata to the var *and* the bound object (if `metable?`)." [sym meta-val x] - `(def ~(vary-meta sym merge meta-val) ~(vary-meta x merge meta-val)))) + `(def ~(vary-meta sym merge meta-val) + ~(if (with-metable? x) + (vary-meta x merge meta-val) + x)))) ;; ===== Aliases ===== ;; diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index acb93696..7f40cffd 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -2189,7 +2189,8 @@ (self/defn reactive-extensible ([a (t/input-type dependent-extensible :?)]))))]))) ;; TODO make this into an actual test - (self/extend-defn! dependent-extensible ([] 5))) + (doto (macroexpand '(self/extend-defn! dependent-extensible ([] 5))) + eval)) ;; ===== Reactive types ===== ;; From e6b313a639c4e2840e5ef045f6df2c77bffc4278 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 7 Nov 2018 13:04:44 -0700 Subject: [PATCH 640/810] Ensure per-overload types decls are interned in the correct ns --- .../quantum/untyped/core/type/defnt.cljc | 27 +++++++++---------- 1 file changed, 13 insertions(+), 14 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 8e201ac0..ec813531 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -202,7 +202,7 @@ (s/def ::types-decl-datum (s/kv {:id ::overload|id - :ns-sym simple-symbol? + :ns-name simple-symbol? :arg-types (s/vec-of t/type?) :output-type t/type? :index index?})) ; overload-index (position in the overall types-decl) @@ -436,7 +436,7 @@ (str "Overwriting type overload for `" (uid/qualify fn|ns-name fn|name) "`") {:arg-types-prev (:arg-types prev-datum) :arg-types (:arg-types datum)}) (-> data pop - (conj (assoc prev-datum :ns-sym (:ns-sym datum) + (conj (assoc prev-datum :ns-name (:ns-name datum) :overload (:overload datum) :replacing-id (:id datum)))))))) @@ -452,17 +452,16 @@ dynamic dispatch uses to dispatch off input types." [{:as opts :keys [compilation-mode _, lang _]} ::opts {:as fn|globals :keys [fn|ns-name _, fn|name _, fn|overload-types-name _]} ::fn|globals - arg-types (s/vec-of t/type?), overload|id ::overload|id, overload-index index?, !fn|types _ + {:as types-decl-datum :keys [id _, index _] ns-name- [:ns-name _]} ::types-decl-datum, !fn|types _ > ::overload-types-decl] - (let [decl-name (-> (>overload-types-decl|name fn|name overload|id) + (let [decl-name (-> (>overload-types-decl|name fn|name id) (ufth/with-type-hint "[Ljava.lang.Object;")) form (if (or (not= compilation-mode :test) (= lang :clj)) - (do (intern fn|ns-name decl-name - (overload-types>arg-types !fn|types overload-index)) + (do (intern ns-name- decl-name (overload-types>arg-types !fn|types index)) nil) `(def ~decl-name (overload-types>arg-types - ~(uid/qualify fn|ns-name fn|overload-types-name) ~overload-index)))] + ~(uid/qualify fn|ns-name fn|overload-types-name) ~index)))] {:form form :name decl-name})) (defns- overload-basis-data>types+ @@ -605,7 +604,7 @@ (uc/map-indexed (c/fn [i {:keys [arg-types output-type]}] {:id (+ i first-current-overload-id) - :ns-sym (ns-name *ns*) + :ns-name (ns-name *ns*) :arg-types arg-types :output-type output-type}))) ;; We need to maintain the `overload-types` ordering by type-specificity so the dynamic @@ -657,9 +656,9 @@ :clj (let [direct-dispatch-data-seq (->> !overload-queue (uc/map - (c/fn [{:as indexed-type-decl-datum :keys [arg-types id index overload]}] + (c/fn [{:as type-decl-datum :keys [arg-types id index overload]}] {:overload-types-decl - (>overload-types-decl opts fn|globals arg-types id index !fn|types) + (>overload-types-decl opts fn|globals type-decl-datum !fn|types) :reify (overload>reify overload opts fn|globals id)}))) _ (uvec/alist-empty! !overload-queue) form (->> direct-dispatch-data-seq @@ -687,9 +686,9 @@ arglist (s/vec-of simple-symbol?)] (->> overload-types-for-arity (uc/map+ - (c/fn [{:as types-decl-datum :keys [arg-types ns-sym] overload|id :id}] - (let [overload-types-decl|name (>overload-types-decl|name ns-sym fn|name overload|id) - reify|name|qualified (>reify-name-unhinted ns-sym fn|name overload|id)] + (c/fn [{:as types-decl-datum :keys [arg-types] overload|id :id ns-name- :ns-name}] + (let [overload-types-decl|name (>overload-types-decl|name ns-name- fn|name overload|id) + reify|name|qualified (>reify-name-unhinted ns-name- fn|name overload|id)] [(>dynamic-dispatch|reify-call reify|name|qualified arglist) (->> arg-types (uc/map-indexed @@ -745,7 +744,7 @@ fn|meta' (merge fn|meta {:quantum.core.type/type (uid/qualify fn|ns-name fn|type-name)}) overload-types|form (when (= compilation-mode :test) - (->> !fn|types norx-deref :overload-types >form (uc/map (fn1 dissoc :ns-sym))))] + (->> !fn|types norx-deref :overload-types >form (uc/map (fn1 dissoc :ns-name))))] ;; TODO determine whether CLJS needs (update-in m [:jsdoc] conj "@param {...*} var_args") (if (= kind :extend-defn!) [overload-types|form From b5aa626fc33fcb0911e0f9cc971d218dcf3e4a88 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 7 Nov 2018 13:23:55 -0700 Subject: [PATCH 641/810] Fix comparison for expressions --- src-untyped/quantum/untyped/core/type.cljc | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 1e35ef3b..7b5ff851 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -385,9 +385,9 @@ (defn- logical-compare "This is so `t/empty-set` doesn't get left in `t/or`s or `t/and`s." [t0 #_utr/type?, t1 #_utr/type? #_> #_uset/comparison?] - (if (c/= t0 empty-set) - (if (c/= t1 empty-set) =ident ident (compare t0 t1)))) + (if (== t0 empty-set) + (if (== t1 empty-set) =ident ident (compare t0 t1)))) (defns- create-logical-type|inner|or [{:as accum :keys [t' utr/type?]} _, t* utr/type?, c* uset/comparison?] From 9f8e40190b9a05315c0e94191c1df0e9ee1dbfe5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 7 Nov 2018 13:39:36 -0700 Subject: [PATCH 642/810] Remove instrumentation from certain fns --- src-untyped/quantum/untyped/core/analyze.cljc | 1 + src-untyped/quantum/untyped/core/type.cljc | 24 +++++++++---------- 2 files changed, 13 insertions(+), 12 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 0d983a1a..10eab752 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -706,6 +706,7 @@ (defns- handle-type-combinators [caller|node uast/node?, input-nodes _, out-type t/type? > t/type?] (condp = (:type caller|node) + ;; TODO this relies on spec instrumentation not happening for these fns (t/value t/isa?) (apply-arg-type-combine t/isa? input-nodes) (t/value t/value) (apply-arg-type-combine t/value input-nodes) (t/value t/or) (apply-arg-type-combine t/or input-nodes) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 7b5ff851..61612229 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -252,9 +252,9 @@ ;; ----- ValueType ----- ;; -(defns value +(defn value "Creates a type whose extension is the singleton set containing only the value `v`." - [v _] (ValueType. uhash/default uhash/default nil v)) + [v] (ValueType. uhash/default uhash/default nil v)) (defns unvalue [t utr/type?] @@ -337,32 +337,32 @@ ;; ===== Type metadata (not for reactive types) ===== ;; -(defns assume +(defn assume "Denotes that, whatever the declared output type (to which `assume` is applied) of a function may be, it is assumed that the output satisfies that type." - [t utr/type? > utr/type?] + [t #_utr/type? #_> #_utr/type?] (assert (c/not (utr/rx-type? t))) (update-meta t assoc :quantum.core.type/assume? true)) -(defns unassume [t utr/type? > utr/type?] +(defn unassume [t #_utr/type? #_> #_utr/type?] (assert (c/not (utr/rx-type? t))) (update-meta t dissoc :quantum.core.type/assume?)) -(defns * +(defn * "Denote on a type that it must be enforced at runtime. For use with `defnt`." - [t utr/type? > utr/type?] + [t #_utr/type? #_> #_utr/type?] (assert (c/not (utr/rx-type? t))) (update-meta t assoc :quantum.core.type/runtime? true)) -(defns ref +(defn ref "Denote on a type that it must not be expanded to use primitive values. For use with `defnt`." - [t utr/type? > utr/type?] + [t #_utr/type? #_> #_utr/type?] (assert (c/not (utr/rx-type? t))) (update-meta t assoc :quantum.core.type/ref? true)) -(defns unref [t utr/type? > utr/type?] +(defn unref [t #_utr/type? #_> #_utr/type?] (assert (c/not (utr/rx-type? t))) (update-meta t dissoc :quantum.core.type/ref?)) @@ -635,9 +635,9 @@ (defns deducible [x type? > deducible-type?] (DeducibleType. (atom x)))) -(defns ? +(defn ? "Computes a type denoting a nilable value satisfying `t`." - ([t utr/type? > utr/type?] (or nil? t))) + ([t #_utr/type? #_> #_utr/type?] (or nil? t))) ;; ===== Etc. ===== ;; From 10e5ec55c3adeab06d3eee555de76a465b174751 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 7 Nov 2018 13:40:09 -0700 Subject: [PATCH 643/810] Ensure `output-type-norx` is included with declaration --- src-untyped/quantum/untyped/core/type/defnt.cljc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index ec813531..0bc008bb 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -590,8 +590,8 @@ (seq (>changed-unanalyzed-overloads fn|globals overload-bases-data existing-overload-types))] (or existing-fn-types - {:fn|output-type-norx t/none? - :fn|type-norx (t/ftype fn|output-type-norx) + {:fn|output-type-norx fn|output-type-norx + :fn|type-norx (t/ftype fn|output-type-norx) :overload-types []}) (let [sorted-changed-unanalyzed-overloads (->> changed-unanalyzed-overloads From c9dcd824d0e52d5ed7ec58f7aaa826b1fde88b0d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 7 Nov 2018 15:00:12 -0700 Subject: [PATCH 644/810] Can pass non-form output types; also better meta check for forms --- src-untyped/quantum/untyped/core/analyze.cljc | 26 +++++++++++-------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 10eab752..40069756 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -829,7 +829,8 @@ (let [expanded-form (ufeval/macroexpand form)] (if-let [no-expansion? (ucomp/== form expanded-form)] (analyze-seq* env expanded-form) - (let [expanded-form' (some-> expanded-form (update-meta merge (meta form))) + (let [expanded-form' (cond-> expanded-form + (uvar/with-metable? expanded-form) (update-meta merge (meta form))) expanded (analyze* env expanded-form')] (uast/macro-call {:env env @@ -995,11 +996,13 @@ (defn- analyze-arg-syms* [env #_::env] (uref/update! !!analyze-arg-syms|iter inc) - (let [{:keys [arg-sym->arg-type-form arglist-syms|queue arglist-syms|unanalyzed out-type-form + (let [{:keys [arg-sym->arg-type-form arglist-syms|queue arglist-syms|unanalyzed out-type-or-form split-types?]} (:opts env)] (ifs (empty? arglist-syms|unanalyzed) [{:env env - :out-type-node (-> (analyze env out-type-form) (update :type t/unvalue)) + :out-type-node (if (t/type? out-type-or-form) + (ast/literal env nil out-type-or-form) ; a simulated AST node + (-> (analyze env out-type-or-form) (update :type t/unvalue))) :dependent? (uref/get !!dependent?)}] (>= (uref/get !!analyze-arg-syms|iter) analyze-arg-syms|max-iter) (err! "Max number of iterations reached for `analyze-arg-syms`" @@ -1032,14 +1035,14 @@ ur/join)))))) (defns- >analyze-arg-syms|opts - [env ::env, arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _ + [env ::env, arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-or-form _ split-types? boolean?] {:arglist-context? true :arglist-syms|queue (uset/ordered-set (-> arg-sym->arg-type-form keys first)) :arglist-syms|unanalyzed (-> arg-sym->arg-type-form keys set) :arg-env (atom env) ; Mutable so it can cache :arg-sym->arg-type-form arg-sym->arg-type-form - :out-type-form out-type-form + :out-type-or-form out-type-or-form :split-types? split-types?}) (defns analyze-arg-syms @@ -1053,18 +1056,19 @@ might be a 'splittable' type like `t/or` (whose cardinality is the number of arguments to it when simplified) which would require a Cartesian product of the splits of the arg types." > vector? #_(s/vec-of (s/kv {:env ::env :out-type-node uast/node? :dependent? boolean?})) - ([arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _] - (analyze-arg-syms {} arg-sym->arg-type-form out-type-form true)) - ([arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _, split-types? boolean?] - (analyze-arg-syms {} arg-sym->arg-type-form out-type-form split-types?)) - ([env ::env, arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-form _ + ([arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-or-form _] + (analyze-arg-syms {} arg-sym->arg-type-form out-type-or-form true)) + ([arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-or-form _, split-types? boolean?] + (analyze-arg-syms {} arg-sym->arg-type-form out-type-or-form split-types?)) + ([env ::env, arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-or-form _ split-types? boolean? > (s/vec-of (s/kv {:env ::env :out-type-node uast/node?}))] (uref/set! !!analyze-arg-syms|iter 0) (uref/set! !!dependent? false) (try (analyze-arg-syms* {:opts (merge (:opts env) - (>analyze-arg-syms|opts env arg-sym->arg-type-form out-type-form split-types?))}) + (>analyze-arg-syms|opts env arg-sym->arg-type-form out-type-or-form + split-types?))}) (catch Throwable t (if (and (uerr/error-map? t) (-> t :ident (= ::arg-syms-analyzed))) (-> t :data :result) From 57c8614bebc482d73d092e90f25b4b4f3096bd67 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 7 Nov 2018 15:00:30 -0700 Subject: [PATCH 645/810] Better handling of fn output types and runtime checks --- .../quantum/untyped/core/type/defnt.cljc | 68 ++++++++++--------- 1 file changed, 36 insertions(+), 32 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 0bc008bb..e4e4dad7 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -104,7 +104,8 @@ ;; "global" because they apply to the whole `t/fn` (s/def ::fn|globals - (s/kv {:fn|meta (s/nilable :quantum.core.specs/meta) + (s/kv {:fn|globals-name simple-symbol? + :fn|meta (s/nilable :quantum.core.specs/meta) :fn|ns-name simple-symbol? :fn|name ::uss/fn|name :fn|output-type t/type? @@ -113,7 +114,6 @@ :fn|overload-types-name simple-symbol? :fn|type-name simple-symbol?})) - (s/def ::overload-basis|types|split (s/vec-of (s/kv {:arg-types (s/vec-of t/type?) :output-type t/type?}))) @@ -217,8 +217,6 @@ (cond (not= k :spec) java.lang.Object; default class (symbol? spec) (pred->class lang spec)))) -;; TODO optimize such that `post-type|form` doesn't create a new type-validator wholesale every -;; time the function gets run; e.g. extern it (c/defn >with-runtime-output-type [body output-type|form] `(t/validate ~body ~output-type|form)) ;; TODO simplify this class computation @@ -296,14 +294,16 @@ (defns- unanalyzed-overload>overload "Given an `::unanalyzed-overload`, performs type analysis on the body and computes a resulting `t/fn` overload, which is the foundation for one `reify`." - [{:as unanalyzed-overload - :keys [arglist-form|unanalyzed _, args-form _, varargs-form _, arg-types _, - output-type|form _, body-codelist _] - declared-output-type [:output-type _]} - ::unanalyzed-overload - {:as opts :keys [lang _, kind _]} ::opts - {:as fn|globals :keys [fn|name _, fn|output-type _]} ::fn|globals - fn|type t/type? + [{:as opts :keys [lang _, kind _]} ::opts + {:as fn|globals :keys [fn|globals-name _, fn|name _, fn|ns-name _, fn|output-type _ + fn|overload-types-name _]} ::fn|globals + {:as unanalyzed-overload + :keys [arglist-form|unanalyzed _, args-form _, varargs-form _, arg-types _, + output-type|form _, body-codelist _] + declared-output-type [:output-type _]} + ::unanalyzed-overload + overload|id index? + fn|type t/type? > ::overload] (let [;; Not sure if `nil` is the right approach for the value recursive-ast-node-reference @@ -326,9 +326,15 @@ variadic?))) output-type (with-validate-output-type declared-output-type body-node) body-form - (-> (:form body-node) - (cond-> (-> output-type meta :quantum.core.type/runtime?) - (>with-runtime-output-type output-type|form)))] + (-> (:form body-node) + (cond-> (-> output-type meta :quantum.core.type/runtime?) + ;; TODO here the output type is being re-created each time (unless the fn's overall + ;; output type is being preferred) because it could reference inputs, but we + ;; should probably analyze to determine whether it references inputs so we can, + ;; in the 90% case, extern the output type + (>with-runtime-output-type + (or output-type|form + `(?norx-deref (:fn|output-type ~(uid/qualify fn|ns-name fn|globals-name)))))))] {:arglist-form|unanalyzed arglist-form|unanalyzed :arg-classes arg-classes :arg-types arg-types @@ -466,8 +472,8 @@ (defns- overload-basis-data>types+ "Split and primitivized; not yet sorted." - [{:keys [fn|output-type _]} ::fn|globals, args-form _, body-codelist _, output-type|form _] - (->> (uana/analyze-arg-syms {} args-form output-type|form true) + [{:keys [fn|output-type _]} ::fn|globals, args-form _, output-type|form _, body-codelist _] + (->> (uana/analyze-arg-syms {} args-form (or output-type|form fn|output-type) true) (uc/map+ (c/fn [{:keys [env out-type-node]}] (let [arg-env (->> env :opts :arg-env deref) arg-types (->> args-form keys (uc/map #(:type (get arg-env %)))) @@ -539,7 +545,8 @@ (= arg-types (:arg-types %))) existing-overload-types))] (->> (or types|split (overload-basis-data>types+ - fn|globals args-form body-codelist|unanalyzed output-type|form)) + fn|globals args-form output-type|form + body-codelist|unanalyzed)) (cond->> (and (not new-overload-basis?) (= (:body-codelist basis) (:body-codelist prev-basis))) (uc/remove+ type-signature-equal-to-existing?)) @@ -613,8 +620,6 @@ (if (empty? existing-overload-types) (->> sorted-changed-overload-types (uc/map-indexed (c/fn [i datum] (assoc datum :index i)))) - ;; (assoc datum :overload - ;; (get changed-overloads (- id first-current-overload-id))) (->> (ur/join existing-overload-types sorted-changed-overload-types) (sort-by identity (c/fn [datum0 datum1] @@ -634,7 +639,10 @@ ;; types for now sorted-changed-overloads (->> sorted-changed-unanalyzed-overloads - (uc/map #(unanalyzed-overload>overload % opts fn|globals fn|type-norx))) + (uc/map-indexed + (c/fn [i x] + (let [id (+ i first-current-overload-id)] + (unanalyzed-overload>overload opts fn|globals x id fn|type-norx))))) overload-types (->> overload-types-with-replacing-ids (uc/map @@ -761,7 +769,7 @@ (defns- overload-basis-form>overload-basis [opts ::opts - {:as fn|globals :keys [fn|output-type _, fn|output-type|form _]} ::fn|globals + {:as fn|globals :keys [fn|output-type _, fn|output-type _, fn|output-type|form _]} ::fn|globals {:as overload-basis-form {args [:args _] varargs [:varargs _] @@ -773,12 +781,7 @@ (when varargs (TODO "Need to handle varargs")) (let [arg-types|form (->> args (mapv (c/fn [{[kind #_#{:any :spec}, t #_t/form?] :spec}] (case kind :any `t/any? :spec t)))) - output-type|form (case output-type|form - _ `t/any? - ;; TODO if the output-type|form is nil then we should default to `?`; - ;; otherwise the `fn|output-type|form` gets analyzed over and over - nil fn|output-type|form - output-type|form) + output-type|form (case output-type|form _ `t/any?, nil nil, output-type|form) arg-bindings (->> args (mapv (c/fn [{[kind binding-] :binding-form}] ;; TODO this assertion is purely temporary until destructuring @@ -791,7 +794,8 @@ ;; supported (assert (-> varargs :binding-form first (= :sym)))) args-form (reduce-2 assoc (umap/om) arg-bindings arg-types|form) - [arglist-basis] (uana/analyze-arg-syms {} args-form output-type|form false) + [arglist-basis] (uana/analyze-arg-syms {} args-form + (or output-type|form fn|output-type) false) binding->arg-type|basis (->> arglist-basis :env :opts :arg-env deref (uc/map-vals' :type)) arg-types|basis (->> args-form keys (uc/map binding->arg-type|basis)) output-type|basis (-> arglist-basis :out-type-node :type) @@ -817,7 +821,7 @@ ;; compared to existing overload bases. :types|split (when dependent? (->> (overload-basis-data>types+ fn|globals args-form - body-codelist|unanalyzed output-type|form) + output-type|form body-codelist|unanalyzed) ur/join)) ;; TODO Only needed if `inline? or `reactive?`, or if new :body-codelist body-codelist|unanalyzed @@ -1003,8 +1007,8 @@ fn|overload-types-name (symbol (str fn|name "|__types")) fn|type-name (symbol (str fn|name "|__type")) fn|globals - (kw-map fn|meta fn|name fn|ns-name fn|output-type|form fn|output-type - fn|overload-bases-name fn|overload-types-name fn|type-name)] + (kw-map fn|globals-name fn|meta fn|name fn|ns-name fn|output-type|form + fn|output-type fn|overload-bases-name fn|overload-types-name fn|type-name)] (intern fn|ns-name fn|globals-name fn|globals) (kw-map fn|globals overload-bases-form))))) From 22353d84d6205e9094e9e55c9556d9df271a9690 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 7 Nov 2018 15:01:52 -0700 Subject: [PATCH 646/810] Fix some compilation --- src/quantum/core/data/primitive.cljc | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index a30eb9fc..786f1d03 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -189,13 +189,13 @@ ;; ===== Primitive type properties ===== ;; (t/defn ^:inline signed? - ([x (t/or char? (t/value Character) (t/value char?))] false) -#?@(:clj [([x (t/or byte? (t/value Byte) (t/value byte?) - short? (t/value Short) (t/value short?) - int? (t/value Integer) (t/value int?) - long? (t/value Long) (t/value long?) - float? (t/value Float) (t/value float?) - double? #?(:clj Double :cljs js/Number) (t/value double?))] true)])) + ([x (t/or char? (t/value Character) (t/value char?))] false) +#?@(:clj [([x (t/or byte? (t/value Byte) (t/value byte?) + short? (t/value Short) (t/value short?) + int? (t/value Integer) (t/value int?) + long? (t/value Long) (t/value long?) + float? (t/value Float) (t/value float?) + double? (t/value #?(:clj Double :cljs js/Number)) (t/value double?))] true)])) ;; TODO TYPED `t/numerically-integer?` (t/defn ^:inline >bit-size ; > t/numerically-integer? @@ -207,7 +207,7 @@ ([x (t/or int? (t/value Integer) (t/value int?))] int-bits) ([x (t/or long? (t/value Long) (t/value long?))] long-bits) ([x (t/or float? (t/value Float) (t/value float?))] float-bits)]) - ([x (t/or double? #?(:clj Double :cljs js/Number) (t/value double?))] + ([x (t/or double? (t/value #?(:clj Double :cljs js/Number)) (t/value double?))] double-bits)) ;; ===== Conversion ===== ;; @@ -236,7 +236,7 @@ ( [a boolean? , b (t/- primitive? boolean?)] false) ( [a (t/- primitive? boolean?) , b boolean?] false) (^:in [a long? , b long?] (Numbers/equiv a b)) - ( [a long? , b (t/- numeric? long?)] (Numeric/eq a b)) + ( [a long? , b (t/- numeric? double? long?)] (Numeric/eq a b)) ( [a (t/- numeric? long?) , b long?] (Numeric/eq a b)) (^:in [a double? , b double?] (Numbers/equiv a b)) ( [a double? , b (t/- numeric? double? long?)] (Numeric/eq a b)) @@ -259,7 +259,7 @@ (t/extend-defn! c?/< #?(:clj (^:in [a long? , b long?] (Numbers/lt a b))) -#?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/lt a b))) +#?(:clj ( [a long? , b (t/- numeric? double? long?)] (Numeric/lt a b))) #?(:clj ( [a (t/- numeric? long?) , b long?] (Numeric/lt a b))) #?(:clj (^:in [a double? , b double?] (Numbers/lt a b))) #?(:clj ( [a double? , b (t/- numeric? double? long?)] (Numeric/lt a b))) @@ -270,7 +270,7 @@ (t/extend-defn! c?/<= #?(:clj (^:in [a long? , b long?] (Numbers/lte a b))) -#?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/lte a b))) +#?(:clj ( [a long? , b (t/- numeric? double? long?)] (Numeric/lte a b))) #?(:clj ( [a (t/- numeric? long?) , b long?] (Numeric/lte a b))) #?(:clj (^:in [a double? , b double?] (Numbers/lte a b))) #?(:clj ( [a double? , b (t/- numeric? double? long?)] (Numeric/lte a b))) @@ -281,7 +281,7 @@ (t/extend-defn! c?/> #?(:clj (^:in [a long? , b long?] (Numbers/gt a b))) -#?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/gt a b))) +#?(:clj ( [a long? , b (t/- numeric? double? long?)] (Numeric/gt a b))) #?(:clj ( [a (t/- numeric? long?) , b long?] (Numeric/gt a b))) #?(:clj (^:in [a double? , b double?] (Numbers/gt a b))) #?(:clj ( [a double? , b (t/- numeric? double? long?)] (Numeric/gt a b))) @@ -292,7 +292,7 @@ (t/extend-defn! c?/>= #?(:clj (^:in [a long? , b long?] (Numbers/gte a b))) -#?(:clj ( [a long? , b (t/- numeric? long?)] (Numeric/gte a b))) +#?(:clj ( [a long? , b (t/- numeric? double? long?)] (Numeric/gte a b))) #?(:clj ( [a (t/- numeric? long?) , b long?] (Numeric/gte a b))) #?(:clj (^:in [a double? , b double?] (Numbers/gte a b))) #?(:clj ( [a double? , b (t/- numeric? double? long?)] (Numeric/gte a b))) From d713c6e19d0ccea3b7198cfc86882a8b3b121e66 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 7 Nov 2018 15:40:53 -0700 Subject: [PATCH 647/810] Add some more bug reports --- resources-dev/defnt.cljc | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 64262f01..5cb2be73 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -59,6 +59,10 @@ TODO: except if inline - Handle `|` (pre-type) - Should not accept `t/none?` as an input type + - This subsumes it into the `ref` portion which is not right + (t/or (t/value nil) (t/isa? Long) (t/ref (t/isa? java.lang.Comparable))) + -> (t/or (t/value nil) (t/ref (t/isa? java.lang.Comparable))) + - TODO all `intern`s/effects in `t/defn` should be atomic (all or nothing). This means that the interns should probably be put on a queue too. #_" Note that `;; TODO TYPED` is the annotation we're using for this initiative From 0437dd44b193034e3d110b644d05b3d32bfe80bc Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 7 Nov 2018 15:41:03 -0700 Subject: [PATCH 648/810] Better report errors in `t/defn` --- src-untyped/quantum/untyped/core/type/defnt.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index e4e4dad7..0d359360 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -1035,7 +1035,7 @@ :fn (TODO "Haven't done t/fn yet") (:defn :extend-defn!) `(do ~@fn-codelist))))) t - (do (ulog/pr :error t) + (do (ulog/ppr :error t) (throw t)))) #?(:clj From 0d3f0b985908f4d9d2a02380faf4e2fd0b1b7760 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 7 Nov 2018 16:35:01 -0700 Subject: [PATCH 649/810] Update todos as reactive types are pretty much done! --- resources-dev/defnt.cljc | 44 +++++++------------ src-untyped/quantum/untyped/core/analyze.cljc | 6 +-- .../quantum/untyped/core/type/defnt.cljc | 13 ++++-- src/quantum/core/data/primitive.cljc | 34 +++++++------- 4 files changed, 47 insertions(+), 50 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 5cb2be73..8f002c93 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -70,28 +70,13 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - No typed namespace should refer to any untyped namespace - TODO implement the following: - [1] - Reactive recompilation - - Non-constant types should trigger a chain-reaction of recompilations for its - dependents/watchers when they change: - - t/input-type - - changed via `t/extend-defn!` - - t/output-type - - changed via `t/extend-defn!` - - `t/defn` that gets extended via `t/extend-defn!` (if the input-types and output-types have - changed) - - We can `defonce` a `urx/atom` per `t/defn` and `reset!` on each `t/extend-defn!` - - reactive ftype in ::type meta - - Probably should disallow recursive type references, including: - (t/defn f [x (t/input-type f ...)]) - - Examples - - One could imagine a dynamic set of types corresponding to a given predicate, e.g. - `decimal?`. Say someone comes up with a new `decimal?`-like class and wants to redefine - `decimal?` to accommodate. We could define `decimal?` as a reactive/extensible type to - do this. However, it seems preferable to instead define a marker protocol called - `PDecimal` or some such and put that on the defined `deftype` itself, and incorporate - `PDecimal` into `decimal?` from the start. - [2] - Direct dispatch needs to actually work correctly in typed contexts - [3] - t/numerically : e.g. a double representing exactly what a float is able to represent + [1] - `t/input-type` should cause a split (unique by `t/=`) rather than just doing `t/or` since + otherwise you end up with e.g. `t/any?` as a type instead of + `[t/boolean? ... t/double? t/nil? t/val?]` being handled separately + - (t/extend-defn! c?/comp< + ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] + (c?/< (c?/compare a b) 0))) + [2] - t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. - t/numerically-integer? - Primitive conversions not requiring checks can go in data.primitive @@ -99,16 +84,19 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - numeric definitions - numeric ranges - numeric characteristics - [4] - No trailing `>` means `> ?`f - - ? : type inference - - use logic programming and variable unification e.g. `?1` `?2` ? - - For this situation: `?` is `(t/- dc/counted?)` - ([n dn/std-integer?, xs dc/counted?] (count xs)) - ([n dn/std-integer?, xs ?] ...) + [3] - Direct dispatch needs to actually work correctly in typed contexts + [ ] - Probably should disallow recursive type references, including: + `(t/defn f [x (t/input-type f ...)])` [ ] - t/value-of - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` [ ] - (comp/t== x) - dependent type such that the passed input must be identical to x + [ ] - `?` : type inference + - use logic programming and variable unification e.g. `?1` `?2` ? + - For this situation: `?` is `(t/- dc/counted?)` + ([n dn/std-integer?, xs dc/counted?] (count xs)) + ([n dn/std-integer?, xs ?] ...) + - [ ] No trailing `>` means `> ?`f [ ] - Non-boxed `def`s: `(var/def- min-float (Numeric/negate Float/MAX_VALUE))` - `(t/validate x (t/* t/string?))` for `(t/* t/string?)` needs to be more performant - Don't re-create type on each call diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 40069756..388b1126 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -681,8 +681,8 @@ caller|type (let [args (->> arg-nodes rest (map :type) (map t/unvalue))] (case (name caller|form) - "input-type" (t/rx (t/input-type* @caller|type args)) - "output-type" (t/rx (t/output-type* @caller|type args)))))] + "input-type" (t/input-type* caller|type args) + "output-type" (t/output-type* caller|type args))))] (uref/set! !!dependent? true) (uast/call-node {:env env @@ -1001,7 +1001,7 @@ (ifs (empty? arglist-syms|unanalyzed) [{:env env :out-type-node (if (t/type? out-type-or-form) - (ast/literal env nil out-type-or-form) ; a simulated AST node + (uast/literal env nil out-type-or-form) ; a simulated AST node (-> (analyze env out-type-or-form) (update :type t/unvalue))) :dependent? (uref/get !!dependent?)}] (>= (uref/get !!analyze-arg-syms|iter) analyze-arg-syms|max-iter) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 0d359360..406a4639 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -1049,9 +1049,16 @@ internal forms are analyzed, type-consistency is checked, and type-dispatch is resolved at compile time inasmuch as possible, and at runtime only when necessary. - Within the type system, primitives are always preferred to boxed values. All values that can be - primitives (i.e. ones that are `t/<=` w.r.t. a `(t/isa? )`) are treated - as primitives unless specifically marked otherwise with the `t/ref` metadata-adding directive. + Recommendations for the type system: + - Primitives are always preferred to boxed values. All values that can be primitives (i.e. ones + that are `t/<=` w.r.t. a `(t/isa? )`) are treated as primitives unless + specifically marked otherwise with the `t/ref` metadata-adding directive. + - One could imagine a dynamic set of types corresponding to a given predicate, e.g. `decimal?`. + Say someone comes up with a new `decimal?`-like class and wants to redefine `decimal?` to + accommodate. One could define `decimal?` as a reactive/extensible type to do this. However, it + is preferable to instead define a marker protocol called `PDecimal` or some such and put that + on the defined `deftype` itself, and incorporate `PDecimal` into `decimal?` from the start. In + this way fewer reactive changes have to happen and less compilation occurs. Compile-Time (Direct) Dispatch characteristics - Any input, if its type is `t/<=` a non-nil primitive (boxed or not) class, it will be marked diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 786f1d03..0bf0ac90 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -302,42 +302,43 @@ ) (t/extend-defn! c?/compare - ([a false? , b false?] 0) - ([a false? , b true?] -1) - ([a true? , b false?] 1) - ([a true? , b true?] 0) - ([a numeric? , b numeric?] (ifs (c?/< a b) -1 (c?/> a b) 1 0)) + ([a false? , b false?] (int 0)) + ([a false? , b true?] (int -1)) + ([a true? , b false?] (int 1)) + ([a true? , b true?] (int 0)) + ([a numeric? , b numeric?] + (ifs (c?/< a b) (int -1) (c?/> a b) (int 1) (int 0))) #?(:clj ([a (t/ref c?/icomparable?), b primitive?] (.compareTo a b))) #?(:clj ([a primitive? , b (t/ref c?/icomparable?)] (.compareTo (box a) b)))) (t/extend-defn! c?/comp< - ([a (t/input-type c?/compare [:? :_]), b (t/input-type c?/compare [:_ :?])] + ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] (c?/< (c?/compare a b) 0))) (t/extend-defn! c?/comp<= - ([a (t/input-type c?/compare [:? :_]), b (t/input-type c?/compare [:_ :?])] + ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] (c?/<= (c?/compare a b) 0))) (t/extend-defn! c?/comp= - ([a (t/input-type c?/compare [:? :_]), b (t/input-type c?/compare [:_ :?])] + ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] (c?/= (c?/compare a b) 0))) (t/extend-defn! c?/comp>= - ([a (t/input-type c?/compare [:? :_]), b (t/input-type c?/compare [:_ :?])] + ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] (c?/>= (c?/compare a b) 0))) (t/extend-defn! c?/comp> - ([a (t/input-type c?/compare [:? :_]), b (t/input-type c?/compare [:_ :?])] + ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] (c?/> (c?/compare a b) 0))) (t/defn promote-type [a nil?, b nil?]) (t/defn narrowest > t/type? - ([t0 (t/and (t/input-type >min-safe-integer-value [:?]) - (t/input-type >max-safe-integer-value [:?])) - t1 (t/and (t/input-type >min-safe-integer-value [:?]) - (t/input-type >max-safe-integer-value [:?]))] + ([t0 (t/and (t/input-type >min-safe-integer-value :?) + (t/input-type >max-safe-integer-value :?)) + t1 (t/and (t/input-type >min-safe-integer-value :?) + (t/input-type >max-safe-integer-value :?))] (let [t0-min (>min-safe-integer-value t0) t1-min (>min-safe-integer-value t1) t0-max (>max-safe-integer-value t0) @@ -355,8 +356,9 @@ t1))))) (t/extend-defn! c?/min -#?(:clj ( [a (t/- numeric? int?), b numeric?] (Numeric/min a b))) -#?(:clj ( [a numeric? , b (t/- numeric? int?)] (Numeric/min a b))) +#?(:clj ( [a int? , b (t/- numeric? int?)] (Numeric/min a b))) +#?(:clj ( [a (t/- numeric? int?), b int?] (Numeric/min a b))) +#?(:clj ( [a (t/- numeric? int?), b (t/- numeric? int?)] (Numeric/min a b))) #?(:clj (^:in [a int? , b int?] (Math/min a b))) #?(:cljs ( [a double? , b double? > (t/assume double?)] (js/Math.min a b)))) From ea9bc0a10512edeed370c52ef5b8a3a932cd3a74 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 8 Nov 2018 09:29:08 -0700 Subject: [PATCH 650/810] Add better `(input|output)-type` handling; fix fundamental `type>classes` bug --- src-untyped/quantum/untyped/core/type.cljc | 105 ++++++++++++++------- 1 file changed, 73 insertions(+), 32 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 61612229..9f8401a0 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -46,6 +46,7 @@ [quantum.untyped.core.logic :refer [fn-and ifs whenp->]] [quantum.untyped.core.numeric :as unum] + [quantum.untyped.core.numeric.combinatorics :as ucombo] [quantum.untyped.core.print :as upr] [quantum.untyped.core.reducers :as ur :refer [educe join reducei]] @@ -74,6 +75,7 @@ ProtocolType ClassType UnorderedType OrderedType ValueType FnType + MetaOrType ReactiveType]))) (ucore/log-this-ns) @@ -117,11 +119,6 @@ The only macro in all of the core type predicates." [& body] `(rx* (urx/!rx ~@body) ($ ~(vec body))))) -(defn- deref-when-reactive [x] - (if (utr/rx-type? x) - @x - x)) - (defns- separate-rx-and-apply "Only works for commutative functions." [f c/fn?, type-args (fn-> count (c/> 1)) > utr/type?] @@ -228,7 +225,7 @@ (err! "Not every element of finite type data is a type") (seq-or utr/rx-type? data) (rx (UnorderedType. uhash/default uhash/default nil - (->> data (uc/map+ deref-when-reactive) uc/frequencies) nil)) + (->> data (uc/map+ utr/deref-when-reactive) uc/frequencies) nil)) (UnorderedType. uhash/default uhash/default nil (frequencies data) nil))) ([datum _ & data _ > utr/unordered-type?] (unordered (cons datum data)))) @@ -246,7 +243,7 @@ (err! "Not every element of finite type data is a type") (seq-or utr/rx-type? data) (rx (OrderedType. uhash/default uhash/default nil - (->> data (uc/map deref-when-reactive)) nil)) + (->> data (uc/map utr/deref-when-reactive)) nil)) (OrderedType. uhash/default uhash/default nil data nil))) ([datum _ & data _ > utr/ordered-type?] (ordered (cons datum data)))) @@ -485,7 +482,7 @@ [] type-args)) -(defns- create-logical-type +(defns- create-logical-type|non-meta-ors [kind #{:or :and}, construct-fn _, type-pred _, type>args _ comparison-denotes-supersession? c/fn?, type-args (fn-> count (c/>= 1)) > utr/type?] (let [simplified @@ -498,6 +495,22 @@ (first simplified) (construct-fn uhash/default uhash/default nil simplified (atom nil))))) +(defns- create-logical-type + [kind #{:or :and}, construct-fn _, type-pred _, type>args _ + comparison-denotes-supersession? c/fn?, type-args (fn-> count (c/>= 1)) > utr/type?] + (let [meta-ors (->> type-args (uc/filter utr/meta-or-type?)) + non-meta-ors (->> type-args (uc/remove utr/meta-or-type?))] + (if (empty? meta-ors) + (create-logical-type|non-meta-ors + kind construct-fn type-pred type>args comparison-denotes-supersession? non-meta-ors) + (->> meta-ors + (uc/map utr/meta-or-type>types) + (apply ucombo/cartesian-product) + (uc/map (fn [types] + (create-logical-type|non-meta-ors kind construct-fn type-pred type>args + comparison-denotes-supersession? (concat types non-meta-ors)))) + meta-or)))) + ;; ===== `t/ftype` ===== ;; (defn ftype [out-type & arities-form] @@ -552,24 +565,33 @@ ([type-data-seq' [i|arg arg-type]] (c/or (->> type-data-seq' (uc/lfilter (c/fn [{:keys [input-types]}] - (utcomp/<= arg-type (get input-types i|arg)))) + (utcomp/<= (get input-types i|arg) arg-type))) seq) (reduced nil)))))))) (defn- input-or-output-type-handle-reactive [f t args] (if (utr/rx-type? t) (if (seq-or utr/rx-type? args) - (rx (f @t (map deref-when-reactive args))) + (rx (f @t (map utr/deref-when-reactive args))) (rx (f @t args))) (if (seq-or utr/rx-type? args) - (rx (f t (map deref-when-reactive args))) + (rx (f t (map utr/deref-when-reactive args))) (f t args)))) -(defn- input-type*|norx [t args] +(defn- input-type-seq|norx [t args] (let [i|? (->> args (reducei (c/fn [_ t i] (when (c/= t :?) (reduced i))) nil))] (->> (match-spec>type-data-seq t args) - (uc/lmap (c/fn [{:keys [input-types]}] (get input-types i|?))) - (apply or)))) + (uc/map (c/fn [{:keys [input-types]}] (get input-types i|?)))))) + +(defn- input-type-meta-or|norx [t args] (meta-or (input-type-seq|norx t args))) + +(defn- input-type*|norx [t args] (apply or (input-type-seq|norx t args))) + +(defns input-type-meta-or + [t (us/or* utr/fn-type? utr/rx-type?) args _ #_(us/seq-of (us/or* #{:_ :?} type?)) + | (->> args (filter #(c/= % :?)) count (c/= 1)) + > type?] + (input-or-output-type-handle-reactive input-type-meta-or|norx t args)) (defns input-type* "Outputs the type of a specified input to a typed fn." @@ -580,40 +602,43 @@ (defn input-type "Usage in arglist contexts: - - `(t/input-type >namespace [:?])` + - `(t/input-type >namespace :?)` - Outputs a reactive type embodying the union of the possible types of the first input to `>namespace`. - - `(t/input-type reduce [:_ :_ :?])` + - `(t/input-type reduce :_ :_ :?)` - Outputs a reactive type embodying the union of the possible types of the third input to `reduce`. - - `(t/input-type reduce [:? :_ string?])` + - `(t/input-type reduce :? :_ string?)` - Outputs a reactive type embodying the union of the possible types of the first input to `reduce` when the third input satisfies `string?`." - ([t] (err! "Can't use `input-type` outside of arglist contexts")) - ([t args] (err! "Can't use `input-type` outside of arglist contexts"))) + ([t & args] (err! "Can't use `input-type` outside of arglist contexts"))) -(defn- output-type*|norx [t args] +(defn- output-type-seq|norx [t args] (->> (match-spec>type-data-seq t args) - (uc/lmap :output-type) - (apply or))) + (uc/map :output-type))) + +(defn- output-type-meta-or|norx [t args] (meta-or (output-type-seq|norx t args))) + +(defn- output-type*|norx [t args] (apply or (output-type-seq|norx t args))) + +(defns output-type-meta-or + [t (us/or* utr/fn-type? utr/rx-type?) args (us/seq-of (us/or* #{:_} type?)) > type?] + (input-or-output-type-handle-reactive output-type-meta-or|norx t args)) (defns output-type* "Outputs the output type of a typed fn." - ([t (us/or* utr/fn-type? utr/rx-type?)] - (->> t utr/fn-type>arities (uc/mapcat+ val) (uc/map :output-type) (apply or))) - ([t (us/or* utr/fn-type? utr/rx-type?) args (us/seq-of (us/or* #{:_} type?)) > type?] - (input-or-output-type-handle-reactive output-type*|norx t args))) + [t (us/or* utr/fn-type? utr/rx-type?) args (us/seq-of (us/or* #{:_} type?)) > type?] + (input-or-output-type-handle-reactive output-type*|norx t args)) (defn output-type "Usage in arglist contexts: - - `(t/output-type >namespace)` - - Outputs a reactive type embodying the union of the possible output types of `>namespace` - given any valid inputs at all + - `(t/output-type >namespace :any)` + - (TODO) Outputs a reactive type embodying the union of the possible output types of + `>namespace` given any valid inputs at all - `(t/output-type reduce [:_ :_ string?])` - Outputs a reactive type embodying the union of the possible output types of `reduce` when the third input satisfies `string?`." - ([t] (err! "Can't use `output-type` outside of arglist contexts")) - ([t args] (err! "Can't use `output-type` outside of arglist contexts"))) + ([t & args] (err! "Can't use `output-type` outside of arglist contexts"))) ;; ===== Dependent types ===== ;; @@ -641,6 +666,22 @@ ;; ===== Etc. ===== ;; +(defns meta-or + "Essentially a combinatorial combinator: + + (t/or (t/meta-or [byte? short? char?]) string?) + -> (t/meta-or [(t/or byte? string?) + (t/or short? string?) + (t/or char? string?)])) + + Dedupes inputs that are `t/=`." + > utr/type? + [types (us/seq-of utr/type?)] + (let [types' (->> types (sort-by identity utcomp/compare) (uc/dedupe-by utcomp/=))] + (if (empty? types') + empty-set + (MetaOrType. uhash/default uhash/default nil types')))) + ;; TODO figure out the best place to put this #?(:clj (def unboxed-class->boxed-class @@ -691,7 +732,7 @@ (utr/or-type? t) (reduce (c/fn [classes' t'] (-type>classes t' include-classes-of-value-type? classes')) classes (utr/or-type>args t)) - (c/= val?) + (c/= t val?) (-type>classes val|by-class? include-classes-of-value-type? classes) :else (err! "Not sure how to handle type" t))) From ba8f37e69fb1060868670945f901854cffe4e518 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 8 Nov 2018 09:40:31 -0700 Subject: [PATCH 651/810] `dedupe`+`dedupe-by` --- .../quantum/untyped/core/collections.cljc | 24 +++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index 9b96e757..94266b74 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -388,6 +388,30 @@ (conj! distincts x))))) boolean)) +(defn dedupe-by|tf + "Like `dedupe`'s transducer but is able to dedupe by comparing two inputs by `eq-f` rather than + only `=`." + [eq-f] + (fn [rf] + (let [pv (volatile! ::none)] + (fn ([] (rf)) + ([result] (rf result)) + ([result input] + (let [prior @pv] + (vreset! pv input) + (if (and (not (identical? prior ::none)) + (eq-f prior input)) + result + (rf result input)))))))) + +(def-transducer>eager dedupe-by dedupe-by|tf 1) + +(def dedupe|tf + (let [gen-rf (dedupe-by|tf =)] + (fn [] gen-rf))) + +(def-transducer>eager dedupe dedupe|tf 0) + ;; ===== ZIPPER ===== ;; (defn default-zipper [coll] From 4f1a4ad997dd4cceb2da9c294f4426e29efe16cd Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 8 Nov 2018 09:41:17 -0700 Subject: [PATCH 652/810] `t/meta-or` to the rescue --- src-untyped/quantum/untyped/core/analyze.cljc | 56 ++++++++-------- .../quantum/untyped/core/type/defnt.cljc | 1 - .../untyped/core/type/reifications.cljc | 25 +++++++ test/quantum/test/untyped/core/analyze.cljc | 65 ++++++++++++++++--- test/quantum/test/untyped/core/type.cljc | 19 +++++- 5 files changed, 130 insertions(+), 36 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 388b1126..37704377 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -676,14 +676,15 @@ {:form form :args-ct (count args-form)}) (let [arg-nodes (->> args-form (mapv #(analyze* env %))) caller|node (analyze* env caller|form) - caller|type (-> arg-nodes first :type) - t (if (= (name caller|form) "type") - caller|type - (let [args (->> arg-nodes rest (map :type) (map t/unvalue))] - (case (name caller|form) - "input-type" (t/input-type* caller|type args) - "output-type" (t/output-type* caller|type args))))] - (uref/set! !!dependent? true) + caller|t (-> arg-nodes first :type) + _ (uref/set! !!dependent? true) + t (case (name caller|form) + "input-type" + (t/input-type-meta-or caller|t (->> arg-nodes rest (map :type) (map t/unvalue))) + "output-type" + (t/output-type-meta-or caller|t (->> arg-nodes rest (map :type) (map t/unvalue))) + "type" + caller|t)] (uast/call-node {:env env :unanalyzed-form form @@ -973,20 +974,23 @@ ;; TODO move? (defns type>split - "Only `t/or`s are splittable for now. + "Only `t/or`s and `t/meta-or`s are splittable for now. Reactive types are non-reactively derefed in order to make splitting possible." [t t/type? > (s/vec-of t/type?)] (let [t' (cond-> t (utr/rx-type? t) urx/norx-deref)] - (if (utr/or-type? t') - (utr/or-type>args t') - [t']))) + (ifs (utr/or-type? t') (utr/or-type>args t') + (utr/meta-or-type? t') (utr/meta-or-type>types t') + [t']))) (defns type>split+primitivized [t t/type? > (s/vec-of t/type?)] - (let [primitive-subtypes - (->> (t/type>primitive-subtypes (cond-> t (utr/rx-type? t) urx/norx-deref) false) - (sort-by sort-guide) ; For cleanliness and reproducibility in tests - vec)] - (uc/distinct (join primitive-subtypes (type>split t))))) + (let [t|norx (cond-> t (utr/rx-type? t) urx/norx-deref) + t|split (type>split t|norx) + primitive-subtypes + (->> t|split + (uc/map+ #(t/type>primitive-subtypes % false)) + (ur/educe uset/union) + (sort-by sort-guide))] ; For cleanliness and reproducibility in tests + (uc/distinct (concat primitive-subtypes t|split)))) (defn- enqueue-first-unanalyzed-if-queue-empty [env #_::env #_> #_::env] (cond-> env @@ -1007,16 +1011,16 @@ (>= (uref/get !!analyze-arg-syms|iter) analyze-arg-syms|max-iter) (err! "Max number of iterations reached for `analyze-arg-syms`" {:n (uref/get !!analyze-arg-syms|iter)}) - (let [_ (assert (not (empty? arglist-syms|queue))) - arg-sym (uc/last arglist-syms|queue) + (let [_ (assert (not (empty? arglist-syms|queue))) + arg-sym (uc/last arglist-syms|queue) arg-type-form (arg-sym->arg-type-form arg-sym) - analyzed (-> (analyze env arg-type-form) (update :type t/unvalue)) - env-analyzed (-> analyzed :env - (update-in [:opts :arglist-syms|queue] disj arg-sym) - (update-in [:opts :arglist-syms|unanalyzed] disj arg-sym)) - t-split (if split-types? - (-> analyzed :type type>split+primitivized) - [(:type analyzed)])] + analyzed (-> (analyze env arg-type-form) (update :type t/unvalue)) + env-analyzed (-> analyzed :env + (update-in [:opts :arglist-syms|queue] disj arg-sym) + (update-in [:opts :arglist-syms|unanalyzed] disj arg-sym)) + t-split (if split-types? + (-> analyzed :type type>split+primitivized) + [(:type analyzed)])] (if (-> t-split count (= 1)) (recur (-> env-analyzed (update-in [:opts :arg-env] diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 406a4639..2d657d3d 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -44,7 +44,6 @@ :refer [fn-or fn= if-not-let ifs]] [quantum.untyped.core.loops :refer [reduce-2]] - [quantum.untyped.core.numeric.combinatorics :as ucombo] [quantum.untyped.core.reducers :as ur :refer [educe educei reducei]] [quantum.untyped.core.refs :as uref diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 0a829ab9..ec326efd 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -414,6 +414,29 @@ (update :input-types vec) (set/rename-keys {:output-type-pair :output-type})))))) +;; ----- MetaOrType ----- ;; + +(udt/deftype MetaOrType + [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) + #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) + meta #_(t/? ::meta) + types #_(t/seq-of form?)] + {PType nil + ?Meta {meta ([this] meta) + with-meta ([this meta'] (MetaOrType. hash hash-code meta' types))} + ?Hash {hash ([this] (uhash/caching-set-ordered! hash MetaOrType types)) + hash-code ([this] (uhash/caching-set-code! hash-code MetaOrType types))} + ?Equals {= ([this that #_any?] + (or (== this that) + (and (instance? MetaOrType that) + (= types (.-types ^MetaOrType that)))))} + fedn/IOverride nil + fedn/IEdn {-edn ([this] (list 'quantum.untyped.core.type/meta-or types))}}) + +(defn meta-or-type? [x] (instance? MetaOrType x)) + +(defns meta-or-type>types [^MetaOrType t meta-or-type?] (.-types t)) + ;; ----- ReactiveType ----- ;; (declare rx-type?) @@ -445,3 +468,5 @@ fedn/IEdn {-edn ([this] (list `reactive-type {:value (urx/norx-deref this)}))}}) (defn rx-type? [x] (instance? ReactiveType x)) + +(defn deref-when-reactive [x] (if (rx-type? x) @x x)) diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index 6ef95601..0198f610 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -22,6 +22,15 @@ (defn- dummy {:quantum.core.type/type (t/rx (t/ftype nil [(t/or tt/short? tt/char?)]))} []) +;; For this fn, the input types combine when applying `t/or` (`(t/or t/nil? t/val?)`) +(defn- input-types-combine + {:quantum.core.type/type + (t/rx (t/ftype nil [t/nil? tt/byte?] + [t/nil? tt/char?] + [(t/ref t/val?) tt/byte?] + [(t/ref t/val?) tt/char?]))} + []) + (defn- transform-ana [ana] (->> ana (mapv #(vector (->> % :env :opts :arg-env deref (uc/map-vals' :type)) @@ -181,7 +190,7 @@ -> ERROR `a` not in environment and `a` already in queue; circular dependency detected" (throws (self/analyze-arg-syms '{a (t/type b) b (t/type c) c (t/type a)} 't/any?))) - (testing "Combination/integration test" + (testing "Complex test for `t/type` and simple test for `t/input-type`" ;; This test overview was put up in ~30 minutes on 9/30/2018 during a seemingly random walk of ;; thoughts without any testing or research whatsoever that happened to actually coalesce ;; into a working, clear, simple algorithm for handling dependent types. Not sure if @@ -415,14 +424,54 @@ transform-ana) ret) (is= (-> (self/analyze-arg-syms - '{a (t/or tt/boolean? (t/type b)) - b (t/or tt/byte? (t/type d)) - c (t/input-type dummy :?) - d (let [b (t/- tt/char? tt/long?)] - (t/or tt/char? (t/type b) (t/type c)))} - '(t/or (t/type b) (t/type d))) + '{a (t/or tt/boolean? (t/type b)) + b (t/or tt/byte? (t/type d)) + c (t/input-type dummy :?) + d (let [b (t/- tt/char? tt/long?)] + (t/or tt/char? (t/type b) (t/type c)))} + '(t/or (t/type b) (t/type d))) transform-ana) - ret))))) + ret))) + ;; TODO add multiple tests for this (`input-types-combine`) + (testing "`t/input-type` + `t/type`" + (is= (-> (self/analyze-arg-syms + '{a (t/or (t/input-type input-types-combine :? (t/type c)) tt/string?) + b (t/and (t/input-type input-types-combine :? (t/type c)) tt/long?) + c (t/or tt/byte? tt/char?)} + 'tt/int?) + transform-ana) + [[{'a (t/or (t/value nil) (t/isa? String)) + 'b (t/isa? Long) + 'c (t/isa? Byte)} + (t/isa? Integer)] + [{'a (t/or (t/value nil) (t/isa? String)) + 'b t/none? + 'c (t/isa? Byte)} + (t/isa? Integer)] + [{'a (t/ref (t/not (t/value nil))) + 'b (t/isa? Long) + 'c (t/isa? Byte)} + (t/isa? Integer)] + [{'a (t/ref (t/not (t/value nil))) + 'b t/none? + 'c (t/isa? Byte)} + (t/isa? Integer)] + [{'a (t/or (t/value nil) (t/isa? String)) + 'b (t/isa? Long) + 'c (t/isa? Character)} + (t/isa? Integer)] + [{'a (t/or (t/value nil) (t/isa? String)) + 'b t/none? + 'c (t/isa? Character)} + (t/isa? Integer)] + [{'a (t/ref (t/not (t/value nil))) + 'b (t/isa? Long) + 'c (t/isa? Character)} + (t/isa? Integer)] + [{'a (t/ref (t/not (t/value nil))) + 'b t/none? + 'c (t/isa? Character)} + (t/isa? Integer)]])))) (defn- rx=* [a b] (if (and (utr/rx-type? a) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 5d30d833..9b4debb9 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -551,4 +551,21 @@ #(t/value 1) #(t/value "abc") #(t/or (t/isa? #?(:clj Double :cljs js/Number)) (t/value "abc"))]] - (= (t/rx (gen-t)) (t/rx (gen-t)))))) + (is= @(t/rx (gen-t)) @(t/rx (gen-t)))))) + +(deftest test|meta-or + (is= (t/meta-or [string? string?]) + (t/meta-or [string?])) + (is= (t/or (t/meta-or [byte? short? char?]) string?) + (t/meta-or [(t/or byte? string?) + (t/or short? string?) + (t/or char? string?)])) + (is= (t/or (t/meta-or [long? t/any?]) + (t/meta-or [byte? short? char?])) + (t/meta-or [(t/or long? byte?) + (t/or long? short?) + (t/or long? char?) + t/any?])) + (is= (t/and (t/meta-or [long? t/any?]) + (t/meta-or [byte? short? char?])) + (t/meta-or [t/none? byte? short? char?]))) From e21b82eb8a8deabb02c8f3d593179322319302ec Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 8 Nov 2018 09:43:07 -0700 Subject: [PATCH 653/810] Fix compossibility --- src/quantum/core/data/primitive.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 0bf0ac90..c97f757f 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -312,7 +312,7 @@ #?(:clj ([a primitive? , b (t/ref c?/icomparable?)] (.compareTo (box a) b)))) (t/extend-defn! c?/comp< - ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] + ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare (t/type a) :?)] (c?/< (c?/compare a b) 0))) (t/extend-defn! c?/comp<= From 289ba2194424c533dd23c9b4d6bd589948419f9a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 8 Nov 2018 11:54:55 -0700 Subject: [PATCH 654/810] Add todo --- resources-dev/defnt.cljc | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 8f002c93..25daaced 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -87,6 +87,10 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative [3] - Direct dispatch needs to actually work correctly in typed contexts [ ] - Probably should disallow recursive type references, including: `(t/defn f [x (t/input-type f ...)])` + [ ] - `t/ref` and `t/assume` need to be combined correctly. E.g. (t/and (t/ref ...) ...) means the + whole thing should be `t/ref`, while `(t/or (t/ref ...) (...))` does not mean the metadata + is transferred. Probably `t/assume` should be combined in the same way. + - What about `(t/and (t/or t/long? (t/ref t/byte?)) pos?)` ? [ ] - t/value-of - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` [ ] - (comp/t== x) From e373d92c315f0b981c657a8b8421eb34ea9d93ab Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 8 Nov 2018 11:55:27 -0700 Subject: [PATCH 655/810] Add test and a related fix for rx output types --- src-untyped/quantum/untyped/core/analyze.cljc | 3 +- test/quantum/test/untyped/core/analyze.cljc | 30 +++++++++++++++---- 2 files changed, 27 insertions(+), 6 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 37704377..7237e8bc 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -1006,7 +1006,8 @@ [{:env env :out-type-node (if (t/type? out-type-or-form) (uast/literal env nil out-type-or-form) ; a simulated AST node - (-> (analyze env out-type-or-form) (update :type t/unvalue))) + (-> (analyze env out-type-or-form) + (update :type (fn-> t/unvalue urx/?norx-deref)))) :dependent? (uref/get !!dependent?)}] (>= (uref/get !!analyze-arg-syms|iter) analyze-arg-syms|max-iter) (err! "Max number of iterations reached for `analyze-arg-syms`" diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index 0198f610..6df38f37 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -31,6 +31,14 @@ [(t/ref t/val?) tt/char?]))} []) +(defn- fake-compare + {:quantum.core.type/type + (t/rx (t/ftype t/int? [t/nil? t/nil?] + [t/nil? (t/ref t/val?)] + [(t/ref t/val?) t/nil?] + [t/long? t/long?]))} + []) + (defn- transform-ana [ana] (->> ana (mapv #(vector (->> % :env :opts :arg-env deref (uc/map-vals' :type)) @@ -440,11 +448,11 @@ c (t/or tt/byte? tt/char?)} 'tt/int?) transform-ana) - [[{'a (t/or (t/value nil) (t/isa? String)) + [[{'a (t/or (t/isa? String) (t/value nil)) 'b (t/isa? Long) 'c (t/isa? Byte)} (t/isa? Integer)] - [{'a (t/or (t/value nil) (t/isa? String)) + [{'a (t/or (t/isa? String) (t/value nil)) 'b t/none? 'c (t/isa? Byte)} (t/isa? Integer)] @@ -456,11 +464,11 @@ 'b t/none? 'c (t/isa? Byte)} (t/isa? Integer)] - [{'a (t/or (t/value nil) (t/isa? String)) + [{'a (t/or (t/isa? String) (t/value nil)) 'b (t/isa? Long) 'c (t/isa? Character)} (t/isa? Integer)] - [{'a (t/or (t/value nil) (t/isa? String)) + [{'a (t/or (t/isa? String) (t/value nil)) 'b t/none? 'c (t/isa? Character)} (t/isa? Integer)] @@ -471,7 +479,19 @@ [{'a (t/ref (t/not (t/value nil))) 'b t/none? 'c (t/isa? Character)} - (t/isa? Integer)]])))) + (t/isa? Integer)]])) + (testing "input to `t/input-type` depends on another `t/input-type`; `t/output-type` depends on + other `t/input-type`s" + (is= (-> (self/analyze-arg-syms + '{a (t/input-type fake-compare :? :_) + b (t/input-type fake-compare (t/type a) :?)} + '(t/output-type fake-compare (type a) (type b))) + transform-ana) + [[{'a (t/isa? Long) 'b (t/isa? Long)} (t/isa? Integer)] + [{'a (t/value nil) 'b (t/value nil)} (t/isa? Integer)] + [{'a (t/value nil) 'b (t/ref (t/not (t/value nil)))} (t/isa? Integer)] + [{'a (t/ref (t/not (t/value nil))) 'b (t/isa? Long)} (t/isa? Integer)] + [{'a (t/ref (t/not (t/value nil))) 'b (t/value nil)} (t/isa? Integer)]])))) (defn- rx=* [a b] (if (and (utr/rx-type? a) From 60782eb9f4b0e828bcc96533c1eff1de21e82aae Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 8 Nov 2018 12:11:37 -0700 Subject: [PATCH 656/810] input-type and output-type should respect non-splitting --- src-untyped/quantum/untyped/core/analyze.cljc | 16 ++-- src-untyped/quantum/untyped/core/type.cljc | 95 +++++++++++-------- .../quantum/untyped/core/type/defnt.cljc | 18 ++-- test/quantum/test/untyped/core/type.cljc | 19 +++- 4 files changed, 93 insertions(+), 55 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 7237e8bc..e41cde40 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -676,15 +676,17 @@ {:form form :args-ct (count args-form)}) (let [arg-nodes (->> args-form (mapv #(analyze* env %))) caller|node (analyze* env caller|form) - caller|t (-> arg-nodes first :type) + caller|t (-> arg-nodes first :type) + arg-types (->> arg-nodes rest (map :type) (map t/unvalue)) _ (uref/set! !!dependent? true) t (case (name caller|form) - "input-type" - (t/input-type-meta-or caller|t (->> arg-nodes rest (map :type) (map t/unvalue))) - "output-type" - (t/output-type-meta-or caller|t (->> arg-nodes rest (map :type) (map t/unvalue))) - "type" - caller|t)] + "input-type" (if (-> env :opts :split-types?) + (t/input-type-meta-or caller|t arg-types) + (t/input-type-or caller|t arg-types)) + "output-type" (if (-> env :opts :split-types?) + (t/output-type-meta-or caller|t arg-types) + (t/output-type-or caller|t arg-types)) + "type" caller|t)] (uast/call-node {:env env :unanalyzed-form form diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 9f8401a0..80035cbf 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -37,7 +37,7 @@ [quantum.untyped.core.error :as uerr :refer [err! TODO catch-all]] [quantum.untyped.core.fn :as ufn - :refer [fn1 rcomp <- fn->]] + :refer [fn1 rcomp <- fn-> fn->>]] [quantum.untyped.core.form :refer [$]] [quantum.untyped.core.form.generate.deftype :as udt] @@ -83,7 +83,7 @@ ;; ===== TODOS ===== ;; (declare - - create-logical-type nil? val? + - create-logical-type meta-or with-expand-meta-ors nil? val? and or val|by-class?) (defonce *type-registry (atom {})) @@ -498,18 +498,10 @@ (defns- create-logical-type [kind #{:or :and}, construct-fn _, type-pred _, type>args _ comparison-denotes-supersession? c/fn?, type-args (fn-> count (c/>= 1)) > utr/type?] - (let [meta-ors (->> type-args (uc/filter utr/meta-or-type?)) - non-meta-ors (->> type-args (uc/remove utr/meta-or-type?))] - (if (empty? meta-ors) - (create-logical-type|non-meta-ors - kind construct-fn type-pred type>args comparison-denotes-supersession? non-meta-ors) - (->> meta-ors - (uc/map utr/meta-or-type>types) - (apply ucombo/cartesian-product) - (uc/map (fn [types] - (create-logical-type|non-meta-ors kind construct-fn type-pred type>args - comparison-denotes-supersession? (concat types non-meta-ors)))) - meta-or)))) + (with-expand-meta-ors type-args + (fn [types'] + (create-logical-type|non-meta-ors + kind construct-fn type-pred type>args comparison-denotes-supersession? types')))) ;; ===== `t/ftype` ===== ;; @@ -578,14 +570,14 @@ (rx (f t (map utr/deref-when-reactive args))) (f t args)))) -(defn- input-type-seq|norx [t args] +(defn- input-type-meta-or|norx [t args] (let [i|? (->> args (reducei (c/fn [_ t i] (when (c/= t :?) (reduced i))) nil))] - (->> (match-spec>type-data-seq t args) - (uc/map (c/fn [{:keys [input-types]}] (get input-types i|?)))))) - -(defn- input-type-meta-or|norx [t args] (meta-or (input-type-seq|norx t args))) - -(defn- input-type*|norx [t args] (apply or (input-type-seq|norx t args))) + (with-expand-meta-ors args + (fn [args'] + (->> args' + (match-spec>type-data-seq t) + (uc/map (c/fn [{:keys [input-types]}] (get input-types i|?))) + meta-or))))) (defns input-type-meta-or [t (us/or* utr/fn-type? utr/rx-type?) args _ #_(us/seq-of (us/or* #{:_ :?} type?)) @@ -593,12 +585,16 @@ > type?] (input-or-output-type-handle-reactive input-type-meta-or|norx t args)) -(defns input-type* +(defn- input-type-or|norx [t args] + (let [t' (input-type-meta-or|norx t args)] + (cond-> t' (utr/meta-or-type? t') (->> utr/meta-or-type>types (apply or))))) + +(defns input-type-or "Outputs the type of a specified input to a typed fn." [t (us/or* utr/fn-type? utr/rx-type?) args _ #_(us/seq-of (us/or* #{:_ :?} type?)) | (->> args (filter #(c/= % :?)) count (c/= 1)) > type?] - (input-or-output-type-handle-reactive input-type*|norx t args)) + (input-or-output-type-handle-reactive input-type-or|norx t args)) (defn input-type "Usage in arglist contexts: @@ -613,22 +609,24 @@ `reduce` when the third input satisfies `string?`." ([t & args] (err! "Can't use `input-type` outside of arglist contexts"))) -(defn- output-type-seq|norx [t args] - (->> (match-spec>type-data-seq t args) - (uc/map :output-type))) - -(defn- output-type-meta-or|norx [t args] (meta-or (output-type-seq|norx t args))) - -(defn- output-type*|norx [t args] (apply or (output-type-seq|norx t args))) +(defn- output-type-meta-or|norx [t args] + (with-expand-meta-ors args + (fn->> (match-spec>type-data-seq t) + (uc/map :output-type) + meta-or))) (defns output-type-meta-or [t (us/or* utr/fn-type? utr/rx-type?) args (us/seq-of (us/or* #{:_} type?)) > type?] (input-or-output-type-handle-reactive output-type-meta-or|norx t args)) -(defns output-type* +(defn- output-type-or|norx [t args] + (let [t' (output-type-meta-or|norx t args)] + (cond-> t' (utr/meta-or-type? t') (->> utr/meta-or-type>types (apply or))))) + +(defns output-type-or "Outputs the output type of a typed fn." [t (us/or* utr/fn-type? utr/rx-type?) args (us/seq-of (us/or* #{:_} type?)) > type?] - (input-or-output-type-handle-reactive output-type*|norx t args)) + (input-or-output-type-handle-reactive output-type-or|norx t args)) (defn output-type "Usage in arglist contexts: @@ -666,6 +664,25 @@ ;; ===== Etc. ===== ;; +(defns- with-expand-meta-ors [type-args (us/seq-of type?), f c/fn?] + (if-not (seq-or utr/meta-or-type? type-args) + (f type-args) + (->> type-args + (uc/map (fn [t] (if (utr/meta-or-type? t) + (utr/meta-or-type>types t) + [t]))) + (apply ucombo/cartesian-product) + (uc/map f) + meta-or))) + +(defns- meta-or|norx + > utr/type? + [types (us/seq-of utr/type?)] + (let [types' (->> types uc/distinct (sort-by identity utcomp/compare) (uc/dedupe-by utcomp/=))] + (ifs (empty? types') empty-set + (-> types' count (c/= 1)) (first types') + (MetaOrType. uhash/default uhash/default nil types')))) + (defns meta-or "Essentially a combinatorial combinator: @@ -674,13 +691,13 @@ (t/or short? string?) (t/or char? string?)])) - Dedupes inputs that are `t/=`." - > utr/type? - [types (us/seq-of utr/type?)] - (let [types' (->> types (sort-by identity utcomp/compare) (uc/dedupe-by utcomp/=))] - (if (empty? types') - empty-set - (MetaOrType. uhash/default uhash/default nil types')))) + - Commutative. + - Dedupes inputs that are either structurally `=` or `t/=`. + - Does not handle nested `meta-or`s." + > utr/type? + [types (us/seq-of utr/type?)] + (quantum.untyped.core.analyze/pr! ["types" types]) + (separate-rx-and-apply meta-or|norx types)) ;; TODO figure out the best place to put this #?(:clj diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 2d657d3d..0d820022 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -274,16 +274,22 @@ arg-types0 arg-types1) ct-comparison))) -(c/defn- dedupe-type-data [on-dupe #_fn?, type-data #_(vec-of ::types-decl-datum)] - (reduce (let [*prev-datum (volatile! nil)] +(c/defn- dedupe-type-data + "Performs both structural and `t/compare` deduplication." + [on-dupe #_fn?, type-data #_(vec-of ::types-decl-datum)] + (reduce (let [!prev-datum (volatile! nil) + !unique-data (transient #{})] (c/fn [data {:as datum :keys [arg-types]}] (with-do - (ifs (nil? @*prev-datum) + (ifs (nil? @!prev-datum) (conj data datum) - (= uset/=ident (utcomp/compare-inputs (:arg-types @*prev-datum) arg-types)) - (on-dupe data @*prev-datum datum) + (or (contains? !unique-data datum) + (= uset/=ident + (utcomp/compare-inputs (:arg-types @!prev-datum) arg-types))) + (on-dupe data @!prev-datum datum) (conj data datum)) - (vreset! *prev-datum datum)))) + (conj! !unique-data datum) + (vreset! !prev-datum datum)))) [] type-data)) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 9b4debb9..e63735c9 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -554,8 +554,6 @@ (is= @(t/rx (gen-t)) @(t/rx (gen-t)))))) (deftest test|meta-or - (is= (t/meta-or [string? string?]) - (t/meta-or [string?])) (is= (t/or (t/meta-or [byte? short? char?]) string?) (t/meta-or [(t/or byte? string?) (t/or short? string?) @@ -568,4 +566,19 @@ t/any?])) (is= (t/and (t/meta-or [long? t/any?]) (t/meta-or [byte? short? char?])) - (t/meta-or [t/none? byte? short? char?]))) + (t/meta-or [t/none? byte? short? char?])) + (testing "Reactive types" + (is= @(t/meta-or [(t/rx string?) byte?]) + (t/meta-or [byte? string?]))) + (testing "Structural deduplication" + (is= (t/meta-or [string? string?]) + (t/meta-or [string?]) + string?) + (is= (t/meta-or [(t/value 1) + (t/value true) + (t/value false) + (t/value true) + (t/value 1)]) + (t/meta-or [(t/value 1) + (t/value true) + (t/value false)])))) From 959a4602f80931a697424623ab4caabd6f10c675 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 8 Nov 2018 13:21:38 -0700 Subject: [PATCH 657/810] Fix overload splitting with `t/(in|out)put-type` --- src-untyped/quantum/untyped/core/analyze.cljc | 16 ++-- src-untyped/quantum/untyped/core/type.cljc | 75 +++++++++++-------- src/quantum/core/data/primitive.cljc | 10 +-- src/quantum/core/type.cljc | 4 +- test/quantum/test/untyped/core/analyze.cljc | 31 ++++---- test/quantum/test/untyped/core/type.cljc | 47 +++++++++--- 6 files changed, 113 insertions(+), 70 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index e41cde40..717c02db 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -674,18 +674,18 @@ (-> args-form count (not= 1))) (err! "Incorrect number of args passed to dependent type call" {:form form :args-ct (count args-form)}) - (let [arg-nodes (->> args-form (mapv #(analyze* env %))) - caller|node (analyze* env caller|form) - caller|t (-> arg-nodes first :type) - arg-types (->> arg-nodes rest (map :type) (map t/unvalue)) + (let [arg-nodes (->> args-form (mapv #(analyze* env %))) + caller|node (analyze* env caller|form) + caller|t (-> arg-nodes first :type) + unvalued-arg-types (->> arg-nodes rest (map :type) (map t/unvalue)) _ (uref/set! !!dependent? true) t (case (name caller|form) "input-type" (if (-> env :opts :split-types?) - (t/input-type-meta-or caller|t arg-types) - (t/input-type-or caller|t arg-types)) + (t/input-type|meta-or caller|t unvalued-arg-types) + (t/input-type|or caller|t unvalued-arg-types)) "output-type" (if (-> env :opts :split-types?) - (t/output-type-meta-or caller|t arg-types) - (t/output-type-or caller|t arg-types)) + (t/output-type|meta-or caller|t unvalued-arg-types) + (t/output-type|or caller|t unvalued-arg-types)) "type" caller|t)] (uast/call-node {:env env diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 80035cbf..e72036df 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -546,20 +546,28 @@ (defns compare|out [x0 utr/fn-type?, x1 utr/fn-type? > uset/comparison?] (utcomp/compare (fn-type>output-type x0) (fn-type>output-type x1))) -(defn- match-spec>type-data-seq [t args] - (let [type-data-seq (-> t utr/fn-type>arities (get (count args)))] - (->> args +(defn- match-spec>type-data-seq + "Returns the type data of overloads that support the specified arg types." + [t match-spec] + (let [type-data-seq (-> t utr/fn-type>arities (get (count match-spec)))] + (->> match-spec (uc/map-indexed+ vector) (uc/remove (fn-> second #{:_ :?})) (educe (c/fn ([] type-data-seq) ([type-data-seq'] type-data-seq') - ([type-data-seq' [i|arg arg-type]] - (c/or (->> type-data-seq' - (uc/lfilter (c/fn [{:keys [input-types]}] - (utcomp/<= (get input-types i|arg) arg-type))) - seq) - (reduced nil)))))))) + ([type-data-seq' [i|arg arg-type-or-vec]] + (let [compf (if (sequential? arg-type-or-vec) + (first arg-type-or-vec) + utcomp/<=) + arg-type (if (sequential? arg-type-or-vec) + (second arg-type-or-vec) + arg-type-or-vec)] + (c/or (->> type-data-seq' + (uc/lfilter (c/fn [{:keys [input-types]}] + (compf arg-type (get input-types i|arg)))) + seq) + (reduced nil))))))))) (defn- input-or-output-type-handle-reactive [f t args] (if (utr/rx-type? t) @@ -570,31 +578,33 @@ (rx (f t (map utr/deref-when-reactive args))) (f t args)))) -(defn- input-type-meta-or|norx [t args] - (let [i|? (->> args (reducei (c/fn [_ t i] (when (c/= t :?) (reduced i))) nil))] - (with-expand-meta-ors args - (fn [args'] - (->> args' +(defn- input-type|meta-or|norx [t match-spec] + (let [i|? (->> match-spec (reducei (c/fn [_ t i] (when (c/= t :?) (reduced i))) nil))] + (with-expand-meta-ors match-spec + (fn [match-spec'] + (->> match-spec' (match-spec>type-data-seq t) (uc/map (c/fn [{:keys [input-types]}] (get input-types i|?))) meta-or))))) -(defns input-type-meta-or - [t (us/or* utr/fn-type? utr/rx-type?) args _ #_(us/seq-of (us/or* #{:_ :?} type?)) - | (->> args (filter #(c/= % :?)) count (c/= 1)) +(defns input-type|meta-or + [t (us/or* utr/fn-type? utr/rx-type?) + match-spec _ #_(us/seq-of (us/or* #{:_ :?} (us/or* type? (us/tuple ifn? type?)))) + | (->> match-spec (filter #(c/= % :?)) count (c/= 1)) > type?] - (input-or-output-type-handle-reactive input-type-meta-or|norx t args)) + (input-or-output-type-handle-reactive input-type|meta-or|norx t match-spec)) -(defn- input-type-or|norx [t args] - (let [t' (input-type-meta-or|norx t args)] +(defn- input-type|or|norx [t match-spec] + (let [t' (input-type|meta-or|norx t match-spec)] (cond-> t' (utr/meta-or-type? t') (->> utr/meta-or-type>types (apply or))))) -(defns input-type-or +(defns input-type|or "Outputs the type of a specified input to a typed fn." - [t (us/or* utr/fn-type? utr/rx-type?) args _ #_(us/seq-of (us/or* #{:_ :?} type?)) - | (->> args (filter #(c/= % :?)) count (c/= 1)) + [t (us/or* utr/fn-type? utr/rx-type?) + match-spec _ #_(us/seq-of (us/or* #{:_ :?} (us/or* type? (us/tuple ifn? type?)))) + | (->> match-spec (filter #(c/= % :?)) count (c/= 1)) > type?] - (input-or-output-type-handle-reactive input-type-or|norx t args)) + (input-or-output-type-handle-reactive input-type|or|norx t match-spec)) (defn input-type "Usage in arglist contexts: @@ -609,24 +619,24 @@ `reduce` when the third input satisfies `string?`." ([t & args] (err! "Can't use `input-type` outside of arglist contexts"))) -(defn- output-type-meta-or|norx [t args] +(defn- output-type|meta-or|norx [t args] (with-expand-meta-ors args (fn->> (match-spec>type-data-seq t) (uc/map :output-type) meta-or))) -(defns output-type-meta-or +(defns output-type|meta-or [t (us/or* utr/fn-type? utr/rx-type?) args (us/seq-of (us/or* #{:_} type?)) > type?] - (input-or-output-type-handle-reactive output-type-meta-or|norx t args)) + (input-or-output-type-handle-reactive output-type|meta-or|norx t args)) -(defn- output-type-or|norx [t args] - (let [t' (output-type-meta-or|norx t args)] +(defn- output-type|or|norx [t args] + (let [t' (output-type|meta-or|norx t args)] (cond-> t' (utr/meta-or-type? t') (->> utr/meta-or-type>types (apply or))))) -(defns output-type-or +(defns output-type|or "Outputs the output type of a typed fn." [t (us/or* utr/fn-type? utr/rx-type?) args (us/seq-of (us/or* #{:_} type?)) > type?] - (input-or-output-type-handle-reactive output-type-or|norx t args)) + (input-or-output-type-handle-reactive output-type|or|norx t args)) (defn output-type "Usage in arglist contexts: @@ -693,10 +703,9 @@ - Commutative. - Dedupes inputs that are either structurally `=` or `t/=`. - - Does not handle nested `meta-or`s." + - Does not currently handle nested `meta-or`s." > utr/type? [types (us/seq-of utr/type?)] - (quantum.untyped.core.analyze/pr! ["types" types]) (separate-rx-and-apply meta-or|norx types)) ;; TODO figure out the best place to put this diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index c97f757f..17f563e1 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -312,23 +312,23 @@ #?(:clj ([a primitive? , b (t/ref c?/icomparable?)] (.compareTo (box a) b)))) (t/extend-defn! c?/comp< - ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare (t/type a) :?)] + ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare [= (t/type a)] :?)] (c?/< (c?/compare a b) 0))) (t/extend-defn! c?/comp<= - ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] + ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare [= (t/type a)] :?)] (c?/<= (c?/compare a b) 0))) (t/extend-defn! c?/comp= - ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] + ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare [= (t/type a)] :?)] (c?/= (c?/compare a b) 0))) (t/extend-defn! c?/comp>= - ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] + ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare [= (t/type a)] :?)] (c?/>= (c?/compare a b) 0))) (t/extend-defn! c?/comp> - ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] + ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare [= (t/type a)] :?)] (c?/> (c?/compare a b) 0))) (t/defn promote-type [a nil?, b nil?]) diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index 87d0f079..2b0449fd 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -19,7 +19,9 @@ ;; Generators ? *, isa? isa?|direct ; fn ; TODO TYPED rename - ftype input-type output-type + ftype + input-type input-type|meta-or input-type|or + output-type output-type|meta-or output-type|or value unvalue ;; Combinators and or - if not diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index 6df38f37..26c474b7 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -31,14 +31,6 @@ [(t/ref t/val?) tt/char?]))} []) -(defn- fake-compare - {:quantum.core.type/type - (t/rx (t/ftype t/int? [t/nil? t/nil?] - [t/nil? (t/ref t/val?)] - [(t/ref t/val?) t/nil?] - [t/long? t/long?]))} - []) - (defn- transform-ana [ana] (->> ana (mapv #(vector (->> % :env :opts :arg-env deref (uc/map-vals' :type)) @@ -483,15 +475,26 @@ (testing "input to `t/input-type` depends on another `t/input-type`; `t/output-type` depends on other `t/input-type`s" (is= (-> (self/analyze-arg-syms - '{a (t/input-type fake-compare :? :_) - b (t/input-type fake-compare (t/type a) :?)} - '(t/output-type fake-compare (type a) (type b))) + '{a (t/input-type tt/fake-compare :? :_) + b (t/input-type tt/fake-compare (t/type a) :?)} + '(t/output-type tt/fake-compare (t/type a) (t/type b))) transform-ana) - [[{'a (t/isa? Long) 'b (t/isa? Long)} (t/isa? Integer)] + [;; Directly from `[t/long? t/long?]` + [{'a (t/isa? Long) 'b (t/isa? Long)} (t/isa? Integer)] + ;; Because arg0 is `t/long?`, is `t/<=` `(t/ref t/val?)`, and so this is from + ;; `[(t/ref t/val?) t/nil?]` + [{'a (t/isa? Long) 'b (t/value nil)} (t/isa? Integer)] + ;; Directly from `[t/nil? t/nil?]` [{'a (t/value nil) 'b (t/value nil)} (t/isa? Integer)] + ;; Directly from `[t/nil? (t/ref t/val?)]` [{'a (t/value nil) 'b (t/ref (t/not (t/value nil)))} (t/isa? Integer)] - [{'a (t/ref (t/not (t/value nil))) 'b (t/isa? Long)} (t/isa? Integer)] - [{'a (t/ref (t/not (t/value nil))) 'b (t/value nil)} (t/isa? Integer)]])))) + ;; Directly from `[(t/ref t/val?) t/nil?]` + [{'a (t/ref (t/not (t/value nil))) 'b (t/value nil)} (t/isa? Integer)]]) + (is= (-> (self/analyze-arg-syms + '{a (t/input-type tt/fake-compare :? :_) + b (t/input-type tt/fake-compare [= (t/type a)] :?)} + '(t/output-type tt/fake-compare (t/type a) (t/type b))) + transform-ana))))) (defn- rx=* [a b] (if (and (utr/rx-type? a) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index e63735c9..285176fa 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -49,6 +49,16 @@ #?(:clj (def comparable? (t/isa? Comparable))) #?(:clj (def java-set? (t/isa? java.util.Set))) +;; ----- Simulated typed fns ----- ;; + +(defn fake-compare + {:quantum.core.type/type + (t/rx (t/ftype t/int? [t/nil? t/nil?] + [t/nil? (t/ref t/val?)] + [(t/ref t/val?) t/nil?] + [t/long? t/long?]))} + []) + ;; ----- Example interface hierarchy ----- ;; (do @@ -532,15 +542,34 @@ (def reduce|type (t/ftype t/any? [fn? t/any? string? :> char-seq?] [ifn? t/any? java-set? :> comparable?])) -(deftest test|input-type* - (is= (t/or string? symbol?) (t/input-type* >namespace|type [:?])) - (is= (t/or string? java-set?) (t/input-type* reduce|type [:_ :_ :?]))) - (is= fn? (t/input-type* reduce|type [:? :_ string?])) - -(deftest test|output-type* - (is= string? (t/output-type* >namespace|type)) - (is= (t/or char-seq? comparable?) (t/output-type* reduce|type)) - (is= char-seq? (t/output-type* reduce|type [:_ :_ string?]))) +(deftest test|input-type|meta-or + (is= (t/input-type|meta-or + (-> #'fake-compare meta :quantum.core.type/type deref) + [(t/not (t/value nil)) :?]) + ;; i.e., not `long?` + (t/meta-or [(t/value nil)])) + (is= (t/input-type|meta-or + (-> #'fake-compare meta :quantum.core.type/type deref) + [long? :?]) + (t/meta-or + ;; Because arg0 is `long?`, is `t/<=` `(t/ref t/val?)`, and so this is from + ;; `[(t/ref t/val?) t/nil?]` + [(t/value nil) + long?])) + (is= (t/input-type|meta-or + (-> #'fake-compare meta :quantum.core.type/type deref) + [[= long?] :?]) + (t/meta-or [long?]))) + +(deftest test|input-type|or + (is= (t/or string? symbol?) (t/input-type|or >namespace|type [:?])) + (is= (t/or string? java-set?) (t/input-type|or reduce|type [:_ :_ :?]))) + (is= fn? (t/input-type|or reduce|type [:? :_ string?])) + +(deftest test|output-type|or + (is= string? (t/output-type|or >namespace|type)) + (is= (t/or char-seq? comparable?) (t/output-type|or reduce|type)) + (is= char-seq? (t/output-type|or reduce|type [:_ :_ string?]))) (deftest test|rx (testing "=" From 20fdcc5487e57991da8218eb99aa5d8658730c37 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 8 Nov 2018 15:15:31 -0700 Subject: [PATCH 658/810] Analyze built-in sets and vectors --- resources-dev/defnt.cljc | 2 - src-untyped/quantum/untyped/core/analyze.cljc | 87 +++++++++++++------ .../quantum/untyped/core/analyze/ast.cljc | 27 +++++- src-untyped/quantum/untyped/core/type.cljc | 20 +++-- test/quantum/test/untyped/core/analyze.cljc | 10 ++- 5 files changed, 108 insertions(+), 38 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 25daaced..308189e3 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -169,8 +169,6 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative -> the only one that can be < 0 is the -1 -> (< a b) - Better analysis of compound literals - - Literal vectors need to be analyzed — (t/finite-of t/built-in-vector? a-type b-type ...) - - Literal sets need to be analyzed — (t/finite-of t/built-in-set? a-type b-type ...) - Literal seqs need to be better analyzed — (t/finite-of t/built-in-list? [ak-type av-type] ...) - Peformance analysis (this comes very much later) - We should be able to do complexity analysis. Similarly to how we can combine and manipulate diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 717c02db..69475a2d 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -205,6 +205,7 @@ (declare analyze* analyze-arg-syms*) +;; TODO maybe just roll this into `analyze-seq|do`? Not sure yet (defns- analyze-non-map-seqable "Analyzes a non-map seqable." {:params-doc @@ -220,32 +221,72 @@ (update :form (fn-> persistent! (add-file-context-from form))) (update :body persistent!))) +;; TODO abstract `analyze-unkeyed` and `analyze-map` +(defns- analyze-unkeyed + [env ::env, form _, empty-v _, built-in-type t/type?, ordered-or-unordered fn?, >ast fn? + > uast/node?] + (let [{:keys [all-values? nodes]} + (->> form + (uc/map+ (fn [form-v] (analyze* env form-v))) + (educe (fn ([ret] ret) + ([{:as ret :keys [all-values?]} v] + (-> ret + (cond-> (and all-values? (-> v :type utr/value-type?)) + (assoc :all-values? true)) + (update :nodes conj v)))) + {:all-values? true :nodes []})) + t (if all-values? + (->> nodes + (uc/map+ (fn-> :type t/unvalue)) + (join empty-v) + t/value) + (t/and built-in-type (->> nodes (uc/map :type) ordered-or-unordered)))] + (>ast {:env env + :unanalyzed-form form + :form (->> nodes (uc/map+ :form) (join empty-v) + (<- (add-file-context-from form))) + :nodes nodes + :type t}))) + +(defns- analyze-vector [env ::env, form _ > uast/vector-node?] + (analyze-unkeyed env form [] t/+vector|built-in? t/ordered uast/vector-node)) + +(defns- analyze-set [env ::env, form _ > uast/set-node?] + (analyze-unkeyed env form #{} t/+unordered-set|built-in? t/unordered uast/set-node)) + (defns- analyze-map {:todo #{"Should we differentiate between array map and hash map here depen. on ct of inputs?"}} [env ::env, form _] - (let [{:keys [all-values? m]} + (let [{:keys [all-values? nodes]} (->> form (uc/map+ (fn [[form-k form-v]] [(analyze* env form-k) (analyze* env form-v)])) (educe (fn ([ret] ret) - ([{:as ret :keys [all-values? m]} [k v]] + ([{:as ret :keys [all-values?]} [k v :as kv]] (-> ret (cond-> (and all-values? (-> k :type utr/value-type?) (-> v :type utr/value-type?)) (assoc :all-values? true)) - (update :m assoc k v)))) - {:all-values? true :m {}})) + (update :nodes conj kv)))) + {:all-values? true :nodes []})) t (if all-values? - (->> m (uc/map+ (fn [[k v]] [(-> k :type t/unvalue) (-> v :type t/unvalue)])) - (join {}) - t/value) - (t/and t/+map|built-in? (->> m (uc/map (fn [[k v]] (t/ordered k v))) t/unordered)))] - (uast/map-node {:env env - :unanalyzed-form form - :form (->> m (uc/map+ (fn [[k v]] [(:form k) (:form v)])) - (join {}) - (<- (add-file-context-from form))) - :type t}))) + (->> nodes + (uc/map+ (fn [[k v]] [(-> k :type t/unvalue) (-> v :type t/unvalue)])) + (join {}) + t/value) + (t/and t/+map|built-in? + (->> nodes + (uc/map (fn [[k v]] (t/ordered (:type k) (:type v)))) + t/unordered)))] + (uast/map-node + {:env env + :unanalyzed-form form + :form (->> nodes + (uc/map+ (fn [[k v]] [(:form k) (:form v)])) + (join {}) + (<- (add-file-context-from form))) + :nodes nodes + :type t}))) (defns- analyze-seq|do [env ::env, [_ _ & body|form _ :as form] _ > uast/do?] (if (empty? body|form) @@ -904,18 +945,12 @@ (defns- analyze* [env ::env, form _ > uast/node?] (when (> (uref/get (uref/update! !!analyze-depth inc)) 200) (throw (ex-info "Stack too deep" {:form form}))) - (ifs (symbol? form) - (analyze-symbol env form) - (t/literal? form) - (uast/literal env form (t/value form)) - (or (vector? form) - (set? form)) - ;; TODO use `uast/vector-node` and `uast/set-node` - (analyze-non-map-seqable env form (empty form) (fn stop [& [a b :as args]] (prl! args) (err! "STOP"))) - (map? form) - (analyze-map env form) - (seq? form) - (analyze-seq env form) + (ifs (symbol? form) (analyze-symbol env form) + (t/literal? form) (uast/literal env form (t/value form)) + (vector? form) (analyze-vector env form) + (set? form) (analyze-set env form) + (map? form) (analyze-map env form) + (seq? form) (analyze-seq env form) (throw (ex-info "Unrecognized form" {:form form})))) (defns analyze diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index c93562c9..619fad4e 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -91,7 +91,12 @@ (defn literal? [x] (instance? Literal x)) -(defrecord VectorNode [env #_::env, unanalyzed-form #_::t/form, form #_::t/form, type #_t/type?] +(defrecord VectorNode + [env #_::env + unanalyzed-form #_::t/form + form #_::t/form + nodes #_(s/seq-of node?) + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -99,7 +104,14 @@ (defn vector-node [m] (map->VectorNode m)) -(defrecord MapNode [env #_::env, unanalyzed-form #_::t/form, form #_::t/form, type #_t/type?] +(defn vector-node? [x] (instance? VectorNode x)) + +(defrecord MapNode + [env #_::env + unanalyzed-form #_::t/form + form #_::t/form + nodes #_(s/seq-of (s/tuple node? node?)) + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -107,7 +119,14 @@ (defn map-node [m] (map->MapNode m)) -(defrecord SetNode [env #_::env, unanalyzed-form #_::t/form, form #_::t/form, type #_t/type?] +(defn map-node? [x] (instance? MapNode x)) + +(defrecord SetNode + [env #_::env + unanalyzed-form #_::t/form + form #_::t/form + nodes #_(s/seq-of node?) + type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -115,6 +134,8 @@ (defn set-node [m] (map->SetNode m)) +(defn set-node? [x] (instance? SetNode x)) + (defrecord ClassValue [env #_::env, form #_simple-symbol?, value #_t/class?, type #_(t/value value)] INode fipp.ednize/IOverride diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index e72036df..23c718cd 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -896,18 +896,26 @@ (isa? #?(:clj clojure.lang.PersistentList :cljs cljs.core/List)))) ;; Used by `quantum.untyped.core.analyze` -(def +vector|built-in? (isa? #?(:clj clojure.lang.PersistentVector - :cljs cljs.core/PersistentVector))) +(def +vector|built-in? + (isa? #?(:clj clojure.lang.PersistentVector :cljs cljs.core/PersistentVector))) + +;; Used by `quantum.untyped.core.analyze` +(def +unordered-map|built-in? + (or (isa? #?(:clj clojure.lang.PersistentHashMap :cljs cljs.core/PersistentHashMap)) + (isa? #?(:clj clojure.lang.PersistentArrayMap :cljs cljs.core/PersistentArrayMap)))) ;; Used by `quantum.untyped.core.analyze` (def +map|built-in? - (or (isa? #?(:clj clojure.lang.PersistentHashMap :cljs cljs.core/PersistentHashMap)) - (isa? #?(:clj clojure.lang.PersistentArrayMap :cljs cljs.core/PersistentArrayMap)) - (isa? #?(:clj clojure.lang.PersistentTreeMap :cljs cljs.core/PersistentTreeMap)))) + (or +unordered-map|built-in? + (isa? #?(:clj clojure.lang.PersistentTreeMap :cljs cljs.core/PersistentTreeMap)))) + +;; Used by `quantum.untyped.core.analyze` +(def +unordered-set|built-in? + (isa? #?(:clj clojure.lang.PersistentHashSet :cljs cljs.core/PersistentHashSet))) ;; Used by `quantum.untyped.core.analyze` (def +set|built-in? - (or (isa? #?(:clj clojure.lang.PersistentHashSet :cljs cljs.core/PersistentHashSet)) + (or +unordered-set|built-in? (isa? #?(:clj clojure.lang.PersistentTreeSet :cljs cljs.core/PersistentTreeSet)))) ;; ===== Functions ===== ;; diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index 26c474b7..8a8980d1 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -494,7 +494,15 @@ '{a (t/input-type tt/fake-compare :? :_) b (t/input-type tt/fake-compare [= (t/type a)] :?)} '(t/output-type tt/fake-compare (t/type a) (t/type b))) - transform-ana))))) + transform-ana) + [;; Directly from `[t/long? t/long?]` + [{'a (t/isa? Long) 'b (t/isa? Long)} (t/isa? Integer)] + ;; Directly from `[t/nil? t/nil?]` + [{'a (t/value nil) 'b (t/value nil)} (t/isa? Integer)] + ;; Directly from `[t/nil? (t/ref t/val?)]` + [{'a (t/value nil) 'b (t/ref (t/not (t/value nil)))} (t/isa? Integer)] + ;; Directly from `[(t/ref t/val?) t/nil?]` + [{'a (t/ref (t/not (t/value nil))) 'b (t/value nil)} (t/isa? Integer)]])))) (defn- rx=* [a b] (if (and (utr/rx-type? a) From 1575e6f52a9e98d233ee0cf98c74ab0b8e37bbe6 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 8 Nov 2018 19:20:40 -0700 Subject: [PATCH 659/810] More correctly compare two ProtocolTypes --- resources-dev/defnt.cljc | 3 + .../quantum/untyped/core/type/compare.cljc | 241 +++++++++++------- src/quantum/core/data/primitive.cljc | 3 +- test/quantum/test/untyped/core/type.cljc | 5 + .../test/untyped/core/type/compare.cljc | 20 +- 5 files changed, 176 insertions(+), 96 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 308189e3..594c5c39 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -157,6 +157,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - (t/seq vector? [ [0 (t/value :a)] [1 (t/value :b)] [2 (t/value :c)]]) - (t/kv vector? { 0 [0 (t/value :a)] 1 [1 (t/value :b)] 2 [2 (t/value :c)]}) - and so on ad infinitum. Therefore we reserve `t/kv` for `(t/and t/lookup? (t/not indexed?))`. + - Probably comparing a protocol with something else should be a matter for reactivity since + protocols can be extended + - TODO CLJS needs to implement it better - Analysis/Optimization - `(p/nil? ...)` should probably be inlined to `(?/== ... nil)` rather than using the overhead of the deftype diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index a937350c..a356acf8 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -10,6 +10,7 @@ :refer [seq-and seq-or]] ;; TODO remove this dependency [quantum.untyped.core.classes :as uclass] + [quantum.untyped.core.collections :as uc] [quantum.untyped.core.compare :as ucomp :refer [==]] [quantum.untyped.core.core :as ucore] @@ -24,6 +25,7 @@ :refer [fn' fn1]] [quantum.untyped.core.logic :refer [ifs]] + [quantum.untyped.core.spec :as us] ;; TODO remove this dependency [quantum.untyped.core.type.core :as utcore] [quantum.untyped.core.type.reifications :as utr @@ -177,19 +179,23 @@ ;; ----- OrType ----- ;; -;; TODO performance can be improved here by doing fewer comparisons -;; Possibly look at `quantum.untyped.core.type.defnt/compare-args-types` for reference? -(defns- compare|or+or [^OrType t0 or-type?, ^OrType t1 or-type? > comparison?] - (let [l (->> t0 .-args (seq-and (fn1 < t1))) - r (->> t1 .-args (seq-and (fn1 < t0)))] +(defns- compare|or+or-like + [ts0 (us/seq-of type?), ts1 (us/seq-of type?), ts1 fn? > comparison?] + (let [l (->> ts0 (seq-and > ts1 (seq-and ident - (if (->> t0 .-args (seq-and (fn1 <> t1))) + (if (->> ts0 (seq-and <>ts1)) <>ident > comparison?] + (compare|or+or-like (.-args t0) (.-args t1) (fn1 < t0) (fn1 < t1) (fn1 <> t1))) + (defns- compare|or+and [^OrType t0 or-type?, ^AndType t1 and-type? > comparison?] (let [r (->> t1 .-args (seq-and (fn1 < t0)))] (if r >ident <>ident))) @@ -213,10 +219,62 @@ ;; ----- ProtocolType ----- ;; -(defns- compare|protocol+protocol [t0 protocol-type?, t1 protocol-type? > comparison?] - (if (== (utr/protocol-type>protocol t0) (utr/protocol-type>protocol t1)) - =ident - <>ident)) +(declare compare|class+class*) + +(defn- compare|protocol+protocol|full-scan [p0 #_protocol?, p1 #_protocol? #_> #_comparison?] + ;; We treat `extenders` as `t/or` without actually creating a `t/or` + (let [ts0 (extenders p0) + ts1 (extenders p1) + gen-compare (fn [t ident ts] (->> ts (uc/map+ (fn [t*] (compare|class+class* t t*))) + (seq-or (fn1 c/= ident)))) + ts1 (fn [t] (gen-compare t <>ident ts1))] + (compare|or+or-like ts0 ts1 ts1))) + +(defns- compare|protocol+protocol + "Protocols cannot extend protocols." + [t0 protocol-type?, t1 protocol-type? > comparison?] + (let [p0 (utr/protocol-type>protocol t0) + p1 (utr/protocol-type>protocol t1)] + (if (== p0 p1) + =ident + ;; TODO use clojure.logic / match + #?(:clj (ifs (-> p0 :impls empty?) + (if (-> p1 :impls empty?) =ident <>ident) + (-> p1 :impls empty?) + <>ident + (-> p0 :impls (contains? Object)) + (if (-> p1 :impls (contains? Object)) + (if (-> p0 :impls (contains? nil)) + (if (-> p1 :impls (contains? nil)) =ident >ident) + (if (-> p1 :impls (contains? nil)) p0 :impls (contains? nil)) + >ident + (if (-> p1 :impls (contains? nil)) + (if (-> p1 :impls count (c/> 1)) >ident) + >ident))) + (-> p1 :impls (contains? Object)) + (if (-> p0 :impls (contains? nil)) + (if (-> p1 :impls (contains? nil)) + p0 :impls count (c/> 1)) >ident)) + p0 :impls (contains? nil)) + (if (-> p0 :impls count (c/> 1)) + (compare|protocol+protocol|full-scan p0 p1) + <>ident) + (-> p1 :impls (contains? nil)) + (if (-> p1 :impls count (c/> 1)) + (compare|protocol+protocol|full-scan p0 p1) + <>ident) + (compare|protocol+protocol|full-scan p0 p1)) + ;; TODO CLJS — also incorporate `default` etc. + ;; Simplistic but we don't have safe insight into what has been extended vs. not + :cljs <>ident)))) + +(defns- compare|protocol+class [t0 protocol-type?, t1 class-type? > comparison?] + ) ;; TODO transition to `compare|protocol+value` when stable (defns- compare|value+protocol [t0 value-type?, t1 protocol-type? > comparison?] @@ -291,100 +349,99 @@ ;; ===== Dispatch ===== ;; -;; TODO take away var indirection once done (def- compare|dispatch (let [inverted (fn [f] (fn [t0 t1] (uset/invert-comparison (f t1 t0))))] {UniversalSetType - {UniversalSetType #'fn= - EmptySetType #'compare|universal+empty - NotType #'compare|universal+not - OrType #'compare|universal+or - AndType #'compare|universal+and - Expression #'compare|universal+expr - ProtocolType #'compare|universal+protocol - ClassType #'compare|universal+class - ValueType #'compare|universal+value} + {UniversalSetType fn= + EmptySetType compare|universal+empty + NotType compare|universal+not + OrType compare|universal+or + AndType compare|universal+and + Expression compare|universal+expr + ProtocolType compare|universal+protocol + ClassType compare|universal+class + ValueType compare|universal+value} EmptySetType - {UniversalSetType (inverted #'compare|universal+empty) - EmptySetType #'fn= - NotType #'compare|empty+not - OrType #'compare|empty+or - AndType #'compare|empty+and - Expression #'compare|empty+expr - ProtocolType #'compare|empty+protocol - ClassType #'compare|empty+class - ValueType #'compare|empty+value} + {UniversalSetType (inverted compare|universal+empty) + EmptySetType fn= + NotType compare|empty+not + OrType compare|empty+or + AndType compare|empty+and + Expression compare|empty+expr + ProtocolType compare|empty+protocol + ClassType compare|empty+class + ValueType compare|empty+value} NotType - {UniversalSetType (inverted #'compare|universal+not) - EmptySetType (inverted #'compare|empty+not) - NotType #'compare|not+not - OrType #'compare|not+or - AndType #'compare|not+and - Expression #'fn>< ; TODO not entirely true - ProtocolType #'compare|not+protocol - ClassType #'compare|not+class - ValueType #'compare|not+value} + {UniversalSetType (inverted compare|universal+not) + EmptySetType (inverted compare|empty+not) + NotType compare|not+not + OrType compare|not+or + AndType compare|not+and + Expression fn>< ; TODO not entirely true + ProtocolType compare|not+protocol + ClassType compare|not+class + ValueType compare|not+value} OrType - {UniversalSetType (inverted #'compare|universal+or) - EmptySetType (inverted #'compare|empty+or) - NotType (inverted #'compare|not+or) - OrType #'compare|or+or - AndType #'compare|or+and - Expression #'fn>< ; TODO not entirely true - ProtocolType #'compare|todo - ClassType (inverted #'compare|class+or) - ValueType (inverted #'compare|value+or)} + {UniversalSetType (inverted compare|universal+or) + EmptySetType (inverted compare|empty+or) + NotType (inverted compare|not+or) + OrType compare|or+or + AndType compare|or+and + Expression fn>< ; TODO not entirely true + ProtocolType compare|todo + ClassType (inverted compare|class+or) + ValueType (inverted compare|value+or)} AndType - {UniversalSetType (inverted #'compare|universal+and) - EmptySetType (inverted #'compare|empty+and) - NotType #'compare|todo - OrType (inverted #'compare|or+and) - AndType #'compare|and+and - Expression #'fn>< ; TODO not entirely true - ProtocolType #'compare|todo - ClassType (inverted #'compare|class+and) - ValueType (inverted #'compare|value+and)} + {UniversalSetType (inverted compare|universal+and) + EmptySetType (inverted compare|empty+and) + NotType compare|todo + OrType (inverted compare|or+and) + AndType compare|and+and + Expression fn>< ; TODO not entirely true + ProtocolType compare|todo + ClassType (inverted compare|class+and) + ValueType (inverted compare|value+and)} ;; TODO review this Expression - {UniversalSetType (inverted #'compare|universal+expr) - EmptySetType (inverted #'compare|empty+expr) - NotType #'fn>< ; TODO not entirely true - OrType #'fn>< ; TODO not entirely true - AndType #'fn>< ; TODO not entirely true - Expression #'compare|expr+expr - ProtocolType #'fn>< ; TODO not entirely true - ClassType #'fn>< ; TODO not entirely true - ValueType #'compare|expr+value} + {UniversalSetType (inverted compare|universal+expr) + EmptySetType (inverted compare|empty+expr) + NotType fn>< ; TODO not entirely true + OrType fn>< ; TODO not entirely true + AndType fn>< ; TODO not entirely true + Expression compare|expr+expr + ProtocolType fn>< ; TODO not entirely true + ClassType fn>< ; TODO not entirely true + ValueType compare|expr+value} ProtocolType - {UniversalSetType (inverted #'compare|universal+protocol) - EmptySetType (inverted #'compare|empty+protocol) - NotType (inverted #'compare|not+protocol) - OrType #'compare|todo - AndType #'compare|todo - Expression #'fn>< ; TODO not entirely true - ProtocolType #'compare|protocol+protocol - ClassType #'compare|todo - ValueType (inverted #'compare|value+protocol)} + {UniversalSetType (inverted compare|universal+protocol) + EmptySetType (inverted compare|empty+protocol) + NotType (inverted compare|not+protocol) + OrType compare|todo + AndType compare|todo + Expression fn>< ; TODO not entirely true + ProtocolType compare|protocol+protocol + ClassType compare|protocol+class + ValueType (inverted compare|value+protocol)} ClassType - {UniversalSetType (inverted #'compare|universal+class) - EmptySetType (inverted #'compare|empty+class) - NotType (inverted #'compare|not+class) - OrType #'compare|class+or - AndType #'compare|class+and - Expression #'fn>< ; TODO not entirely true - ProtocolType #'compare|todo - ClassType #'compare|class+class - ValueType #'compare|class+value} + {UniversalSetType (inverted compare|universal+class) + EmptySetType (inverted compare|empty+class) + NotType (inverted compare|not+class) + OrType compare|class+or + AndType compare|class+and + Expression fn>< ; TODO not entirely true + ProtocolType (inverted compare|protocol+class) + ClassType compare|class+class + ValueType compare|class+value} ValueType - {UniversalSetType (inverted #'compare|universal+value) - EmptySetType (inverted #'compare|empty+value) - NotType (inverted #'compare|not+value) - OrType #'compare|value+or - AndType #'compare|value+and - Expression (inverted #'compare|expr+value) - ProtocolType #'compare|value+protocol - ClassType (inverted #'compare|class+value) - ValueType #'compare|value+value}})) + {UniversalSetType (inverted compare|universal+value) + EmptySetType (inverted compare|empty+value) + NotType (inverted compare|not+value) + OrType compare|value+or + AndType compare|value+and + Expression (inverted compare|expr+value) + ProtocolType compare|value+protocol + ClassType (inverted compare|class+value) + ValueType compare|value+value}})) ;; ===== Operators ===== ;; diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 17f563e1..22110fa8 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -339,7 +339,8 @@ (t/input-type >max-safe-integer-value :?)) t1 (t/and (t/input-type >min-safe-integer-value :?) (t/input-type >max-safe-integer-value :?))] - (let [t0-min (>min-safe-integer-value t0) + t0 + #_(let [t0-min (>min-safe-integer-value t0) t1-min (>min-safe-integer-value t1) t0-max (>max-safe-integer-value t0) t1-max (>max-safe-integer-value t1)] diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 285176fa..aa6c8558 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -127,6 +127,11 @@ nil (a-protocol-all [this]) Object (a-protocol-all [this])) +(defprotocol AProtocolCharSeq (a-protocol-char-seq [this])) + +(extend-protocol AProtocolCharSeq + java.lang.CharSequence (a-protocol-char-seq [this])) + (defprotocol AProtocolString (a-protocol-string [this])) (extend-protocol AProtocolString diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 38aaf379..b7ff7fad 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -613,9 +613,23 @@ (testing "+ ValueType")) (testing "ProtocolType" (testing "+ ProtocolType" - (test-comparison =ident (t/isa? AProtocolAll) (t/isa? AProtocolAll)) - (test-comparison <>ident (t/isa? AProtocolAll) (t/isa? AProtocolNone))) - (testing "+ ClassType") + (test-comparison =ident (t/isa? AProtocolAll) (t/isa? AProtocolAll)) + (test-comparison ident (t/isa? AProtocolNone) (t/isa? AProtocolAll)) + (test-comparison =ident (t/isa? AProtocolNonNil) (t/isa? AProtocolNonNil)) + (test-comparison <>ident (t/isa? AProtocolOnlyNil) (t/isa? AProtocolNonNil)) + (test-comparison ident (t/isa? AProtocolNone) (t/isa? AProtocolNonNil)) + (test-comparison =ident (t/isa? AProtocolOnlyNil) (t/isa? AProtocolOnlyNil)) + (test-comparison <>ident (t/isa? AProtocolString) (t/isa? AProtocolOnlyNil)) + (test-comparison <>ident (t/isa? AProtocolNone) (t/isa? AProtocolOnlyNil)) + (test-comparison =ident (t/isa? AProtocolString) (t/isa? AProtocolString)) + (test-comparison <>ident (t/isa? AProtocolNone) (t/isa? AProtocolString))) + (testing "+ ClassType" + (extends? AProtocolString AProtocolAll) + (test-comparison =ident ())) (testing "+ ValueType" (let [values #{t/universal-set t/empty-set nil {} 1 "" AProtocolAll quantum.test.untyped.core.type.AProtocolAll}] From 051ca462bf618ba5c8ff272a38cf99e363903d6d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 8 Nov 2018 22:31:30 -0700 Subject: [PATCH 660/810] Ensure protocol and class types are comparable --- .../quantum/untyped/core/type/compare.cljc | 72 ++++++++++--------- .../test/untyped/core/type/compare.cljc | 34 +++++++-- 2 files changed, 69 insertions(+), 37 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index a356acf8..eb94896b 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -70,24 +70,21 @@ ;; ----- Multiple ----- ;; (defns- compare|atomic+or [t0 type?, ^OrType t1 or-type? > comparison?] - (let [ts (.-args t1)] - (first - (reduce - (fn [[ret found] t] - (let [c (compare t0 t) - found' (-> found (ubit/conj c) long)] - (ifs (or (ubit/contains? found' found (ubit/conj c) long)] + (ifs (or (ubit/contains? found' ident) - (ubit/contains? found' <>ident))) + (or (ubit/contains? found' >ident) + (ubit/contains? found' <>ident))) [>ident ubit/empty] - ts)))) + [c found']))) + [<>ident ubit/empty] + (.-args t1)))) (defns- compare|atomic+and [t0 type?, ^AndType t1 and-type? > comparison?] (let [ts (.-args t1)] @@ -180,7 +177,7 @@ ;; ----- OrType ----- ;; (defns- compare|or+or-like - [ts0 (us/seq-of type?), ts1 (us/seq-of type?), ts1 fn? > comparison?] + [ts0 _, ts1 _, ts1 fn? > comparison?] (let [l (->> ts0 (seq-and > ts1 (seq-and <) ; TODO not entirely true ;; ----- ProtocolType ----- ;; +;; Protocols cannot extend protocols. +;; A protocol may be seen as `(->> p extenders (map >type) (apply t/or))`." (declare compare|class+class*) -(defn- compare|protocol+protocol|full-scan [p0 #_protocol?, p1 #_protocol? #_> #_comparison?] - ;; We treat `extenders` as `t/or` without actually creating a `t/or` - (let [ts0 (extenders p0) - ts1 (extenders p1) - gen-compare (fn [t ident ts] (->> ts (uc/map+ (fn [t*] (compare|class+class* t t*))) - (seq-or (fn1 c/= ident)))) - ts1 (fn [t] (gen-compare t <>ident ts1))] - (compare|or+or-like ts0 ts1 ts1))) +(defns- compare|or+or-via-class [cs0 _, cs1 _ > comparison?] + (if (empty? cs0) + (if (empty? cs1) =ident <>ident) + (if (empty? cs1) + <>ident + (let [gen-compare (fn [compare-comparison c cs] + (->> cs (uc/map+ (fn [c*] (compare|class+class* c c*))) + (seq-or compare-comparison))) + cs1 (fn [c] (gen-compare uset/comparison<> c cs1))] + (compare|or+or-like cs0 cs1 cs1))))) (defns- compare|protocol+protocol - "Protocols cannot extend protocols." [t0 protocol-type?, t1 protocol-type? > comparison?] (let [p0 (utr/protocol-type>protocol t0) p1 (utr/protocol-type>protocol t1)] @@ -262,19 +262,24 @@ p0 :impls (contains? nil)) (if (-> p0 :impls count (c/> 1)) - (compare|protocol+protocol|full-scan p0 p1) + (compare|or+or-via-class (extenders p0) (extenders p1)) <>ident) (-> p1 :impls (contains? nil)) (if (-> p1 :impls count (c/> 1)) - (compare|protocol+protocol|full-scan p0 p1) + (compare|or+or-via-class (extenders p0) (extenders p1)) <>ident) - (compare|protocol+protocol|full-scan p0 p1)) + (compare|or+or-via-class (extenders p0) (extenders p1))) ;; TODO CLJS — also incorporate `default` etc. ;; Simplistic but we don't have safe insight into what has been extended vs. not :cljs <>ident)))) (defns- compare|protocol+class [t0 protocol-type?, t1 class-type? > comparison?] - ) + (let [p0 (utr/protocol-type>protocol t0) + c1 (utr/class-type>class t1)] + #?(:clj (if (-> p0 :on-interface (== c1)) + =ident + (compare|or+or-via-class (extenders p0) [c1])) + :cljs (TODO)))) ;; TODO transition to `compare|protocol+value` when stable (defns- compare|value+protocol [t0 value-type?, t1 protocol-type? > comparison?] @@ -300,8 +305,9 @@ `3` means their generality/specificity is incomparable: - ✓ `(t/<> c0 c1)` : the extension of ->`c0` is disjoint w.r.t. to that of ->`c1`. Unboxed primitives are considered to be less general (more specific) than boxed primitives." - [^Class c0 class? ^Class c1 class? > comparison?] + [^Class c0 (us/nilable class?) ^Class c1 (us/nilable class?) > comparison?] (ifs (== c0 c1) =ident + (or (nil? c0) (nil? c1)) <>ident (== c0 Object) >ident (== c1 Object) unboxed c0) c1) >ident diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index b7ff7fad..ea432750 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -12,7 +12,8 @@ <0 ><1 ><2 - AProtocolAll AProtocolNone AProtocolString AProtocolNonNil AProtocolOnlyNil + AProtocolAll AProtocolCharSeq AProtocolString AProtocolNonNil AProtocolOnlyNil + AProtocolNone protocol-types Uc C A I P]] @@ -616,20 +617,45 @@ (test-comparison =ident (t/isa? AProtocolAll) (t/isa? AProtocolAll)) (test-comparison ident (t/isa? AProtocolNone) (t/isa? AProtocolAll)) (test-comparison =ident (t/isa? AProtocolNonNil) (t/isa? AProtocolNonNil)) (test-comparison <>ident (t/isa? AProtocolOnlyNil) (t/isa? AProtocolNonNil)) + (test-comparison ident (t/isa? AProtocolNone) (t/isa? AProtocolNonNil)) (test-comparison =ident (t/isa? AProtocolOnlyNil) (t/isa? AProtocolOnlyNil)) + (test-comparison <>ident (t/isa? AProtocolCharSeq) (t/isa? AProtocolOnlyNil)) (test-comparison <>ident (t/isa? AProtocolString) (t/isa? AProtocolOnlyNil)) (test-comparison <>ident (t/isa? AProtocolNone) (t/isa? AProtocolOnlyNil)) - (test-comparison =ident (t/isa? AProtocolString) (t/isa? AProtocolString)) + (test-comparison =ident (t/isa? AProtocolCharSeq) (t/isa? AProtocolCharSeq)) + (test-comparison ident (t/isa? AProtocolNone) (t/isa? AProtocolCharSeq)) + (test-comparison =ident (t/isa? AProtocolString) (t/isa? AProtocolString)) (test-comparison <>ident (t/isa? AProtocolNone) (t/isa? AProtocolString))) (testing "+ ClassType" - (extends? AProtocolString AProtocolAll) - (test-comparison =ident ())) + (testing "universal class" + (test-comparison ident (t/isa? Object) (t/isa? AProtocolOnlyNil)) + (test-comparison >ident (t/isa? Object) (t/isa? AProtocolCharSeq)) + (test-comparison >ident (t/isa? Object) (t/isa? AProtocolString)) + (test-comparison <>ident (t/isa? Object) (t/isa? AProtocolNone))) + (testing "interface" + (test-comparison ident (t/isa? CharSequence) (t/isa? AProtocolOnlyNil)) + (test-comparison =ident (t/isa? CharSequence) (t/isa? AProtocolCharSeq)) + (test-comparison >ident (t/isa? CharSequence) (t/isa? AProtocolString)) + (test-comparison <>ident (t/isa? CharSequence) (t/isa? AProtocolNone))) + (testing "concrete class" + (test-comparison ident (t/isa? String) (t/isa? AProtocolOnlyNil)) + (test-comparison ident (t/isa? String) (t/isa? AProtocolNone)))) (testing "+ ValueType" (let [values #{t/universal-set t/empty-set nil {} 1 "" AProtocolAll quantum.test.untyped.core.type.AProtocolAll}] From 4f037b56b58dfbacf2ec65e0aed59cd8b4b94eae Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 9 Nov 2018 00:28:30 -0700 Subject: [PATCH 661/810] Ensure safer exception printing and remove `t/none?` from split meta-or --- src-untyped/quantum/untyped/core/analyze.cljc | 25 ++++++++++--------- 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 69475a2d..84b61cb5 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -19,7 +19,7 @@ [quantum.untyped.core.error :as uerr :refer [TODO err!]] [quantum.untyped.core.fn - :refer [<- fn-> fn->>]] + :refer [<- fn-> fn->> fn1]] [quantum.untyped.core.form :as uform] [quantum.untyped.core.form.evaluate :as ufeval] [quantum.untyped.core.form.type-hint :as ufth] @@ -642,7 +642,7 @@ {:input|analyzed input|analyzed}))) (defn- filter-direct-dispatchable-overloads - [{:as ret :keys [dispatchable-overloads-seq]} input|analyzed i caller|node body] + [{:as ret :keys [dispatchable-overloads-seq]} input|analyzed i caller|node args-form] (if-let [dispatchable-overloads-seq' (->> dispatchable-overloads-seq (uc/lfilter @@ -651,11 +651,11 @@ seq)] (assoc ret :dispatchable-overloads-seq dispatchable-overloads-seq') (if (-> caller|node :unanalyzed-form meta :dyn) - (filter-dynamic-dispatchable-overloads ret input|analyzed i caller|node body) + (filter-dynamic-dispatchable-overloads ret input|analyzed i caller|node args-form) (err! (str "No overloads satisfy the inputs via direct dispatch; " "dynamic dispatch not requested") - {:caller caller|node - :inputs body + {:caller (select-keys caller|node [:unanalyzed-form :form :type]) + :inputs args-form :failing-input-form (:form input|analyzed) :failing-input-type (:type input|analyzed)})))) @@ -669,7 +669,7 @@ (apply t/or)))) (defns- call>input-nodes+out-type - [env ::env, caller|node _, caller|type _, caller-kind _, inputs-ct _, body _ + [env ::env, caller|node _, caller|type _, caller-kind _, inputs-ct _, args-form _ > (s/kv {:input-nodes t/any? #_(s/seq-of ast/node?) :out-type t/type?})] (dissoc @@ -680,7 +680,7 @@ (-> caller|type utr/fn-type>arities (get inputs-ct) first :output-type) ;; We could do a little smarter analysis here but we'll keep it simple for now t/any?)} - (->> body + (->> args-form (uc/map+ #(analyze* env %)) (reducei (fn [{:as ret :keys [dispatch-type]} input|analyzed i] @@ -688,9 +688,9 @@ (let [{:as ret' :keys [dispatchable-overloads-seq]} (case dispatch-type :direct (filter-direct-dispatchable-overloads - ret input|analyzed i caller|node body) + ret input|analyzed i caller|node args-form) :dynamic (filter-dynamic-dispatchable-overloads - ret input|analyzed i caller|node body))] + ret input|analyzed i caller|node args-form))] (-> ret' (update :input-nodes conj input|analyzed) (assoc :out-type @@ -721,10 +721,10 @@ unvalued-arg-types (->> arg-nodes rest (map :type) (map t/unvalue)) _ (uref/set! !!dependent? true) t (case (name caller|form) - "input-type" (if (-> env :opts :split-types?) + "input-type" (if (-> env :opts :quantum.untyped.core.analyze-types?) (t/input-type|meta-or caller|t unvalued-arg-types) (t/input-type|or caller|t unvalued-arg-types)) - "output-type" (if (-> env :opts :split-types?) + "output-type" (if (-> env :opts :analyze-arg-syms-types?) (t/output-type|meta-or caller|t unvalued-arg-types) (t/output-type|or caller|t unvalued-arg-types)) "type" caller|t)] @@ -1016,7 +1016,8 @@ [t t/type? > (s/vec-of t/type?)] (let [t' (cond-> t (utr/rx-type? t) urx/norx-deref)] (ifs (utr/or-type? t') (utr/or-type>args t') - (utr/meta-or-type? t') (utr/meta-or-type>types t') + ;; TODO determine if this is the appropriate place to deal with `t/none?` + (utr/meta-or-type? t') (->> t' utr/meta-or-type>types (uc/remove (fn1 t/= t/none?))) [t']))) (defns type>split+primitivized [t t/type? > (s/vec-of t/type?)] From 01fe1ebbf9cf695e1ce65535ef83ce9471bd5cf8 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 9 Nov 2018 00:28:47 -0700 Subject: [PATCH 662/810] `type>classes` for protocol types --- src-untyped/quantum/untyped/core/type.cljc | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 23c718cd..ae29fd46 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -744,6 +744,9 @@ > (us/set-of (us/nilable #?(:clj c/class? :cljs c/fn?)))] (cond (utr/class-type? t) (conj classes (utr/class-type>class t)) + (utr/protocol-type? t) + ;; probably better than specifying *all* implementing classes + (conj classes (-> t utr/protocol-type>protocol :on-interface) Object) (utr/value-type? t) (cond-> classes include-classes-of-value-type? (conj (-> t utr/value-type>value c/type))) From 6f83b26729efd2380f52cfcecc6f03e3b732492a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 9 Nov 2018 00:29:30 -0700 Subject: [PATCH 663/810] Fulfill one todo and spawn another --- resources-dev/defnt.cljc | 9 ++---- src/quantum/core/data/primitive.cljc | 43 +++++++++++++++++----------- 2 files changed, 29 insertions(+), 23 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 594c5c39..455d4b00 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -70,12 +70,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - No typed namespace should refer to any untyped namespace - TODO implement the following: - [1] - `t/input-type` should cause a split (unique by `t/=`) rather than just doing `t/or` since - otherwise you end up with e.g. `t/any?` as a type instead of - `[t/boolean? ... t/double? t/nil? t/val?]` being handled separately - - (t/extend-defn! c?/comp< - ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare :_ :?)] - (c?/< (c?/compare a b) 0))) + [1] - Perhaps it's the case that we can't actually have type bases but rather reactive splits. + In the case of `narrowest`, it expects a split and fails without it: + `[a (t/- integer? int?), b integer? > (narrowest (t/type a) (t/type b))]` [2] - t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. - t/numerically-integer? diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 22110fa8..e139ee95 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -120,6 +120,16 @@ (^:intrinsic [x (t/ref float?) > (t/unref (t/type x))] (.floatValue x)) (^:intrinsic [x (t/ref double?) > (t/unref (t/type x))] (.doubleValue x)))) +(t/defn ^:inline >type > t/type? + ([x (t/or boolean? (t/value boolean?))] boolean?) + ([x (t/or byte? (t/value byte?))] byte?) + ([x (t/or char? (t/value char?))] char?) + ([x (t/or short? (t/value short?))] short?) + ([x (t/or int? (t/value int?))] int?) + ([x (t/or long? (t/value long?))] long?) + ([x (t/or float? (t/value float?))] float?) + ([x (t/or double? (t/value double?))] double?)) + ;; ===== Bit lengths ===== ;; (var/def boolean-bits "Implementationally might not be bit-manipulable but logically 1 bit" 1) @@ -339,22 +349,21 @@ (t/input-type >max-safe-integer-value :?)) t1 (t/and (t/input-type >min-safe-integer-value :?) (t/input-type >max-safe-integer-value :?))] - t0 - #_(let [t0-min (>min-safe-integer-value t0) - t1-min (>min-safe-integer-value t1) - t0-max (>max-safe-integer-value t0) - t1-max (>max-safe-integer-value t1)] - (ifs (c?/= t0-min t1-min) - (ifs (c?/= t0-max t1-max) t0 - (c?/< t0-max t1-max) t1 - t0) - (c?/< t0-min t1-min) - (ifs (c?/< t0-max t1-max) (promote-type t0 t1) - (c?/= t0-max t1-max) t0 - t0) - (ifs (c?/> t0-max t1-max) (promote-type t0 t1) - (c?/= t0-max t1-max) t1 - t1))))) + (>type (let [t0-min (>min-safe-integer-value t0) + t1-min (>min-safe-integer-value t1) + t0-max (>max-safe-integer-value t0) + t1-max (>max-safe-integer-value t1)] + (ifs (c?/= t0-min t1-min) + (ifs (c?/= t0-max t1-max) t0 + (c?/< t0-max t1-max) t1 + t0) + (c?/< t0-min t1-min) + (ifs (c?/< t0-max t1-max) (promote-type t0 t1) + (c?/= t0-max t1-max) t0 + t0) + (ifs (c?/> t0-max t1-max) (promote-type t0 t1) + (c?/= t0-max t1-max) t1 + t1)))))) (t/extend-defn! c?/min #?(:clj ( [a int? , b (t/- numeric? int?)] (Numeric/min a b))) @@ -364,7 +373,7 @@ #?(:cljs ( [a double? , b double? > (t/assume double?)] (js/Math.min a b)))) (t/extend-defn! c?/max -#?(:clj ( [a (t/- integer? int?), b integer? > (t/narrowest (t/type a) (t/type b))] +#?(:clj ( [a (t/- integer? int?), b integer? > (narrowest (t/type a) (t/type b))] (if (c?/> a b) a b))) #?(:clj ( [a integer? , b (t/- integer? int?)] (if (c?/> a b) a b))) From 9957ad3a68919432053d6ad0296e217ac35f2545 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 9 Nov 2018 14:30:17 -0700 Subject: [PATCH 664/810] Add better `find-spec` --- src-untyped/quantum/untyped/core/type.cljc | 41 ++++++++++++++-------- src/quantum/core/type.cljc | 5 +-- 2 files changed, 29 insertions(+), 17 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index ae29fd46..1049668d 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -546,23 +546,36 @@ (defns compare|out [x0 utr/fn-type?, x1 utr/fn-type? > uset/comparison?] (utcomp/compare (fn-type>output-type x0) (fn-type>output-type x1))) +(us/def ::match-spec + (us/seq-of (us/or* #{:_ :?} type? + (us/tuple #{:?} type?) + (us/tuple ifn? type?) + (us/tuple #{:?} ifn? type?)))) + +(defn- find-spec? [match-spec-element] + (c/or (c/= match-spec-element :?) + (c/and (sequential? match-spec-element) + (-> match-spec-element first (c/= :?))))) + (defn- match-spec>type-data-seq "Returns the type data of overloads that support the specified arg types." [t match-spec] (let [type-data-seq (-> t utr/fn-type>arities (get (count match-spec)))] (->> match-spec (uc/map-indexed+ vector) - (uc/remove (fn-> second #{:_ :?})) + (uc/remove #(c/or (-> % second (c/= :_)) (-> % second (c/= :?)))) (educe (c/fn ([] type-data-seq) ([type-data-seq'] type-data-seq') ([type-data-seq' [i|arg arg-type-or-vec]] - (let [compf (if (sequential? arg-type-or-vec) - (first arg-type-or-vec) - utcomp/<=) - arg-type (if (sequential? arg-type-or-vec) - (second arg-type-or-vec) - arg-type-or-vec)] + (let [[compf arg-type] + (if (sequential? arg-type-or-vec) + (if (-> arg-type-or-vec first (c/= :?)) + (if (-> arg-type-or-vec count (c/= 3)) + [(nth arg-type-or-vec 1) (nth arg-type-or-vec 2)] + [utcomp/<= (nth arg-type-or-vec 1)]) + [(nth arg-type-or-vec 0) (nth arg-type-or-vec 1)]) + [utcomp/<= arg-type-or-vec])] (c/or (->> type-data-seq' (uc/lfilter (c/fn [{:keys [input-types]}] (compf arg-type (get input-types i|arg)))) @@ -578,8 +591,8 @@ (rx (f t (map utr/deref-when-reactive args))) (f t args)))) -(defn- input-type|meta-or|norx [t match-spec] - (let [i|? (->> match-spec (reducei (c/fn [_ t i] (when (c/= t :?) (reduced i))) nil))] +(defn- input-type|meta-or|norx [t match-spec #_::match-spec] + (let [i|? (->> match-spec (reducei (c/fn [_ t i] (when (find-spec? t) (reduced i))) nil))] (with-expand-meta-ors match-spec (fn [match-spec'] (->> match-spec' @@ -588,9 +601,8 @@ meta-or))))) (defns input-type|meta-or - [t (us/or* utr/fn-type? utr/rx-type?) - match-spec _ #_(us/seq-of (us/or* #{:_ :?} (us/or* type? (us/tuple ifn? type?)))) - | (->> match-spec (filter #(c/= % :?)) count (c/= 1)) + [t (us/or* utr/fn-type? utr/rx-type?), match-spec _ #_::match-spec + | (->> match-spec (filter find-spec?) count (c/= 1)) > type?] (input-or-output-type-handle-reactive input-type|meta-or|norx t match-spec)) @@ -600,9 +612,8 @@ (defns input-type|or "Outputs the type of a specified input to a typed fn." - [t (us/or* utr/fn-type? utr/rx-type?) - match-spec _ #_(us/seq-of (us/or* #{:_ :?} (us/or* type? (us/tuple ifn? type?)))) - | (->> match-spec (filter #(c/= % :?)) count (c/= 1)) + [t (us/or* utr/fn-type? utr/rx-type?), match-spec _ #_::match-spec + | (->> match-spec (filter find-spec?) count (c/= 1)) > type?] (input-or-output-type-handle-reactive input-type|or|norx t match-spec)) diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index 2b0449fd..deb6afde 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -1,7 +1,7 @@ (ns quantum.core.type "This is this the namespace upon which all other fully-typed namespaces rest." (:refer-clojure :exclude - [* - and any? defn fn fn? isa? not or ref seq? symbol? type var?]) + [* - < <= = >= > and any? defn fn fn? isa? not or ref seq? symbol? type var?]) (:require [quantum.untyped.core.type.defnt :as udefnt] [quantum.untyped.core.type :as ut] @@ -32,7 +32,8 @@ nil? none? ref? - fn?) + fn? + < <= = >= > <> ><) ;; TODO TYPED move From 07ba3a436d635f1490211244f9b0e699cfe05907 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 9 Nov 2018 14:30:28 -0700 Subject: [PATCH 665/810] `min` and `max` should be good to go --- src/quantum/core/data/primitive.cljc | 103 +++++++++++++++++---------- 1 file changed, 66 insertions(+), 37 deletions(-) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index e139ee95..d19f7b46 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -341,44 +341,73 @@ ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare [= (t/type a)] :?)] (c?/> (c?/compare a b) 0))) -(t/defn promote-type [a nil?, b nil?]) - -(t/defn narrowest +;; TODO come back to this +;; Use interval tree? +#_(t/defn promote-type + "Based on max/min safe integer value." + ;; TODO Write it all out and compress later + ([t|max (t/value byte?)] t|max (t/value short?)] t|>max) + ([t|max (t/value char?)] int?) + ([t|max (t/value int?)] t|>max) + ([t|max (t/value long?)] t|>max) + ([t|max (t/value float?)] t|>max) + ([t|max (t/value double?)] t|>max)) + +;; TODO come back to this +#_(t/defn narrowest + "Based on max/min safe integer value." > t/type? - ([t0 (t/and (t/input-type >min-safe-integer-value :?) - (t/input-type >max-safe-integer-value :?)) - t1 (t/and (t/input-type >min-safe-integer-value :?) - (t/input-type >max-safe-integer-value :?))] - (>type (let [t0-min (>min-safe-integer-value t0) - t1-min (>min-safe-integer-value t1) - t0-max (>max-safe-integer-value t0) - t1-max (>max-safe-integer-value t1)] - (ifs (c?/= t0-min t1-min) - (ifs (c?/= t0-max t1-max) t0 - (c?/< t0-max t1-max) t1 - t0) - (c?/< t0-min t1-min) - (ifs (c?/< t0-max t1-max) (promote-type t0 t1) - (c?/= t0-max t1-max) t0 - t0) - (ifs (c?/> t0-max t1-max) (promote-type t0 t1) - (c?/= t0-max t1-max) t1 - t1)))))) - + ([t0 (t/and (t/input-type >min-safe-integer-value [:? t/>= t/type?]) + (t/input-type >max-safe-integer-value [:? t/>= t/type?])) + t1 (t/and (t/input-type >min-safe-integer-value [:? t/>= t/type?]) + (t/input-type >max-safe-integer-value [:? t/>= t/type?]))] + (let [t0-min (>min-safe-integer-value t0) + t1-min (>min-safe-integer-value t1) + t0-max (>max-safe-integer-value t0) + t1-max (>max-safe-integer-value t1)] + ;; TODO this provides great room for auto-optimization + (ifs (c?/= t0-min t1-min) + (ifs (c?/= t0-max t1-max) t0 + (c?/< t0-max t1-max) t1 + t0) + (c?/< t0-min t1-min) + (ifs (c?/< t0-max t1-max) (promote-type t0 t1) + (c?/= t0-max t1-max) t0 + t0) + (ifs (c?/> t0-max t1-max) (promote-type t1 t0) + (c?/= t0-max t1-max) t1 + t1))))) + +;; TODO maybe use `> (narrowest (t/type a) (t/type b))` for `min` and `max` (t/extend-defn! c?/min -#?(:clj ( [a int? , b (t/- numeric? int?)] (Numeric/min a b))) -#?(:clj ( [a (t/- numeric? int?), b int?] (Numeric/min a b))) -#?(:clj ( [a (t/- numeric? int?), b (t/- numeric? int?)] (Numeric/min a b))) -#?(:clj (^:in [a int? , b int?] (Math/min a b))) -#?(:cljs ( [a double? , b double? > (t/assume double?)] (js/Math.min a b)))) +#?(:clj ( [a (t/- numeric? int? float? double?) + b (t/- numeric? int? float? double?)] (if (c?/< a b) a b))) +#?(:clj ( [a int? , b (t/- numeric? int?)] (if (c?/< a b) a b))) +#?(:clj ( [a (t/- numeric? int?) , b int?] (if (c?/< a b) a b))) +#?(:clj (^:in [a int? , b int?] (Math/min a b))) +#?(:clj ( [a float? , b (t/- numeric? int? float?)] (if (c?/< a b) a b))) +#?(:clj ( [a (t/- numeric? int? float?), b float?] (if (c?/< a b) a b))) +#?(:clj ( [a float? , b float?] (Math/min a b))) +#?(:clj ( [a double? + b (t/- numeric? int? float? double?)] (if (c?/< a b) a b))) +#?(:clj ( [a (t/- numeric? int? float? double?) + b double?] (if (c?/< a b) a b))) +#?(:clj ( [a double? , b double?] (Math/min a b))) +#?(:cljs ( [a double? , b double? > (t/assume double?)] (js/Math.min a b)))) (t/extend-defn! c?/max -#?(:clj ( [a (t/- integer? int?), b integer? > (narrowest (t/type a) (t/type b))] - (if (c?/> a b) a b))) -#?(:clj ( [a integer? , b (t/- integer? int?)] - (if (c?/> a b) a b))) -#?(:clj (^:in [a int? , b int?] (Math/max a b))) -#?(:clj ( [a float? , b float?] (Math/max a b))) -#?(:clj ( [a float? , b float?] (Math/max a b))) -#?(:clj ( [a double? , b double?] (Math/max a b))) -#?(:cljs ( [a double? , b double? > (t/assume double?)] (js/Math.max a b)))) +#?(:clj ( [a (t/- numeric? int? float? double?) + b (t/- numeric? int? float? double?)] (if (c?/> a b) a b))) +#?(:clj ( [a int? , b (t/- numeric? int?)] (if (c?/> a b) a b))) +#?(:clj ( [a (t/- numeric? int?) , b int?] (if (c?/> a b) a b))) +#?(:clj (^:in [a int? , b int?] (Math/max a b))) +#?(:clj ( [a float? , b (t/- numeric? int? float?)] (if (c?/> a b) a b))) +#?(:clj ( [a (t/- numeric? int? float?), b float?] (if (c?/> a b) a b))) +#?(:clj ( [a float? , b float?] (Math/max a b))) +#?(:clj ( [a double? + b (t/- numeric? int? float? double?)] (if (c?/> a b) a b))) +#?(:clj ( [a (t/- numeric? int? float? double?) + b double?] (if (c?/> a b) a b))) +#?(:clj ( [a double? , b double?] (Math/max a b))) +#?(:cljs ( [a double? , b double? > (t/assume double?)] (js/Math.max a b)))) From 62204a9f9065ddad79e9ac67346304b68cfa0180 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 9 Nov 2018 14:56:04 -0700 Subject: [PATCH 666/810] `t/ftype` should not require an output type --- src-untyped/quantum/untyped/core/type.cljc | 18 ++++-- test/quantum/test/untyped/core/analyze.cljc | 12 ++-- .../test/untyped/core/type/compare.cljc | 58 +++++++++---------- .../quantum/test/untyped/core/type/defnt.cljc | 2 +- 4 files changed, 48 insertions(+), 42 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 1049668d..260f41b4 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -505,13 +505,19 @@ ;; ===== `t/ftype` ===== ;; -(defn ftype [out-type & arities-form] +(defn ftype [& args] (let [name- nil - arities (->> arities-form - (uc/map+ (c/fn [arity-form] - (-> (us/conform ::fn-type|arity arity-form) - (update :output-type #(c/or % out-type universal-set))))) - (uc/group-by #(-> % :input-types count)))] + out-type (if (-> args first c/sequential?) + universal-set + (first args)) + arities-form (if (-> args first c/sequential?) + args + (rest args)) + arities (->> arities-form + (uc/map+ (c/fn [arity-form] + (-> (us/conform ::fn-type|arity arity-form) + (update :output-type #(c/or % out-type universal-set))))) + (uc/group-by #(-> % :input-types count)))] (FnType. nil name- out-type arities-form arities))) (defns compare|in [x0 utr/fn-type?, x1 utr/fn-type? > uset/comparison?] diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index 8a8980d1..d79b40cd 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -18,17 +18,17 @@ [quantum.untyped.core.type.reifications :as utr])) ;; Simulates a typed fn -(defn- >long-checked {:quantum.core.type/type (t/rx (t/ftype nil [t/string? :> tt/long?]))} []) +(defn- >long-checked {:quantum.core.type/type (t/rx (t/ftype [t/string? :> tt/long?]))} []) -(defn- dummy {:quantum.core.type/type (t/rx (t/ftype nil [(t/or tt/short? tt/char?)]))} []) +(defn- dummy {:quantum.core.type/type (t/rx (t/ftype [(t/or tt/short? tt/char?)]))} []) ;; For this fn, the input types combine when applying `t/or` (`(t/or t/nil? t/val?)`) (defn- input-types-combine {:quantum.core.type/type - (t/rx (t/ftype nil [t/nil? tt/byte?] - [t/nil? tt/char?] - [(t/ref t/val?) tt/byte?] - [(t/ref t/val?) tt/char?]))} + (t/rx (t/ftype [t/nil? tt/byte?] + [t/nil? tt/char?] + [(t/ref t/val?) tt/byte?] + [(t/ref t/val?) tt/char?]))} []) (defn- transform-ana [ana] diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index ea432750..859eff85 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -779,7 +779,7 @@ to compare the extension of their inputs and the extension of their outputs separately. That said, it's not clear how useful this sort of comparison is. - Furthermore, is it the case that `(t/< [[] t/any?] (t/ftype t/any? []))`? Intuitively it + Furthermore, is it the case that `(t/< [[] t/any?] (t/ftype []))`? Intuitively it doesn't seem like it should be, but under the WHK model it nevertheless seems to be the case. So we opt to make `t/ftype`s `t/compare`-able only with what its underlying function object is @@ -825,39 +825,39 @@ (testing "same-arity input types <" (testing "output <" (test-comparison|fn [ t/boolean?]) - (t/ftype t/any? [] [t/any? :> t/long?]))) + (t/ftype [t/boolean? :> t/boolean?]) + (t/ftype [] [t/any? :> t/long?]))) (testing "output =") (testing "output >" (test-comparison|fn [ ident] - (t/ftype t/any? [t/boolean?]) - (t/ftype t/any? [:> t/boolean?] [t/any? :> t/boolean?]))) + (t/ftype [t/boolean?]) + (t/ftype [:> t/boolean?] [t/any? :> t/boolean?]))) (testing "output ><") (testing "output <>")) (testing "same-arity input types =" (testing "output <" (test-comparison|fn [ t/boolean?]) - (t/ftype t/any? [] [t/any?]))) + (t/ftype [:> t/boolean?]) + (t/ftype [] [t/any?]))) (testing "output =" (test-comparison|fn [ " (test-comparison|fn [ ident] - (t/ftype t/any? []) - (t/ftype t/any? [:> t/boolean?] [t/any? :> t/long?]))) + (t/ftype []) + (t/ftype [:> t/boolean?] [t/any? :> t/long?]))) (testing "output ><") (testing "output <>")) (testing "same-arity input types >" (testing "output <" (test-comparison|fn [> t/boolean?]) - (t/ftype t/any? [] [t/boolean?]))) + (t/ftype [t/any? :> t/boolean?]) + (t/ftype [] [t/boolean?]))) (testing "output =" (test-comparison|fn [>") (testing "output ><") (testing "output <>")) @@ -877,33 +877,33 @@ (testing "same-arity input types <" (testing "output <" (test-comparison|fn [ t/boolean?]) - (t/ftype t/any? [t/any?]))) + (t/ftype [t/boolean? :> t/boolean?]) + (t/ftype [t/any?]))) (testing "output =" (test-comparison|fn [ " (test-comparison|fn [ ident] - (t/ftype t/any? [t/boolean?]) - (t/ftype t/any? [t/any? :> t/boolean?]))) + (t/ftype [t/boolean?]) + (t/ftype [t/any? :> t/boolean?]))) (testing "output ><" (test-comparison|fn [ i|><0]) - (t/ftype t/any? [t/any? :> i|><1]))) + (t/ftype [t/boolean? :> i|><0]) + (t/ftype [t/any? :> i|><1]))) (testing "output <>" (test-comparison|fn [ ident] - (t/ftype t/any? [t/boolean? :> ><0]) - (t/ftype t/any? [t/any? :> ><1])))) + (t/ftype [t/boolean? :> ><0]) + (t/ftype [t/any? :> ><1])))) (testing "same-arity input types =" (testing "output <" (test-comparison|fn [ =ident >ident] - (t/ftype t/any? []) - (t/ftype t/any? [:> t/boolean?]))) + (t/ftype []) + (t/ftype [:> t/boolean?]))) (testing "output =" (test-comparison|fn [ =ident =ident] - (t/ftype t/any? []) - (t/ftype t/any? []))) + (t/ftype []) + (t/ftype []))) (testing "output >") (testing "output ><") (testing "output <>")) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 7f40cffd..1ec62a06 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1686,7 +1686,7 @@ (defn seq "Taken from `clojure.lang.RT/seq`" {:quantum.core.type/type - (t/ftype :> (t/? (t/isa? ISeq)) + (t/ftype (t/? (t/isa? ISeq)) [t/nil?] [(t/isa? ASeq)] [(t/or (t/isa? LazySeq) (t/isa? Seqable))] From 882e778653b14fd2267cfa3e3204f415bab5d14d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 9 Nov 2018 14:56:20 -0700 Subject: [PATCH 667/810] Think more about todos --- resources-dev/defnt.cljc | 115 +++++++++++++++++++-------------------- 1 file changed, 56 insertions(+), 59 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 455d4b00..c7aa8583 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -45,65 +45,58 @@ These two should be defined in the (whatever) data namespace: - `>(whatever)` - `(whatever)>` -TODO: -- `(or (and pred then) (and (not pred) else))` (which is not correct) -- needs to equal `(t/and (t/or (t/not a) b) (t/or a c))` (which is correct) -- `(- (or ?!+vector? !vector? #?(:clj !!vector?)) (isa? clojure.lang.Counted))` is not right -- t/or should probably order by `t/compare` descending - - - - TODO `or` and `and` should be `=` regardless of order - - To fix this, sort when it's created? - - (rx/dispose! ) when the `t/defn` is redefined (?) - - Dependents should not get recompiled if the type has not changed but only the implementation has, - except if inline - - Handle `|` (pre-type) - - Should not accept `t/none?` as an input type - - This subsumes it into the `ref` portion which is not right - (t/or (t/value nil) (t/isa? Long) (t/ref (t/isa? java.lang.Comparable))) - -> (t/or (t/value nil) (t/ref (t/isa? java.lang.Comparable))) - - TODO all `intern`s/effects in `t/defn` should be atomic (all or nothing). This means that the interns should probably be put on a queue too. - #_" Note that `;; TODO TYPED` is the annotation we're using for this initiative - There will be some code duplication with untyped code for now and that's okay. - No typed namespace should refer to any untyped namespace - TODO implement the following: - [1] - Perhaps it's the case that we can't actually have type bases but rather reactive splits. - In the case of `narrowest`, it expects a split and fails without it: - `[a (t/- integer? int?), b integer? > (narrowest (t/type a) (t/type b))]` - [2] - t/numerically : e.g. a double representing exactly what a float is able to represent - - and variants thereof: `numerically-long?` etc. - - t/numerically-integer? - - Primitive conversions not requiring checks can go in data.primitive - - core.data.numeric (requires data.primitive) - - numeric definitions - - numeric ranges - - numeric characteristics - [3] - Direct dispatch needs to actually work correctly in typed contexts - [ ] - Probably should disallow recursive type references, including: - `(t/defn f [x (t/input-type f ...)])` - [ ] - `t/ref` and `t/assume` need to be combined correctly. E.g. (t/and (t/ref ...) ...) means the - whole thing should be `t/ref`, while `(t/or (t/ref ...) (...))` does not mean the metadata - is transferred. Probably `t/assume` should be combined in the same way. - - What about `(t/and (t/or t/long? (t/ref t/byte?)) pos?)` ? - [ ] - t/value-of - - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` - [ ] - (comp/t== x) - - dependent type such that the passed input must be identical to x - [ ] - `?` : type inference - - use logic programming and variable unification e.g. `?1` `?2` ? - - For this situation: `?` is `(t/- dc/counted?)` - ([n dn/std-integer?, xs dc/counted?] (count xs)) - ([n dn/std-integer?, xs ?] ...) - - [ ] No trailing `>` means `> ?`f - [ ] - Non-boxed `def`s: `(var/def- min-float (Numeric/negate Float/MAX_VALUE))` - - `(t/validate x (t/* t/string?))` for `(t/* t/string?)` needs to be more performant - - Don't re-create type on each call - - replace `deref` with `ref/deref` in typed contexts? So we can do `@` still + [2] t/numerically : e.g. a double representing exactly what a float is able to represent + - and variants thereof: `numerically-long?` etc. + - t/numerically-integer? + - Primitive conversions not requiring checks can go in data.primitive + - core.data.numeric (requires data.primitive) + - numeric definitions + - numeric ranges + - numeric characteristics + [3] Direct dispatch needs to actually work correctly in typed contexts + [ ] Probably should disallow recursive type references, including: + `(t/defn f [x (t/input-type f ...)])` + [ ] Perhaps it's the case that we can't actually have type bases but rather reactive splits. + In the case of `narrowest`, it expects a split and fails without it: + `[a (t/- integer? int?), b integer? > (narrowest (t/type a) (t/type b))]` + [ ] `t/ref` and `t/assume` need to be combined correctly. E.g. (t/and (t/ref ...) ...) means the + whole thing should be `t/ref`, while `(t/or (t/ref ...) (...))` does not mean the metadata + is transferred. Probably `t/assume` should be combined in the same way. + - What about `(t/and (t/or t/long? (t/ref t/byte?)) pos?)` ? + [ ] t/value-of + - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` + [ ] (comp/t== x) + - dependent type such that the passed input must be identical to x + [ ] `?` : type inference + - use logic programming and variable unification e.g. `?1` `?2` ? + - For this situation: `?` is `(t/- dc/counted?)` + ([n dn/std-integer?, xs dc/counted?] (count xs)) + ([n dn/std-integer?, xs ?] ...) + - [ ] No trailing `>` means `> ?`f + [ ] Non-boxed `def`s: `(var/def- min-float (Numeric/negate Float/MAX_VALUE))` + [ ] `(t/validate x (t/* t/string?))` for `(t/* t/string?)` needs to be more performant + - Don't re-create type on each call (see `defnt/unanalyzed-overload>overload`) + [ ] replace `deref` with `ref/deref` in typed contexts? So we can do `@` still - Type Logic and Predicates + - It is possible to check satisfaction of arities to an `t/ftype` at runtime even if the type + meta is not stripped (well, at least the arity counts can be checked and primitive types in + CLJ): + - In CLJ via e.g. `(clojure.reflect/reflect (class (fn ([]) ([^long a]))))` + - In CLJS via e.g.: + - `(js/Object.getOwnPropertyNames (fn ([]) ([a])))` + -> `#js [... \"cljs$core$IFn$_invoke$arity$0\" \"cljs$core$IFn$_invoke$arity$1\"]` - We should probably have a 'normal form' so we can correctly hash if we do spec lookup + - `or` and `and` should be `=` regardless of order + - To fix this, sort when it's created? (order by `t/compare` descending) + - `(or (and pred then) (and (not pred) else))` (which is not correct) + - needs to equal `(t/and (t/or (t/not a) b) (t/or a c))` (which is correct) + - `(- (or ?!+vector? !vector? #?(:clj !!vector?)) (isa? clojure.lang.Counted))` is not right - t/- : fix - (t/- (t/isa? java.util.Queue) (t/or ?!+queue? !!queue?)) - (t/- t/any? p/float? p/double?); (t/- number? p/primitive?) @@ -158,8 +151,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative protocols can be extended - TODO CLJS needs to implement it better - Analysis/Optimization - - `(p/nil? ...)` should probably be inlined to `(?/== ... nil)` rather than using the overhead of the - deftype + - `(p/nil? ...)` should probably be inlined to `(?/== ... nil)` rather than using the overhead + of the deftype - This should realize that we're negating a `<` and change the operator to `<=` - `(t/def nneg? (fn/comp ?/not neg?))` - For numbers: @@ -201,8 +194,9 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative (#?(:clj clojure.core.protocols/coll-reduce :cljs cljs.core/-reduce) xs rf init)) - (if (A) ...) should be (if ^boolean (A) ...) if A returns a `p/boolean?` - - We'll should make a special class or *something* like that to ensure that typed bindings are only - bound within typed contexts. + - t/binding + - We should make a special class or *something* like that to ensure that typed bindings are only + bound within typed contexts. - t/defrecord - t/def-concrete-type (i.e. `t/deftype`) - expressions (`quantum.untyped.core.analyze.expr`) @@ -219,17 +213,20 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative we annotate like `(name ^:dyn (read ...))`, meaning figure out at runtime what the out-type of the call to `(read ...)` is, not, call `name` dynamically. - `t/defn` + - Should not accept `t/none?` as an input type + - Arity elision: if any type in an arity is `t/none?` then elide it and emit a warning + - `([x bigint?] x)` + - All `intern`s/effects in `t/defn` should be atomic (all or nothing). This means that the + interns should probably be put on a queue too. - `declare` but for `t/defn` - Currently we can declare that there is an fn, and what its output type is, and its metadata, but we cannot currently declare type-overloads. Experience will make clearer what to do in these cases. - `|` (pre-types) - - Arity elision: if any type in an arity is `t/none?` then elide it and emit a warning - - `([x bigint?] x)` - t/defn- - Not just a private var for the dynamic dispatch, but needs to be private for purposes of the analyzer when doing direct dispatch. Should emit a warning, not just fail. - - (t/and (t/or a b) c) should -> (t/or (t/and a c) (t/and b c)) for purposes of separating dispatches + - (t/and (t/or a b) c) should -> (t/or (t/and a c) (t/and b c)) for purposes of type-splitting - ^:inline - should be able to mark either ^:unline or ^{:inline false} on arities of an inline function - if you do (Numeric/bitAnd a b) inline then bitAnd needs to know the primitive type so maybe @@ -258,7 +255,7 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - t/extend-defn! [ ] Ability to add output type restriction after the fact? - lazy compilation especially around `t/input-type` - - equivalence of typed predicates (i.e. that which is `t/<=` `(t/fn [x t/any? :> p/boolean?])`) + - equivalence of typed predicates (i.e. that which is `t/<=` `(t/ftype [x t/any? :> p/boolean?])`) to types: - [xs (t/fn [x (t/isa? clojure.lang.Range)] ...)] - NOTE on namespace organization: From 7222cf29737834c5bbabc50fe46c242ddb98422f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 9 Nov 2018 15:04:14 -0700 Subject: [PATCH 668/810] `inline` is now first type system priority --- resources-dev/defnt.cljc | 279 ++++++++++++++++++++------------------- 1 file changed, 141 insertions(+), 138 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index c7aa8583..d82f9925 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -41,16 +41,41 @@ Note that for anything built-in js/, the `t/isa?` predicates might nee Sometimes you want (byte ) to fail at runtime rather than fail at runtime when you can't know everything about the input's range -These two should be defined in the (whatever) data namespace: -- `>(whatever)` -- `(whatever)>` + #_" -Note that `;; TODO TYPED` is the annotation we're using for this initiative +Pinned: +- `;; TODO TYPED` is the annotation we're using for this initiative - There will be some code duplication with untyped code for now and that's okay. -- No typed namespace should refer to any untyped namespace +- No typed namespace should refer to any untyped namespace. +- The initial definition of conversion functions belongs in the namespace that their destination + type belongs in, and it may be extended in every namespace in which there is a source type. +- These two should be defined in the `whatever` data namespace: + - `>(whatever)` + - `(whatever)>` +Legend: +- [.] : in progress +- [-] : done as far as possible but not truly complete +- [x] : actually done +- [|] : not possible / N/A +- [!] : refused - TODO implement the following: + [1] ^:inline + - should be able to mark either ^:unline or ^{:inline false} on arities of an inline function + - if you do (Numeric/bitAnd a b) inline then bitAnd needs to know the primitive type so maybe + we do the `let*`-binding approach to typing vars? + - A good example of inlining: + (t/def empty?|rf + (fn/aritoid + (t/fn [] true) + fn/identity + (t/fn [ret _, x _] (dc/reduced false)) + (t/fn [ret _, k _, v _] (dc/reduced false)))) + (t/defn empty? > p/boolean? + ([x p/nil?] true) + ([xs dc/counted?] (-> xs count num/zero?)) + ([xs (t/input-type educe :_ :_ :?)] (educe empty?|rf x))) [2] t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. - t/numerically-integer? @@ -84,6 +109,8 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - Don't re-create type on each call (see `defnt/unanalyzed-overload>overload`) [ ] replace `deref` with `ref/deref` in typed contexts? So we can do `@` still - Type Logic and Predicates + - expressions (`quantum.untyped.core.analyze.expr`) + - comparison of `t/fn`s is probably possible? - It is possible to check satisfaction of arities to an `t/ftype` at runtime even if the type meta is not stripped (well, at least the arity counts can be checked and primitive types in CLJ): @@ -150,125 +177,101 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - Probably comparing a protocol with something else should be a matter for reactivity since protocols can be extended - TODO CLJS needs to implement it better - - Analysis/Optimization - - `(p/nil? ...)` should probably be inlined to `(?/== ... nil)` rather than using the overhead - of the deftype - - This should realize that we're negating a `<` and change the operator to `<=` - - `(t/def nneg? (fn/comp ?/not neg?))` - - For numbers: - - (< (compare a b) 0) - -> - (< (ifs (< a b) -1 (> a b) 1 0) 0) - -> the only one that can be < 0 is the -1 - -> (< a b) - - Better analysis of compound literals - - Literal seqs need to be better analyzed — (t/finite-of t/built-in-list? [ak-type av-type] ...) - - Peformance analysis (this comes very much later) - - We should be able to do complexity analysis. Similarly to how we can combine and manipulate - types, we could do like `(cplex/assume (cplex/o :n))` or `(cplex/assume (cplex/o :n2))` etc. - - For `reduce` we'd always know it's up to N operations, so O(n * ) - - Record performance for each relevant part and cache? - - (if (dcoll/reduced? ret) - ;; TODO TYPED `(ref/deref ret)` should realize it's dealing with a `reduced?` - (ref/deref ret) - ...) - - (let [ct (count arr)] - (loop [i 0 v init] - (if (comp/< i ct) - (let [ret (f v (get arr i))] - (if (reduced? ret) - @ret - ;; TODO TYPED automatically figure out that `inc` will never go out of bounds here - (recur (inc* i) ret))) - v))) - - (let [xs' (seq xs)] - (if (dcomp/== (class xs') (class xs)) - (reduce-seq rf ret xs') - ;; TODO TYPED automatically figure out that: - ;; - `(not (dcomp/== (class xs') (class xs)))` - ;; - What the possible types of xs' are as a result - (reduce rf init xs'))) - - ([rf rf?, init t/any?, xs #?(:clj (t/isa? clojure.core.protocols/CollReduce) - :cljs (t/isa?|direct cljs.core/IReduce))] - ;; TODO add `^not-native` to `xs` for CLJS - (#?(:clj clojure.core.protocols/coll-reduce - :cljs cljs.core/-reduce) xs rf init)) - - (if (A) ...) should be (if ^boolean (A) ...) if A returns a `p/boolean?` - - t/binding - - We should make a special class or *something* like that to ensure that typed bindings are only - bound within typed contexts. - - t/defrecord - - t/def-concrete-type (i.e. `t/deftype`) - - expressions (`quantum.untyped.core.analyze.expr`) - - comparison of `t/fn`s is probably possible? - - t/def - - TODO what would this even look like? I guess it would just declare the sym, meta, and type - - It would also have the benefit of creating a typed context - - Without an argument, it would work like `declare` - - t/fn - - t/ftype - - conditionally optional arities etc. - - ^:dyn - - `(name (read ...))` fails at compile-time; we want it to at least try at runtime. So instead - we annotate like `(name ^:dyn (read ...))`, meaning figure out at runtime what the out-type of - the call to `(read ...)` is, not, call `name` dynamically. - - `t/defn` - - Should not accept `t/none?` as an input type - - Arity elision: if any type in an arity is `t/none?` then elide it and emit a warning - - `([x bigint?] x)` - - All `intern`s/effects in `t/defn` should be atomic (all or nothing). This means that the - interns should probably be put on a queue too. - - `declare` but for `t/defn` - - Currently we can declare that there is an fn, and what its output type is, and its metadata, - but we cannot currently declare type-overloads. Experience will make clearer what to do in - these cases. - - `|` (pre-types) - - t/defn- - - Not just a private var for the dynamic dispatch, but needs to be private for purposes of the - analyzer when doing direct dispatch. Should emit a warning, not just fail. - - (t/and (t/or a b) c) should -> (t/or (t/and a c) (t/and b c)) for purposes of type-splitting - - ^:inline - - should be able to mark either ^:unline or ^{:inline false} on arities of an inline function - - if you do (Numeric/bitAnd a b) inline then bitAnd needs to know the primitive type so maybe - we do the `let*`-binding approach to typing vars? - - A good example of inlining: - (t/def empty?|rf - (fn/aritoid - (t/fn [] true) - fn/identity - (t/fn [ret _, x _] (dc/reduced false)) - (t/fn [ret _, k _, v _] (dc/reduced false)))) - (t/defn empty? > p/boolean? - ([x p/nil?] true) - ([xs dc/counted?] (-> xs count num/zero?)) - ([xs (t/input-type educe :_ :_ :?)] (educe empty?|rf x))) - - handle varargs / variadic arity - - [& args _] shouldn't result in `t/any?` but rather like `t/reducible?` or whatever - - should configurably auto-generate arities and/or perform variadic proxying - - do the defnt-equivalences / `t/defn` test namespace - - a linting warning that you can narrow the type to whatever the deduced type is from whatever - wider declared type there is - - the option of creating a `t/defn` that isn't extensible? Or at least in which the input types are limited in the same way per-overload output types are limited by the per-fn output type? - - t/defmacro - - t/deftype - - t/dotyped - - t/extend-defn! - [ ] Ability to add output type restriction after the fact? - - lazy compilation especially around `t/input-type` - - equivalence of typed predicates (i.e. that which is `t/<=` `(t/ftype [x t/any? :> p/boolean?])`) - to types: - - [xs (t/fn [x (t/isa? clojure.lang.Range)] ...)] -- NOTE on namespace organization: - - The initial definition of conversion functions belongs in the namespace that their destination - type belongs in, and it may be extended in every namespace in which there is a source type. + [-] Analysis/Optimization + - `(p/nil? ...)` should probably be inlined to `(?/== ... nil)` rather than using the overhead + of the deftype + - This should realize that we're negating a `<` and change the operator to `<=` + - `(t/def nneg? (fn/comp ?/not neg?))` + - For numbers: + - (< (compare a b) 0) + -> + (< (ifs (< a b) -1 (> a b) 1 0) 0) + -> the only one that can be < 0 is the -1 + -> (< a b) + - Better analysis of compound literals + - Literal seqs need to be better analyzed — (t/finite-of t/built-in-list? [ak-type av-type] ...) + - Peformance analysis (this comes very much later) + - We should be able to do complexity analysis. Similarly to how we can combine and manipulate + types, we could do like `(cplex/assume (cplex/o :n))` or `(cplex/assume (cplex/o :n2))` etc. + - For `reduce` we'd always know it's up to N operations, so O(n * ) + - Record performance for each relevant part and cache? + - (if (dcoll/reduced? ret) + ;; TODO TYPED `(ref/deref ret)` should realize it's dealing with a `reduced?` + (ref/deref ret) + ...) + - (let [ct (count arr)] + (loop [i 0 v init] + (if (comp/< i ct) + (let [ret (f v (get arr i))] + (if (reduced? ret) + @ret + ;; TODO TYPED automatically figure out that `inc` will never go out of bounds here + (recur (inc* i) ret))) + v))) + - (let [xs' (seq xs)] + (if (dcomp/== (class xs') (class xs)) + (reduce-seq rf ret xs') + ;; TODO TYPED automatically figure out that: + ;; - `(not (dcomp/== (class xs') (class xs)))` + ;; - What the possible types of xs' are as a result + (reduce rf init xs'))) + - ([rf rf?, init t/any?, xs #?(:clj (t/isa? clojure.core.protocols/CollReduce) + :cljs (t/isa?|direct cljs.core/IReduce))] + ;; TODO add `^not-native` to `xs` for CLJS + (#?(:clj clojure.core.protocols/coll-reduce + :cljs cljs.core/-reduce) xs rf init)) + - (if (A) ...) should be (if ^boolean (A) ...) if A returns a `p/boolean?` + [ ] t/binding + - We should make a special class or *something* like that to ensure that typed bindings are + only bound within typed contexts. + [ ] t/defrecord + [ ] t/def-concrete-type (i.e. `t/deftype`) + [ ] t/def + - TODO what would this even look like? I guess it would just declare the sym, meta, and type + - It would also have the benefit of creating a typed context + - Without an argument, it would work like `declare` + [-] t/fn + [-] t/ftype + [ ] conditionally optional arities etc. + [ ] ^:dyn + - `(name (read ...))` fails at compile-time; we want it to at least try at runtime. So instead + we annotate like `(name ^:dyn (read ...))`, meaning figure out at runtime what the out-type of + the call to `(read ...)` is, not, call `name` dynamically. + [-] `t/defn` + [ ] Should not accept `t/none?` as an input type + - Arity elision: if any type in an arity is `t/none?` then elide it and emit a warning + - `([x bigint?] x)` + [ ] All `intern`s/effects in `t/defn` should be atomic (all or nothing). This means that the + interns should probably be put on a queue too. + [ ] `declare` but for `t/defn` + - Currently we can declare that there is an fn, and what its output type is, and its + metadata, but we cannot currently declare type-overloads. Experience will make clearer + what to do in these cases. + [ ] `|` (pre-types) + [ ] t/defn- + - Not just a private var for the dynamic dispatch, but needs to be private for purposes of + the analyzer when doing direct dispatch. Should emit a warning, not just fail. + [ ] (t/and (t/or a b) c) should -> (t/or (t/and a c) (t/and b c)) for purposes of type-splitting + [ ] handle varargs / variadic arity + - [& args _] shouldn't result in `t/any?` but rather like `t/reducible?` or whatever + - should configurably auto-generate arities and/or perform variadic proxying + [ ] do the defnt-equivalences / `t/defn` test namespace + [ ] a linting warning that you can narrow the type to whatever the deduced type is from whatever + wider declared type there is + [ ] the option of creating a `t/defn` that isn't extensible? Or at least in which the input + types are limited in the same way per-overload output types are limited by the per-fn output + type? + [ ] t/defmacro + [ ] t/deftype + [ ] t/dotyped + [-] t/extend-defn! + [ ] Ability to add output type restriction after the fact? + [ ] lazy compilation especially around `t/input-type` + [ ] equivalence of typed predicates (i.e. that which is t/<= `(t/ftype [x t/any? :> p/boolean?])`) + to types: + - [xs (t/fn [x (t/isa? clojure.lang.Range)] ...)] - TODO transition the quantum.core.* namespaces: ->>>>>> TODO need to add *all* quantum namespaces in here - - Legend: - [.] : in progress - [-] : done as far as possible but not truly complete - [x] : actually done - [|] : not possible / N/A - [!] : refused - List of semi-approximately topologically ordered namespaces to make typed: - [.] clojure.core / cljs.core (note that many things unexpectedly have associated macros) - [! !] .. @@ -1434,22 +1437,22 @@ Note that `;; TODO TYPED` is the annotation we're using for this initiative - [ ] java.lang.invoke.MethodHandle.linkToInterface(*) - [ ] >=9 : java.lang.invoke.MethodHandleImpl.profileBoolean(boolean, ints) > boolean - [ ] >=9 : java.lang.invoke.MethodHandleImpl.isCompileConstant(object) > boolean - - [x] .booleanValue() > boolean - - [x] .byteValue () > byte - - [x] .shortValue () > short - - [x] .charValue () > char - - [x] .intValue () > int - - [x] .longValue () > long - - [x] .floatValue () > float - - [x] .doubleValue () > double - - [x] Boolean .valueOf(boolean) > Boolean - - [x] Byte .valueOf(byte ) > Byte - - [x] Short .valueOf(short ) > Short - - [x] Character.valueOf(char ) > Character - - [x] Integer .valueOf(int ) > Integer - - [x] Long .valueOf(long ) > Long - - [x] Float .valueOf(float ) > Float - - [x] Double .valueOf(double ) > Double + - [x] .booleanValue() > boolean + - [x] .byteValue () > byte + - [x] .shortValue () > short + - [x] .charValue () > char + - [x] .intValue () > int + - [x] .longValue () > long + - [x] .floatValue () > float + - [x] .doubleValue () > double + - [x] Boolean .valueOf (boolean) > Boolean + - [x] Byte .valueOf (byte ) > Byte + - [x] Short .valueOf (short ) > Short + - [x] Character .valueOf (char ) > Character + - [x] Integer .valueOf (int ) > Integer + - [x] Long .valueOf (long ) > Long + - [x] Float .valueOf (float ) > Float + - [x] Double .valueOf (double ) > Double - [ ] >=9 : .forEachRemaining(java.util.function.IntConsumer) - [.] clojure.lang.RT https://github.com/clojure/clojure/blob/master/src/jvm/clojure/lang/RT.java From 9326559bd10b3b697e97e83e26abc0ee0ee46521 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 9 Nov 2018 15:09:58 -0700 Subject: [PATCH 669/810] Finish updating todos for now --- resources-dev/defnt.cljc | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index d82f9925..e9a378ff 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -2,14 +2,11 @@ Note that for anything built-in js/, the `t/isa?` predicates might nee ;; TO MOVE -#?(:clj (def thread? (isa? java.lang.Thread))) - +#?(:clj (def thread? (isa? java.lang.Thread))) #?(:clj (def class? (isa? java.lang.Class))) - ;; TODO for CLJS based on untyped impl #?(:clj (def protocol? (>expr (ufn/fn-> :on-interface class?)))) - ;; ===== quantum.core.system #?(:clj @@ -39,7 +36,7 @@ Note that for anything built-in js/, the `t/isa?` predicates might nee >boolean is different than `truthy?` -Sometimes you want (byte ) to fail at runtime rather than fail at runtime when you can't know everything about the input's range +Sometimes you want (byte ) to fail at runtime rather than fail at compile time when you can't know everything about the input's range @@ -76,6 +73,8 @@ Legend: ([x p/nil?] true) ([xs dc/counted?] (-> xs count num/zero?)) ([xs (t/input-type educe :_ :_ :?)] (educe empty?|rf x))) + - Should we allow something like `^:analyze-impl` or something to mimic inline optimizations + but avoid actual inlining? [2] t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. - t/numerically-integer? @@ -110,11 +109,13 @@ Legend: [ ] replace `deref` with `ref/deref` in typed contexts? So we can do `@` still - Type Logic and Predicates - expressions (`quantum.untyped.core.analyze.expr`) - - comparison of `t/fn`s is probably possible? + - comparison of `t/fn`s is probably possible - It is possible to check satisfaction of arities to an `t/ftype` at runtime even if the type meta is not stripped (well, at least the arity counts can be checked and primitive types in CLJ): - - In CLJ via e.g. `(clojure.reflect/reflect (class (fn ([]) ([^long a]))))` + - In CLJ via e.g.: + - `(clojure.reflect/reflect (fn ([]) ([^long a])))` + -> {:members #{{:parameter-types [] ...} {:parameter-types [long] ...} ...}} - In CLJS via e.g.: - `(js/Object.getOwnPropertyNames (fn ([]) ([a])))` -> `#js [... \"cljs$core$IFn$_invoke$arity$0\" \"cljs$core$IFn$_invoke$arity$1\"]` From 8d5eb6079f8739de64699d2b3be04a7c49a12f65 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 9 Nov 2018 18:34:21 -0700 Subject: [PATCH 670/810] First pass at direct dispatch seems to work! --- resources-dev/defnt.cljc | 8 +- src-untyped/quantum/untyped/core/analyze.cljc | 250 +++++++------ src-untyped/quantum/untyped/core/form.cljc | 3 +- src-untyped/quantum/untyped/core/type.cljc | 20 +- .../quantum/untyped/core/type/defnt.cljc | 330 +++++++++--------- .../untyped/core/type/reifications.cljc | 26 +- 6 files changed, 352 insertions(+), 285 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index e9a378ff..73d2bc62 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -58,7 +58,8 @@ Legend: - [!] : refused - TODO implement the following: - [1] ^:inline + [1] Direct dispatch needs to actually work correctly in typed contexts + [3] ^:inline - should be able to mark either ^:unline or ^{:inline false} on arities of an inline function - if you do (Numeric/bitAnd a b) inline then bitAnd needs to know the primitive type so maybe we do the `let*`-binding approach to typing vars? @@ -83,7 +84,6 @@ Legend: - numeric definitions - numeric ranges - numeric characteristics - [3] Direct dispatch needs to actually work correctly in typed contexts [ ] Probably should disallow recursive type references, including: `(t/defn f [x (t/input-type f ...)])` [ ] Perhaps it's the case that we can't actually have type bases but rather reactive splits. @@ -234,10 +234,6 @@ Legend: [-] t/fn [-] t/ftype [ ] conditionally optional arities etc. - [ ] ^:dyn - - `(name (read ...))` fails at compile-time; we want it to at least try at runtime. So instead - we annotate like `(name ^:dyn (read ...))`, meaning figure out at runtime what the out-type of - the call to `(read ...)` is, not, call `name` dynamically. [-] `t/defn` [ ] Should not accept `t/none?` as an input type - Arity elision: if any type in an arity is `t/none?` then elide it and emit a warning diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 84b61cb5..7136161f 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -34,7 +34,7 @@ :refer [educe join reducei]] [quantum.untyped.core.refs :as uref :refer [>!thread-local]] - [quantum.untyped.core.spec :as s] + [quantum.untyped.core.spec :as us] [quantum.untyped.core.type :as t :refer [?]] [quantum.untyped.core.type.compare :as utcomp] @@ -199,9 +199,9 @@ ([v] (->WatchableMutable v nil)) ([v watch] (->WatchableMutable v watch))) -(s/def ::opts (s/map-of keyword? t/any?)) +(us/def ::opts (us/map-of keyword? t/any?)) -(s/def ::env (s/map-of (s/or* symbol? #(= % :opts)) t/any?)) +(us/def ::env (us/map-of (us/or* symbol? #(= % :opts)) t/any?)) (declare analyze* analyze-arg-syms*) @@ -357,7 +357,7 @@ (defns- call-sites>most-specific "Time complexity = O(m•n) where m = # of call sites and n = # of args per call site." - [call-sites (s/vec-of t/any? #_(s/array-of class?)) > (s/vec-of t/any? #_(s/array-of class?))] + [call-sites (us/vec-of t/any? #_(us/array-of class?)) > (us/vec-of t/any? #_(us/array-of class?))] (let [^"[Ljava.lang.Object;" sample-arg-classes (-> call-sites first :arg-classes) args-ct (alength sample-arg-classes)] (->> (range args-ct) @@ -373,7 +373,7 @@ (defns- analyze-seq|method-or-constructor-call|incrementally-analyze [env ::env, form _, target-class class?, args|form _, call-sites-for-ct _ - kinds-str string? > (s/kv {:args|analyzed vector?})] + kinds-str string? > (us/kv {:args|analyzed vector?})] (let [{:as ret :keys [call-sites args|analyzed]} (->> args|form (reducei @@ -414,13 +414,13 @@ (defns- analyze-seq|dot|method-call|incrementally-analyze [env ::env, form _, target uast/node?, target-class class?, method-form _ - args|form _ methods-for-ct-and-kind (s/seq-of t/any?) > uast/method-call?] + args|form _ methods-for-ct-and-kind (us/seq-of t/any?) > uast/method-call?] (let [{:keys [args|analyzed call-sites]} (analyze-seq|method-or-constructor-call|incrementally-analyze env form target-class args|form methods-for-ct-and-kind "methods") ?cast-type (?cast-call->type target-class method-form) ;; TODO enable the below: - ;; (s/validate (-> with-ret-type :args first :type) #(t/>= % (t/numerically ?cast-type))) + ;; (us/validate (-> with-ret-type :args first :type) #(t/>= % (t/numerically ?cast-type))) _ (when ?cast-type (log/ppr :warn "Not yet able to statically validate whether primitive cast will succeed at runtime" @@ -472,7 +472,7 @@ (defns classes>class "Ensure that given a set of classes, that set consists of at most a class C and nil. If so, returns C. Otherwise, throws." - [cs (s/set-of (s/nilable class?)) > class?] + [cs (us/set-of (us/nilable class?)) > class?] (let [cs' (disj cs nil)] (if (-> cs' count (= 1)) (first cs') @@ -606,52 +606,52 @@ (err! "Expected var, but found" {:form form :resolved resolved}) (uast/var* env (list 'var (uid/>symbol resolved)) resolved (t/value resolved)))))) -(defn- filter-dynamic-dispatchable-overloads +(defn- filter-dynamic-dispatchable-overload-types "An example of dynamic dispatch: - When we call `seq` on an input of type `(t/? (t/isa? java.util.Set))`, direct dispatch will fail as it is not `t/<=` to any overload (including `t/iterable?` which is the only one under which `(t/isa? java.util.Set)` falls). However since all branches of the `t/or` are guaranteed to result in a successful dispatch (i.e. `t/nil?` and `t/iterable?`) then dynamic dispatch will go forward without an error." - [{:as ret :keys [dispatchable-overloads-seq]} input|analyzed i caller|node body] + [{:as ret :keys [dispatchable-overload-types-seq]} input|analyzed i caller|node body] (if (-> input|analyzed :type utr/or-type?) (let [or-types (-> input|analyzed :type utr/or-type>args) - {:keys [dispatchable-overloads-seq' non-dispatchable-or-types]} - (->> dispatchable-overloads-seq + {:keys [dispatchable-overload-types-seq' non-dispatchable-or-types]} + (->> dispatchable-overload-types-seq (reduce - (fn [ret {:as overload :keys [input-types]}] + (fn [ret {:as overload :keys [arg-types]}] (if-let [or-types-that-match - (->> or-types (uc/lfilter #(t/<= % (get input-types i))) seq)] + (->> or-types (uc/lfilter #(t/<= % (get arg-types i))) seq)] (-> ret - (update :dispatchable-overloads-seq' conj overload) + (update :dispatchable-overload-types-seq' conj overload) (update :non-dispatchable-or-types #(apply disj % or-types-that-match))) ret)) - {:dispatchable-overloads-seq' [] + {:dispatchable-overload-types-seq' [] :non-dispatchable-or-types (set or-types)}))] - (if (or (empty? dispatchable-overloads-seq') + (if (or (empty? dispatchable-overload-types-seq') (uc/contains? non-dispatchable-or-types)) (err! "No overloads satisfy the inputs, whether direct or dynamic" {:caller caller|node :inputs body :failing-input-form (:form input|analyzed) :failing-input-type (:type input|analyzed)}) - (assoc ret :dispatchable-overloads-seq dispatchable-overloads-seq' - :dispatch-type :dynamic))) + (assoc ret :dispatchable-overload-types-seq dispatchable-overload-types-seq' + :dispatch-type :dynamic))) (err! "Cannot currently do a dynamic dispatch on a non-`t/or` input type" {:input|analyzed input|analyzed}))) -(defn- filter-direct-dispatchable-overloads - [{:as ret :keys [dispatchable-overloads-seq]} input|analyzed i caller|node args-form] - (if-let [dispatchable-overloads-seq' - (->> dispatchable-overloads-seq +(defn- filter-direct-dispatchable-overload-types + [{:as ret :keys [dispatchable-overload-types-seq]} input|analyzed i caller|node args-form] + (if-let [dispatchable-overload-types-seq' + (->> dispatchable-overload-types-seq (uc/lfilter - (fn [{:keys [input-types]}] - (t/<= (:type input|analyzed) (get input-types i)))) + (fn [{:keys [arg-types]}] + (t/<= (:type input|analyzed) (get arg-types i)))) seq)] - (assoc ret :dispatchable-overloads-seq dispatchable-overloads-seq') + (assoc ret :dispatchable-overload-types-seq dispatchable-overload-types-seq') (if (-> caller|node :unanalyzed-form meta :dyn) - (filter-dynamic-dispatchable-overloads ret input|analyzed i caller|node args-form) + (filter-dynamic-dispatchable-overload-types ret input|analyzed i caller|node args-form) (err! (str "No overloads satisfy the inputs via direct dispatch; " "dynamic dispatch not requested") {:caller (select-keys caller|node [:unanalyzed-form :form :type]) @@ -659,55 +659,102 @@ :failing-input-form (:form input|analyzed) :failing-input-type (:type input|analyzed)})))) -(defn- >dispatch|out-type [dispatch-type dispatchable-overloads-seq] +(defn- >dispatch|output-type [dispatch-type dispatchable-overload-types-seq] (case dispatch-type - :direct (-> dispatchable-overloads-seq first :output-type) - :dynamic (->> dispatchable-overloads-seq + :direct (-> dispatchable-overload-types-seq first :output-type) + :dynamic (->> dispatchable-overload-types-seq (uc/lmap :output-type) ;; Technically we could do a complex conditional instead of a simple `t/or` but ;; no need (apply t/or)))) -(defns- call>input-nodes+out-type - [env ::env, caller|node _, caller|type _, caller-kind _, inputs-ct _, args-form _ - > (s/kv {:input-nodes t/any? #_(s/seq-of ast/node?) - :out-type t/type?})] - (dissoc - (if (zero? inputs-ct) +(def direct-dispatch-method-sym 'invoke) + +(defns- overload-type-datum>reify-name [type-datum _, fn|name symbol? > qualified-symbol?] + (symbol (-> type-datum :ns-name name) (str (name fn|name) "|__" (:id type-datum)))) + +(defns- >direct-dispatch|reify-call + [caller|node uast/node?, caller|type _, type-datum _, args-codelist (us/seq-of t/any?)] + (if-let [fn|name (utr/fn-type>name caller|type)] + `(. ~(overload-type-datum>reify-name type-datum fn|name) + ~direct-dispatch-method-sym ~@args-codelist) + (err! "No name found for typed fn corresponding to caller; cannot create direct dispatch call" + (assoc (select-keys caller|node [:unanalyzed-form :form]) :type caller|type)))) + +(defns- caller>overload-type-data-for-arity + [env ::env, caller|node uast/node?, caller|type _, inputs-ct _] + (if-let [fn|name (utr/fn-type>name caller|type)] + (let [overload-types-name (symbol (namespace fn|name) (str (name fn|name) "|__types"))] + (if-let [fn|types (get env overload-types-name)] + (->> fn|types (uc/filter #(-> % :arg-types count (= inputs-ct)))) + (if-let [fn|types-var (resolve overload-types-name)] + (->> fn|types-var var-get urx/norx-deref :overload-types + (uc/filter #(-> % :arg-types count (= inputs-ct)))) + (err! "Overload-types not found for typed fn" + {:fn|name fn|name + :caller (assoc (select-keys caller|node [:unanalyzed-form :form]) + :type caller|type)})))) + (err! "No name found for typed fn corresponding to caller" + (assoc (select-keys caller|node [:unanalyzed-form :form]) :type caller|type)))) + +(defns- update-call-data-with-fnt-dispatch|empty-args + [env ::env, caller|node uast/node?, caller|type _, caller-kind _, inputs-ct _, args-form _] + (if (= :fnt caller-kind) + (if-not-let [overload-type-datum + (first (caller>overload-type-data-for-arity + env caller|node caller|type inputs-ct))] + (err! (str "No overloads satisfy the inputs via direct dispatch; " + "dynamic dispatch not requested") + {:caller (assoc (select-keys caller|node [:unanalyzed-form :form]) :type caller|type) + :inputs args-form}) {:input-nodes [] - :out-type - (if (= :fnt caller-kind) - (-> caller|type utr/fn-type>arities (get inputs-ct) first :output-type) - ;; We could do a little smarter analysis here but we'll keep it simple for now - t/any?)} - (->> args-form - (uc/map+ #(analyze* env %)) - (reducei - (fn [{:as ret :keys [dispatch-type]} input|analyzed i] - (if (= :fnt caller-kind) - (let [{:as ret' :keys [dispatchable-overloads-seq]} - (case dispatch-type - :direct (filter-direct-dispatchable-overloads - ret input|analyzed i caller|node args-form) - :dynamic (filter-dynamic-dispatchable-overloads - ret input|analyzed i caller|node args-form))] - (-> ret' - (update :input-nodes conj input|analyzed) - (assoc :out-type - (when-let [last-input-to-check? (= i (dec inputs-ct))] - (>dispatch|out-type - dispatch-type dispatchable-overloads-seq))))) - (update ret :input-nodes conj input|analyzed))) - {:input-nodes [] - ;; We could do a little smarter analysis here but we'll keep it simple for now - :out-type (when-not (= :fnt caller-kind) t/any?) - :dispatch-type :direct - :dispatchable-overloads-seq - (when (= :fnt caller-kind) - (-> caller|type - utr/fn-type>arities - (get inputs-ct)))}))) - :dispatchable-overloads-seq)) + :output-type (:output-type overload-type-datum) + :form (>direct-dispatch|reify-call caller|node caller|type overload-type-datum [])}) + ;; We could do a little smarter analysis here but we'll keep it simple for now + {:input-nodes [] :output-type t/any? :form (list (:form caller|node))})) + +(defns- update-call-data-with-fnt-dispatch + [env ::env, caller|node uast/node?, caller|type _, caller-kind _, inputs-ct _, args-form _ + > (us/kv {:input-nodes t/any? #_(us/seq-of uast/node?) + :output-type t/type? + :form t/any?})] + (if (zero? inputs-ct) + (update-call-data-with-fnt-dispatch|empty-args + env caller|node caller|type caller-kind inputs-ct args-form) + (->> args-form + (uc/map+ #(analyze* env %)) + (reducei + (fn [{:as ret :keys [dispatch-type]} input|analyzed i] + (if (= :fnt caller-kind) + (let [{:as ret' :keys [dispatchable-overload-types-seq input-nodes]} + (case dispatch-type + :direct (filter-direct-dispatchable-overload-types + ret input|analyzed i caller|node args-form) + :dynamic (filter-dynamic-dispatchable-overload-types + ret input|analyzed i caller|node args-form)) + last-input? (= i (dec inputs-ct))] + (-> ret' + (update :input-nodes conj input|analyzed) + (cond-> last-input? + (assoc + :output-type + (>dispatch|output-type dispatch-type dispatchable-overload-types-seq) + :form + (if (= dispatch-type :direct) + (>direct-dispatch|reify-call caller|node caller|type + (first dispatchable-overload-types-seq) + (uc/lmap :form input-nodes)) + (list* (:form caller|node) (uc/lmap :form input-nodes))))))) + (update ret :input-nodes conj input|analyzed))) + {:input-nodes [] + ;; We could do a little smarter analysis here but we'll keep it simple for now + :output-type (when-not (= :fnt caller-kind) t/any?) + :caller|node caller|node + :dispatch-type :direct + :dispatchable-overload-types-seq + (when (= :fnt caller-kind) + (caller>overload-type-data-for-arity env caller|node caller|type inputs-ct))}) + (<- (dissoc :caller|node :dispatch-type :dispatchable-overload-types-seq))))) (defns- analyze-seq|dependent-type-call [env ::env, [caller|form _, & args-form _ :as form] _ > uast/node?] @@ -748,7 +795,7 @@ ;; Maybe it would work more cleanly if we added the `::t/type` metadata to each `t/` operator after ;; the fact? (defns- handle-type-combinators - [caller|node uast/node?, input-nodes _, out-type t/type? > t/type?] + [caller|node uast/node?, input-nodes _, output-type t/type? > t/type?] (condp = (:type caller|node) ;; TODO this relies on spec instrumentation not happening for these fns (t/value t/isa?) (apply-arg-type-combine t/isa? input-nodes) @@ -762,7 +809,7 @@ (t/value t/unref) (apply-arg-type-combine t/unref input-nodes) (t/value t/assume) (apply-arg-type-combine t/assume input-nodes) (t/value t/unassume) (apply-arg-type-combine t/unassume input-nodes) - out-type)) + output-type)) (defns- analyze-seq|call [env ::env, [caller|form _ & args-form _ :as form] _ > uast/call-node?] @@ -815,24 +862,22 @@ (when-not (-> caller|type utr/fn-type>arities (contains? inputs-ct)) (err! "Unhandled number of inputs for fnt" {:inputs-ct inputs-ct :caller caller|node})) - ;; For non-typed fns, unknown; we will have to risk runtime exception - ;; because we can't necessarily rely on metadata to tell us the - ;; whole truth + ;; TODO use the `reflect/reflect` and `js/Object.getOwnPropertyNames` trick :fn nil) - {:keys [input-nodes out-type]} - (call>input-nodes+out-type + {:keys [input-nodes output-type] analyzed-form :form} + (update-call-data-with-fnt-dispatch env caller|node caller|type caller-kind inputs-ct args-form) - out-type' + output-type' (if (-> env :opts :arglist-context?) - (handle-type-combinators caller|node input-nodes out-type) - out-type)] + (handle-type-combinators caller|node input-nodes output-type) + output-type)] (uast/call-node {:env env :unanalyzed-form form - :form (list* (:form caller|node) (map :form input-nodes)) + :form analyzed-form :caller caller|node :args input-nodes - :type out-type'}))))) + :type output-type'}))))) (defns- analyze-seq* "Analyze a seq after it has been macro-expanded. @@ -876,6 +921,7 @@ (let [expanded-form' (cond-> expanded-form (uvar/with-metable? expanded-form) (update-meta merge (meta form))) expanded (analyze* env expanded-form')] + (pr! (kw-map form expanded-form' (:form expanded))) (uast/macro-call {:env env :unexpanded-form form @@ -985,7 +1031,7 @@ ;; ===== Arglist analysis ===== ;; -(s/def ::arg-sym->arg-type-form (s/map-of simple-symbol? t/any?)) +(us/def ::arg-sym->arg-type-form (us/map-of simple-symbol? t/any?)) (def analyze-arg-syms|max-iter 10000) @@ -1013,14 +1059,14 @@ (defns type>split "Only `t/or`s and `t/meta-or`s are splittable for now. Reactive types are non-reactively derefed in order to make splitting possible." - [t t/type? > (s/vec-of t/type?)] + [t t/type? > (us/vec-of t/type?)] (let [t' (cond-> t (utr/rx-type? t) urx/norx-deref)] (ifs (utr/or-type? t') (utr/or-type>args t') ;; TODO determine if this is the appropriate place to deal with `t/none?` (utr/meta-or-type? t') (->> t' utr/meta-or-type>types (uc/remove (fn1 t/= t/none?))) [t']))) -(defns type>split+primitivized [t t/type? > (s/vec-of t/type?)] +(defns type>split+primitivized [t t/type? > (us/vec-of t/type?)] (let [t|norx (cond-> t (utr/rx-type? t) urx/norx-deref) t|split (type>split t|norx) primitive-subtypes @@ -1038,15 +1084,15 @@ (defn- analyze-arg-syms* [env #_::env] (uref/update! !!analyze-arg-syms|iter inc) - (let [{:keys [arg-sym->arg-type-form arglist-syms|queue arglist-syms|unanalyzed out-type-or-form - split-types?]} (:opts env)] + (let [{:keys [arg-sym->arg-type-form arglist-syms|queue arglist-syms|unanalyzed + output-type-or-form split-types?]} (:opts env)] (ifs (empty? arglist-syms|unanalyzed) - [{:env env - :out-type-node (if (t/type? out-type-or-form) - (uast/literal env nil out-type-or-form) ; a simulated AST node - (-> (analyze env out-type-or-form) - (update :type (fn-> t/unvalue urx/?norx-deref)))) - :dependent? (uref/get !!dependent?)}] + [{:env env + :output-type-node (if (t/type? output-type-or-form) + (uast/literal env nil output-type-or-form) ; a simulated AST node + (-> (analyze env output-type-or-form) + (update :type (fn-> t/unvalue urx/?norx-deref)))) + :dependent? (uref/get !!dependent?)}] (>= (uref/get !!analyze-arg-syms|iter) analyze-arg-syms|max-iter) (err! "Max number of iterations reached for `analyze-arg-syms`" {:n (uref/get !!analyze-arg-syms|iter)}) @@ -1078,14 +1124,14 @@ ur/join)))))) (defns- >analyze-arg-syms|opts - [env ::env, arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-or-form _ + [env ::env, arg-sym->arg-type-form ::arg-sym->arg-type-form, output-type-or-form _ split-types? boolean?] {:arglist-context? true :arglist-syms|queue (uset/ordered-set (-> arg-sym->arg-type-form keys first)) :arglist-syms|unanalyzed (-> arg-sym->arg-type-form keys set) :arg-env (atom env) ; Mutable so it can cache :arg-sym->arg-type-form arg-sym->arg-type-form - :out-type-or-form out-type-or-form + :output-type-or-form output-type-or-form :split-types? split-types?}) (defns analyze-arg-syms @@ -1098,19 +1144,19 @@ deduced types of the inputs. In other words, in the worst case scenario each of the arg types might be a 'splittable' type like `t/or` (whose cardinality is the number of arguments to it when simplified) which would require a Cartesian product of the splits of the arg types." - > vector? #_(s/vec-of (s/kv {:env ::env :out-type-node uast/node? :dependent? boolean?})) - ([arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-or-form _] - (analyze-arg-syms {} arg-sym->arg-type-form out-type-or-form true)) - ([arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-or-form _, split-types? boolean?] - (analyze-arg-syms {} arg-sym->arg-type-form out-type-or-form split-types?)) - ([env ::env, arg-sym->arg-type-form ::arg-sym->arg-type-form, out-type-or-form _ + > vector? #_(us/vec-of (us/kv {:env ::env :output-type-node uast/node? :dependent? boolean?})) + ([arg-sym->arg-type-form ::arg-sym->arg-type-form, output-type-or-form _] + (analyze-arg-syms {} arg-sym->arg-type-form output-type-or-form true)) + ([arg-sym->arg-type-form ::arg-sym->arg-type-form, output-type-or-form _, split-types? boolean?] + (analyze-arg-syms {} arg-sym->arg-type-form output-type-or-form split-types?)) + ([env ::env, arg-sym->arg-type-form ::arg-sym->arg-type-form, output-type-or-form _ split-types? boolean? - > (s/vec-of (s/kv {:env ::env :out-type-node uast/node?}))] + > (us/vec-of (us/kv {:env ::env :output-type-node uast/node?}))] (uref/set! !!analyze-arg-syms|iter 0) (uref/set! !!dependent? false) (try (analyze-arg-syms* {:opts (merge (:opts env) - (>analyze-arg-syms|opts env arg-sym->arg-type-form out-type-or-form + (>analyze-arg-syms|opts env arg-sym->arg-type-form output-type-or-form split-types?))}) (catch Throwable t (if (and (uerr/error-map? t) (-> t :ident (= ::arg-syms-analyzed))) diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index 67cf0fbe..32b246ea 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -63,7 +63,8 @@ :cljs cljs.core/PersistentList) (>form [x] (->> x (map >form) list*)) - #?@(:clj [clojure.lang.ASeq (>form [x] (->> x (map >form)))]) + #?@(:clj [clojure.lang.ASeq (>form [x] (->> x (map >form)))]) + #?@(:clj [clojure.lang.LazySeq (>form [x] (->> x (map >form)))]) #?(:clj clojure.lang.Var :cljs cljs.core/Var) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 260f41b4..f1b902f3 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -506,13 +506,15 @@ ;; ===== `t/ftype` ===== ;; (defn ftype [& args] - (let [name- nil - out-type (if (-> args first c/sequential?) + (let [name- (when (-> args first c/symbol?) + (first args)) + rest-args (if name- (rest args) args) + out-type (if (-> rest-args first c/sequential?) universal-set - (first args)) - arities-form (if (-> args first c/sequential?) - args - (rest args)) + (first rest-args)) + arities-form (if (-> rest-args first c/sequential?) + rest-args + (rest rest-args)) arities (->> arities-form (uc/map+ (c/fn [arity-form] (-> (us/conform ::fn-type|arity arity-form) @@ -554,9 +556,9 @@ (us/def ::match-spec (us/seq-of (us/or* #{:_ :?} type? - (us/tuple #{:?} type?) - (us/tuple ifn? type?) - (us/tuple #{:?} ifn? type?)))) + (us/tuple #{:?} type?) + (us/tuple c/ifn? type?) + (us/tuple #{:?} c/ifn? type?)))) (defn- find-spec? [match-spec-element] (c/or (c/= match-spec-element :?) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 0d820022..872615f2 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -48,7 +48,7 @@ :refer [educe educei reducei]] [quantum.untyped.core.refs :as uref :refer [?deref]] - [quantum.untyped.core.spec :as s] + [quantum.untyped.core.spec :as us] [quantum.untyped.core.specs :as uss] [quantum.untyped.core.type :as t :refer [?]] @@ -66,14 +66,14 @@ ;; ===== `t/extend-defn!` specs ===== ;; -(s/def :quantum.core.defnt/fn|extended-name symbol?) +(us/def :quantum.core.defnt/fn|extended-name symbol?) -(s/def :quantum.core.defnt/extend-defn! - (s/and (s/spec - (s/cat :quantum.core.defnt/fn|extended-name :quantum.core.defnt/fn|extended-name - :quantum.core.defnt/overloads :quantum.core.defnt/overloads)) - (uss/fn-like|postchecks|gen :quantum.core.defnt/overloads) - :quantum.core.defnt/postchecks)) +(us/def :quantum.core.defnt/extend-defn! + (us/and (us/spec + (us/cat :quantum.core.defnt/fn|extended-name :quantum.core.defnt/fn|extended-name + :quantum.core.defnt/overloads :quantum.core.defnt/overloads)) + (uss/fn-like|postchecks|gen :quantum.core.defnt/overloads) + :quantum.core.defnt/postchecks)) ;; ===== End `t/extend-defn!` specs ===== ;; @@ -87,129 +87,129 @@ ;; ==== Internal specs ===== ;; -(s/def ::lang #{:clj :cljs}) +(us/def ::lang #{:clj :cljs}) (def ^:dynamic *compilation-mode* :normal) -(s/def ::compilation-mode #{:normal :test}) +(us/def ::compilation-mode #{:normal :test}) -(s/def ::kind #{:fn :defn :extend-defn!}) +(us/def ::kind #{:fn :defn :extend-defn!}) -(s/def ::opts - (s/kv {:compilation-mode ::compilation-mode - :gen-gensym t/fn? - :lang ::lang - :kind ::kind})) +(us/def ::opts + (us/kv {:compilation-mode ::compilation-mode + :gen-gensym t/fn? + :lang ::lang + :kind ::kind})) ;; "global" because they apply to the whole `t/fn` -(s/def ::fn|globals - (s/kv {:fn|globals-name simple-symbol? - :fn|meta (s/nilable :quantum.core.specs/meta) - :fn|ns-name simple-symbol? - :fn|name ::uss/fn|name - :fn|output-type t/type? - :fn|output-type|form t/any? - :fn|overload-bases-name simple-symbol? - :fn|overload-types-name simple-symbol? - :fn|type-name simple-symbol?})) - -(s/def ::overload-basis|types|split - (s/vec-of (s/kv {:arg-types (s/vec-of t/type?) :output-type t/type?}))) - -(s/def ::overload-basis|norx +(us/def ::fn|globals + (us/kv {:fn|globals-name simple-symbol? + :fn|meta (us/nilable :quantum.core.specs/meta) + :fn|ns-name simple-symbol? + :fn|name ::uss/fn|name + :fn|output-type t/type? + :fn|output-type|form t/any? + :fn|overload-bases-name simple-symbol? + :fn|overload-types-name simple-symbol? + :fn|type-name simple-symbol?})) + +(us/def ::overload-basis|types|split + (us/vec-of (us/kv {:arg-types (us/vec-of t/type?) :output-type t/type?}))) + +(us/def ::overload-basis|norx ;; None of these types should be reactive - (s/kv {:arg-types|basis (s/vec-of t/type?) - :output-type|basis t/type? - ;; This is non-nil only for arglists with dependent types - :types|split (s/nilable ::overload-basis|types|split) - :body-codelist (s/vec-of t/any?) - :dependent? boolean? - :reactive? boolean?})) - -(s/def ::overload-basis - (s/kv {:ns simple-symbol? - :args-form map? ; from binding to form - :varargs-form (s/nilable map?) ; from binding to form - :arglist-form|unanalyzed t/any? - :arg-types|basis (s/vec-of t/type?) - :output-type|form t/any? - :output-type|basis t/type? - ;; This is non-nil only for arglists with dependent types - :types|split (s/nilable ::overload-basis|types|split) - :body-codelist (s/vec-of t/any?) - :dependent? boolean? - :reactive? boolean?})) - -(s/def ::overload-bases-data - (s/kv {:prev-norx (s/nilable (s/vec-of ::overload-basis|norx)) - :current (s/vec-of ::overload-basis)})) + (us/kv {:arg-types|basis (us/vec-of t/type?) + :output-type|basis t/type? + ;; This is non-nil only for arglists with dependent types + :types|split (us/nilable ::overload-basis|types|split) + :body-codelist (us/vec-of t/any?) + :dependent? boolean? + :reactive? boolean?})) + +(us/def ::overload-basis + (us/kv {:ns simple-symbol? + :args-form map? ; from binding to form + :varargs-form (us/nilable map?) ; from binding to form + :arglist-form|unanalyzed t/any? + :arg-types|basis (us/vec-of t/type?) + :output-type|form t/any? + :output-type|basis t/type? + ;; This is non-nil only for arglists with dependent types + :types|split (us/nilable ::overload-basis|types|split) + :body-codelist (us/vec-of t/any?) + :dependent? boolean? + :reactive? boolean?})) + +(us/def ::overload-bases-data + (us/kv {:prev-norx (us/nilable (us/vec-of ::overload-basis|norx)) + :current (us/vec-of ::overload-basis)})) ;; Technically it's partially analyzed — its type definitions are analyzed (with the exception of ;; requests for type inference) while its body is not. - (s/def ::unanalyzed-overload - (s/kv {:arglist-form|unanalyzed t/any? - :args-form map? ; from binding to form - :varargs-vorm (s/nilable map?) ; from binding to form - :arg-types (s/vec-of t/type?) - :output-type|form t/any? - :output-type t/type? - :body-codelist t/any? - :i|basis index?})) + (us/def ::unanalyzed-overload + (us/kv {:arglist-form|unanalyzed t/any? + :args-form map? ; from binding to form + :varargs-vorm (us/nilable map?) ; from binding to form + :arg-types (us/vec-of t/type?) + :output-type|form t/any? + :output-type t/type? + :body-codelist t/any? + :i|basis index?})) ;; This is the overload after the input specs are split by their respective `t/or` constituents, ;; and after primitivization, but before readiness for incorporation into a `reify`. ;; One of these corresponds to one reify overload. -(s/def ::overload - (s/kv {:arg-classes (s/vec-of class?) - :arg-types (s/vec-of t/type?) - :arglist-form|unanalyzed t/any? - :arglist-code|fn|hinted t/any? - :arglist-code|reify|unhinted t/any? - :body-form t/any? - :output-class (s/nilable class?) - :output-type t/type? - :positional-args-ct count? - ;; When present, varargs are considered to be of class Object - :variadic? t/boolean?})) - -(s/def ::overload|id index?) - -(s/def ::overload-types-decl - (s/kv {:form t/any? - :name simple-symbol?})) - -(s/def ::reify|name simple-symbol?) ; hinted with the interface name - -(s/def ::reify - (s/kv {:form t/any? - :interface class? - :name ::reify|name - :overload ::overload})) - -(s/def ::direct-dispatch-data - (s/kv {:overload-types-decl ::overload-types-decl - :reify ::reify})) - -(s/def ::direct-dispatch - (s/kv {:form t/any? - :direct-dispatch-data-seq (s/vec-of ::direct-dispatch-data)})) - -(s/def ::type-datum - (s/kv {:arg-types (s/vec-of t/type?) - :pre-type t/type? - :output-type t/type?})) - -(s/def ::types-decl-datum - (s/kv {:id ::overload|id - :ns-name simple-symbol? - :arg-types (s/vec-of t/type?) - :output-type t/type? - :index index?})) ; overload-index (position in the overall types-decl) - -(s/def ::fn|types - (s/kv {:fn|output-type-norx t/type? - :fn|type-norx t/type? - :overload-types (s/vec-of ::types-decl-datum)})) +(us/def ::overload + (us/kv {:arg-classes (us/vec-of class?) + :arg-types (us/vec-of t/type?) + :arglist-form|unanalyzed t/any? + :arglist-code|fn|hinted t/any? + :arglist-code|reify|unhinted t/any? + :body-form t/any? + :output-class (us/nilable class?) + :output-type t/type? + :positional-args-ct count? + ;; When present, varargs are considered to be of class Object + :variadic? t/boolean?})) + +(us/def ::overload|id index?) + +(us/def ::overload-types-decl + (us/kv {:form t/any? + :name simple-symbol?})) + +(us/def ::reify|name simple-symbol?) ; hinted with the interface name + +(us/def ::reify + (us/kv {:form t/any? + :interface class? + :name ::reify|name + :overload ::overload})) + +(us/def ::direct-dispatch-data + (us/kv {:overload-types-decl ::overload-types-decl + :reify ::reify})) + +(us/def ::direct-dispatch + (us/kv {:form t/any? + :direct-dispatch-data-seq (us/vec-of ::direct-dispatch-data)})) + +(us/def ::type-datum + (us/kv {:arg-types (us/vec-of t/type?) + :pre-type t/type? + :output-type t/type?})) + +(us/def ::types-decl-datum + (us/kv {:id ::overload|id + :ns-name simple-symbol? + :arg-types (us/vec-of t/type?) + :output-type t/type? + :index index?})) ; overload-index (position in the overall types-decl) + +(us/def ::fn|types + (us/kv {:fn|output-type-norx t/type? + :fn|type-norx t/type? + :overload-types (us/vec-of ::types-decl-datum)})) #_(:clj (c/defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] @@ -263,7 +263,7 @@ 1 (uset/normalize-comparison (t/compare t0 t1))))) -(c/defn compare-args-types [arg-types0 #_(s/vec-of t/type?) arg-types1 #_(s/vec-of t/type?)] +(c/defn compare-args-types [arg-types0 #_(us/vec-of t/type?) arg-types1 #_(us/vec-of t/type?)] (let [ct-comparison (compare (count arg-types0) (count arg-types1))] (if (zero? ct-comparison) (reduce-2 @@ -307,8 +307,9 @@ output-type|form _, body-codelist _] declared-output-type [:output-type _]} ::unanalyzed-overload - overload|id index? - fn|type t/type? + overload|id index? + fn|overload-types (us/vec-of ::types-decl-datum) + fn|type t/type? > ::overload] (let [;; Not sure if `nil` is the right approach for the value recursive-ast-node-reference @@ -318,7 +319,10 @@ [arg-binding (uast/unbound nil arg-binding arg-type)])) ;; To support recursion (<- (cond-> (not= kind :extend-defn!) - (assoc fn|name recursive-ast-node-reference)))) + (assoc fn|name + recursive-ast-node-reference + (uid/qualify fn|ns-name fn|overload-types-name) + fn|overload-types)))) variadic? (not (empty? varargs-form)) arg-classes (->> arg-types (uc/map type>class)) body-node (uana/analyze env (ufgen/?wrap-do body-codelist)) @@ -365,16 +369,14 @@ ;; ----- Direct dispatch: `reify` ---- ;; -(defns- overload-classes>interface-sym [args-classes (s/seq-of class?), out-class class? > symbol?] +(defns- overload-classes>interface-sym [args-classes (us/seq-of class?), out-class class? > symbol?] (>symbol (str (->> args-classes (uc/lmap class>interface-part-name) (str/join "+")) ">" (class>interface-part-name out-class)))) -(def reify-method-sym 'invoke) - (defns- overload-classes>interface - [args-classes (s/vec-of class?), out-class class?, gen-gensym fn?] + [args-classes (us/vec-of class?), out-class class?, gen-gensym fn?] (let [interface-sym (overload-classes>interface-sym args-classes out-class) - hinted-method-sym (ufth/with-type-hint reify-method-sym + hinted-method-sym (ufth/with-type-hint uana/direct-dispatch-method-sym (ufth/>interface-method-tag out-class)) hinted-args (ufth/hint-arglist-with (ufgen/gen-args 0 (count args-classes) "x" gen-gensym) @@ -416,7 +418,7 @@ (ufth/with-type-hint (>name interface))) form `(~'def ~reify|name (reify* [~(-> interface >name >symbol)] - (~(ufth/with-type-hint reify-method-sym + (~(ufth/with-type-hint uana/direct-dispatch-method-sym (ufth/>arglist-embeddable-tag output-class|reify)) ~arglist-code ~body-form)))] {:form form @@ -431,13 +433,17 @@ #_> #_(objects-of type?)] (apply uarr/*<> (-> !fn|types norx-deref :overload-types (get overload-index) :arg-types))) -(c/defn overload-types>ftype [overload-types #_(vec-of ::type-datum), fn|output-type #_t/type?] +(c/defn overload-types>ftype + [fn|ns-name #_simple-symbol? + fn|name #_simple-symbol? + overload-types #_(vec-of ::type-datum) + fn|output-type #_t/type?] (->> overload-types (uc/lmap (c/fn [{:keys [arg-types pre-type output-type]}] (cond-> arg-types pre-type (conj :| pre-type) output-type (conj :> output-type)))) - (apply t/ftype fn|output-type))) + (apply t/ftype (uid/qualify fn|ns-name fn|name) fn|output-type))) (c/defn- dedupe-overload-types-data [fn|ns-name fn|name types-decl-data] (->> types-decl-data @@ -479,10 +485,10 @@ "Split and primitivized; not yet sorted." [{:keys [fn|output-type _]} ::fn|globals, args-form _, output-type|form _, body-codelist _] (->> (uana/analyze-arg-syms {} args-form (or output-type|form fn|output-type) true) - (uc/map+ (c/fn [{:keys [env out-type-node]}] + (uc/map+ (c/fn [{:keys [env output-type-node]}] (let [arg-env (->> env :opts :arg-env deref) arg-types (->> args-form keys (uc/map #(:type (get arg-env %)))) - output-type (:type out-type-node)] + output-type (:type output-type-node)] (when-not (t/<= output-type fn|output-type) (err! (str "Overload's declared output type does not satisfy function's" "overall declared output type") @@ -532,8 +538,8 @@ times for each `m`. All other computations are done only once for each `m`." [fn|globals ::fn|globals {:keys [prev-norx _, current _]} ::overload-bases-data - existing-overload-types (s/nilable (s/vec-of ::types-decl-datum)) - > (s/vec-of ::unanalyzed-overload)] + existing-overload-types (us/nilable (us/vec-of ::types-decl-datum)) + > (us/vec-of ::unanalyzed-overload)] (let [first-new-basis-index (count prev-norx)] (->> current (uc/map-indexed+ @@ -567,8 +573,8 @@ (defns- validate-unique-types-for-unanalyzed-overloads "Prior to validation we must first sort the overloads by comparing their arg types. Then if we find any type signature duplicates in a linear scan, we throw an error." - [unanalyzed-overloads (s/seq-of ::unanalyzed-overload) - > (s/vec-of ::unanalyzed-overload)] + [unanalyzed-overloads (us/seq-of ::unanalyzed-overload) + > (us/vec-of ::unanalyzed-overload)] (->> unanalyzed-overloads (dedupe-type-data (c/fn [overloads prev-overload overload] @@ -584,7 +590,7 @@ "Each overload type is structurally (`=`) unique and if an overload is introduced which is `t/=` but not `=` then that overload will be rejected." [overload-bases-data ::overload-bases-data - existing-fn-types (s/nilable ::fn|types) + existing-fn-types (us/nilable ::fn|types) opts ::opts {:as fn|globals :keys [fn|name _, fn|ns-name _, fn|output-type _, fn|overload-types-name _]} ::fn|globals @@ -603,7 +609,7 @@ fn|globals overload-bases-data existing-overload-types))] (or existing-fn-types {:fn|output-type-norx fn|output-type-norx - :fn|type-norx (t/ftype fn|output-type-norx) + :fn|type-norx (t/ftype (uid/qualify fn|ns-name fn|name) fn|output-type-norx) :overload-types []}) (let [sorted-changed-unanalyzed-overloads (->> changed-unanalyzed-overloads @@ -638,7 +644,8 @@ (dedupe-overload-types-data fn|ns-name fn|name) (uc/map-indexed (c/fn [i datum] (assoc datum :index i))))) ;; For recursive purposes - fn|type-norx (overload-types>ftype overload-types-with-replacing-ids fn|output-type-norx) + fn|type-norx (overload-types>ftype + fn|ns-name fn|name overload-types-with-replacing-ids fn|output-type-norx) ;; We should analyze everything first in order to figure out body-dependent input types ;; before we can compare them against each other, but we're ignoring body-dependent input ;; types for now @@ -647,7 +654,8 @@ (uc/map-indexed (c/fn [i x] (let [id (+ i first-current-overload-id)] - (unanalyzed-overload>overload opts fn|globals x id fn|type-norx))))) + (unanalyzed-overload>overload opts fn|globals x id + overload-types-with-replacing-ids fn|type-norx))))) overload-types (->> overload-types-with-replacing-ids (uc/map @@ -684,9 +692,8 @@ ;; ===== Dynamic dispatch ===== ;; -(defns- >dynamic-dispatch|reify-call - [reify|name|qualified qualified-symbol?, arglist (s/vec-of simple-symbol?)] - `(. ~reify|name|qualified ~reify-method-sym ~@arglist)) +(defns >direct-dispatch|reify-call [reify-name symbol?, args-codelist (us/seq-of t/any?)] + `(. ~reify-name ~uana/direct-dispatch-method-sym ~@args-codelist)) ;; TODO spec (defns unsupported! [name- _ #_t/qualified-symbol?, args _ #_indexed?, i index?] @@ -695,14 +702,14 @@ (defns- >combinatoric-seq+ [{:as fn|globals :keys [fn|ns-name _ fn|name _]} ::fn|globals - overload-types-for-arity (s/vec-of ::types-decl-datum) - arglist (s/vec-of simple-symbol?)] + overload-types-for-arity (us/vec-of ::types-decl-datum) + arglist (us/vec-of simple-symbol?)] (->> overload-types-for-arity (uc/map+ (c/fn [{:as types-decl-datum :keys [arg-types] overload|id :id ns-name- :ns-name}] (let [overload-types-decl|name (>overload-types-decl|name ns-name- fn|name overload|id) - reify|name|qualified (>reify-name-unhinted ns-name- fn|name overload|id)] - [(>dynamic-dispatch|reify-call reify|name|qualified arglist) + reify-name-unhinted (>reify-name-unhinted ns-name- fn|name overload|id)] + [(>direct-dispatch|reify-call reify-name-unhinted arglist) (->> arg-types (uc/map-indexed (c/fn [i|arg arg-type] @@ -713,12 +720,11 @@ (defns- >dynamic-dispatch|body-for-arity [{:as fn|globals :keys [fn|ns-name _, fn|name _]} ::fn|globals - overload-types-for-arity (s/vec-of ::types-decl-datum) - arglist (s/vec-of simple-symbol?)] + overload-types-for-arity (us/vec-of ::types-decl-datum) + arglist (us/vec-of simple-symbol?)] (if (empty? arglist) (let [overload|id (-> overload-types-for-arity first :id)] - (>dynamic-dispatch|reify-call - (>reify-name-unhinted fn|ns-name fn|name overload|id) arglist)) + (>direct-dispatch|reify-call (>reify-name-unhinted fn|ns-name fn|name overload|id) arglist)) (let [!!i|arg (atom 0) combinef (c/fn @@ -803,7 +809,7 @@ (or output-type|form fn|output-type) false) binding->arg-type|basis (->> arglist-basis :env :opts :arg-env deref (uc/map-vals' :type)) arg-types|basis (->> args-form keys (uc/map binding->arg-type|basis)) - output-type|basis (-> arglist-basis :out-type-node :type) + output-type|basis (-> arglist-basis :output-type-node :type) dependent? (:dependent? arglist-basis) reactive? (or (utr/rx-type? output-type|basis) (seq-or utr/rx-type? arg-types|basis))] @@ -837,8 +843,8 @@ (defns- incorporate-overload-bases "O(m•n) where `m` = # of existing overload bases and `n` = # of new overload bases." - [existing-bases (s/vec-of ::overload-basis), new-bases (s/vec-of ::overload-basis) - > (s/vec-of ::overload-basis)] + [existing-bases (us/vec-of ::overload-basis), new-bases (us/vec-of ::overload-basis) + > (us/vec-of ::overload-basis)] (reduce (c/fn [bases new-basis] (if-let [i|existing @@ -972,16 +978,16 @@ (defns- >fn|globals+?overload-bases-form "`opts` are per invocation of `t/defn` and/or `extend-defn!`, while `globals` persist for as long as the `t/defn` does." - [kind ::kind, args _ > (s/kv {:fn|globals ::fn|globals :overload-bases-form t/any?})] + [kind ::kind, args _ > (us/kv {:fn|globals ::fn|globals :overload-bases-form t/any?})] (let [{:as args' :keys [:quantum.core.specs/fn|name :quantum.core.defnt/fn|extended-name :quantum.core.defnt/output-spec] overload-bases-form :quantum.core.defnt/overloads fn|meta :quantum.core.specs/meta} - (s/validate args (case kind :defn :quantum.core.defnt/defnt - :fn :quantum.core.defnt/fnt - :extend-defn! :quantum.core.defnt/extend-defn!)) + (us/validate args (case kind :defn :quantum.core.defnt/defnt + :fn :quantum.core.defnt/fnt + :extend-defn! :quantum.core.defnt/extend-defn!)) fn|var (when (= kind :extend-defn!) (or (uvar/resolve *ns* fn|extended-name) (err! "Could not resolve fn name to extend" @@ -999,7 +1005,7 @@ (let [inline? (-> (if (= kind :extend-defn!) (-> fn|var meta :inline) (:inline fn|meta)) - (s/validate (t/? t/boolean?))) + (us/validate (t/? t/boolean?))) fn|meta (if inline? (do (ulog/pr :warn "requested `:inline`; ignoring until feature is implemented") @@ -1078,6 +1084,16 @@ - When a typed function (or a typed object with function-like characteristics such as a `t/deftype`) is referenced outside of a typed context. + Metadata directives special to all typed contexts include: + - `:val` : If `true` and attached as metadata to a form, it will cause that form's type to be + `t/and`ed with `t/val?`. + - `:dyn` : If `true` and attached as metadata to a form corresponding with a typed fn in functor + position, it will cause that typed fn to be called dynamically if no direct dispatch + is found at compile time. + - For instance, `(name (read ...))` fails at compile-time; we want it to at least try + at runtime. So we annotate like `(^:dyn name (read ...))`, which tells the compiler + to figure out at runtime whether a call to `name` will succeed. + Metadata directives special to `t/fn`/`t/defn` include: - `:inline` : If `true` and attached as metadata to the arglist of an overload, will cause that overload to be inlined if possible. diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index ec326efd..2906f2ac 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -381,28 +381,34 @@ ;; ----- FnType ----- ;; (udt/deftype FnType - [meta #_(t/? ::meta) - name - out-type #_t/type? + [meta #_(t/? ::meta) + name #_(t/? qualified-symbol?) + output-type #_t/type? arities-form - arities #_(s/map-of nneg-int? (s/seq-of (s/kv {:input-types (s/vec-of type?) - :output-type type?})))] + arities #_(s/map-of nneg-int? (s/seq-of (s/kv {:input-types (s/vec-of type?) + :output-type type?})))] {PType nil ;; Outputs whether the args match any input spec ?Fn {invoke ([this args] (TODO))} ?Meta {meta ([this] meta) - with-meta ([this meta'] (FnType. meta' name out-type arities-form arities))} - uform/PGenForm {>form ([this] (-> (list* 'quantum.untyped.core.type/ftype - (>form out-type) (>form arities-form)) - (accounting-for-meta meta)))} + with-meta ([this meta'] (FnType. meta' name output-type arities-form arities))} + uform/PGenForm {>form ([this] + (-> (if (nil? name) + (list* 'quantum.untyped.core.type/ftype + (>form output-type) (>form arities-form)) + (list* 'quantum.untyped.core.type/ftype + name (>form output-type) (>form arities-form))) + (accounting-for-meta meta)))} fedn/IOverride nil fedn/IEdn {-edn ([this] (>form this))}}) (defns fn-type? [x _ > boolean?] (instance? FnType x)) +(defns fn-type>name [^FnType x fn-type?] (.-name x)) + (defns fn-type>arities [^FnType x fn-type?] (.-arities x)) -(defns fn-type>out-type [^FnType x fn-type?] (.-out-type x)) +(defns fn-type>output-type [^FnType x fn-type?] (.-output-type x)) (us/def :quantum.untyped.core.type/fn-type|arity (us/and From 2e4b76a8e8c2108b05617ba52137b32212ba10bd Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 9 Nov 2018 18:56:17 -0700 Subject: [PATCH 671/810] Fix direct dispatch bug --- src-untyped/quantum/untyped/core/analyze.cljc | 33 +++++++++---------- 1 file changed, 16 insertions(+), 17 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 7136161f..22b50f01 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -727,24 +727,23 @@ (fn [{:as ret :keys [dispatch-type]} input|analyzed i] (if (= :fnt caller-kind) (let [{:as ret' :keys [dispatchable-overload-types-seq input-nodes]} - (case dispatch-type - :direct (filter-direct-dispatchable-overload-types - ret input|analyzed i caller|node args-form) - :dynamic (filter-dynamic-dispatchable-overload-types - ret input|analyzed i caller|node args-form)) + (-> (case dispatch-type + :direct (filter-direct-dispatchable-overload-types + ret input|analyzed i caller|node args-form) + :dynamic (filter-dynamic-dispatchable-overload-types + ret input|analyzed i caller|node args-form)) + (update :input-nodes conj input|analyzed)) last-input? (= i (dec inputs-ct))] - (-> ret' - (update :input-nodes conj input|analyzed) - (cond-> last-input? - (assoc - :output-type - (>dispatch|output-type dispatch-type dispatchable-overload-types-seq) - :form - (if (= dispatch-type :direct) - (>direct-dispatch|reify-call caller|node caller|type - (first dispatchable-overload-types-seq) - (uc/lmap :form input-nodes)) - (list* (:form caller|node) (uc/lmap :form input-nodes))))))) + (cond-> ret' last-input? + (assoc + :output-type + (>dispatch|output-type dispatch-type dispatchable-overload-types-seq) + :form + (if (= dispatch-type :direct) + (>direct-dispatch|reify-call caller|node caller|type + (first dispatchable-overload-types-seq) + (uc/lmap :form input-nodes)) + (list* (:form caller|node) (uc/lmap :form input-nodes)))))) (update ret :input-nodes conj input|analyzed))) {:input-nodes [] ;; We could do a little smarter analysis here but we'll keep it simple for now From ae6b197f5e7f0edef7783ebdc5c5e94871bcd97f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 9 Nov 2018 22:42:08 -0700 Subject: [PATCH 672/810] `inline` appears to work!! --- resources-dev/defnt.cljc | 13 +- src-untyped/quantum/untyped/core/analyze.cljc | 124 ++++---- src-untyped/quantum/untyped/core/defnt.cljc | 43 +-- .../quantum/untyped/core/type/compare.cljc | 2 +- .../quantum/untyped/core/type/defnt.cljc | 269 ++++++++++-------- src/quantum/core/type.cljc | 3 + 6 files changed, 255 insertions(+), 199 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 73d2bc62..ac350d16 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -58,11 +58,10 @@ Legend: - [!] : refused - TODO implement the following: - [1] Direct dispatch needs to actually work correctly in typed contexts - [3] ^:inline - - should be able to mark either ^:unline or ^{:inline false} on arities of an inline function + [1] ^:inline - if you do (Numeric/bitAnd a b) inline then bitAnd needs to know the primitive type so maybe we do the `let*`-binding approach to typing vars? + - `let*` the vars but make it so it can auto-replace if it's just a symbol to symbol mapping - A good example of inlining: (t/def empty?|rf (fn/aritoid @@ -119,9 +118,10 @@ Legend: - In CLJS via e.g.: - `(js/Object.getOwnPropertyNames (fn ([]) ([a])))` -> `#js [... \"cljs$core$IFn$_invoke$arity$0\" \"cljs$core$IFn$_invoke$arity$1\"]` - - We should probably have a 'normal form' so we can correctly hash if we do spec lookup - - `or` and `and` should be `=` regardless of order - - To fix this, sort when it's created? (order by `t/compare` descending) + - We should probably use DNF (https://en.wikipedia.org/wiki/Disjunctive_normal_form) with sorted + arguments (on creation, order by `t/compare` descending) so we can correctly hash if we do + spec lookup, and so we can split more correctly, and so we can perform faster equality checks + - (t/and (t/or a b) c) should -> (t/or (t/and a c) (t/and b c)) - `(or (and pred then) (and (not pred) else))` (which is not correct) - needs to equal `(t/and (t/or (t/not a) b) (t/or a c))` (which is correct) - `(- (or ?!+vector? !vector? #?(:clj !!vector?)) (isa? clojure.lang.Counted))` is not right @@ -248,7 +248,6 @@ Legend: [ ] t/defn- - Not just a private var for the dynamic dispatch, but needs to be private for purposes of the analyzer when doing direct dispatch. Should emit a warning, not just fail. - [ ] (t/and (t/or a b) c) should -> (t/or (t/and a c) (t/and b c)) for purposes of type-splitting [ ] handle varargs / variadic arity - [& args _] shouldn't result in `t/any?` but rather like `t/reducible?` or whatever - should configurably auto-generate arities and/or perform variadic proxying diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 22b50f01..e8e134d8 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -668,19 +668,6 @@ ;; no need (apply t/or)))) -(def direct-dispatch-method-sym 'invoke) - -(defns- overload-type-datum>reify-name [type-datum _, fn|name symbol? > qualified-symbol?] - (symbol (-> type-datum :ns-name name) (str (name fn|name) "|__" (:id type-datum)))) - -(defns- >direct-dispatch|reify-call - [caller|node uast/node?, caller|type _, type-datum _, args-codelist (us/seq-of t/any?)] - (if-let [fn|name (utr/fn-type>name caller|type)] - `(. ~(overload-type-datum>reify-name type-datum fn|name) - ~direct-dispatch-method-sym ~@args-codelist) - (err! "No name found for typed fn corresponding to caller; cannot create direct dispatch call" - (assoc (select-keys caller|node [:unanalyzed-form :form]) :type caller|type)))) - (defns- caller>overload-type-data-for-arity [env ::env, caller|node uast/node?, caller|type _, inputs-ct _] (if-let [fn|name (utr/fn-type>name caller|type)] @@ -697,30 +684,50 @@ (err! "No name found for typed fn corresponding to caller" (assoc (select-keys caller|node [:unanalyzed-form :form]) :type caller|type)))) -(defns- update-call-data-with-fnt-dispatch|empty-args - [env ::env, caller|node uast/node?, caller|type _, caller-kind _, inputs-ct _, args-form _] +(def direct-dispatch-method-sym 'invoke) + +(defns- overload-type-datum>reify-name [type-datum _, fn|name symbol? > qualified-symbol?] + (symbol (-> type-datum :ns-name name) (str (name fn|name) "|__" (:id type-datum)))) + +(defns- >direct-dispatch|reify-call + [caller|node uast/node?, caller|type _, type-datum _, args-codelist (us/seq-of t/any?)] + (if-let [fn|name (utr/fn-type>name caller|type)] + `(. ~(overload-type-datum>reify-name type-datum fn|name) + ~direct-dispatch-method-sym ~@args-codelist) + (err! "No name found for typed fn corresponding to caller; cannot create direct dispatch call" + (assoc (select-keys caller|node [:unanalyzed-form :form]) :type caller|type)))) + +(defns- >direct-dispatch + [env ::env, {:as overload-type-datum :keys [arglist-code|hinted _, body-codelist _, inline? _]} _ + caller|node uast/node?, caller|type _, input-nodes (us/vec-of uast/node?)] + (if inline? + (analyze* env (list* 'let* (reducei (fn [bindings to i|arg] + (let [from (-> input-nodes (get i|arg) :form)] + (conj bindings to from))) + [] arglist-code|hinted) + body-codelist)) + {:input-nodes input-nodes + :form (>direct-dispatch|reify-call + caller|node caller|type overload-type-datum (uc/map :form input-nodes)) + :type (:output-type overload-type-datum)})) + +(defns- >call-data-with-fnt-dispatch|empty-args + [env ::env, caller|node uast/node?, caller|type _, caller-kind _] (if (= :fnt caller-kind) (if-not-let [overload-type-datum - (first (caller>overload-type-data-for-arity - env caller|node caller|type inputs-ct))] + (first (caller>overload-type-data-for-arity env caller|node caller|type 0))] (err! (str "No overloads satisfy the inputs via direct dispatch; " "dynamic dispatch not requested") {:caller (assoc (select-keys caller|node [:unanalyzed-form :form]) :type caller|type) - :inputs args-form}) - {:input-nodes [] - :output-type (:output-type overload-type-datum) - :form (>direct-dispatch|reify-call caller|node caller|type overload-type-datum [])}) + :inputs []}) + (>direct-dispatch env overload-type-datum caller|node caller|type [])) ;; We could do a little smarter analysis here but we'll keep it simple for now - {:input-nodes [] :output-type t/any? :form (list (:form caller|node))})) + {:form (list (:form caller|node)) :input-nodes [] :type t/any?})) -(defns- update-call-data-with-fnt-dispatch - [env ::env, caller|node uast/node?, caller|type _, caller-kind _, inputs-ct _, args-form _ - > (us/kv {:input-nodes t/any? #_(us/seq-of uast/node?) - :output-type t/type? - :form t/any?})] +(defns- >call-data-with-fnt-dispatch + [env ::env, caller|node uast/node?, caller|type _, caller-kind _, inputs-ct _, args-form _] (if (zero? inputs-ct) - (update-call-data-with-fnt-dispatch|empty-args - env caller|node caller|type caller-kind inputs-ct args-form) + (>call-data-with-fnt-dispatch|empty-args env caller|node caller|type caller-kind) (->> args-form (uc/map+ #(analyze* env %)) (reducei @@ -732,28 +739,27 @@ ret input|analyzed i caller|node args-form) :dynamic (filter-dynamic-dispatchable-overload-types ret input|analyzed i caller|node args-form)) - (update :input-nodes conj input|analyzed)) - last-input? (= i (dec inputs-ct))] - (cond-> ret' last-input? - (assoc - :output-type - (>dispatch|output-type dispatch-type dispatchable-overload-types-seq) - :form - (if (= dispatch-type :direct) - (>direct-dispatch|reify-call caller|node caller|type - (first dispatchable-overload-types-seq) - (uc/lmap :form input-nodes)) - (list* (:form caller|node) (uc/lmap :form input-nodes)))))) + (update :input-nodes conj input|analyzed))] + (if-let [last-input? (= i (dec inputs-ct))] + (if (= dispatch-type :direct) + (>direct-dispatch env (first dispatchable-overload-types-seq) + caller|node caller|type input-nodes) + (-> ret' + (assoc :form (list* (:form caller|node) (uc/lmap :form input-nodes)) + :type (>dispatch|output-type dispatch-type + dispatchable-overload-types-seq)) + (dissoc :caller|node :dispatch-type + :dispatchable-overload-types-seq))) + ret')) (update ret :input-nodes conj input|analyzed))) {:input-nodes [] ;; We could do a little smarter analysis here but we'll keep it simple for now - :output-type (when-not (= :fnt caller-kind) t/any?) + :type (when-not (= :fnt caller-kind) t/any?) :caller|node caller|node :dispatch-type :direct :dispatchable-overload-types-seq (when (= :fnt caller-kind) - (caller>overload-type-data-for-arity env caller|node caller|type inputs-ct))}) - (<- (dissoc :caller|node :dispatch-type :dispatchable-overload-types-seq))))) + (caller>overload-type-data-for-arity env caller|node caller|type inputs-ct))})))) (defns- analyze-seq|dependent-type-call [env ::env, [caller|form _, & args-form _ :as form] _ > uast/node?] @@ -863,20 +869,21 @@ {:inputs-ct inputs-ct :caller caller|node})) ;; TODO use the `reflect/reflect` and `js/Object.getOwnPropertyNames` trick :fn nil) - {:keys [input-nodes output-type] analyzed-form :form} - (update-call-data-with-fnt-dispatch - env caller|node caller|type caller-kind inputs-ct args-form) - output-type' - (if (-> env :opts :arglist-context?) - (handle-type-combinators caller|node input-nodes output-type) - output-type)] - (uast/call-node - {:env env - :unanalyzed-form form - :form analyzed-form - :caller caller|node - :args input-nodes - :type output-type'}))))) + {:as call-data :keys [input-nodes] analyzed-form :form} + (>call-data-with-fnt-dispatch + env caller|node caller|type caller-kind inputs-ct args-form)] + (if (uast/node? call-data) ; in the case of an inline expansion + call-data + (uast/call-node + {:env env + :unanalyzed-form form + :form analyzed-form + :caller caller|node + :args input-nodes + :type (if (-> env :opts :arglist-context?) + (handle-type-combinators + caller|node input-nodes (:type call-data)) + (:type call-data))})))))) (defns- analyze-seq* "Analyze a seq after it has been macro-expanded. @@ -920,7 +927,6 @@ (let [expanded-form' (cond-> expanded-form (uvar/with-metable? expanded-form) (update-meta merge (meta form))) expanded (analyze* env expanded-form')] - (pr! (kw-map form expanded-form' (:form expanded))) (uast/macro-call {:env env :unexpanded-form form diff --git a/src-untyped/quantum/untyped/core/defnt.cljc b/src-untyped/quantum/untyped/core/defnt.cljc index 44b5f5e1..13714850 100644 --- a/src-untyped/quantum/untyped/core/defnt.cljc +++ b/src-untyped/quantum/untyped/core/defnt.cljc @@ -15,6 +15,7 @@ [quantum.untyped.core.loops :refer [reduce-2]] [quantum.untyped.core.reducers :as ur] + [quantum.untyped.core.refs :as uref] [quantum.untyped.core.spec :as us] [quantum.untyped.core.specs :as uss]) #?(:cljs @@ -88,25 +89,29 @@ (s/? (s/cat :sym #(= % '>) :spec :quantum.core.defnt/spec))) (s/def :quantum.core.defnt/arglist - (s/and vector? - (s/spec - (s/cat :args (s/* :quantum.core.defnt/speced-binding) - :varargs (s/? (s/cat :sym #(= % '&) - :speced-binding :quantum.core.defnt/speced-binding)) - :pre (s/? (s/cat :sym #(= % '|) - :spec (s/or :any-spec #{'_} :spec any?))) - :post :quantum.core.defnt/output-spec)) - (s/conformer - #(cond-> % (nil? (:args %)) (assoc :args []) - (contains? % :varargs) (update :varargs :speced-binding) - (contains? % :pre ) (update :pre :spec) - (contains? % :post ) (update :post :spec))) - (fn [{:keys [args varargs]}] - ;; so `env` in `fnt` can work properly in the analysis - ;; TODO need to adjust for destructuring - (distinct? - (concat (map :binding-form args) - [(:binding-form varargs)]))))) + (let [!meta (uref/>!thread-local nil)] ; a dirty hack till clojure.spec preserves meta + (s/and vector? + (fn [arglist] (uref/set! !meta (meta arglist)) true) + (s/spec + (s/cat :args (s/* :quantum.core.defnt/speced-binding) + :varargs (s/? (s/cat :sym #(= % '&) + :speced-binding :quantum.core.defnt/speced-binding)) + :pre (s/? (s/cat :sym #(= % '|) + :spec (s/or :any-spec #{'_} :spec any?))) + :post :quantum.core.defnt/output-spec)) + (s/conformer + #(-> % + (with-meta (uref/get !meta)) + (cond-> (nil? (:args %)) (assoc :args []) + (contains? % :varargs) (update :varargs :speced-binding) + (contains? % :pre ) (update :pre :spec) + (contains? % :post ) (update :post :spec)))) + (fn [{:keys [args varargs]}] + ;; so `env` in `fnt` can work properly in the analysis + ;; TODO need to adjust for destructuring + (distinct? + (concat (map :binding-form args) + [(:binding-form varargs)])))))) (s/def :quantum.core.defnt/body (s/alt :body (s/* any?))) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index eb94896b..3aefe4b6 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -462,7 +462,7 @@ Does not compare cardinalities or other relations of sets, but rather only sub/superset relations." [t0 type?, t1 type? > comparison?] - (if (identical? t0 t1) + (if (c/= t0 t1) =ident (let [dispatched (-> compare|dispatch (get (type t0)) (get (type t1)))] (if (nil? dispatched) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 872615f2..4a2ad10e 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -104,6 +104,7 @@ ;; "global" because they apply to the whole `t/fn` (us/def ::fn|globals (us/kv {:fn|globals-name simple-symbol? + :fn|inline? boolean? :fn|meta (us/nilable :quantum.core.specs/meta) :fn|ns-name simple-symbol? :fn|name ::uss/fn|name @@ -124,7 +125,8 @@ :types|split (us/nilable ::overload-basis|types|split) :body-codelist (us/vec-of t/any?) :dependent? boolean? - :reactive? boolean?})) + :reactive? boolean? + :inline? boolean?})) (us/def ::overload-basis (us/kv {:ns simple-symbol? @@ -138,7 +140,8 @@ :types|split (us/nilable ::overload-basis|types|split) :body-codelist (us/vec-of t/any?) :dependent? boolean? - :reactive? boolean?})) + :reactive? boolean? + :inline? boolean?})) (us/def ::overload-bases-data (us/kv {:prev-norx (us/nilable (us/vec-of ::overload-basis|norx)) @@ -147,14 +150,19 @@ ;; Technically it's partially analyzed — its type definitions are analyzed (with the exception of ;; requests for type inference) while its body is not. (us/def ::unanalyzed-overload - (us/kv {:arglist-form|unanalyzed t/any? - :args-form map? ; from binding to form - :varargs-vorm (us/nilable map?) ; from binding to form - :arg-types (us/vec-of t/type?) - :output-type|form t/any? - :output-type t/type? - :body-codelist t/any? - :i|basis index?})) + (us/kv {:arg-classes (us/vec-of class?) + :arg-types (us/vec-of t/type?) + :arglist-code|hinted (us/vec-of simple-symbol?) + :arglist-code|reify|unhinted (us/vec-of simple-symbol?) + :arglist-form|unanalyzed t/any? + :args-form map? ; from binding to form + :varargs-vorm (us/nilable map?) ; from binding to form + :output-type|form t/any? + :output-type t/type? + :pre-type (us/nilable t/type?) + :body-codelist (us/vec-of t/any?) + :i|basis index? + :inline? boolean?})) ;; This is the overload after the input specs are split by their respective `t/or` constituents, ;; and after primitivization, but before readiness for incorporation into a `reify`. @@ -163,8 +171,9 @@ (us/kv {:arg-classes (us/vec-of class?) :arg-types (us/vec-of t/type?) :arglist-form|unanalyzed t/any? - :arglist-code|fn|hinted t/any? - :arglist-code|reify|unhinted t/any? + :arglist-code|fn|hinted (us/vec-of simple-symbol?) + :arglist-code|hinted (us/vec-of simple-symbol?) + :arglist-code|reify|unhinted (us/vec-of simple-symbol?) :body-form t/any? :output-class (us/nilable class?) :output-type t/type? @@ -200,11 +209,14 @@ :output-type t/type?})) (us/def ::types-decl-datum - (us/kv {:id ::overload|id - :ns-name simple-symbol? - :arg-types (us/vec-of t/type?) - :output-type t/type? - :index index?})) ; overload-index (position in the overall types-decl) + (us/kv {:id ::overload|id + :index index? ; overload-index (position in the overall types-decl) + :ns-name simple-symbol? + :arglist-code|hinted (us/vec-of simple-symbol?) + :arg-types (us/vec-of t/type?) + :output-type t/type? + :body-codelist (us/vec-of t/any?) + :inline? boolean?})) (us/def ::fn|types (us/kv {:fn|output-type-norx t/type? @@ -303,8 +315,9 @@ {:as fn|globals :keys [fn|globals-name _, fn|name _, fn|ns-name _, fn|output-type _ fn|overload-types-name _]} ::fn|globals {:as unanalyzed-overload - :keys [arglist-form|unanalyzed _, args-form _, varargs-form _, arg-types _, - output-type|form _, body-codelist _] + :keys [arg-classes _, arg-types _, arglist-code|hinted _, arglist-code|reify|unhinted _, + arglist-form|unanalyzed _, args-form _, body-codelist _ output-type|form _ + varargs-form _, variadic? _] declared-output-type [:output-type _]} ::unanalyzed-overload overload|id index? @@ -314,48 +327,42 @@ (let [;; Not sure if `nil` is the right approach for the value recursive-ast-node-reference (when-not (= kind :extend-defn!) (uast/symbol {} fn|name nil fn|type)) - env (->> (zipmap (keys args-form) arg-types) - (uc/map' (c/fn [[arg-binding arg-type]] - [arg-binding (uast/unbound nil arg-binding arg-type)])) - ;; To support recursion - (<- (cond-> (not= kind :extend-defn!) - (assoc fn|name - recursive-ast-node-reference - (uid/qualify fn|ns-name fn|overload-types-name) - fn|overload-types)))) - variadic? (not (empty? varargs-form)) - arg-classes (->> arg-types (uc/map type>class)) - body-node (uana/analyze env (ufgen/?wrap-do body-codelist)) - hint-arg|fn (c/fn [i arg-binding] - (ufth/with-type-hint arg-binding - (ufth/>fn-arglist-tag - (uc/get arg-classes i) - lang - (uc/count args-form) - variadic?))) - output-type (with-validate-output-type declared-output-type body-node) + env (->> (zipmap (keys args-form) arg-types) + (uc/map' (c/fn [[arg-binding arg-type]] + [arg-binding (uast/unbound nil arg-binding arg-type)])) + ;; To support recursion + (<- (cond-> (not= kind :extend-defn!) + (assoc fn|name + recursive-ast-node-reference + (uid/qualify fn|ns-name fn|overload-types-name) + fn|overload-types)))) + body-node (uana/analyze env (ufgen/?wrap-do body-codelist)) + hint-arg|fn (c/fn [i arg-binding] + (ufth/with-type-hint arg-binding + (ufth/>fn-arglist-tag + (uc/get arg-classes i) + lang + (uc/count args-form) + variadic?))) + output-type (with-validate-output-type declared-output-type body-node) + output-class (type>class output-type) body-form - (-> (:form body-node) - (cond-> (-> output-type meta :quantum.core.type/runtime?) - ;; TODO here the output type is being re-created each time (unless the fn's overall - ;; output type is being preferred) because it could reference inputs, but we - ;; should probably analyze to determine whether it references inputs so we can, - ;; in the 90% case, extern the output type - (>with-runtime-output-type - (or output-type|form - `(?norx-deref (:fn|output-type ~(uid/qualify fn|ns-name fn|globals-name)))))))] - {:arglist-form|unanalyzed arglist-form|unanalyzed - :arg-classes arg-classes - :arg-types arg-types - :arglist-code|fn|hinted (cond-> (->> args-form keys (uc/map-indexed hint-arg|fn)) - variadic? (conj '& (-> varargs-form keys first))) - :arglist-code|reify|unhinted (cond-> (-> args-form keys vec) - variadic? (conj (-> varargs-form keys first))) - :body-form body-form - :positional-args-ct (count args-form) - :output-type output-type - :output-class (type>class output-type) - :variadic? variadic?}))) + (-> (:form body-node) + (cond-> (-> output-type meta :quantum.core.type/runtime?) + ;; TODO here the output type is being re-created each time (unless the fn's overall + ;; output type is being preferred) because it could reference inputs, but we + ;; should probably analyze to determine whether it references inputs so we can, + ;; in the 90% case, extern the output type + (>with-runtime-output-type + (or output-type|form + `(?norx-deref (:fn|output-type ~(uid/qualify fn|ns-name fn|globals-name))))))) + positional-args-ct (count args-form) + arglist-code|fn|hinted + (cond-> (->> args-form keys (uc/map-indexed hint-arg|fn)) + variadic? (conj '& (-> varargs-form keys first)))] + (kw-map arglist-form|unanalyzed arg-classes arg-types arglist-code|fn|hinted + arglist-code|reify|unhinted arglist-code|hinted body-form positional-args-ct + output-type output-class variadic?)))) (defns- class>interface-part-name [c class? > string?] (if (= c java.lang.Object) @@ -453,9 +460,10 @@ (str "Overwriting type overload for `" (uid/qualify fn|ns-name fn|name) "`") {:arg-types-prev (:arg-types prev-datum) :arg-types (:arg-types datum)}) (-> data pop - (conj (assoc prev-datum :ns-name (:ns-name datum) - :overload (:overload datum) - :replacing-id (:id datum)))))))) + (conj (assoc datum :id (:id prev-datum) + :arg-types (:arg-types prev-datum) + :output-type (:output-type prev-datum) + :replacing-id (:id datum)))))))) (defns- >overload-types-decl|name ([fn|name simple-symbol?, overload|id ::overload|id > simple-symbol?] @@ -488,12 +496,13 @@ (uc/map+ (c/fn [{:keys [env output-type-node]}] (let [arg-env (->> env :opts :arg-env deref) arg-types (->> args-form keys (uc/map #(:type (get arg-env %)))) - output-type (:type output-type-node)] + output-type (:type output-type-node) + pre-type nil] ; TODO fix (when-not (t/<= output-type fn|output-type) (err! (str "Overload's declared output type does not satisfy function's" "overall declared output type") (kw-map output-type fn|output-type))) - (kw-map arg-types output-type)))))) + (kw-map arg-types output-type pre-type)))))) (defns- overload-basis|changed? [overload-basis ::overload-basis, prev-basis ::overload-basis|norx > boolean?] @@ -525,13 +534,40 @@ (->> arg-types|basis (uc/run! ?deref)) (?deref output-type|basis))))) +(defns- >unanalyzed-overload + [{:as basis :keys [args-form _, varargs-form _]} ::overload-basis + i|basis index? + type-datum ::type-datum + > ::unanalyzed-overload] + (let [variadic? (not (empty? varargs-form)) + arg-classes (->> type-datum :arg-types (uc/map type>class)) + arglist-code|reify|unhinted + (cond-> (-> args-form keys vec) + variadic? (conj (-> varargs-form keys first))) + arglist-code|hinted + (->> arglist-code|reify|unhinted + (uc/map-indexed + (c/fn [i|arg arg|form] + (ufth/with-type-hint arg|form + ;; `>body-embeddable-tag` because this will go in a `let*` + (-> arg-classes (uc/get i|arg) ufth/>body-embeddable-tag)))))] + (-> (select-keys basis + [:arglist-form|unanalyzed :args-form :body-codelist :inline? :output-type|form + :varargs-form]) + (merge type-datum) + (merge (kw-map arg-classes arglist-code|hinted arglist-code|reify|unhinted i|basis + variadic?))))) + (defns- >changed-unanalyzed-overloads - "A 'changed' overload here means either 1) an overload from an overload basis whose type signature - has changed, and after being split, does not have the same type signature as that of an existing - overload, 2) an overload from a newly declared overload basis whose type signature is unique for - the `t/defn` in question, or 3) an overload from a newly declared overload basis whose type - signature is the same as one that already exists for the `t/defn` in question (in which case its - implementation will overwrite the existing one). + "A 'changed' overload here means one of three things: + - An overload from an overload basis whose type signature has changed, and after being split, + does not have the same type signature as that of an existing overload + - An overload from an overload basis for which its body has changed and it is an inline overload + - An overload from a newly declared overload basis whose type signature is unique for the + `t/defn` in question + - An overload from a newly declared overload basis whose type signature is the same as one that + already exists for the `t/defn` in question (in which case its implementation will overwrite + the existing one). 'Cheaply' O(m•n) where `m` is the number split types resulting from changed overload bases, and `n` is the size of the existing overload types. 'Cheap' because only a `=` check is performed `n` @@ -562,11 +598,7 @@ (= (:body-codelist basis) (:body-codelist prev-basis))) (uc/remove+ type-signature-equal-to-existing?)) (uc/map+ (c/fn [type-datum] - (-> (select-keys basis - [:arglist-form|unanalyzed :args-form :body-codelist - :output-type|form :varargs-form]) - (merge type-datum) - (assoc :i|basis i|basis)))))))))) + (>unanalyzed-overload basis i|basis type-datum))))))))) (uc/filter+ identity) uc/cat))) @@ -620,11 +652,11 @@ sorted-changed-overload-types (->> sorted-changed-unanalyzed-overloads (uc/map-indexed - (c/fn [i {:keys [arg-types output-type]}] - {:id (+ i first-current-overload-id) - :ns-name (ns-name *ns*) - :arg-types arg-types - :output-type output-type}))) + (c/fn [i {:keys [arg-types output-type body-codelist arglist-code|hinted + inline?]}] + (-> (kw-map arg-types output-type arglist-code|hinted body-codelist inline?) + (assoc :id (+ i first-current-overload-id) + :ns-name (ns-name *ns*)))))) ;; We need to maintain the `overload-types` ordering by type-specificity so the dynamic ;; dispatch and fn-type work correctly. overload-types-with-replacing-ids @@ -665,8 +697,9 @@ (let [overload (get sorted-changed-overloads (- id first-current-overload-id))] ;; So that direct dispatch can use them later on in the pipeline - (uvec/alist-conj! !overload-queue (assoc datum :overload overload))))) - (dissoc datum :replacing-id))))] + (uvec/alist-conj! !overload-queue + (assoc datum :overload overload)))) + (dissoc datum :replacing-id)))))] (kw-map fn|output-type-norx fn|type-norx overload-types))))) ;; ----- Direct dispatch ----- ;; @@ -763,7 +796,9 @@ fn|meta' (merge fn|meta {:quantum.core.type/type (uid/qualify fn|ns-name fn|type-name)}) overload-types|form (when (= compilation-mode :test) - (->> !fn|types norx-deref :overload-types >form (uc/map (fn1 dissoc :ns-name))))] + (->> !fn|types norx-deref :overload-types >form + (uc/map (c/fn [{:keys [id index inline? arg-types output-type]}] + [id index inline? arg-types output-type]))))] ;; TODO determine whether CLJS needs (update-in m [:jsdoc] conj "@param {...*} var_args") (if (= kind :extend-defn!) [overload-types|form @@ -780,9 +815,11 @@ (defns- overload-basis-form>overload-basis [opts ::opts - {:as fn|globals :keys [fn|output-type _, fn|output-type _, fn|output-type|form _]} ::fn|globals + {:as fn|globals + :keys [fn|inline? _, fn|output-type _, fn|output-type _, fn|output-type|form _]} ::fn|globals {:as overload-basis-form - {args [:args _] + {:as arglist-form + args [:args _] varargs [:varargs _] pre-type|form [:pre _] [_ _, output-type|form _] [:post _]} [:arglist _] @@ -812,7 +849,9 @@ output-type|basis (-> arglist-basis :output-type-node :type) dependent? (:dependent? arglist-basis) reactive? (or (utr/rx-type? output-type|basis) - (seq-or utr/rx-type? arg-types|basis))] + (seq-or utr/rx-type? arg-types|basis)) + inline? (or (and fn|inline? (-> arglist-form meta :unline? not)) + (-> arglist-form meta :inline?))] {:ns (>symbol *ns*) ;; TODO Only needed if `dependent?` or if new :args-form args-form @@ -837,7 +876,8 @@ ;; TODO Only needed if `inline? or `reactive?`, or if new :body-codelist body-codelist|unanalyzed :dependent? dependent? - :reactive? reactive?})) + :reactive? reactive? + :inline? inline?})) ;; ===== Reactive auxiliary vars ===== ;; @@ -1002,26 +1042,22 @@ (if (= kind :extend-defn!) {:fn|globals (-> (uid/qualify fn|ns-name fn|globals-name) resolve var-get) :overload-bases-form overload-bases-form} - (let [inline? (-> (if (= kind :extend-defn!) - (-> fn|var meta :inline) - (:inline fn|meta)) - (us/validate (t/? t/boolean?))) - fn|meta (if inline? - (do (ulog/pr :warn - "requested `:inline`; ignoring until feature is implemented") - (dissoc fn|meta :inline)) - fn|meta) - fn|output-type|form (or (second output-spec) `t/any?) - ;; TODO this needs to be analyzed for dependent types referring to local vars - fn|output-type (eval fn|output-type|form) - fn|overload-bases-name (symbol (str fn|name "|__bases")) - fn|overload-types-name (symbol (str fn|name "|__types")) - fn|type-name (symbol (str fn|name "|__type")) - fn|globals - (kw-map fn|globals-name fn|meta fn|name fn|ns-name fn|output-type|form - fn|output-type fn|overload-bases-name fn|overload-types-name fn|type-name)] - (intern fn|ns-name fn|globals-name fn|globals) - (kw-map fn|globals overload-bases-form))))) + (let [fn|inline? (if (nil? (:inline fn|meta)) + false + (us/validate (:inline fn|meta) t/boolean?)) + fn|meta (dissoc fn|meta :inline) + fn|output-type|form (or (second output-spec) `t/any?) + ;; TODO this needs to be analyzed for dependent types referring to local vars + fn|output-type (eval fn|output-type|form) + fn|overload-bases-name (symbol (str fn|name "|__bases")) + fn|overload-types-name (symbol (str fn|name "|__types")) + fn|type-name (symbol (str fn|name "|__type")) + fn|globals + (kw-map fn|globals-name fn|inline? fn|meta fn|name fn|ns-name fn|output-type|form + fn|output-type fn|overload-bases-name fn|overload-types-name + fn|type-name)] + (intern fn|ns-name fn|globals-name fn|globals) + (kw-map fn|globals overload-bases-form))))) ;; ===== Whole `t/(de)fn` creation ===== ;; @@ -1096,13 +1132,20 @@ Metadata directives special to `t/fn`/`t/defn` include: - `:inline` : If `true` and attached as metadata to the arglist of an overload, will cause that - overload to be inlined if possible. - - Example: `(t/defn abc (^:inline [] ...))` + overload to be inlined if possible: + - `(t/defn abc (^:inline [] ...))` If `true` and attached as metadata to the whole `t/defn` or `t/fn`, will cause every one of its overloads to be inlined if possible. Overloads added to a `t/defn` - with `:inline` `true` will inherit this inline directive. - - Example: `(t/defn ^:inline abc ([] ...) ([...] ...))` - Note that inlining is possible only in typed contexts. + with `:inline` `true` will inherit this inline directive unless `:inline` is false + for the overload or `:unline` is true: + - `(t/defn ^:inline abc ([] ...) ([...] ...))` + - `(t/defn ^:inline abc (^{:inline false} [] ...) ([...] ...))` + - `(t/defn ^:inline abc ([] ...) (^:unline [...] ...))` + Note: + - Inlining is possible only in typed contexts. + - If the metadata for an overload changes via `extend-defn!` from designating it as + inline to designating it as non-inline, or vice versa, unexpected behavior may + occur. `t/fn` only works fully in contexts in which the metalanguage (compiler language) is the same as the object language. Otherwise, while the compiler could still analyze types symbolically to an diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index deb6afde..c54bb187 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -3,6 +3,7 @@ (:refer-clojure :exclude [* - < <= = >= > and any? defn fn fn? isa? not or ref seq? symbol? type var?]) (:require + [quantum.untyped.core.analyze :as uana] [quantum.untyped.core.type.defnt :as udefnt] [quantum.untyped.core.type :as ut] ;; TODO TYPED prefer e.g. `deft-alias` @@ -64,3 +65,5 @@ ;; TODO TYPED move #_(:clj (defalias false? core/false?)) + +#?(:clj (defmacro dotyped [& args] (-> `(do ~@args) uana/analyze :form))) From 9484611bb9622da5d84d65b22b17f9d169724db1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 9 Nov 2018 23:47:23 -0700 Subject: [PATCH 673/810] A few inline tests --- .../quantum/test/untyped/core/type/defnt.cljc | 145 +++++++++--------- 1 file changed, 72 insertions(+), 73 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 1ec62a06..147f66a4 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1,8 +1,10 @@ (ns quantum.test.untyped.core.type.defnt (:refer-clojure :exclude - [> count get name seq some? zero?]) + [> count get identity name seq some? zero?]) (:require [clojure.core :as core] + [quantum.core.type + :refer [dotyped]] [quantum.test.untyped.core.type :as tt] [quantum.untyped.core.type.defnt :as self :refer [unsupported!]] @@ -80,80 +82,80 @@ ;; TODO test `:inline` -(deftest test|identity|uninlined +(deftest test|identity (let [actual (binding [self/*compilation-mode* :test] (macroexpand ' - (self/defn identity|uninlined ([x t/any? > (t/type x)] x)))) + (self/defn ^:inline identity ([x t/any? > (t/type x) #_"TODO TYPED (t/== x)"] x)))) expected (case (env-lang) :clj - ($ (do (declare ~'identity|uninlined) + ($ (do (declare ~'identity) ;; [x t/any?] - (def ~(tag (cstr `boolean>boolean) 'identity|uninlined|__0) + (def ~(tag (cstr `boolean>boolean) 'identity|__0) (reify* [boolean>boolean] (~(B 'invoke) [~'_0__ ~(B 'x)] ~'x))) - (def ~(tag (cstr `byte>byte) 'identity|uninlined|__1) + (def ~(tag (cstr `byte>byte) 'identity|__1) (reify* [byte>byte] (~(Y 'invoke) [~'_1__ ~(Y 'x)] ~'x))) - (def ~(tag (cstr `short>short) 'identity|uninlined|__2) + (def ~(tag (cstr `short>short) 'identity|__2) (reify* [short>short] (~(S 'invoke) [~'_2__ ~(S 'x)] ~'x))) - (def ~(tag (cstr `char>char) 'identity|uninlined|__3) + (def ~(tag (cstr `char>char) 'identity|__3) (reify* [char>char] (~(C 'invoke) [~'_3__ ~(C 'x)] ~'x))) - (def ~(tag (cstr `int>int) 'identity|uninlined|__4) + (def ~(tag (cstr `int>int) 'identity|__4) (reify* [int>int] (~(I 'invoke) [~'_4__ ~(I 'x)] ~'x))) - (def ~(tag (cstr `long>long) 'identity|uninlined|__5) + (def ~(tag (cstr `long>long) 'identity|__5) (reify* [long>long] (~(L 'invoke) [~'_5__ ~(L 'x)] ~'x))) - (def ~(tag (cstr `float>float) 'identity|uninlined|__6) + (def ~(tag (cstr `float>float) 'identity|__6) (reify* [float>float] (~(F 'invoke) [~'_6__ ~(F 'x)] ~'x))) - (def ~(tag (cstr `double>double) 'identity|uninlined|__7) + (def ~(tag (cstr `double>double) 'identity|__7) (reify* [double>double] (~(D 'invoke) [~'_7__ ~(D 'x)] ~'x))) - (def ~(tag (cstr `Object>Object) 'identity|uninlined|__8) + (def ~(tag (cstr `Object>Object) 'identity|__8) (reify* [Object>Object] (~(O 'invoke) [~'_8__ ~(O 'x)] ~(O 'x)))) - [{:id 0 :index 0 :arg-types [(t/isa? Boolean)] :output-type (t/isa? Boolean)} - {:id 1 :index 1 :arg-types [(t/isa? Byte)] :output-type (t/isa? Byte)} - {:id 2 :index 2 :arg-types [(t/isa? Short)] :output-type (t/isa? Short)} - {:id 3 :index 3 :arg-types [(t/isa? Character)] :output-type (t/isa? Character)} - {:id 4 :index 4 :arg-types [(t/isa? Integer)] :output-type (t/isa? Integer)} - {:id 5 :index 5 :arg-types [(t/isa? Long)] :output-type (t/isa? Long)} - {:id 6 :index 6 :arg-types [(t/isa? Float)] :output-type (t/isa? Float)} - {:id 7 :index 7 :arg-types [(t/isa? Double)] :output-type (t/isa? Double)} - {:id 8 :index 8 :arg-types [t/any?] :output-type t/any?}] - - (defmeta ~'identity|uninlined - {:quantum.core.type/type identity|uninlined|__type} + [[0 0 true [(t/isa? Boolean)] (t/isa? Boolean)] + [1 1 true [(t/isa? Byte)] (t/isa? Byte)] + [2 2 true [(t/isa? Short)] (t/isa? Short)] + [3 3 true [(t/isa? Character)] (t/isa? Character)] + [4 4 true [(t/isa? Integer)] (t/isa? Integer)] + [5 5 true [(t/isa? Long)] (t/isa? Long)] + [6 6 true [(t/isa? Float)] (t/isa? Float)] + [7 7 true [(t/isa? Double)] (t/isa? Double)] + [8 8 true [t/any?] t/any?]] + + (defmeta ~'identity + {:quantum.core.type/type identity|__type} (fn* ([~'x00__] (ifs - ((Array/get identity|uninlined|__0|types 0) ~'x00__) - (. identity|uninlined|__0 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__1|types 0) ~'x00__) - (. identity|uninlined|__1 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__2|types 0) ~'x00__) - (. identity|uninlined|__2 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__3|types 0) ~'x00__) - (. identity|uninlined|__3 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__4|types 0) ~'x00__) - (. identity|uninlined|__4 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__5|types 0) ~'x00__) - (. identity|uninlined|__5 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__6|types 0) ~'x00__) - (. identity|uninlined|__6 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__7|types 0) ~'x00__) - (. identity|uninlined|__7 ~'invoke ~'x00__) - ((Array/get identity|uninlined|__8|types 0) ~'x00__) - (. identity|uninlined|__8 ~'invoke ~'x00__) + ((Array/get identity|__0|types 0) ~'x00__) + (. identity|__0 ~'invoke ~'x00__) + ((Array/get identity|__1|types 0) ~'x00__) + (. identity|__1 ~'invoke ~'x00__) + ((Array/get identity|__2|types 0) ~'x00__) + (. identity|__2 ~'invoke ~'x00__) + ((Array/get identity|__3|types 0) ~'x00__) + (. identity|__3 ~'invoke ~'x00__) + ((Array/get identity|__4|types 0) ~'x00__) + (. identity|__4 ~'invoke ~'x00__) + ((Array/get identity|__5|types 0) ~'x00__) + (. identity|__5 ~'invoke ~'x00__) + ((Array/get identity|__6|types 0) ~'x00__) + (. identity|__6 ~'invoke ~'x00__) + ((Array/get identity|__7|types 0) ~'x00__) + (. identity|__7 ~'invoke ~'x00__) + ((Array/get identity|__8|types 0) ~'x00__) + (. identity|__8 ~'invoke ~'x00__) ;; TODO no need for `unsupported!` because it will always get a valid ;; branch - (unsupported! `identity|uninlined [~'x00__] 0))))))) + (unsupported! `identity [~'x00__] 0))))))) :cljs ;; Direct dispatch will be simple functions, not `reify`s - ($ (do (defn ~'identity|uninlined [~'x] ~'x))))] + ($ (do (defn ~'identity [~'x] ~'x))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) - (eval '(do (is= (identity|uninlined 1) (identity 1)) - (is= (identity|uninlined "") (identity ""))))))) + (eval '(do (is= (identity 1) (dotyped (identity 1)) (core/identity 1)) + (is= (identity "") (dotyped (identity "")) (core/identity ""))))))) (deftest test|name (let [actual @@ -928,7 +930,7 @@ (let [actual (binding [self/*compilation-mode* :test] (macroexpand ' - (self/defn #_:inline >long* + (self/defn ^:inline >long* {:source "clojure.lang.RT.uncheckedLongCast"} > tt/long? ([x (t/- tt/primitive? tt/boolean?)] (Primitive/uncheckedLongCast x)) @@ -975,15 +977,14 @@ (~(L 'invoke) [~'_7__ ~(O 'x)] (. ~(tag "java.lang.Number" 'x) ~'longValue)))) - [{:id 0 :index 0 :arg-types [(t/isa? Byte)] :output-type (t/isa? Long)} - {:id 1 :index 1 :arg-types [(t/isa? Short)] :output-type (t/isa? Long)} - {:id 2 :index 2 :arg-types [(t/isa? Character)] :output-type (t/isa? Long)} - {:id 3 :index 3 :arg-types [(t/isa? Integer)] :output-type (t/isa? Long)} - {:id 4 :index 4 :arg-types [(t/isa? Long)] :output-type (t/isa? Long)} - {:id 5 :index 5 :arg-types [(t/isa? Float)] :output-type (t/isa? Long)} - {:id 6 :index 6 :arg-types [(t/isa? Double)] :output-type (t/isa? Long)} - {:id 7 :index 7 :arg-types [(t/ref (t/isa? Number))] - :output-type (t/isa? Long)}] + [[0 0 true [(t/isa? Byte)] (t/isa? Long)] + [1 1 true [(t/isa? Short)] (t/isa? Long)] + [2 2 true [(t/isa? Character)] (t/isa? Long)] + [3 3 true [(t/isa? Integer)] (t/isa? Long)] + [4 4 true [(t/isa? Long)] (t/isa? Long)] + [5 5 true [(t/isa? Float)] (t/isa? Long)] + [6 6 true [(t/isa? Double)] (t/isa? Long)] + [7 7 true [(t/ref (t/isa? Number))] (t/isa? Long)]] (defmeta ~'>long* {:source "clojure.lang.RT.uncheckedLongCast" @@ -1044,10 +1045,8 @@ (def ~(tag (cstr `byte>Object) 'ref-output-type|__1) (reify* [byte>Object] (~(O 'invoke) [~'_1__ ~(Y 'x)] (new ~'Byte ~'x)))) - [{:id 0 :index 0 :arg-types [(t/isa? Boolean)] - :output-type (t/ref (t/isa? Boolean))} - {:id 1 :index 1 :arg-types [(t/isa? Byte)] - :output-type (t/ref (t/isa? Byte))}] + [[0 0 nil [(t/isa? Boolean)] (t/ref (t/isa? Boolean))] + [1 1 nil [(t/isa? Byte)] (t/ref (t/isa? Byte))]] (defmeta ~'ref-output-type {:quantum.core.type/type ref-output-type|__type} @@ -1088,7 +1087,7 @@ (.longValue x)) ;; FIXME it doesn't know what `>long-checked`'s type is i.e. what it ;; has defined so far - ([x tt/ratio?] (-> x >big-integer >long-checked)) + ([x tt/ratio?] 5 (-> x >big-integer >long-checked)) ([x (t/value true)] 1) ([x (t/value false)] 0) ([x t/string?] (Long/parseLong x)) @@ -1102,35 +1101,35 @@ (reify byte>long (~(L 'invoke) [_## ~(Y 'x)] ;; Resolved from `(>long* x)` - (.invoke >long*|__0 ~'x)))) + (. >long*|__0 invoke ~'x)))) - #_(def ~'>long|__1|input-types (*<> char?)) + #_(def ~'>long|__1|input-types (*<> short?)) (def ~'>long|__1 - (reify char>long + (reify short>long (~(L 'invoke) [_## ~(C 'x)] ;; Resolved from `(>long* x)` - (.invoke >long*|__1 ~'x)))) + (. >long*|__1 invoke ~'x)))) - #_(def ~'>long|__2|input-types (*<> short?)) + #_(def ~'>long|__2|input-types (*<> char?)) (def ~'>long|__2 - (reify short>long + (reify char>long (~(L 'invoke) [_## ~(S 'x)] ;; Resolved from `(>long* x)` - (.invoke >long*|__2 ~'x)))) + (. >long*|__2 invoke ~'x)))) #_(def ~'>long|__3|input-types (*<> tt/int?)) (def ~'>long|__3 (reify int>long (~(L 'invoke) [_## ~(I 'x)] ;; Resolved from `(>long* x)` - (.invoke >long*|__3 ~'x)))) + (. >long*|__3 invoke ~'x)))) #_(def ~'>long|__4|input-types (*<> tt/long?)) (def ~'>long|__4 (reify long>long (~(L 'invoke) [_## ~(L 'x)] ;; Resolved from `(>long* x)` - (.invoke >long*|__4 ~'x)))) + (. >long*|__4 invoke ~'x)))) #_[x (t/and (t/or double? float?) (t/fn [x (t/or double? float?)] @@ -1144,7 +1143,7 @@ (reify double>long (~(L 'invoke) [_## ~(D 'x)] ;; Resolved from `(>long* x)` - (.invoke >long*|__6 ~'x)))) + (. >long*|__6 invoke ~'x)))) #_(def ~'>long|__6|input-types (*<> (t/and t/float? @@ -1154,7 +1153,7 @@ (reify float>long (~(L 'invoke) [_## ~(F 'x)] ;; Resolved from `(>long* x)` - (.invoke >long*|__5 ~'x)))) + (. >long*|__6 invoke ~'x)))) #_[(t/and (t/isa? clojure.lang.BigInt) (t/fn [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x))))] From 66b5be0188ce4bbbe41836d07051e9171a323021 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 9 Nov 2018 23:47:34 -0700 Subject: [PATCH 674/810] Fix type sorting --- src-untyped/quantum/untyped/core/type/defnt.cljc | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 4a2ad10e..ab6db5b9 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -270,10 +270,8 @@ (if-let [c0 (uana/sort-guide t0)] (if-let [c1 (uana/sort-guide t1)] (ifs (< c0 c1) -1 (> c0 c1) 1 0) - -1) - (if-let [c1 (uana/sort-guide t1)] - 1 - (uset/normalize-comparison (t/compare t0 t1))))) + (uset/normalize-comparison (t/compare t0 t1))) + (uset/normalize-comparison (t/compare t0 t1)))) (c/defn compare-args-types [arg-types0 #_(us/vec-of t/type?) arg-types1 #_(us/vec-of t/type?)] (let [ct-comparison (compare (count arg-types0) (count arg-types1))] From a724d41221d34c6d2802a22c65b37b83602c147d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 9 Nov 2018 23:47:45 -0700 Subject: [PATCH 675/810] Disambiguate --- src-untyped/quantum/untyped/core/type.cljc | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index f1b902f3..0489131b 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -813,9 +813,9 @@ Distinct from primitive-expansion / primitivization." [t type? > (us/set-of (us/nilable c/class?))] (let [cs (type>classes t)] - (if-let [nilable? (c/or (-> t c/meta :quantum.core.type/ref?) (contains? cs nil))] - cs - (->> cs (uc/map+ class>most-primitive-class) (ur/join #{})))))) + (if (c/or (contains? cs nil) (-> t c/meta :quantum.core.type/ref?)) + cs + (->> cs (uc/map+ class>most-primitive-class) (ur/join #{})))))) #?(:clj (defns type>primitive-subtypes From d30b540d6dac66a73510a31ce98187d03339b2c1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 9 Nov 2018 23:47:58 -0700 Subject: [PATCH 676/810] Add overload to `>form` --- src-untyped/quantum/untyped/core/form.cljc | 1 + 1 file changed, 1 insertion(+) diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index 32b246ea..4e641258 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -63,6 +63,7 @@ :cljs cljs.core/PersistentList) (>form [x] (->> x (map >form) list*)) + #?@(:clj [clojure.lang.PersistentList$EmptyList (>form [x] '())]) #?@(:clj [clojure.lang.ASeq (>form [x] (->> x (map >form)))]) #?@(:clj [clojure.lang.LazySeq (>form [x] (->> x (map >form)))]) From 9737011e78218bbe9043861d11fe9a0c8ef8667d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 9 Nov 2018 23:48:08 -0700 Subject: [PATCH 677/810] Update todos --- resources-dev/defnt.cljc | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index ac350d16..3bcc72ac 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -179,6 +179,9 @@ Legend: protocols can be extended - TODO CLJS needs to implement it better [-] Analysis/Optimization + - dead code elimination + - in `let*`, we should elide variables that are unused and that have no side effects (or at + least warn) - `(p/nil? ...)` should probably be inlined to `(?/== ... nil)` rather than using the overhead of the deftype - This should realize that we're negating a `<` and change the operator to `<=` @@ -259,7 +262,6 @@ Legend: type? [ ] t/defmacro [ ] t/deftype - [ ] t/dotyped [-] t/extend-defn! [ ] Ability to add output type restriction after the fact? [ ] lazy compilation especially around `t/input-type` From 8e8a7fc772393c9f5c77a5cbc8622452f3c183b4 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 10 Nov 2018 02:26:11 -0700 Subject: [PATCH 678/810] Fix method not being implemented --- src-untyped/quantum/untyped/core/form/generate/deftype.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/form/generate/deftype.cljc b/src-untyped/quantum/untyped/core/form/generate/deftype.cljc index 4e69d050..5a2b8c53 100644 --- a/src-untyped/quantum/untyped/core/form/generate/deftype.cljc +++ b/src-untyped/quantum/untyped/core/form/generate/deftype.cljc @@ -159,7 +159,7 @@ :clj `[~(?Collection lang) ~@(p-arity 'empty (get impls 'empty)) - ~@(p-arity 'equiv (get-in impls ['?Equals '=])) ; TBD + ~@(p-arity 'equiv (get-in methods-spec ['?Equals '=])) ; TBD ~@(p-arity 'cons (get impls 'conj)) ~(implement-map-or-collection methods-spec) ~@(p-arity 'isEmpty (get impls 'empty?)) From 2f63aed28cff933aa224c93d0a0148b7db03ee6d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 10 Nov 2018 02:26:53 -0700 Subject: [PATCH 679/810] Fix some errors with inline; not too many left! --- src-untyped/quantum/untyped/core/analyze.cljc | 37 ++++++++++++++----- src-untyped/quantum/untyped/core/type.cljc | 7 ++++ .../quantum/untyped/core/type/defnt.cljc | 9 ++--- src/quantum/core/data/primitive.cljc | 10 +++-- test/quantum/test/untyped/core/analyze.cljc | 2 +- 5 files changed, 46 insertions(+), 19 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index e8e134d8..bee9468b 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -701,11 +701,29 @@ [env ::env, {:as overload-type-datum :keys [arglist-code|hinted _, body-codelist _, inline? _]} _ caller|node uast/node?, caller|type _, input-nodes (us/vec-of uast/node?)] (if inline? - (analyze* env (list* 'let* (reducei (fn [bindings to i|arg] - (let [from (-> input-nodes (get i|arg) :form)] - (conj bindings to from))) - [] arglist-code|hinted) - body-codelist)) + ;; TODO abstract this with the `let*` code + (let [bindings-map (reducei (fn [bindings sym i|arg] + (assoc bindings sym (get input-nodes i|arg))) + {} arglist-code|hinted) + body-node (analyze* (merge env bindings-map) (list* 'do body-codelist)) + bindings|form + (reducei (fn [bindings to i|arg] + (let [from-node (get input-nodes i|arg) + ;; To avoid "Can't hint a primitive local" errors + to' (cond-> to (-> from-node :type t/primitive-type?) + ufth/un-type-hint)] + (conj bindings to' (:form from-node)))) + [] arglist-code|hinted) + node (uast/let* {:env env + :unanalyzed-form (list* 'let* bindings|form body-codelist) + :form (list* 'let* bindings|form + (->> body-node :body (uc/lmap :form))) + :bindings bindings-map + :body body-node + :type (:type body-node)})] + ;; TODO fix this; apparently it's not enough or maybe `assume` isn't being propagated + (cond-> node (-> overload-type-datum :output-type meta :quantum.core.type/assume?) + (update :type #(t/and % (:output-type overload-type-datum))))) {:input-nodes input-nodes :form (>direct-dispatch|reify-call caller|node caller|type overload-type-datum (uc/map :form input-nodes)) @@ -771,12 +789,12 @@ caller|node (analyze* env caller|form) caller|t (-> arg-nodes first :type) unvalued-arg-types (->> arg-nodes rest (map :type) (map t/unvalue)) - _ (uref/set! !!dependent? true) + _ (uref/set! !!dependent? true) t (case (name caller|form) - "input-type" (if (-> env :opts :quantum.untyped.core.analyze-types?) + "input-type" (if (-> env :opts :split-types?) (t/input-type|meta-or caller|t unvalued-arg-types) (t/input-type|or caller|t unvalued-arg-types)) - "output-type" (if (-> env :opts :analyze-arg-syms-types?) + "output-type" (if (-> env :opts :split-types?) (t/output-type|meta-or caller|t unvalued-arg-types) (t/output-type|or caller|t unvalued-arg-types)) "type" caller|t)] @@ -1044,7 +1062,8 @@ (defn pr! [x] (binding [quantum.untyped.core.analyze.ast/*print-env?* false quantum.untyped.core.print/*collapse-symbols?* true - *print-meta* true] + *print-meta* true + *print-level* 10] (quantum.untyped.core.print/ppr x))) #?(:clj diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 0489131b..c8a8feac 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -829,6 +829,13 @@ (uc/map+ isa?) (ur/join #{})))))) +#?(:clj +(defns primitive-type? [t type? > boolean?] + (c/and (-> t c/meta :quantum.core.type/ref? c/not) + (let [cs (type>classes t)] + (c/and (-> cs count (c/= 1)) + (contains? boxed-class->unboxed-symbol (first cs))))))) + #?(:clj (defns- -type>?class-value [t utr/type?, type-nilable? c/boolean?] (if (utr/value-type? t) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index ab6db5b9..5eb598c3 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -313,11 +313,10 @@ {:as fn|globals :keys [fn|globals-name _, fn|name _, fn|ns-name _, fn|output-type _ fn|overload-types-name _]} ::fn|globals {:as unanalyzed-overload - :keys [arg-classes _, arg-types _, arglist-code|hinted _, arglist-code|reify|unhinted _, - arglist-form|unanalyzed _, args-form _, body-codelist _ output-type|form _ - varargs-form _, variadic? _] - declared-output-type [:output-type _]} - ::unanalyzed-overload + :keys [arg-classes _, arg-types _, arglist-code|hinted _, arglist-code|reify|unhinted _, + arglist-form|unanalyzed _, args-form _, body-codelist _ output-type|form _ + varargs-form _, variadic? _] + declared-output-type [:output-type _]} ::unanalyzed-overload overload|id index? fn|overload-types (us/vec-of ::types-decl-datum) fn|type t/type? diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index d19f7b46..6109c716 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -312,10 +312,12 @@ ) (t/extend-defn! c?/compare - ([a false? , b false?] (int 0)) - ([a false? , b true?] (int -1)) - ([a true? , b false?] (int 1)) - ([a true? , b true?] (int 0)) + ([a false? , b false?] (int 0)) + ([a false? , b true?] (int -1)) + ([a true? , b false?] (int 1)) + ([a true? , b true?] (int 0)) + ([a boolean? , b boolean?] + (if a (if b (int 0) (int 1)) (if b (int -1) (int 0)))) ([a numeric? , b numeric?] (ifs (c?/< a b) (int -1) (c?/> a b) (int 1) (int 0))) #?(:clj ([a (t/ref c?/icomparable?), b primitive?] (.compareTo a b))) diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index d79b40cd..3014fd2a 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -34,7 +34,7 @@ (defn- transform-ana [ana] (->> ana (mapv #(vector (->> % :env :opts :arg-env deref (uc/map-vals' :type)) - (-> % :out-type-node :type))))) + (-> % :output-type-node :type))))) ;; More dependent type tests in `quantum.test.untyped.core.type.defnt` but those are more like ;; integration tests From d293f87bc6ce6d8a604cc444f4b7d5af4526b4cf Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 10 Nov 2018 22:47:06 -0700 Subject: [PATCH 680/810] `cond-let` -> `ifs-let` --- src-untyped/quantum/untyped/core/logic.cljc | 8 +- src/quantum/audio/midi.clj | 12 +-- src/quantum/compile/transpile/from/java.cljc | 4 +- src/quantum/core/logic.cljc | 2 +- src/quantum/core/macros/defnt.cljc | 6 +- test/quantum/test/core/logic.cljc | 97 +------------------- 6 files changed, 18 insertions(+), 111 deletions(-) diff --git a/src-untyped/quantum/untyped/core/logic.cljc b/src-untyped/quantum/untyped/core/logic.cljc index bb266689..991a2711 100644 --- a/src-untyped/quantum/untyped/core/logic.cljc +++ b/src-untyped/quantum/untyped/core/logic.cljc @@ -93,7 +93,7 @@ ([cond-expr then-expr] `(if ~cond-expr ~then-expr - (throw (ex-info "`cond`: No matching clause" {})))) + (throw (ex-info "`ifs`: No matching clause" {})))) ([cond-expr then-expr & clauses] `(if ~cond-expr ~then-expr @@ -269,12 +269,12 @@ [& args] `(when-let-base when-not ~@args))) #?(:clj -(defmacro cond-let +(defmacro ifs-let "Transforms into a series of nested `if-let` statements." {:attribution "alexandergunnarson"} - ([] nil) ; no else + ([] `(throw (ex-info "`ifs-let`: No matching clause" {}))) ; no else ([else] else) - ([bindings then & more] `(if-let ~bindings ~then (cond-let ~@more))))) + ([bindings then & more] `(if-let ~bindings ~then (ifs-let ~@more))))) #?(:clj (defmacro logical-let-base diff --git a/src/quantum/audio/midi.clj b/src/quantum/audio/midi.clj index 4995f8e0..7b5486fc 100644 --- a/src/quantum/audio/midi.clj +++ b/src/quantum/audio/midi.clj @@ -8,7 +8,7 @@ [quantum.core.fn :refer [<- fn-> fn->> fn1 fnl]] [quantum.core.logic - :refer [fn-and whenc whenf whenf1 xor cond-let]] + :refer [fn-and whenc whenf whenf1 xor ifs-let]] [quantum.core.collections :as coll :refer [ffilter filter+ remove+ remove partition-all+ keys+ partition-all lpartition-all cat lcat concatv @@ -291,11 +291,11 @@ _ (validate expr #(not (and (contains? % \^) (contains? % \v)))) [octave' expr'] - (cond-let [ups (get expr \^)] - [(+ octave ups ) (dissoc expr \^)] - [downs (get expr \v)] - [(- octave downs) (dissoc expr \v)] - [octave expr]) + (ifs-let [ups (get expr \^)] + [(+ octave ups ) (dissoc expr \^)] + [downs (get expr \v)] + [(- octave downs) (dissoc expr \v)] + [octave expr]) expr' (->> expr' keys+ (join #{})) found-articulation (-> (get articulations->articulation-name expr') (validate keyword?)) diff --git a/src/quantum/compile/transpile/from/java.cljc b/src/quantum/compile/transpile/from/java.cljc index ca73ab09..d3c3155f 100644 --- a/src/quantum/compile/transpile/from/java.cljc +++ b/src/quantum/compile/transpile/from/java.cljc @@ -18,7 +18,7 @@ [quantum.core.fn :as fn :refer [fn' fn-> fn->> fn1 rcomp]] [quantum.core.logic :as logic - :refer [fn= fn-or fn-and whenf whenf1 ifn1 condf1 if-let cond-let]] + :refer [fn= fn-or fn-and whenf whenf1 ifn1 condf1 if-let ifs-let]] [quantum.core.type-old :as t :refer [val?]] [quantum.core.type.core :as tcore] @@ -464,7 +464,7 @@ (fn-> last anap/return-statement?)) (fn1 update-last (fn1 second)) anap/sym-call? - (fn [x] (cond-let + (fn [x] (ifs-let [{[form] :form [oper] :oper} (re-match-whole x (m/& (m/as :oper (| '+ '-)) diff --git a/src/quantum/core/logic.cljc b/src/quantum/core/logic.cljc index e5e8eea5..fd90be48 100644 --- a/src/quantum/core/logic.cljc +++ b/src/quantum/core/logic.cljc @@ -153,7 +153,7 @@ (defaliases u if-let if-not-let when-let when-not-let - cond-let + ifs-let and-let nand-let or-let nor-let xor-let xnor-let)) diff --git a/src/quantum/core/macros/defnt.cljc b/src/quantum/core/macros/defnt.cljc index d43b0e35..b42d1e17 100644 --- a/src/quantum/core/macros/defnt.cljc +++ b/src/quantum/core/macros/defnt.cljc @@ -16,7 +16,7 @@ [quantum.core.log :as log :refer [prl]] [quantum.core.logic :as logic - :refer [fn= fn-not fn-and fn-or whenc whenf whenf1 whenc1 ifn1 condf if-not-let cond-let]] + :refer [fn= fn-not fn-and fn-or whenc whenf whenf1 whenc1 ifn1 condf if-not-let ifs-let]] [quantum.core.macros.fn :as mfn] [quantum.core.analyze.clojure.core :as ana] [quantum.core.analyze.clojure.predicates :as anap] @@ -506,7 +506,7 @@ (hint-expr-with-class arg expected-type) not-matchable) (.isPrimitive actual-type) - (cond-let + (ifs-let [c (get-in tcore/unboxed->convertible [actual-type expected-type])] ; cast unboxed primitive to compatible unboxed primitive via Clojure intrinsic (hint-expr-with-class `(~(symbol "clojure.core" (.getName ^Class c)) ~arg) c) @@ -517,7 +517,7 @@ (hint-expr-with-class `(new ~(symbol (.getName ^Class c)) ~arg) c) not-matchable) (tcore/boxed->unboxed actual-type) - (cond-let + (ifs-let [c (get-in tcore/unboxed->convertible [(tcore/boxed->unboxed actual-type) expected-type])] ; cast boxed primitive to compatible unboxed primitive via Clojure intrinsic (hint-expr-with-class `(~(symbol "clojure.core" (.getName ^Class c)) ~arg) c) diff --git a/test/quantum/test/core/logic.cljc b/test/quantum/test/core/logic.cljc index 41cb1954..9517fe2a 100644 --- a/test/quantum/test/core/logic.cljc +++ b/test/quantum/test/core/logic.cljc @@ -6,14 +6,14 @@ :refer [deftest is]])) #?(:clj -(deftest test:some-but-not-more-than-n +(deftest test|some-but-not-more-than-n (doseq [n [1]] ; TODO test more (doseq [args-n (range 5)] (doseq [args (combo/selections #{true false} args-n)] (is (= (boolean (eval `(ns/some-but-not-more-than-n ~n ~@args))) (boolean (eval `(and (or ~@args) (not (and ~@args)))))))))))) -(deftest test:default +(deftest test|default (let [a (atom 0)] (ns/default nil (reset! a 1)) (is (= @a 1)) @@ -25,96 +25,3 @@ (is (= @a 1)) (ns/default nil (reset! a 5)) (is (= @a 5)))) - -;___________________________________________________________________________________________________________________________________ -;==================================================={ BOOLEANS + CONDITIONALS }===================================================== -;==================================================={ }===================================================== -(defn test:nnil? [x]) -(defn test:nempty? [x]) -(defn test:nseq? [x]) - -(defn test:iff [pred const else]) -(defn test:iffn [pred const else-fn]) - -(defn test:eq? [x]) - -(defn test:neq? [x]) - -(defn test:any? [pred args]) - -(defn test:every? [pred args]) - -(defn test:dor [& args]) - -(defn test:fn-logic-base - [oper & preds]) - -(defn test:fn-or [& preds]) -(defn test:fn-and [& preds]) -(defn test:fn-not [pred] ) - -(defn test:falsey? [x]) -(defn test:truthy? [x]) - -(defn test:splice-or [obj compare-fn & coll]) -(defn test:splice-and [obj compare-fn & coll]) - -(defn test:coll-base [logical-oper & elems]) - -(defn test:coll-or [& elems]) - -(defn test:coll-and [& elems]) - -(defn test:bool [v]) - -(defn test:rcompare [x y]) - -(defn test:condf - [obj & clauses]) - -(defn test:condf1 [& args]) - -(defn test:condf**n [& args]) - -(defn test:condfc - [obj & clauses]) - -(defn test:ifn [obj pred true-fn false-fn]) - -(defn test:ifc [obj pred true-expr false-expr]) - -(defn test:ifp [obj pred true-fn false-fn]) - -(defn test:ifcf$n [pred true-expr false-expr]) - -(defn test:ifn1 [pred true-fn false-fn]) - -(defn test:whenf - [obj pred true-fn]) - -(defn test:whenc - [obj pred true-expr]) - -(defn test:whenp - [obj pred true-fn]) - -(defn test:whenf1 - [pred true-fn]) - -(defn test:whenc1 - [pred true-obj]) - -(defn test:condpc - [pred expr & clauses]) - -; ======== CONDITIONAL LET BINDINGS ======== - -(defn test:if-let - ([bindings then]) - ([[bnd expr & more] then else])) - -(defn test:when-let - ([[var- expr & more] & body])) - -(defn test:cond-let - [bindings & clauses]) From 0c70e6b29eced13bef1413b8bea2d9e56bad49a8 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 10 Nov 2018 22:48:02 -0700 Subject: [PATCH 681/810] Ensure ns is configurable when analyzing; fix inline analysis --- src-untyped/quantum/untyped/core/analyze.cljc | 19 +-- .../quantum/untyped/core/type/defnt.cljc | 116 ++++++++++-------- src/quantum/core/data/primitive.cljc | 6 +- 3 files changed, 81 insertions(+), 60 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index bee9468b..9eae20c2 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -599,7 +599,7 @@ (err! "Must supply exactly one input to `var`" {:form form}) (not (symbol? arg-form)) (err! "`var` accepts a symbol argument" {:form form}) - (let [resolved (uvar/resolve *ns* arg-form)] + (let [resolved (uvar/resolve (or (-> env :opts :ns) *ns*) arg-form)] (ifs (nil? resolved) (err! "Could not resolve var from symbol" {:symbol arg-form}) (not (var? resolved)) @@ -674,7 +674,7 @@ (let [overload-types-name (symbol (namespace fn|name) (str (name fn|name) "|__types"))] (if-let [fn|types (get env overload-types-name)] (->> fn|types (uc/filter #(-> % :arg-types count (= inputs-ct)))) - (if-let [fn|types-var (resolve overload-types-name)] + (if-let [fn|types-var (uvar/resolve (or (-> env :opts :ns) *ns*) overload-types-name)] (->> fn|types-var var-get urx/norx-deref :overload-types (uc/filter #(-> % :arg-types count (= inputs-ct)))) (err! "Overload-types not found for typed fn" @@ -705,7 +705,10 @@ (let [bindings-map (reducei (fn [bindings sym i|arg] (assoc bindings sym (get input-nodes i|arg))) {} arglist-code|hinted) - body-node (analyze* (merge env bindings-map) (list* 'do body-codelist)) + ns-val (the-ns (:ns-name overload-type-datum)) + body-node + (analyze* (-> env (merge bindings-map) (update :opts assoc :ns ns-val)) + (list* 'do body-codelist)) bindings|form (reducei (fn [bindings to i|arg] (let [from-node (get input-nodes i|arg) @@ -925,7 +928,9 @@ (if (-> env :opts :arglist-context?) (if-let [caller-form-dependent-type-call? (and (symbol? caller|form) - (when-let [sym (some-> (uvar/resolve *ns* caller|form) uid/>symbol)] + (when-let [sym (some-> + (uvar/resolve (or (-> env :opts :ns) *ns*) caller|form) + uid/>symbol)] (case sym (quantum.core.type/type quantum.untyped.core.type/type @@ -939,7 +944,7 @@ (analyze-seq|call env form)))) (defns- analyze-seq [env ::env, form _] - (let [expanded-form (ufeval/macroexpand form)] + (let [expanded-form (binding [*ns* (or (-> env :opts :ns) *ns*)] (ufeval/macroexpand form))] (if-let [no-expansion? (ucomp/== form expanded-form)] (analyze-seq* env expanded-form) (let [expanded-form' (cond-> expanded-form @@ -958,10 +963,10 @@ (and (-> env :opts :arglist-context?) (-> env :opts :arg-env deref (find sym))))] {:resolved local :resolved-via :env} - (let [resolved (uvar/resolve *ns* sym)] + (let [resolved (uvar/resolve (or (-> env :opts :ns) *ns*) sym)] (ifs resolved {:resolved resolved :resolved-via :resolve} - (some->> sym namespace symbol (uvar/resolve *ns*) class?) + (some->> sym namespace symbol (uvar/resolve (or (-> env :opts :ns) *ns*)) class?) {:resolved (analyze-seq|dot env (list '. (-> sym namespace symbol) (-> sym name symbol))) :resolved-via :dot} diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 5eb598c3..6e9b9046 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -41,7 +41,7 @@ :refer [>name >?namespace >symbol]] [quantum.untyped.core.log :as ulog] [quantum.untyped.core.logic :as ul - :refer [fn-or fn= if-not-let ifs]] + :refer [fn-or fn= if-not-let ifs ifs-let]] [quantum.untyped.core.loops :refer [reduce-2]] [quantum.untyped.core.reducers :as ur @@ -129,7 +129,7 @@ :inline? boolean?})) (us/def ::overload-basis - (us/kv {:ns simple-symbol? + (us/kv {:ns-name simple-symbol? :args-form map? ; from binding to form :varargs-form (us/nilable map?) ; from binding to form :arglist-form|unanalyzed t/any? @@ -150,7 +150,8 @@ ;; Technically it's partially analyzed — its type definitions are analyzed (with the exception of ;; requests for type inference) while its body is not. (us/def ::unanalyzed-overload - (us/kv {:arg-classes (us/vec-of class?) + (us/kv {:ns-name simple-symbol? + :arg-classes (us/vec-of class?) :arg-types (us/vec-of t/type?) :arglist-code|hinted (us/vec-of simple-symbol?) :arglist-code|reify|unhinted (us/vec-of simple-symbol?) @@ -273,6 +274,11 @@ (uset/normalize-comparison (t/compare t0 t1))) (uset/normalize-comparison (t/compare t0 t1)))) +;; FIXME apparently this occasionally causes “Comparison method violates its general contract!” +;; NOTE saw “Comparison method violates its general contract!” here +;; (t/extend-defn! c?/comp< +;; ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare [= (t/type a)] :?)] +;; (c?/< (c?/compare a b) 0))) (c/defn compare-args-types [arg-types0 #_(us/vec-of t/type?) arg-types1 #_(us/vec-of t/type?)] (let [ct-comparison (compare (count arg-types0) (count arg-types1))] (if (zero? ct-comparison) @@ -333,7 +339,9 @@ recursive-ast-node-reference (uid/qualify fn|ns-name fn|overload-types-name) fn|overload-types)))) - body-node (uana/analyze env (ufgen/?wrap-do body-codelist)) + body-node (uana/analyze + (assoc env :opts {:ns (-> unanalyzed-overload :ns-name the-ns)}) + (ufgen/?wrap-do body-codelist)) hint-arg|fn (c/fn [i arg-binding] (ufth/with-type-hint arg-binding (ufth/>fn-arglist-tag @@ -488,8 +496,10 @@ (defns- overload-basis-data>types+ "Split and primitivized; not yet sorted." - [{:keys [fn|output-type _]} ::fn|globals, args-form _, output-type|form _, body-codelist _] - (->> (uana/analyze-arg-syms {} args-form (or output-type|form fn|output-type) true) + [{:keys [fn|output-type _]} ::fn|globals, ns-name-val _, args-form _, output-type|form _ + body-codelist _] + (->> (uana/analyze-arg-syms {:opts {:ns (the-ns ns-name-val)}} + args-form (or output-type|form fn|output-type) true) (uc/map+ (c/fn [{:keys [env output-type-node]}] (let [arg-env (->> env :opts :arg-env deref) arg-types (->> args-form keys (uc/map #(:type (get arg-env %)))) @@ -552,6 +562,7 @@ [:arglist-form|unanalyzed :args-form :body-codelist :inline? :output-type|form :varargs-form]) (merge type-datum) + (assoc :ns-name (:ns-name basis)) (merge (kw-map arg-classes arglist-code|hinted arglist-code|reify|unhinted i|basis variadic?))))) @@ -589,7 +600,7 @@ (= arg-types (:arg-types %))) existing-overload-types))] (->> (or types|split (overload-basis-data>types+ - fn|globals args-form output-type|form + fn|globals (:ns-name basis) args-form output-type|form body-codelist|unanalyzed)) (cond->> (and (not new-overload-basis?) (= (:body-codelist basis) (:body-codelist prev-basis))) @@ -649,11 +660,12 @@ sorted-changed-overload-types (->> sorted-changed-unanalyzed-overloads (uc/map-indexed - (c/fn [i {:keys [arg-types output-type body-codelist arglist-code|hinted + (c/fn [i {:as unanalyzed-overload + :keys [arg-types output-type body-codelist arglist-code|hinted inline?]}] (-> (kw-map arg-types output-type arglist-code|hinted body-codelist inline?) (assoc :id (+ i first-current-overload-id) - :ns-name (ns-name *ns*)))))) + :ns-name (:ns-name unanalyzed-overload)))))) ;; We need to maintain the `overload-types` ordering by type-specificity so the dynamic ;; dispatch and fn-type work correctly. overload-types-with-replacing-ids @@ -811,6 +823,7 @@ ;; ===== End dynamic dispatch ===== ;; (defns- overload-basis-form>overload-basis + "This is for overloads being created brand-new within `defn` or `extend-defn!`." [opts ::opts {:as fn|globals :keys [fn|inline? _, fn|output-type _, fn|output-type _, fn|output-type|form _]} ::fn|globals @@ -839,7 +852,8 @@ ;; supported (assert (-> varargs :binding-form first (= :sym)))) args-form (reduce-2 assoc (umap/om) arg-bindings arg-types|form) - [arglist-basis] (uana/analyze-arg-syms {} args-form + ns-name-val (>symbol *ns*) + [arglist-basis] (uana/analyze-arg-syms {:opts {:ns (the-ns ns-name-val)}} args-form (or output-type|form fn|output-type) false) binding->arg-type|basis (->> arglist-basis :env :opts :arg-env deref (uc/map-vals' :type)) arg-types|basis (->> args-form keys (uc/map binding->arg-type|basis)) @@ -849,7 +863,7 @@ (seq-or utr/rx-type? arg-types|basis)) inline? (or (and fn|inline? (-> arglist-form meta :unline? not)) (-> arglist-form meta :inline?))] - {:ns (>symbol *ns*) + {:ns-name ns-name-val ;; TODO Only needed if `dependent?` or if new :args-form args-form :arg-types|basis arg-types|basis @@ -867,7 +881,7 @@ ;; previous split types. If non-reactive, then the split types of this overload basis can be ;; compared to existing overload bases. :types|split (when dependent? - (->> (overload-basis-data>types+ fn|globals args-form + (->> (overload-basis-data>types+ fn|globals ns-name-val args-form output-type|form body-codelist|unanalyzed) ur/join)) ;; TODO Only needed if `inline? or `reactive?`, or if new @@ -888,11 +902,12 @@ (->> existing-bases (uc/map-indexed+ (c/fn [i existing-basis] - (if-let [same-code? - (and (= (:arglist-form|unanalyzed existing-basis) - (:arglist-form|unanalyzed new-basis)) - (= (:body-codelist existing-basis) - (:body-codelist new-basis)))] + (ifs-let + [same-code? + (and (= (:arglist-form|unanalyzed existing-basis) + (:arglist-form|unanalyzed new-basis)) + (= (:body-codelist existing-basis) + (:body-codelist new-basis)))] (do (ulog/pr :warn "Overwriting existing overload with same arglist and body" {:arglist|form (:arglist-form|unanalyzed new-basis)}) @@ -900,43 +915,44 @@ ;; This only checks for `=` because `t/=` will be deduped later on in ;; overloads, not overload bases ;; TODO this doesn't take into account `|` types - (if-let [same-unreactive-type? - (and (not (:reactive? existing-basis)) - (not (:reactive? new-basis)) - (if (and (:dependent? existing-basis) - (:dependent? new-basis)) - (= (:types|split existing-basis) - (:types|split new-basis)) - (and (= (:output-type|basis existing-basis) - (:output-type|basis new-basis)) - (= (:arg-types|basis existing-basis) - (:arg-types|basis new-basis)))))] - (do (ulog/pr :warn "Overwriting existing overload with same types" - {:arglist|form|prev (:arglist-form|unanalyzed existing-basis) - :arglist|form (:arglist-form|unanalyzed new-basis)}) - i) - ;; TODO enhance this; figure out how to effectively compare reactive - ;; and dependent types, if that's even possible - ;; TODO maybe we don't even want this; maybe this should be based on - ;; an atom that's configurable. It does override/nullify some - ;; safety behavior in `overload-basis|changed?` - (when-let [probably-same-reactive-type? - (and (= (:reactive? existing-basis) - (:reactive? new-basis)) - (= (:dependent? existing-basis) - (:dependent? new-basis)) - (= (:types|split existing-basis) - (:types|split new-basis)) - (= (-> existing-basis :output-type|basis ?norx-deref) - (-> new-basis :output-type|basis ?norx-deref)) - (= (-> existing-basis :arg-types|basis ?norx-deref) - (-> new-basis :arg-types|basis ?norx-deref)))] - (ulog/pr :warn + [same-unreactive-type? + (and (not (:reactive? existing-basis)) + (not (:reactive? new-basis)) + (if (and (:dependent? existing-basis) + (:dependent? new-basis)) + (= (:types|split existing-basis) + (:types|split new-basis)) + (and (= (:output-type|basis existing-basis) + (:output-type|basis new-basis)) + (= (:arg-types|basis existing-basis) + (:arg-types|basis new-basis)))))] + (do (ulog/pr :warn "Overwriting existing overload with same types" + {:arglist|form|prev (:arglist-form|unanalyzed existing-basis) + :arglist|form (:arglist-form|unanalyzed new-basis)}) + i) + ;; TODO enhance this; figure out how to effectively compare reactive + ;; and dependent types, if that's even possible + ;; TODO maybe we don't even want this; maybe this should be based on + ;; an atom that's configurable. It does override/nullify some + ;; safety behavior in `overload-basis|changed?` + [probably-same-reactive-type? + (and (= (:reactive? existing-basis) + (:reactive? new-basis)) + (= (:dependent? existing-basis) + (:dependent? new-basis)) + (= (:types|split existing-basis) + (:types|split new-basis)) + (= (-> existing-basis :output-type|basis ?norx-deref) + (-> new-basis :output-type|basis ?norx-deref)) + (= (-> existing-basis :arg-types|basis ?norx-deref) + (-> new-basis :arg-types|basis ?norx-deref)))] + (do (ulog/pr :warn (str "Assuming that new reactive overload basis is a subsequent " "version of existing reactive overload basis") {:new (:arglist-form|unanalyzed existing-basis) :existing (:arglist-form|unanalyzed existing-basis)}) - i))))) + i) + nil))) (uc/filter+ some?) uc/first)] (assoc bases i|existing new-basis) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 6109c716..113ba1e6 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -316,12 +316,12 @@ ([a false? , b true?] (int -1)) ([a true? , b false?] (int 1)) ([a true? , b true?] (int 0)) - ([a boolean? , b boolean?] + #_([a boolean? , b boolean?] (if a (if b (int 0) (int 1)) (if b (int -1) (int 0)))) ([a numeric? , b numeric?] (ifs (c?/< a b) (int -1) (c?/> a b) (int 1) (int 0))) -#?(:clj ([a (t/ref c?/icomparable?), b primitive?] (.compareTo a b))) -#?(:clj ([a primitive? , b (t/ref c?/icomparable?)] (.compareTo (box a) b)))) +#?(:clj ([a (t/ref c?/icomparable?), b numeric?] (.compareTo a b))) +#?(:clj ([a numeric? , b (t/ref c?/icomparable?)] (.compareTo (box a) b)))) (t/extend-defn! c?/comp< ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare [= (t/type a)] :?)] From cccbcff5bba64cf3e2135e7f6df2224d924744ac Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 12 Nov 2018 12:05:05 -0700 Subject: [PATCH 682/810] Ensure field access form is not botched --- src-untyped/quantum/untyped/core/analyze.cljc | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 9eae20c2..5861af3c 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -421,10 +421,12 @@ ?cast-type (?cast-call->type target-class method-form) ;; TODO enable the below: ;; (us/validate (-> with-ret-type :args first :type) #(t/>= % (t/numerically ?cast-type))) - _ (when ?cast-type - (log/ppr :warn - "Not yet able to statically validate whether primitive cast will succeed at runtime" - {:form form}))] + ;; _ (when ?cast-type + ;; TODO fix this: + ;; (log/ppr :warn + ;; "Not yet able to statically validate whether primitive cast will succeed at runtime" + ;; {:form form})) + ] (uast/method-call {:env env :unanalyzed-form form @@ -464,7 +466,7 @@ (uast/field-access {:env env :unanalyzed-form form - :form (:form target) + :form (list '. (:form target) field-form) :target target :field field-form :type (-> field :class (maybe-with-assume-val form))})) From b0e1b39828eb3c0a47dbf38ef04c616bf4ba3162 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 12 Nov 2018 12:05:17 -0700 Subject: [PATCH 683/810] Add `sort!`, `sort-by!` --- .../quantum/untyped/core/collections.cljc | 66 ++++++++++++------- 1 file changed, 41 insertions(+), 25 deletions(-) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index 94266b74..0df06ddb 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -1,30 +1,31 @@ (ns quantum.untyped.core.collections "Operations on collections." - (:refer-clojure :exclude - [#?(:cljs array?) assoc-in cat conj! contains? count distinct distinct? drop first get group-by - filter flatten frequencies last map map-indexed mapcat partition-all pmap remove reverse run! - take zipmap]) - (:require - [clojure.core :as core] - [fast-zip.core :as zip] - [quantum.untyped.core.core :as ucore - :refer [sentinel]] - [quantum.untyped.core.data - :refer [transient?]] - [quantum.untyped.core.data - :refer [val?]] - [quantum.untyped.core.data.array - :refer [array?]] - [quantum.untyped.core.error :as uerr - :refer [err!]] - [quantum.untyped.core.fn :as ufn - :refer [ntha fn' aritoid]] - [quantum.untyped.core.logic - #?(:clj :refer :cljs :refer-macros) [ifs condf1 fn-not]] ; no idea why this is required currently :/ - [quantum.untyped.core.loops - :refer [reduce-2]] - [quantum.untyped.core.reducers :as ur - :refer [defeager def-transducer>eager transducer->transformer educe]])) + (:refer-clojure :exclude + [#?(:cljs array?) assoc-in cat conj! contains? count distinct distinct? drop first get + group-by filter flatten frequencies last map map-indexed mapcat partition-all pmap remove + reverse run! take zipmap]) + (:require + [clojure.core :as core] + [fast-zip.core :as zip] +#?(:cljs [goog.array :as garray]) + [quantum.untyped.core.core :as ucore + :refer [sentinel]] + [quantum.untyped.core.data + :refer [transient?]] + [quantum.untyped.core.data + :refer [val?]] + [quantum.untyped.core.data.array + :refer [array?]] + [quantum.untyped.core.error :as uerr + :refer [err!]] + [quantum.untyped.core.fn :as ufn + :refer [ntha fn' aritoid]] + [quantum.untyped.core.logic + #?(:clj :refer :cljs :refer-macros) [ifs condf1 fn-not]] ; no idea why this is required currently :/ + [quantum.untyped.core.loops + :refer [reduce-2]] + [quantum.untyped.core.reducers :as ur + :refer [defeager def-transducer>eager transducer->transformer educe]])) (ucore/log-this-ns) @@ -483,3 +484,18 @@ (groupf (groupf) [k xs*]) x*]))) xs))))) + +(defn sort! + "Like `sort` but coerces `xs` to an array and then sorts it in place, returning the coerced array + instead of a seq on top of it. If `xs` is already an array, modifies `xs`." + ([xs] (sort! compare xs)) + ([compf xs] + (let [#?(:clj ^objects !xs :cljs !xs) (if (array? xs) xs (to-array xs))] + (doto !xs #?(:clj (java.util.Arrays/sort ^Comparator compf) + :cljs (garray/stableSort !xs (@#'fn->comparator compf))))))) + +(defn sort-by! + "Like `sort-by` but coerces `xs` to an array and then sorts it in place, returning the coerced + array instead of a seq on top of it. If `xs` is already an array, modifies `xs`." + ([kf xs] (sort-by! kf compare xs)) + ([kf compf xs] (sort! (fn [a b] (compf (kf a) (kf b))) xs))) From d571705c48c650134f718a5c0e643b9cb77dc6d8 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 12 Nov 2018 12:05:22 -0700 Subject: [PATCH 684/810] `check-comparator-transitivity` --- src-untyped/quantum/untyped/core/compare.cljc | 31 +++++++++++++++++++ 1 file changed, 31 insertions(+) diff --git a/src-untyped/quantum/untyped/core/compare.cljc b/src-untyped/quantum/untyped/core/compare.cljc index c8c4d934..b7d69a8b 100644 --- a/src-untyped/quantum/untyped/core/compare.cljc +++ b/src-untyped/quantum/untyped/core/compare.cljc @@ -90,3 +90,34 @@ "Returns the 'max' element of `xs` according to comparator `compf` in O(n) time." ([xs] (comp-max-of compare xs)) ([compf xs] (->> xs (reduce (gen-comp-max|rf compf))))) + +(defn check-comparator-transitivity + "To ensure the comparator maintains its contract and that `IllegalArgumentException Comparison + method violates its general contract!` is not thrown." + {:complexity "O(n^3) time" + :adapted-from + "http://code.nomad-labs.com/2015/06/02/finding-the-error-in-your-comparators-compare-method-aka-comparison-method-violates-its-general-contract/"} + [compf xs] + (if (< (int (bounded-count 3 xs)) 3) + (throw (ex-info "`xs` must have at least 3 items")) + (let [^objects xs' (into-array xs) ct (count xs')] + (doseq [i0 (range 0 ct)] + (doseq [i1 (range 1 ct)] + (doseq [i2 (range 2 ct)] + (when (and (not= i0 i1) (not= i0 i2) (not= i1 i2)) + (let [x0 (aget xs' i0) + x1 (aget xs' i1) + x2 (aget xs' i2) + x0+x1 (int (compf x0 x1)) + x0+x2 (int (compf x0 x2)) + x1+x2 (int (compf x1 x2))] + (when (and (< x0+x1 0) (< x1+x2 0) (not (< x0+x2 0))) + (println "x0 comp< x1, x1 comp< x2, but x0 not comp< x2") + (println "x0:" x0) + (println "x1:" x1) + (println "x2:" x2)) + (when (and (> x0+x1 0) (> x1+x2 0) (not (> x0+x2 0))) + (println "x0 comp> x1, x1 comp> x2, but x0 not comp< x2") + (println "x0:" x0) + (println "x1:" x1) + (println "x2:" x2)))))))))) From e91286445e3b10331581498388a298bea823aff5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 12 Nov 2018 12:05:28 -0700 Subject: [PATCH 685/810] Fix compilation --- src-untyped/quantum/untyped/core/type.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index c8a8feac..34c53be9 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -830,7 +830,7 @@ (ur/join #{})))))) #?(:clj -(defns primitive-type? [t type? > boolean?] +(defns primitive-type? [t type? > c/boolean?] (c/and (-> t c/meta :quantum.core.type/ref? c/not) (let [cs (type>classes t)] (c/and (-> cs count (c/= 1)) From 91b3f39360731b5afb8c5c463f4e3e63368dcab8 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 12 Nov 2018 12:05:48 -0700 Subject: [PATCH 686/810] Fix overload types sort --- .../quantum/untyped/core/type/defnt.cljc | 49 ++++++++----- .../quantum/test/untyped/core/type/defnt.cljc | 69 +++++++++++++++++++ 2 files changed, 102 insertions(+), 16 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 6e9b9046..93e66ba6 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -274,11 +274,6 @@ (uset/normalize-comparison (t/compare t0 t1))) (uset/normalize-comparison (t/compare t0 t1)))) -;; FIXME apparently this occasionally causes “Comparison method violates its general contract!” -;; NOTE saw “Comparison method violates its general contract!” here -;; (t/extend-defn! c?/comp< -;; ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare [= (t/type a)] :?)] -;; (c?/< (c?/compare a b) 0))) (c/defn compare-args-types [arg-types0 #_(us/vec-of t/type?) arg-types1 #_(us/vec-of t/type?)] (let [ct-comparison (compare (count arg-types0) (count arg-types1))] (if (zero? ct-comparison) @@ -290,6 +285,33 @@ arg-types0 arg-types1) ct-comparison))) +(c/defn sort-overload-types + "A naïve implementation would do an aggregate compare on the arg-types vectors, but the resulting + comparator would not be transitive due to the behavior of `<>` and `><`. For example, for the + below arg-types vectors, x0 comp< x1, x1 comp< x2, but x0 not comp< x2: + - x0: [t/boolean? t/nil?] + - x1: [(t/ref (t/isa? Comparable)) t/byte?] + - x2: [t/nil? t/val?] + + Because of this, we are forced to do as many sorts as the max arity of the typed fn, which + results in an O(m•n•log(n))) algorithm, where `m` is the max arity and `n` is the number of + overloads." + [kf overload-types] + (let [!overload-types (to-array overload-types) + max-arity (->> !overload-types (uc/map+ count) (educe (aritoid (c/fn [] 0) max max)))] + (dotimes [i max-arity] + (->> !overload-types + (uc/sort-by! kf + (c/fn [a b] (let [ct|a (count a) + ct|b (count b) + ct-comparison (compare ct|a ct|b)] + (if (zero? ct-comparison) + (if (< i ct|a) + (compare-arg-types (get a i) (get b i)) + 0) + ct-comparison)))))) + (>vec !overload-types))) + (c/defn- dedupe-type-data "Performs both structural and `t/compare` deduplication." [on-dupe #_fn?, type-data #_(vec-of ::types-decl-datum)] @@ -653,7 +675,7 @@ :overload-types []}) (let [sorted-changed-unanalyzed-overloads (->> changed-unanalyzed-overloads - (sort-by :arg-types compare-args-types) + (sort-overload-types :arg-types) validate-unique-types-for-unanalyzed-overloads) first-current-overload-id (count existing-overload-types) new-overload? (c/fn [type-datum] (>= (:id type-datum) first-current-overload-id)) @@ -672,16 +694,11 @@ (if (empty? existing-overload-types) (->> sorted-changed-overload-types (uc/map-indexed (c/fn [i datum] (assoc datum :index i)))) - (->> (ur/join existing-overload-types sorted-changed-overload-types) - (sort-by identity - (c/fn [datum0 datum1] - (let [c (compare-args-types (:arg-types datum0) (:arg-types datum1))] - ;; In order to make the earlier ID appear - (if (zero? c) - (if (new-overload? datum0) - (if (new-overload? datum1) c 1) - (if (new-overload? datum1) -1 c)) - c)))) + (->> ;; We `join` in this order because if two overloads are of equal sorting + ;; priority, the ones with earlier IDs should appear in + ;; `dedupe-overload-types-data` + (ur/join existing-overload-types sorted-changed-overload-types) + (sort-overload-types :arg-types) (dedupe-overload-types-data fn|ns-name fn|name) (uc/map-indexed (c/fn [i datum] (assoc datum :index i))))) ;; For recursive purposes diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 147f66a4..2a2e5888 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -2413,3 +2413,72 @@ ((Array/get ns1/fghij|__types|1 0) x00__) (. ns1/fghij|__1 invoke x00__) (unsupported! ...)))) (var ns0/abcde)) + + + +(deftest test|sort-overload-types + (is= (self/sort-overload-types core/identity + [[(t/isa? Boolean) (t/value nil)] + [(t/isa? Double) (t/isa? Byte)] + [(t/isa? Double) (t/isa? Short)] + [(t/isa? Double) (t/isa? Character)] + [(t/isa? Double) (t/isa? Integer)] + [(t/isa? Double) (t/isa? Long)] + [(t/isa? Double) (t/isa? Float)] + [(t/isa? Double) (t/isa? Double)] + [(t/isa? Double) (t/ref (t/isa? Comparable))] + [(t/isa? Double) (t/value nil)] + [(t/value nil) (t/isa? Boolean)] + [(t/value nil) (t/isa? Byte)] + [(t/value nil) (t/isa? Short)] + [(t/value nil) (t/isa? Character)] + [(t/value nil) (t/isa? Integer)] + [(t/value nil) (t/isa? Long)] + [(t/value nil) (t/isa? Float)] + [(t/value nil) (t/isa? Double)] + [(t/value nil) (t/value nil)] + [(t/value nil) (t/not (t/value nil))] + [(t/value true) (t/value false)] + [(t/value true) (t/value true)] + [(t/value false) (t/value false)] + [(t/value false) (t/value true)] + [(t/ref (t/isa? Comparable)) (t/isa? Byte)] + [(t/ref (t/isa? Comparable)) (t/isa? Short)] + [(t/ref (t/isa? Comparable)) (t/isa? Character)] + [(t/ref (t/isa? Comparable)) (t/isa? Integer)] + [(t/ref (t/isa? Comparable)) (t/isa? Long)] + [(t/ref (t/isa? Comparable)) (t/isa? Float)] + [(t/ref (t/isa? Comparable)) (t/isa? Double)] + [(t/ref (t/isa? Comparable)) (t/ref (t/isa? Comparable))]]) + [[(t/value nil) (t/value nil)] + [(t/isa? Boolean) (t/value nil)] + [(t/value nil) (t/isa? Boolean)] + [(t/value nil) (t/isa? Byte)] + [(t/isa? Double) (t/isa? Byte)] + [(t/value nil) (t/isa? Short)] + [(t/isa? Double) (t/isa? Short)] + [(t/value nil) (t/isa? Character)] + [(t/isa? Double) (t/isa? Character)] + [(t/value nil) (t/isa? Integer)] + [(t/isa? Double) (t/isa? Integer)] + [(t/value nil) (t/isa? Long)] + [(t/isa? Double) (t/isa? Long)] + [(t/value nil) (t/isa? Float)] + [(t/isa? Double) (t/isa? Float)] + [(t/value nil) (t/isa? Double)] + [(t/isa? Double) (t/isa? Double)] + [(t/isa? Double) (t/ref (t/isa? Comparable))] + [(t/isa? Double) (t/value nil)] + [(t/value true) (t/value false)] + [(t/value true) (t/value true)] + [(t/value false) (t/value false)] + [(t/value false) (t/value true)] + [(t/ref (t/isa? Comparable)) (t/isa? Byte)] + [(t/ref (t/isa? Comparable)) (t/isa? Short)] + [(t/ref (t/isa? Comparable)) (t/isa? Character)] + [(t/ref (t/isa? Comparable)) (t/isa? Integer)] + [(t/ref (t/isa? Comparable)) (t/isa? Long)] + [(t/ref (t/isa? Comparable)) (t/isa? Float)] + [(t/ref (t/isa? Comparable)) (t/isa? Double)] + [(t/ref (t/isa? Comparable)) (t/ref (t/isa? Comparable))] + [(t/value nil) (t/not (t/value nil))]])) From 79317e8863adfe0615d12efc52924d26abfcbef7 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 12 Nov 2018 13:44:53 -0700 Subject: [PATCH 687/810] Add effects queue; not yet done --- src-untyped/quantum/untyped/core/analyze.cljc | 43 +++-- .../quantum/untyped/core/type/defnt.cljc | 164 ++++++++++++------ src-untyped/quantum/untyped/core/vars.cljc | 2 + src/quantum/core/data/numeric.cljc | 29 ++-- 4 files changed, 160 insertions(+), 78 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 5861af3c..3fec6fff 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -24,7 +24,7 @@ [quantum.untyped.core.form.evaluate :as ufeval] [quantum.untyped.core.form.type-hint :as ufth] [quantum.untyped.core.identifiers :as uid] - [quantum.untyped.core.log :as log + [quantum.untyped.core.log :as ulog :refer [prl!]] [quantum.untyped.core.logic :as l :refer [if-not-let ifs]] @@ -205,6 +205,8 @@ (declare analyze* analyze-arg-syms*) +(defns- select-fields-for-print [node uast/node?] (select-keys node [:form :unanalyzed-form :type])) + ;; TODO maybe just roll this into `analyze-seq|do`? Not sure yet (defns- analyze-non-map-seqable "Analyzes a non-map seqable." @@ -423,7 +425,7 @@ ;; (us/validate (-> with-ret-type :args first :type) #(t/>= % (t/numerically ?cast-type))) ;; _ (when ?cast-type ;; TODO fix this: - ;; (log/ppr :warn + ;; (ulog/ppr :warn ;; "Not yet able to statically validate whether primitive cast will succeed at runtime" ;; {:form form})) ] @@ -568,9 +570,9 @@ :type (apply t/or (->> [(:type @true-node) (:type @false-node)] (remove nil?)))}))] (case (truthy-node? pred-node) - true (do (log/ppr :warn "Predicate in `if` node is always true" {:pred pred-form}) + true (do (ulog/ppr :warn "Predicate in `if` node is always true" {:pred pred-form}) (assoc @true-node :env env)) - false (do (log/ppr :warn "Predicate in `if` node is always false" {:pred pred-form}) + false (do (ulog/ppr :warn "Predicate in `if` node is always false" {:pred pred-form}) (assoc @false-node :env env)) nil @whole-node)))) @@ -840,7 +842,7 @@ output-type)) (defns- analyze-seq|call - [env ::env, [caller|form _ & args-form _ :as form] _ > uast/call-node?] + [env ::env, [caller|form _ & args-form _ :as form] _ > uast/node?] (let [caller|node (analyze* env caller|form) caller|type (:type caller|node) ;; We just `norx-deref` the `caller|type` primarily for `t/defn`s but it could be unsafe @@ -857,8 +859,9 @@ (case (if (utr/fn-type? caller|type) -1 (t/compare caller|type t/callable?)) - (1 2) (err! "It is not known whether form can be called" {:node caller|node}) - 3 (err! "Form cannot be called" {:node caller|node}) + (1 2) (err! "It is not known whether form can be called" + {:node (select-fields-for-print caller|node)}) + 3 (err! "Form cannot be called" {:node (select-fields-for-print caller|node)}) (-1 0) (let [caller-kind (ifs (utr/fn-type? caller|type) :fnt (t/<= caller|type t/keyword?) :keyword @@ -866,10 +869,12 @@ (t/<= caller|type t/+vector|built-in?) :vector (t/<= caller|type t/+set|built-in?) :set (t/<= caller|type t/fn?) :fn + (t/<= caller|type t/type?) :type ;; If it's callable but not fn, we might have missed something in ;; this dispatch so for now we throw (err! "Don't know how how to handle non-fn callable" - {:caller caller|node})) + {:caller (select-fields-for-print caller|node)})) + _ (when (= caller-kind :type) (ulog/pr :warn "need to handle type call better")) assert-valid-inputs-ct (case caller-kind (:keyword :map) @@ -877,19 +882,25 @@ (err! (str "Keywords and `clojure.core` persistent maps must be " "provided with exactly one or two inputs when calling " "them") - {:inputs-ct inputs-ct :caller caller|node})) - + {:inputs-ct inputs-ct + :caller (select-fields-for-print caller|node)})) (:vector :set) (when-not (= inputs-ct 1) - (err! (str "`clojure.core` persistent vectors and `clojure.core` " - "persistent sets must be provided with exactly one " - "input when calling them") - {:inputs-ct inputs-ct :caller caller|node})) - + (err! (str "`clojure.core` persistent vectors and `clojure.core` " + "persistent sets must be provided with exactly one " + "input when calling them") + {:inputs-ct inputs-ct + :caller (select-fields-for-print caller|node)})) + :type + (when-not (= inputs-ct 1) + (err! "Types must be provided with exactly one input when calling them" + {:inputs-ct inputs-ct + :caller (select-fields-for-print caller|node)})) :fnt (when-not (-> caller|type utr/fn-type>arities (contains? inputs-ct)) (err! "Unhandled number of inputs for fnt" - {:inputs-ct inputs-ct :caller caller|node})) + {:inputs-ct inputs-ct + :caller (select-fields-for-print caller|node)})) ;; TODO use the `reflect/reflect` and `js/Object.getOwnPropertyNames` trick :fn nil) {:as call-data :keys [input-nodes] analyzed-form :form} diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 93e66ba6..38a8bdf9 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -27,7 +27,8 @@ [quantum.untyped.core.data.reactive :as urx :refer [?norx-deref norx-deref]] [quantum.untyped.core.data.set :as uset] - [quantum.untyped.core.data.vector :as uvec] + [quantum.untyped.core.data.vector :as uvec + :refer [alist-conj!]] [quantum.untyped.core.error :as uerr :refer [TODO err!]] [quantum.untyped.core.fn @@ -85,6 +86,48 @@ (defonce !overload-queue (uvec/alist)) ; (t/!seq-of ::types-decl-datum-with-overload) +(uvar/defonce !effects-queue + "To ensure that side-effects are as atomic as possible in the case of a failure in `defn` or + `extend-defn!`." + (uvec/alist)) ; (t/!seq-of (t/ftype [])) + +;; TODO move +(defns- >effects-map|intern [ns-sym simple-symbol?, sym simple-symbol?, v _] + (let [var-val (resolve (uid/qualify ns-sym sym)) + value (atom nil)] + {:f #(do (when v (reset! value (var-get var-val))) + (intern ns-sym sym v)) + :unf #(if v + (intern ns-sym sym @value) + (uvar/unintern! ns-sym sym))})) + +(defn- drain-effects-queue! + "Runs effect fns, rolling back the already-executed ones in reverse order if any exception occurs." + [] + (println "about to run effects queue") + (try + (->> !effects-queue + (reduce + (c/fn [!done {:as m :keys [f]}] + (uerr/catch-all + (do (f) (alist-conj! !done m)) + effects-err + (do (->> !done + (uc/run! + (c/fn [{:keys [unf]}] + (uerr/catch-all (unf) + rollback-err + (err! nil + "Exception in effects function; unable to roll back all effects" + {:failed-rollback-fn unf} + nil rollback-err))))) + (err! nil "Exception in effects function; rolled back successfully" + {:failed-fn f} + nil effects-err)))) + (uvec/alist))) + (finally (uvec/alist-empty! !effects-queue))) + (println "done with effects queue")) + ;; ==== Internal specs ===== ;; (us/def ::lang #{:clj :cljs}) @@ -206,7 +249,7 @@ (us/def ::type-datum (us/kv {:arg-types (us/vec-of t/type?) - :pre-type t/type? + :pre-type (us/nilable t/type?) :output-type t/type?})) (us/def ::types-decl-datum @@ -463,9 +506,9 @@ ;; ----- Type declarations ----- ;; (c/defn overload-types>arg-types - [!fn|types #_(t/of urx/reactive? ::fn|types), overload-index #_index? + [?!fn|types #_(t/or ::fn|types (t/of urx/reactive? ::fn|types)), overload-index #_index? #_> #_(objects-of type?)] - (apply uarr/*<> (-> !fn|types norx-deref :overload-types (get overload-index) :arg-types))) + (apply uarr/*<> (-> ?!fn|types ?norx-deref :overload-types (get overload-index) :arg-types))) (c/defn overload-types>ftype [fn|ns-name #_simple-symbol? @@ -504,13 +547,16 @@ dynamic dispatch uses to dispatch off input types." [{:as opts :keys [compilation-mode _, lang _]} ::opts {:as fn|globals :keys [fn|ns-name _, fn|name _, fn|overload-types-name _]} ::fn|globals - {:as types-decl-datum :keys [id _, index _] ns-name- [:ns-name _]} ::types-decl-datum, !fn|types _ + {:as types-decl-datum :keys [id _, index _] ns-name- [:ns-name _]} ::types-decl-datum + fn|types ::fn|types > ::overload-types-decl] (let [decl-name (-> (>overload-types-decl|name fn|name id) (ufth/with-type-hint "[Ljava.lang.Object;")) form (if (or (not= compilation-mode :test) (= lang :clj)) - (do (intern ns-name- decl-name (overload-types>arg-types !fn|types index)) - nil) + (let [arg-types (overload-types>arg-types fn|types index)] + (do (alist-conj! !effects-queue + (>effects-map|intern ns-name- decl-name arg-types)) + nil)) `(def ~decl-name (overload-types>arg-types ~(uid/qualify fn|ns-name fn|overload-types-name) ~index)))] @@ -723,22 +769,23 @@ (let [overload (get sorted-changed-overloads (- id first-current-overload-id))] ;; So that direct dispatch can use them later on in the pipeline - (uvec/alist-conj! !overload-queue - (assoc datum :overload overload)))) + (alist-conj! !overload-queue (assoc datum :overload overload)))) (dissoc datum :replacing-id)))))] (kw-map fn|output-type-norx fn|type-norx overload-types))))) ;; ----- Direct dispatch ----- ;; (defns- >direct-dispatch - [{:as opts :keys [gen-gensym _, lang _, kind _]} ::opts, fn|globals ::fn|globals, !fn|types _] + [{:as opts :keys [gen-gensym _, lang _, kind _]} ::opts + fn|globals ::fn|globals + fn|types ::fn|types] (case lang :clj (let [direct-dispatch-data-seq (->> !overload-queue (uc/map (c/fn [{:as type-decl-datum :keys [arg-types id index overload]}] {:overload-types-decl - (>overload-types-decl opts fn|globals type-decl-datum !fn|types) + (>overload-types-decl opts fn|globals type-decl-datum fn|types) :reify (overload>reify overload opts fn|globals id)}))) _ (uvec/alist-empty! !overload-queue) form (->> direct-dispatch-data-seq @@ -807,10 +854,9 @@ [{:as opts :keys [compilation-mode _, gen-gensym _, lang _, kind _]} ::opts {:as fn|globals :keys [fn|meta _, fn|ns-name _, fn|name _, fn|output-type _ fn|overload-types-name _, fn|type-name _]} ::fn|globals - !fn|types _] + fn|types ::fn|types] (let [overload-forms - (->> !fn|types - norx-deref + (->> fn|types :overload-types (group-by (fn-> :arg-types count)) (sort-by key) ; for purposes of reproducibility and organization @@ -822,7 +868,7 @@ fn|meta' (merge fn|meta {:quantum.core.type/type (uid/qualify fn|ns-name fn|type-name)}) overload-types|form (when (= compilation-mode :test) - (->> !fn|types norx-deref :overload-types >form + (->> fn|types :overload-types >form (uc/map (c/fn [{:keys [id index inline? arg-types output-type]}] [id index inline? arg-types output-type]))))] ;; TODO determine whether CLJS needs (update-in m [:jsdoc] conj "@param {...*} var_args") @@ -878,8 +924,8 @@ dependent? (:dependent? arglist-basis) reactive? (or (utr/rx-type? output-type|basis) (seq-or utr/rx-type? arg-types|basis)) - inline? (or (and fn|inline? (-> arglist-form meta :unline? not)) - (-> arglist-form meta :inline?))] + inline? (boolean (or (and fn|inline? (-> arglist-form meta :unline? not)) + (-> arglist-form meta :inline?)))] {:ns-name ns-name-val ;; TODO Only needed if `dependent?` or if new :args-form args-form @@ -977,20 +1023,22 @@ existing-bases new-bases)) +(defns- with-optional-validate-overload-bases [overload-bases ::overload-bases-data] overload-bases) + (defns- >!overload-bases "`!overload-bases` is a reactive atom updated by `t/extend-defn!`, which cannot be deleted from but which can be updated and appended to." [{:as opts :keys [kind _]} ::opts {:as fn|globals :keys [fn|ns-name _, fn|overload-bases-name _]} ::fn|globals overload-bases-form _] - (let [overload-bases + (let [new-overload-bases (->> overload-bases-form (uc/map (c/fn [x] (overload-basis-form>overload-basis opts fn|globals x))))] (if (= kind :extend-defn!) - (-> (uid/qualify fn|ns-name fn|overload-bases-name) resolve var-get - (doto - (uref/update! - (c/fn [{:keys [current]}] + (with-do-let [!overload-bases + (-> (uid/qualify fn|ns-name fn|overload-bases-name) resolve var-get)] + (let [{:as overload-bases :keys [current]} (norx-deref !overload-bases) + overload-bases' {:prev-norx (->> current (uc/map @@ -1000,10 +1048,18 @@ :types|split (:types|split basis) :body-codelist (:body-codelist basis) :dependent? (:dependent? basis) - :reactive? (:reactive? basis)}))) - :current (incorporate-overload-bases current overload-bases)})))) - (with-do-let [!overload-bases (urx/! {:prev-norx nil :current overload-bases})] - (intern fn|ns-name fn|overload-bases-name !overload-bases))))) + :reactive? (:reactive? basis) + :inline? (:inline? basis)}))) + :current (incorporate-overload-bases current new-overload-bases)}] + (with-optional-validate-overload-bases overload-bases') + (let [prev-overload-bases (atom nil)] + (alist-conj! !effects-queue + {:f #(do (reset! prev-overload-bases (norx-deref !overload-bases)) + (uref/set! !overload-bases overload-bases')) + :unf #(uref/set! !overload-bases @prev-overload-bases)})))) + (with-do-let [!overload-bases (urx/! {:prev-norx nil :current new-overload-bases})] + (alist-conj! !effects-queue + (>effects-map|intern fn|ns-name fn|overload-bases-name !overload-bases)))))) (defns- >!fn|types "`!fn|types` is a reaction which depends on the `!overload-bases` atom and all reactive types @@ -1014,17 +1070,18 @@ what they'll be for the lifetime of the function." [{:as opts :keys [kind _]} ::opts {:as fn|globals :keys [fn|ns-name _, fn|overload-types-name _, fn|type-name _]} ::fn|globals - !overload-bases _] + !overload-bases urx/reactive?] (if (= kind :extend-defn!) (-> (uid/qualify fn|ns-name fn|overload-types-name) resolve var-get) - (with-do-let [!fn|types (urx/!rx @!overload-bases)] - (uref/add-interceptor! !fn|types :the-interceptor - (c/fn [_ _ old-overload-types overload-bases-data] - ;; `opts` and `fn|globals` are closed over - (overload-bases-data>fn|types - overload-bases-data old-overload-types opts fn|globals))) - (norx-deref !fn|types) - (intern fn|ns-name fn|overload-types-name !fn|types)))) + (with-do-let [!fn|types (doto (urx/!rx @!overload-bases) + (uref/add-interceptor! :the-interceptor + (c/fn [_ _ old-overload-types overload-bases-data] + ;; `opts` and `fn|globals` are closed over + (overload-bases-data>fn|types + overload-bases-data old-overload-types opts fn|globals))) + norx-deref)] + (alist-conj! !effects-queue + (>effects-map|intern fn|ns-name fn|overload-types-name !fn|types))))) (defns- >!fn|type [{:as opts :keys [kind _]} ::opts @@ -1033,7 +1090,7 @@ (if (= kind :extend-defn!) (-> (uid/qualify fn|ns-name fn|type-name) resolve var-get) (with-do-let [!fn|type (t/rx* (urx/>!rx #(:fn|type-norx @!fn|types) {:eq-fn t/=}) nil)] - (intern fn|ns-name fn|type-name !fn|type)))) + (alist-conj! !effects-queue (>effects-map|intern fn|ns-name fn|type-name !fn|type))))) ;; ===== `opts` + `fn|globals` ===== ;; @@ -1086,7 +1143,7 @@ (kw-map fn|globals-name fn|inline? fn|meta fn|name fn|ns-name fn|output-type|form fn|output-type fn|overload-bases-name fn|overload-types-name fn|type-name)] - (intern fn|ns-name fn|globals-name fn|globals) + (alist-conj! !effects-queue (>effects-map|intern fn|ns-name fn|globals-name fn|globals)) (kw-map fn|globals overload-bases-form))))) ;; ===== Whole `t/(de)fn` creation ===== ;; @@ -1097,20 +1154,25 @@ {:keys [fn|globals overload-bases-form]} (>fn|globals+?overload-bases-form kind args) !overload-bases (>!overload-bases opts fn|globals overload-bases-form) !fn|types (>!fn|types opts fn|globals !overload-bases) - !fn|type (>!fn|type opts fn|globals !fn|types)] - (if (empty? (norx-deref !overload-bases)) - `(declare ~(:fn|name fn|globals)) - (let [direct-dispatch (>direct-dispatch opts fn|globals !fn|types) - dynamic-dispatch (>dynamic-dispatch-fn|codelist opts fn|globals !fn|types) - fn-codelist - (->> `[;; For recursion - ~@(when (not= kind :extend-defn!) [`(declare ~(:fn|name fn|globals))]) - ~@(:form direct-dispatch) - ~@dynamic-dispatch] - (remove nil?))] - (case kind - :fn (TODO "Haven't done t/fn yet") - (:defn :extend-defn!) `(do ~@fn-codelist))))) + fn|types (norx-deref !fn|types) + !fn|type (>!fn|type opts fn|globals !fn|types) + code + (if (empty? (norx-deref !overload-bases)) + `(declare ~(:fn|name fn|globals)) + (let [direct-dispatch (>direct-dispatch opts fn|globals fn|types) + dynamic-dispatch (>dynamic-dispatch-fn|codelist opts fn|globals fn|types) + fn-codelist + (->> `[;; For recursion + ~@(when (not= kind :extend-defn!) + [`(declare ~(:fn|name fn|globals))]) + ~@(:form direct-dispatch) + ~@dynamic-dispatch] + (remove nil?))] + (case kind + :fn (TODO "Haven't done t/fn yet") + (:defn :extend-defn!) `(do ~@fn-codelist))))] + (drain-effects-queue!) + code) t (do (ulog/ppr :error t) (throw t)))) diff --git a/src-untyped/quantum/untyped/core/vars.cljc b/src-untyped/quantum/untyped/core/vars.cljc index 2dfb350c..d8ed3255 100644 --- a/src-untyped/quantum/untyped/core/vars.cljc +++ b/src-untyped/quantum/untyped/core/vars.cljc @@ -156,3 +156,5 @@ ([ns-sym #_symbol?, sym #_symbol?, v #_t/ref?] (or (resolve (find-ns ns-sym) sym) (intern! ns-sym sym v)))) + +(def unintern! ns-unmap) diff --git a/src/quantum/core/data/numeric.cljc b/src/quantum/core/data/numeric.cljc index ff2231ae..a24466ed 100644 --- a/src/quantum/core/data/numeric.cljc +++ b/src/quantum/core/data/numeric.cljc @@ -90,6 +90,11 @@ (var/def fixnum? "The set of all fixed-precision numbers." (t/or fixint? fixdec?)) +(var/def fixed-numeric? + "The set of all fixed-precision numeric things. Something 'numeric' is something that may be + treated as a number but may not actually *be* one." + (t/or fixnum? p/char?)) + (var/def bignum? "The set of all 'big' (arbitrary-precision) numbers." (t/or fixint? fixdec?)) @@ -134,7 +139,7 @@ #?(:clj (t/defn ^:inline >java-bigint > java-bigint? - ([x fixnum? > (t/assume java-bigint?)] (-> x >long* BigInteger/valueOf)) + ([x fixed-numeric? > (t/assume java-bigint?)] (-> x >long* BigInteger/valueOf)) ([x java-bigint?] x) ([x clj-bigint? > (t/assume java-bigint?)] (.toBigInteger x)) ;; Truncates the decimal portion @@ -146,8 +151,8 @@ #?(:clj (t/defn ^:inline >clj-bigint > clj-bigint? - ([x fixnum? > (t/assume clj-bigint?)] (-> x >long* BigInt/fromLong)) - ([x java-bigint? > (t/assume clj-bigint?)] (BigInt/fromBigInteger x)) + ([x fixed-numeric? > (t/assume clj-bigint?)] (-> x >long* BigInt/fromLong)) + ([x java-bigint? > (t/assume clj-bigint?)] (BigInt/fromBigInteger x)) ([x clj-bigint?] x) ;; Truncates the decimal portion ;; TODO should this overload be part of `>clj-bigint*`? @@ -158,8 +163,8 @@ #?(:clj (t/defn ^:inline >bigdec > bigdec? - ([x fixint? > (t/assume bigdec?)] (-> x >long* BigDecimal/valueOf)) - ([x fixdec? > (t/assume bigdec?)] (-> x >double* BigDecimal/valueOf)) + ([x (t/or fixint? p/char?) > (t/assume bigdec?)] (-> x >long* BigDecimal/valueOf)) + ([x fixdec? > (t/assume bigdec?)] (-> x >double* BigDecimal/valueOf)) ([x java-bigint?] (BigDecimal. x)) ([x clj-bigint? > (t/assume bigdec?)] (.toBigDecimal x)) ([x bigdec?] x) @@ -168,7 +173,7 @@ #?(:clj (t/defn ^:inline >ratio > ratio? - ([x (t/or fixnum? bigint?)] (Ratio. (>java-bigint x) BigInteger/ONE)) + ([x (t/or fixed-numeric? bigint?)] (Ratio. (>java-bigint x) BigInteger/ONE)) ([x bigdec?] (let [v ^:val (.unscaledValue x) scale (.scale x)] (if (c?/< scale 0) @@ -181,7 +186,8 @@ ;; ===== Comparison extensions ===== ;; ;; TODO primitive with non-primitive -(t/extend-defn! c?/= +;; TODO this errors out in the middle of the effects queue +((t/extend-defn! c?/= ;; `.equals` takes into account precision even if they're numerically equivalent ;; `core/=` uses `.equals` for `BigDecimal`s #?(:clj ([a bigdec? , b bigdec?] (c?/comp= a b))) @@ -193,10 +199,11 @@ #?(:clj ([a clj-bigint? , b clj-bigint?] (.equals a b))) #?(:clj ([a clj-bigint? , b numeric?] (c?/= a (>clj-bigint b)))) #?(:clj ([a numeric? , b clj-bigint?] (c?/= (>clj-bigint a) b))) -#?(:clj ([a ratio? , b ratio?] (and (c?/= (.numerator a) (.numerator b)) - (c?/= (.denominator a) (.denominator b))))) +#?(:clj ([a ratio? , b ratio?] + (and (c?/= ^:val (.numerator a) ^:val (.numerator b)) + (c?/= ^:val (.denominator a) ^:val (.denominator b))))) #?(:clj ([a ratio? , b numeric?] (c?/= a (>ratio b)))) -#?(:clj ([a numeric? , b ratio?] (c?/= (>ratio a) b)))) +#?(:clj ([a numeric? , b ratio?] (c?/= (>ratio a) b))))) ;; TODO primitive with non-primitive (t/extend-defn! c?/< @@ -213,7 +220,7 @@ (c?/comp< (>java-bigint a) (>java-bigint b))))) #?(:clj ([a clj-bigint? , b numeric?] (c?/< a (>clj-bigint b)))) #?(:clj ([a numeric? , b clj-bigint?] (c?/< (>clj-bigint a) b))) -#?(:clj ([a ratio? , b ratio?] +#?(:clj ([a ratio? , b ratio?] (c?/< (.multiply (.numerator a) (.numerator b)) (.multiply (.denominator a) (.denominator b))))) #?(:clj ([a ratio? , b numeric?] (c?/< a (>ratio b)))) From 0bb94002862aa93f44792df3e9633ec5a8e1511b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 12 Nov 2018 19:16:53 -0700 Subject: [PATCH 688/810] Rollbacks actually work correctly now! --- src-untyped/quantum/untyped/core/analyze.cljc | 2 +- .../quantum/untyped/core/type/defnt.cljc | 120 ++++++++---------- src/quantum/core/data/numeric.cljc | 33 ++--- 3 files changed, 69 insertions(+), 86 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 3fec6fff..1d00d777 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -1030,7 +1030,7 @@ (uast/symbol env form node (:type node)))))) (defns- analyze* [env ::env, form _ > uast/node?] - (when (> (uref/get (uref/update! !!analyze-depth inc)) 200) + (when (> (uref/get (uref/update! !!analyze-depth inc)) 500) (throw (ex-info "Stack too deep" {:form form}))) (ifs (symbol? form) (analyze-symbol env form) (t/literal? form) (uast/literal env form (t/value form)) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 38a8bdf9..ec5194c4 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -86,47 +86,32 @@ (defonce !overload-queue (uvec/alist)) ; (t/!seq-of ::types-decl-datum-with-overload) -(uvar/defonce !effects-queue +(uvar/defonce !rollback-queue "To ensure that side-effects are as atomic as possible in the case of a failure in `defn` or `extend-defn!`." (uvec/alist)) ; (t/!seq-of (t/ftype [])) -;; TODO move -(defns- >effects-map|intern [ns-sym simple-symbol?, sym simple-symbol?, v _] +(defns- intern-with-rollback! [ns-sym simple-symbol?, sym simple-symbol?, v _] (let [var-val (resolve (uid/qualify ns-sym sym)) - value (atom nil)] - {:f #(do (when v (reset! value (var-get var-val))) - (intern ns-sym sym v)) - :unf #(if v - (intern ns-sym sym @value) - (uvar/unintern! ns-sym sym))})) - -(defn- drain-effects-queue! - "Runs effect fns, rolling back the already-executed ones in reverse order if any exception occurs." + !value (atom nil)] + (when var-val (reset! !value (var-get var-val))) + (intern ns-sym sym v) + (alist-conj! !rollback-queue + #(if var-val + (intern ns-sym sym @!value) + (uvar/unintern! ns-sym sym))))) + +(defn- drain-rollback-queue! + "Rolls back already-executed effects in reverse order." [] - (println "about to run effects queue") - (try - (->> !effects-queue - (reduce - (c/fn [!done {:as m :keys [f]}] - (uerr/catch-all - (do (f) (alist-conj! !done m)) - effects-err - (do (->> !done - (uc/run! - (c/fn [{:keys [unf]}] - (uerr/catch-all (unf) - rollback-err - (err! nil - "Exception in effects function; unable to roll back all effects" - {:failed-rollback-fn unf} - nil rollback-err))))) - (err! nil "Exception in effects function; rolled back successfully" - {:failed-fn f} - nil effects-err)))) - (uvec/alist))) - (finally (uvec/alist-empty! !effects-queue))) - (println "done with effects queue")) + (->> !rollback-queue + reverse + (uc/run! + (c/fn [rollback-fn] + (uerr/catch-all (rollback-fn) + rollback-err + (err! nil "Unable to roll back all effects" {:failed-rollback-fn rollback-fn} + nil rollback-err)))))) ;; ==== Internal specs ===== ;; @@ -554,8 +539,7 @@ (ufth/with-type-hint "[Ljava.lang.Object;")) form (if (or (not= compilation-mode :test) (= lang :clj)) (let [arg-types (overload-types>arg-types fn|types index)] - (do (alist-conj! !effects-queue - (>effects-map|intern ns-name- decl-name arg-types)) + (do (intern-with-rollback! ns-name- decl-name arg-types) nil)) `(def ~decl-name (overload-types>arg-types @@ -787,7 +771,6 @@ {:overload-types-decl (>overload-types-decl opts fn|globals type-decl-datum fn|types) :reify (overload>reify overload opts fn|globals id)}))) - _ (uvec/alist-empty! !overload-queue) form (->> direct-dispatch-data-seq (uc/mapcat (c/fn [{:as direct-dispatch-data :keys [overload-types-decl]}] @@ -1052,14 +1035,12 @@ :inline? (:inline? basis)}))) :current (incorporate-overload-bases current new-overload-bases)}] (with-optional-validate-overload-bases overload-bases') - (let [prev-overload-bases (atom nil)] - (alist-conj! !effects-queue - {:f #(do (reset! prev-overload-bases (norx-deref !overload-bases)) - (uref/set! !overload-bases overload-bases')) - :unf #(uref/set! !overload-bases @prev-overload-bases)})))) + (let [prev-overload-bases (norx-deref !overload-bases)] + (alist-conj! !rollback-queue + #(uref/set! !overload-bases prev-overload-bases)) + (uref/set! !overload-bases overload-bases')))) (with-do-let [!overload-bases (urx/! {:prev-norx nil :current new-overload-bases})] - (alist-conj! !effects-queue - (>effects-map|intern fn|ns-name fn|overload-bases-name !overload-bases)))))) + (intern-with-rollback! fn|ns-name fn|overload-bases-name !overload-bases))))) (defns- >!fn|types "`!fn|types` is a reaction which depends on the `!overload-bases` atom and all reactive types @@ -1080,8 +1061,7 @@ (overload-bases-data>fn|types overload-bases-data old-overload-types opts fn|globals))) norx-deref)] - (alist-conj! !effects-queue - (>effects-map|intern fn|ns-name fn|overload-types-name !fn|types))))) + (intern-with-rollback! fn|ns-name fn|overload-types-name !fn|types)))) (defns- >!fn|type [{:as opts :keys [kind _]} ::opts @@ -1090,7 +1070,7 @@ (if (= kind :extend-defn!) (-> (uid/qualify fn|ns-name fn|type-name) resolve var-get) (with-do-let [!fn|type (t/rx* (urx/>!rx #(:fn|type-norx @!fn|types) {:eq-fn t/=}) nil)] - (alist-conj! !effects-queue (>effects-map|intern fn|ns-name fn|type-name !fn|type))))) + (intern-with-rollback! fn|ns-name fn|type-name !fn|type)))) ;; ===== `opts` + `fn|globals` ===== ;; @@ -1143,7 +1123,7 @@ (kw-map fn|globals-name fn|inline? fn|meta fn|name fn|ns-name fn|output-type|form fn|output-type fn|overload-bases-name fn|overload-types-name fn|type-name)] - (alist-conj! !effects-queue (>effects-map|intern fn|ns-name fn|globals-name fn|globals)) + (intern-with-rollback! fn|ns-name fn|globals-name fn|globals) (kw-map fn|globals overload-bases-form))))) ;; ===== Whole `t/(de)fn` creation ===== ;; @@ -1155,27 +1135,27 @@ !overload-bases (>!overload-bases opts fn|globals overload-bases-form) !fn|types (>!fn|types opts fn|globals !overload-bases) fn|types (norx-deref !fn|types) - !fn|type (>!fn|type opts fn|globals !fn|types) - code - (if (empty? (norx-deref !overload-bases)) - `(declare ~(:fn|name fn|globals)) - (let [direct-dispatch (>direct-dispatch opts fn|globals fn|types) - dynamic-dispatch (>dynamic-dispatch-fn|codelist opts fn|globals fn|types) - fn-codelist - (->> `[;; For recursion - ~@(when (not= kind :extend-defn!) - [`(declare ~(:fn|name fn|globals))]) - ~@(:form direct-dispatch) - ~@dynamic-dispatch] - (remove nil?))] - (case kind - :fn (TODO "Haven't done t/fn yet") - (:defn :extend-defn!) `(do ~@fn-codelist))))] - (drain-effects-queue!) - code) - t - (do (ulog/ppr :error t) - (throw t)))) + !fn|type (>!fn|type opts fn|globals !fn|types)] + (if (empty? (norx-deref !overload-bases)) + `(declare ~(:fn|name fn|globals)) + (let [direct-dispatch (>direct-dispatch opts fn|globals fn|types) + dynamic-dispatch (>dynamic-dispatch-fn|codelist opts fn|globals fn|types) + fn-codelist + (->> `[;; For recursion + ~@(when (not= kind :extend-defn!) + [`(declare ~(:fn|name fn|globals))]) + ~@(:form direct-dispatch) + ~@dynamic-dispatch] + (remove nil?))] + (case kind + :fn (TODO "Haven't done t/fn yet") + (:defn :extend-defn!) `(do ~@fn-codelist))))) + e + (do (ulog/ppr :error e) + (drain-rollback-queue!) + (err! nil "Exception; rolled back successfully" nil nil e)) + (do (uvec/alist-empty! !rollback-queue) + (uvec/alist-empty! !overload-queue)))) #?(:clj (defmacro fn diff --git a/src/quantum/core/data/numeric.cljc b/src/quantum/core/data/numeric.cljc index a24466ed..52eace97 100644 --- a/src/quantum/core/data/numeric.cljc +++ b/src/quantum/core/data/numeric.cljc @@ -147,7 +147,7 @@ ([x bigdec? > (t/assume java-bigint?)] (.toBigInteger x)) ;; Truncates the decimal portion ;; TODO should this overload be part of `>java-bigint*`? - ([x ratio? > (t/assume java-bigint?)] (.bigIntegerValue x))) + ([x ratio? > (t/assume java-bigint?)] (.bigIntegerValue x)))) #?(:clj (t/defn ^:inline >clj-bigint > clj-bigint? @@ -186,24 +186,27 @@ ;; ===== Comparison extensions ===== ;; ;; TODO primitive with non-primitive -;; TODO this errors out in the middle of the effects queue -((t/extend-defn! c?/= +(t/extend-defn! c?/= ;; `.equals` takes into account precision even if they're numerically equivalent ;; `core/=` uses `.equals` for `BigDecimal`s -#?(:clj ([a bigdec? , b bigdec?] (c?/comp= a b))) -#?(:clj ([a bigdec? , b numeric?] (c?/= a (>bigdec b)))) -#?(:clj ([a numeric? , b bigdec?] (c?/= (>bigdec a) b))) -#?(:clj ([a java-bigint?, b java-bigint?] (.equals a b))) -#?(:clj ([a java-bigint?, b numeric?] (c?/= a (>java-bigint b)))) -#?(:clj ([a numeric? , b java-bigint?] (c?/= (>java-bigint a) b))) -#?(:clj ([a clj-bigint? , b clj-bigint?] (.equals a b))) -#?(:clj ([a clj-bigint? , b numeric?] (c?/= a (>clj-bigint b)))) -#?(:clj ([a numeric? , b clj-bigint?] (c?/= (>clj-bigint a) b))) -#?(:clj ([a ratio? , b ratio?] +#?(:clj ([a bigdec? , b bigdec?] (c?/comp= a b))) +#?(:clj ([a bigdec? , b (t/input-type >bigdec :?)] + (c?/= a (>bigdec b)))) +#?(:clj ([a (t/input-type >bigdec :?) , b bigdec?] (c?/= (>bigdec a) b))) +#?(:clj ([a java-bigint? , b java-bigint?] (.equals a b))) +#?(:clj ([a java-bigint? , b (t/input-type >java-bigint :?)] + (c?/= a (>java-bigint b)))) +#?(:clj ([a (t/input-type >java-bigint :?), b java-bigint?] (c?/= (>java-bigint a) b))) +#?(:clj ([a clj-bigint? , b clj-bigint?] (.equals a b))) +#?(:clj ([a clj-bigint? , b (t/input-type >clj-bigint :?)] + (c?/= a (>clj-bigint b)))) +#?(:clj ([a (t/input-type >clj-bigint :?) , b clj-bigint?] (c?/= (>clj-bigint a) b))) +#?(:clj ([a ratio? , b ratio?] (and (c?/= ^:val (.numerator a) ^:val (.numerator b)) (c?/= ^:val (.denominator a) ^:val (.denominator b))))) -#?(:clj ([a ratio? , b numeric?] (c?/= a (>ratio b)))) -#?(:clj ([a numeric? , b ratio?] (c?/= (>ratio a) b))))) +#?(:clj ([a ratio? , b (t/input-type >ratio :?)] + (c?/= a (>ratio b)))) +#?(:clj ([a (t/input-type >ratio :?) , b ratio?] (c?/= (>ratio a) b)))) ;; TODO primitive with non-primitive (t/extend-defn! c?/< From fb6bba8358d94c079671d99a556db9da8ea80069 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 12 Nov 2018 19:44:56 -0700 Subject: [PATCH 689/810] More success! --- src/quantum/core/data/numeric.cljc | 72 +++++++++++++++++++----------- 1 file changed, 46 insertions(+), 26 deletions(-) diff --git a/src/quantum/core/data/numeric.cljc b/src/quantum/core/data/numeric.cljc index 52eace97..1d5be8dd 100644 --- a/src/quantum/core/data/numeric.cljc +++ b/src/quantum/core/data/numeric.cljc @@ -209,41 +209,60 @@ #?(:clj ([a (t/input-type >ratio :?) , b ratio?] (c?/= (>ratio a) b)))) ;; TODO primitive with non-primitive +;; FIXME (c?/< (>clj-bigint 1) (>clj-bigint 2)) +;; `This function is unsupported for the type combination at the argument index` +;; FIXME BigInteger and BigDecimal literals in analyzer (t/extend-defn! c?/< ([x numeric?] true) -#?(:clj ([a bigdec? , b bigdec?] (c?/comp< a b))) -#?(:clj ([a bigdec? , b numeric?] (c?/< a (>bigdec b)))) -#?(:clj ([a numeric? , b bigdec?] (c?/< (>bigdec a) b))) -#?(:clj ([a java-bigint?, b java-bigint?] (c?/comp< a b))) -#?(:clj ([a java-bigint?, b numeric?] (c?/< a (>java-bigint b)))) -#?(:clj ([a numeric? , b java-bigint?] (c?/< (>java-bigint a) b))) -#?(:clj ([a clj-bigint?, b clj-bigint?] +#?(:clj ([a bigdec? , b bigdec?] (c?/comp< a b))) +#?(:clj ([a bigdec? , b (t/input-type >bigdec :?)] + (c?/< a (>bigdec b)))) +#?(:clj ([a (t/input-type >bigdec :?) , b bigdec?] (c?/< (>bigdec a) b))) +#?(:clj ([a java-bigint? , b java-bigint?] (c?/comp< a b))) +#?(:clj ([a java-bigint? , b (t/input-type >java-bigint :?)] + (c?/< a (>java-bigint b)))) +#?(:clj ([a (t/input-type >java-bigint :?), b java-bigint?] (c?/< (>java-bigint a) b))) +#?(:clj ([a clj-bigint? , b clj-bigint?] (if (and (p/nil? (.bipart a)) (p/nil? (.bipart b))) - (c?/< (.lpart a) (.lpart b)) + (c?/< (.lpart a) (.lpart b)) (c?/comp< (>java-bigint a) (>java-bigint b))))) -#?(:clj ([a clj-bigint? , b numeric?] (c?/< a (>clj-bigint b)))) -#?(:clj ([a numeric? , b clj-bigint?] (c?/< (>clj-bigint a) b))) -#?(:clj ([a ratio? , b ratio?] - (c?/< (.multiply (.numerator a) (.numerator b)) - (.multiply (.denominator a) (.denominator b))))) -#?(:clj ([a ratio? , b numeric?] (c?/< a (>ratio b)))) -#?(:clj ([a numeric? , b ratio?] (c?/< (>ratio a) b)))) +#?(:clj ([a clj-bigint? , b (t/input-type >clj-bigint :?)] + (c?/< a (>clj-bigint b)))) +#?(:clj ([a (t/input-type >clj-bigint :?) , b clj-bigint?] (c?/< (>clj-bigint a) b))) +#?(:clj ([a ratio? , b ratio?] + (c?/< ^:val (.multiply ^:val (.numerator a) ^:val (.numerator b)) + ^:val (.multiply ^:val (.denominator a) ^:val (.denominator b))))) +#?(:clj ([a ratio? , b (t/input-type >ratio :?)] + (c?/< a (>ratio b)))) +#?(:clj ([a (t/input-type >ratio :?) , b ratio?] (c?/< (>ratio a) b)))) ;; TODO primitive with non-primitive (t/extend-defn! c?/<= ([x numeric?] true) -#?(:clj ([a bigdec? , b bigdec?] (c?/comp<= a b))) -#?(:clj ([a bigdec? , b numeric?] (c?/<= a (>bigdec b)))) -#?(:clj ([a numeric? , b bigdec?] (c?/<= (>bigdec a) b))) -#?(:clj ([a clj-bigint?, b clj-bigint?] +#?(:clj ([a bigdec? , b bigdec?] (c?/comp<= a b))) +#?(:clj ([a bigdec? , b (t/input-type >bigdec :?)] + (c?/<= a (>bigdec b)))) +#?(:clj ([a (t/input-type >bigdec :?) , b bigdec?] (c?/<= (>bigdec a) b))) +#?(:clj ([a java-bigint? , b java-bigint?] (c?/comp<= a b))) +#?(:clj ([a java-bigint? , b (t/input-type >java-bigint :?)] + (c?/<= a (>java-bigint b)))) +#?(:clj ([a (t/input-type >java-bigint :?), b java-bigint?] (c?/<= (>java-bigint a) b))) +#?(:clj ([a clj-bigint? , b clj-bigint?] (if (and (p/nil? (.bipart a)) (p/nil? (.bipart b))) (c?/<= (.lpart a) (.lpart b)) (c?/comp<= (>java-bigint a) (>java-bigint b))))) -#?(:clj ([a ratio? , b ratio?] - (c?/<= (.multiply (.numerator a) (.numerator b)) - (.multiply (.denominator a) (.denominator b)))))) +#?(:clj ([a clj-bigint? , b (t/input-type >clj-bigint :?)] + (c?/<= a (>clj-bigint b)))) +#?(:clj ([a (t/input-type >clj-bigint :?) , b clj-bigint?] (c?/<= (>clj-bigint a) b))) +#?(:clj ([a ratio? , b ratio?] + (c?/<= ^:val (.multiply ^:val (.numerator a) ^:val (.numerator b)) + ^:val (.multiply ^:val (.denominator a) ^:val (.denominator b))))) +#?(:clj ([a ratio? , b (t/input-type >ratio :?)] + (c?/<= a (>ratio b)))) +#?(:clj ([a (t/input-type >ratio :?) , b ratio?] (c?/<= (>ratio a) b)))) ;; TODO primitive with non-primitive +;; TODO all the stuff the `<` extension has (t/extend-defn! c?/> ([x numeric?] true) #?(:clj ([a bigdec? , b bigdec?] (c?/comp> a b))) @@ -258,6 +277,7 @@ (.multiply (.denominator a) (.denominator b)))))) ;; TODO primitive with non-primitive +;; TODO all the stuff the `<` extension has (t/extend-defn! c?/>= ([x numeric?] true) #?(:clj ([a bigdec? , b bigdec?] (c?/comp>= a b))) @@ -293,11 +313,11 @@ #?(:clj (^:in [x (t/or p/long? p/double?)] (Numbers/isZero x))) #?(:clj ( [x (t/- p/numeric? p/long? p/double?)] (Numeric/isZero x))) #?(:clj ( [x clj-bigint?] (if (p/nil? (.bipart x)) - (-> x .lpart zero?) - (-> x .bipart zero?)))) + (-> x (.lpart) zero?) + (-> x ^:val (.bipart) zero?)))) #?(:clj ( [x (t/or java-bigint? bigdec?)] (-> x .signum zero?))) -#?(:clj ( [x ratio?] (-> x .numerator zero?))) - ( [x #?(:clj (t/ref number?) :cljs numeric?)] (?/= x 0))) +#?(:clj ( [x ratio?] (-> x ^:val (.numerator) zero?))) + ( [x #?(:clj (t/ref number?) :cljs numeric?)] (c?/= x 0))) (t/defn ^:inline >one-of-type #_> #_one? #?(:clj ([x p/byte? > (t/type x)] Numeric/byte1)) From ff2ccf9939c05b4ffff1044c9308a2cdee453f25 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 13 Nov 2018 14:55:04 -0700 Subject: [PATCH 690/810] Begin quantum.core.fn work --- src-untyped/quantum/untyped/core/type.cljc | 5 +++-- src/quantum/core/data/numeric.cljc | 17 +++++++---------- src/quantum/core/fn.cljc | 3 ++- 3 files changed, 12 insertions(+), 13 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 34c53be9..f2c71aa4 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -999,8 +999,9 @@ ;; Used by `quantum.untyped.core.analyze` (def literal? - (or nil? boolean? symbol? keyword? string? #?(:clj long?) double? regex? - #?(:clj tagged-literal?))) + (or nil? boolean? symbol? keyword? string? + #?(:clj long?) double? #?(:clj (isa? clojure.lang.BigInt)) #?(:clj (isa? BigDecimal)) + regex? #?(:clj tagged-literal?))) ;; TODO this might not be right — quite possibly any seq is a valid form ;; TODO this has to be recursively true for seq, vector, map, and set diff --git a/src/quantum/core/data/numeric.cljc b/src/quantum/core/data/numeric.cljc index 1d5be8dd..95343c09 100644 --- a/src/quantum/core/data/numeric.cljc +++ b/src/quantum/core/data/numeric.cljc @@ -211,7 +211,6 @@ ;; TODO primitive with non-primitive ;; FIXME (c?/< (>clj-bigint 1) (>clj-bigint 2)) ;; `This function is unsupported for the type combination at the argument index` -;; FIXME BigInteger and BigDecimal literals in analyzer (t/extend-defn! c?/< ([x numeric?] true) #?(:clj ([a bigdec? , b bigdec?] (c?/comp< a b))) @@ -228,13 +227,13 @@ (c?/comp< (>java-bigint a) (>java-bigint b))))) #?(:clj ([a clj-bigint? , b (t/input-type >clj-bigint :?)] (c?/< a (>clj-bigint b)))) -#?(:clj ([a (t/input-type >clj-bigint :?) , b clj-bigint?] (c?/< (>clj-bigint a) b))) +#?(:clj ([a (t/input-type >clj-bigint :?) , b clj-bigint?] (c?/< (>clj-bigint a) b))) #?(:clj ([a ratio? , b ratio?] (c?/< ^:val (.multiply ^:val (.numerator a) ^:val (.numerator b)) ^:val (.multiply ^:val (.denominator a) ^:val (.denominator b))))) #?(:clj ([a ratio? , b (t/input-type >ratio :?)] (c?/< a (>ratio b)))) -#?(:clj ([a (t/input-type >ratio :?) , b ratio?] (c?/< (>ratio a) b)))) +#?(:clj ([a (t/input-type >ratio :?) , b ratio?] (c?/< (>ratio a) b)))) ;; TODO primitive with non-primitive (t/extend-defn! c?/<= @@ -340,12 +339,12 @@ (t/defn ^:inline neg? > p/boolean? #?(:clj (^:in [x (t/or p/long? p/double?)] (Numbers/isNeg x))) #?(:clj ( [x (t/- p/numeric? p/long? p/double?)] (Numeric/isNeg x))) -#?(:clj ( [x clj-bigint?] (if (?/nil? (.bipart x)) +#?(:clj ( [x clj-bigint?] (if (p/nil? (.bipart x)) (-> x .lpart neg?) (-> x .bipart neg?)))) #?(:clj ( [x (t/or java-bigint? bigdec?)] (-> x .signum neg?))) #?(:clj ( [x ratio?] (-> x .numerator neg?))) - ( [x #?(:clj (t/ref number?) :clj numeric?)] (?/< x 0))) + ( [x #?(:clj (t/ref number?) :clj numeric?)] (c?/< x 0))) ; TODO dispatch not present ;; TODO TYPED this should realize that we're negating a `<` and change the operator to `<=` (t/def nneg? (fn/comp ?/not neg?)) @@ -358,7 +357,7 @@ (-> x .bipart pos?)))) #?(:clj ( [x (t/or java-bigint? bigdec?)] (-> x .signum pos?))) #?(:clj ( [x ratio?] (-> x .numerator pos?))) - ( [x #?(:clj (t/ref number?) :clj numeric?)] (c?/> x 0))) + ( [x #?(:clj (t/ref number?) :clj numeric?)] (c?/> x 0))) ; TODO dispatch not present ;; TODO TYPED this should realize that we're negating a `<` and change the operator to `<=` (t/def npos? (fn/comp ?/not pos?)) @@ -383,7 +382,7 @@ ;; ===== Likenesses ===== ;; -(t/defn integer-value? ; TODO this is the same as `numerically-integer?` but we need to turn it into a predicate +(t/defn numerically-integer? ; TODO turn it into a type {:adapted-from '#{com.google.common.math.DoubleMath/isMathematicalInteger "https://stackoverflow.com/questions/1078953/check-if-bigdecimal-is-integer-value"}} @@ -394,9 +393,7 @@ #?(:clj ( [x bigdec?] (or (zero? (.signum x)) (-> x .scale npos?) (-> x .stripTrailingZeros .scale npos?)))) -#?(:clj ( [x (t/ref number?)] x))) - -(def numerically-integer? (t/or integer? (t/and decimal? (>expr unum/integer-value?)))) +#?(:clj ( [x (t/ref number?)] false))) #_(def numerically-byte? (and numerically-integer? (>expr (c/fn [x] (c/<= -128 x 127))))) diff --git a/src/quantum/core/fn.cljc b/src/quantum/core/fn.cljc index be53bc17..9f3f2a55 100644 --- a/src/quantum/core/fn.cljc +++ b/src/quantum/core/fn.cljc @@ -26,7 +26,8 @@ ;; TODO TYPED move to `data.fn`? (def multimethod? (t/isa? #?(:clj clojure.lang.MultiFn :cljs cljs.core/IMultiFn))) -(t/defn ^:inline identity [x t/any? > (t/== x)] x) +;; TODO TYPED `t/==` +(t/defn ^:inline identity [x t/any? #_> #_(t/== x)] x) ;; ===== `fn`: Positional functions ===== ;; From c89cce301d2b27858f1036b59c2f13e371166404 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 13 Nov 2018 16:56:33 -0700 Subject: [PATCH 691/810] project-base.clj now handles proto-REPL --- project-base.clj | 60 ++++++++++++++++++++++++++++------------ src/quantum/core/fn.cljc | 3 +- 2 files changed, 44 insertions(+), 19 deletions(-) diff --git a/project-base.clj b/project-base.clj index a52d376d..7c1cdb26 100644 --- a/project-base.clj +++ b/project-base.clj @@ -6,6 +6,8 @@ [clojure.string :as str] [leiningen.core.project :as project])) +;; ===== Utils ===== ;; + (defn merge-with-k "Like `merge-with`, but the merging function takes the key being merged as the first argument" @@ -25,6 +27,8 @@ (reduce merge-entry (or m1 {}) (seq m2))))] (reduce merge2 maps)))) +;; ===== Dependencies ===== ;; + (def clj-dependency '[org.clojure/clojure "1.9.0"]) (def cljs-dependency '[org.clojure/clojurescript "1.10.312"]) @@ -438,7 +442,8 @@ "/" "js") output-dir (str server-root-path "/" asset-path)] (cond-> - {:source-paths + {:id id + :source-paths (vec (concat source-paths (case id-suffix @@ -500,9 +505,9 @@ (->> (conj id-suffixes nil) ; for default non-suffixed version (map (fn [id-suffix] (let [id (str (name id-base) (some->> id-suffix name (str "-")))] - [id (id>config id id-base id-suffix)])))))) + (id>config id id-base id-suffix))))))) (apply concat) - (into {})))] + vec))] (id-bases>configs (cond-> #{:web} react-native? (conj :ios :android))))) (defn >default-config [opts project-config] @@ -638,7 +643,7 @@ "-XX:-OmitStackTraceInFastThrow" "-XX:ErrorFile=./JVMErrorDump.log" "-Dquantum.core.log|out-file=./out.log" - "-Dquantum.core.log|print-to-stderror=false" + "-Dquantum.core.log|print-to-stderror=true" ;; ----- Compilation ----- ;; #_(case system-type "t2.micro" @@ -699,10 +704,10 @@ ;; ===== Dependencies ===== ;; :dependencies [clj-dependency cljs-dependency] ;; ===== Paths ===== ;; - :target-path "target" - :test-paths ["test"] - :source-paths ["src"] :java-source-paths ["src-java"] + :source-paths ["src"] + :target-path "target" + :test-paths ["test"] ;; ===== Compilation ===== ;; :jar-name (str artifact-base-name "-dep.jar") :uberjar-name (str artifact-base-name ".jar") @@ -816,7 +821,8 @@ {:jvm-opts (into ["-Dquantum.core.system|profile=dev"] (>jvm-opts :dev)) :resource-paths ["resources-dev"] :source-paths ["src-dev"] - :plugins '[[lein-nodisassemble "0.1.3"]]} + :dependencies '[[org.clojure/tools.nrepl "0.2.13"]] + :plugins '[[lein-nodisassemble "0.1.3"]]} :test {:jvm-opts (>jvm-opts :test)} :prod @@ -831,16 +837,34 @@ {:plugins '[[com.jakemccrary/lein-test-refresh "0.16.0"]]} :frontend {:source-paths ["src-frontend"] - :plugins '[[lein-cljsbuild "1.1.7" - :exclusions [org.clojure/clojure org.clojure/clojurescript]]]} + :plugins '[[lein-cljsbuild "1.1.7" + :exclusions [org.clojure/clojure org.clojure/clojurescript]]]} :frontend|dev {:plugins '[[lein-figwheel "0.5.14"]] :cljsbuild - {:builds (>cljsbuild-builds :dev project-config opts ["src" "src-frontend" "src-dev"] artifact-base-name)} + {:builds (>cljsbuild-builds :dev project-config opts + ["src" "src-frontend" "src-dev"] artifact-base-name)} :figwheel {:http-server-root "server-root" ; assumes "resources" is prepended :server-port 3450 :css-dirs ["resources/server-root/css"]}} + :frontend|dev|proto-repl + {:plugins '[[lein-figwheel "0.5.14"]] + :dependencies '[[figwheel-sidecar "0.5.17"] + [com.cemerick/piggieback "0.2.2"] + [proto-repl "0.3.1"] + ;; To ensure Figwheel loads the project.clj correctly + [leiningen-core "2.8.1"]] + :repl-options ^:replace + {:nrepl-middleware '[cemerick.piggieback/wrap-cljs-repl] + :init + `(do (require 'figwheel-sidecar.repl-api) + (figwheel-sidecar.repl-api/start-figwheel! + {:build-ids ["web"] + :all-builds + '~(>cljsbuild-builds :dev project-config opts + ["src" "src-frontend" "src-dev"] artifact-base-name)}) + (figwheel-sidecar.repl-api/cljs-repl))}} :frontend|dev|re-frame-trace {:source-paths [(:re-frame-trace quantum-source-paths)] ;; It might work with React Native: https://github.com/Day8/re-frame-trace/issues/75 @@ -918,9 +942,11 @@ config# (with-default-config opts# ~config) _# (when (:print-config? opts#) (pprint config#)) root# ~(when f (.getParent f))] - (def ~'project - (project/make - (dissoc config# :name :version) - (:name config#) - (:version config#) - root#)))))) + (let [project-map# + (project/make + (dissoc config# :name :version) + (:name config#) + (:version config#) + root#)] + (def ~'simple-lein-project project-map#) ; for Figwheel+nREPL + (def ~'project project-map#)))))) diff --git a/src/quantum/core/fn.cljc b/src/quantum/core/fn.cljc index 9f3f2a55..52e8b6a2 100644 --- a/src/quantum/core/fn.cljc +++ b/src/quantum/core/fn.cljc @@ -7,8 +7,7 @@ (:require [clojure.core :as core] [clojure.walk] - [quantum.core.core :as qcore] - [quantum.core.typed :as t] + [quantum.core.type :as t] [quantum.untyped.core.form.evaluate :refer [case-env compile-if]] [quantum.untyped.core.form.generate From d96cb108649e5dd117df59027b1901edfbaa0238 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 14 Nov 2018 23:53:03 -0700 Subject: [PATCH 692/810] Add `proto-repl` to project-base.clj --- project-base.clj | 17 ++++++++++++----- 1 file changed, 12 insertions(+), 5 deletions(-) diff --git a/project-base.clj b/project-base.clj index 7c1cdb26..1ced8ef4 100644 --- a/project-base.clj +++ b/project-base.clj @@ -27,6 +27,11 @@ (reduce merge-entry (or m1 {}) (seq m2))))] (reduce merge2 maps)))) +(defn remove-nil-vals [m] + (->> m + (remove (fn [[_ v]] (nil? v))) + (into {}))) + ;; ===== Dependencies ===== ;; (def clj-dependency '[org.clojure/clojure "1.9.0"]) @@ -63,11 +68,6 @@ (defn with-profiles [profiles & args] (into ["with-profile" (->> profiles (map name) (str/join ","))] args)) -(defn remove-nil-vals [m] - (->> m - (remove (fn [[_ v]] (nil? v))) - (into {}))) - (def base-config|quantum {;; ===== Dependencies ===== ;; :repositories @@ -793,10 +793,17 @@ "autobuilder|frontend|debug" ; accepts 1 arg: the target platform name (with-profiles (cond-> [:frontend :dev :frontend|dev] (not quantum?) (conj :quantum|static-deps)) "cljsbuild" "auto") + "autobuilder|frontend|debug|proto-repl" ; accepts 1 arg: the target platform name + (with-profiles (cond-> [:frontend :dev :frontend|dev :frontend|dev|proto-repl] (not quantum?) (conj :quantum|static-deps)) + "cljsbuild" "auto") "autobuilder|frontend|debug|quantum-dynamic" ; accepts 1 arg: the target platform name (when-not quantum? (with-profiles [:frontend :dev :frontend|dev :quantum|dynamic-deps :quantum|dynamic-source] "cljsbuild" "auto")) + "autobuilder|frontend|debug|quantum-dynamic|proto-repl" ; accepts 1 arg: the target platform name + (when-not quantum? + (with-profiles [:frontend :dev :frontend|dev :frontend|dev|proto-repl :quantum|dynamic-deps :quantum|dynamic-source] + "cljsbuild" "auto")) "autobuilder|frontend|debug|quantum-dynamic-untyped" ; accepts 1 arg: the target platform name (when-not quantum? (with-profiles [:frontend :dev :frontend|dev :quantum|dynamic-deps :quantum|dynamic-source|untyped] From 8b0e487e829fc5ffad4345e90e8b27d74db76c22 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 14 Nov 2018 23:53:13 -0700 Subject: [PATCH 693/810] Add `*<>|macro` --- .../quantum/untyped/core/data/array.cljc | 77 ++++++++++++------- 1 file changed, 50 insertions(+), 27 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/array.cljc b/src-untyped/quantum/untyped/core/data/array.cljc index effaca2c..f7a25e3f 100644 --- a/src-untyped/quantum/untyped/core/data/array.cljc +++ b/src-untyped/quantum/untyped/core/data/array.cljc @@ -2,52 +2,75 @@ (:refer-clojure :exclude [array array?]) (:require - [clojure.core :as core] - [quantum.untyped.core.loops :as uloop]) + [clojure.core :as core] + [quantum.untyped.core.loops :as uloop]) #?(:clj (:import + [quantum.core Primitive] [quantum.core.data Array]))) (defn array? [x] #?(:clj (-> x class .isArray) ; must be reflective :cljs (core/array? x))) -(defn ^"[Ljava.lang.Object;" *<> +#?(:clj +(defmacro *<>|macro ([] - #?(:clj (Array/newUninitialized1dObjectArray 0) - :cljs #js [])) + #?(:clj `(Array/newUninitialized1dObjectArray 0) + :cljs `(core/array))) ([x0] - #?(:clj (Array/new1dObjectArray x0) - :cljs #js [x0])) + #?(:clj `(Array/new1dObjectArray ~x0) + :cljs `(core/array ~x0))) ([x0 x1] - #?(:clj (Array/new1dObjectArray x0 x1) - :cljs #js [x0 x1])) + #?(:clj `(Array/new1dObjectArray ~x0 ~x1) + :cljs `(core/array ~x0 ~x1))) ([x0 x1 x2] - #?(:clj (Array/new1dObjectArray x0 x1 x2) - :cljs #js [x0 x1 x2])) + #?(:clj `(Array/new1dObjectArray ~x0 ~x1 ~x2) + :cljs `(core/array ~x0 ~x1 ~x2))) ([x0 x1 x2 x3] - #?(:clj (Array/new1dObjectArray x0 x1 x2 x3) - :cljs #js [x0 x1 x2 x3])) + #?(:clj `(Array/new1dObjectArray ~x0 ~x1 ~x2 ~x3) + :cljs `(core/array ~x0 ~x1 ~x2 ~x3))) ([x0 x1 x2 x3 x4] - #?(:clj (Array/new1dObjectArray x0 x1 x2 x3 x4) - :cljs #js [x0 x1 x2 x3 x4])) + #?(:clj `(Array/new1dObjectArray ~x0 ~x1 ~x2 ~x3 ~x4) + :cljs `(core/array ~x0 ~x1 ~x2 ~x3 ~x4))) ([x0 x1 x2 x3 x4 x5] - #?(:clj (Array/new1dObjectArray x0 x1 x2 x3 x4 x5) - :cljs #js [x0 x1 x2 x3 x4 x5])) + #?(:clj `(Array/new1dObjectArray ~x0 ~x1 ~x2 ~x3 ~x4 ~x5) + :cljs `(core/array ~x0 ~x1 ~x2 ~x3 ~x4 ~x5))) ([x0 x1 x2 x3 x4 x5 x6] - #?(:clj (Array/new1dObjectArray x0 x1 x2 x3 x4 x5 x6) - :cljs #js [x0 x1 x2 x3 x4 x5 x6])) + #?(:clj `(Array/new1dObjectArray ~x0 ~x1 ~x2 ~x3 ~x4 ~x5 ~x6) + :cljs `(core/array ~x0 ~x1 ~x2 ~x3 ~x4 ~x5 ~x6))) ([x0 x1 x2 x3 x4 x5 x6 x7] - #?(:clj (Array/new1dObjectArray x0 x1 x2 x3 x4 x5 x6 x7) - :cljs #js [x0 x1 x2 x3 x4 x5 x6 x7])) + #?(:clj `(Array/new1dObjectArray ~x0 ~x1 ~x2 ~x3 ~x4 ~x5 ~x6 ~x7) + :cljs `(core/array ~x0 ~x1 ~x2 ~x3 ~x4 ~x5 ~x6 ~x7))) ([x0 x1 x2 x3 x4 x5 x6 x7 x8] - #?(:clj (Array/new1dObjectArray x0 x1 x2 x3 x4 x5 x6 x7 x8) - :cljs #js [x0 x1 x2 x3 x4 x5 x6 x7 x8])) + #?(:clj `(Array/new1dObjectArray ~x0 ~x1 ~x2 ~x3 ~x4 ~x5 ~x6 ~x7 ~x8) + :cljs `(core/array ~x0 ~x1 ~x2 ~x3 ~x4 ~x5 ~x6 ~x7 ~x8))) ([x0 x1 x2 x3 x4 x5 x6 x7 x8 x9] - #?(:clj (Array/new1dObjectArray x0 x1 x2 x3 x4 x5 x6 x7 x8 x9) - :cljs #js [x0 x1 x2 x3 x4 x5 x6 x7 x8 x9])) + #?(:clj `(Array/new1dObjectArray ~x0 ~x1 ~x2 ~x3 ~x4 ~x5 ~x6 ~x7 ~x8 ~x9) + :cljs `(core/array ~x0 ~x1 ~x2 ~x3 ~x4 ~x5 ~x6 ~x7 ~x8 ~x9))) ([x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10] - #?(:clj (Array/new1dObjectArray x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) - :cljs #js [x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10])) + #?(:clj `(Array/new1dObjectArray ~x0 ~x1 ~x2 ~x3 ~x4 ~x5 ~x6 ~x7 ~x8 ~x9 ~x10) + :cljs `(core/array ~x0 ~x1 ~x2 ~x3 ~x4 ~x5 ~x6 ~x7 ~x8 ~x9 ~x10))) + ([x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 & xs] + #?(:clj (let [arr-sym (gensym "arr")] + `(let [~arr-sym (Array/newUninitialized1dObjectArray ~(+ 11 (count xs)))] + ~@(for [[i x] (->> (concat [x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10] xs) + (map-indexed vector))] + `(Array/set ~arr-sym (Primitive/box ~x) ~i)))) + :cljs `(core/array ~x0 ~x1 ~x2 ~x3 ~x4 ~x5 ~x6 ~x7 ~x8 ~x9 ~x10 ~@xs))))) + +(defn ^"[Ljava.lang.Object;" *<> + ([] (*<>|macro)) + ([x0] (*<>|macro x0)) + ([x0 x1] (*<>|macro x0 x1)) + ([x0 x1 x2] (*<>|macro x0 x1 x2)) + ([x0 x1 x2 x3] (*<>|macro x0 x1 x2 x3)) + ([x0 x1 x2 x3 x4] (*<>|macro x0 x1 x2 x3 x4)) + ([x0 x1 x2 x3 x4 x5] (*<>|macro x0 x1 x2 x3 x4 x5)) + ([x0 x1 x2 x3 x4 x5 x6] (*<>|macro x0 x1 x2 x3 x4 x5 x6)) + ([x0 x1 x2 x3 x4 x5 x6 x7] (*<>|macro x0 x1 x2 x3 x4 x5 x6 x7)) + ([x0 x1 x2 x3 x4 x5 x6 x7 x8] (*<>|macro x0 x1 x2 x3 x4 x5 x6 x7 x8)) + ([x0 x1 x2 x3 x4 x5 x6 x7 x8 x9] (*<>|macro x0 x1 x2 x3 x4 x5 x6 x7 x8 x9)) + ([x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10] (*<>|macro x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)) ([x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 & xs] #?(:clj (let [arr (Array/newUninitialized1dObjectArray (+ 11 (count xs)))] (Array/set arr x0 0) From 350cd0399e635c773fe803f822154e5a5de62e07 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 14 Nov 2018 23:53:49 -0700 Subject: [PATCH 694/810] Add `AnonFn` and some additions for `t/fn` --- .../quantum/untyped/core/type/defnt.cljc | 110 +++++++++++++++--- 1 file changed, 93 insertions(+), 17 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index ec5194c4..6e2ce4f5 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -22,7 +22,8 @@ :refer [not==]] [quantum.untyped.core.data :refer [kw-map]] - [quantum.untyped.core.data.array :as uarr] + [quantum.untyped.core.data.array :as uarr + :refer [*<>]] [quantum.untyped.core.data.map :as umap] [quantum.untyped.core.data.reactive :as urx :refer [?norx-deref norx-deref]] @@ -261,6 +262,79 @@ ;; TODO simplify this class computation +;; ===== Concrete Types ===== ;; + +(defprotocol PAnonFn + (setFs [this fs'])) + +;; TODO CLJS +#?(:clj +(deftype AnonFn + [;; the types for direct dispatch overloads + ^"[Ljava.lang.Object;" types + ;; the direct dispatch fn/`reify` overloads + ^:unsynchronized-mutable ^"[Ljava.lang.Object;" fs + ;; the dynamic dispatch fn + ^clojure.lang.IFn dynf] + PAnonFn + (setFs [this fs'] (set! fs fs') this) + clojure.lang.IFn + (invoke [ this] + (.invoke dynf types fs)) + (invoke [ this x0] + (.invoke dynf types fs this x0)) + (invoke [ this x0 x1] + (.invoke dynf types fs x0 x1)) + (invoke [ this x0 x1 x2] + (.invoke dynf types fs x0 x1 x2)) + (invoke [ this x0 x1 x2 x3] + (.invoke dynf types fs x0 x1 x2 x3)) + (invoke [ this x0 x1 x2 x3 x4] + (.invoke dynf types fs x0 x1 x2 x3 x4)) + (invoke [ this x0 x1 x2 x3 x4 x5] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 + (*<> x18))) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 + (*<> x18 x19))) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 + ^"[Ljava.lang.Object;" xs] + (.applyTo dynf (->> xs (cons x19) (cons x18) (cons x17) (cons x16) (cons x15) (cons x14) + (cons x13) (cons x12) (cons x11) (cons x10) (cons x9) (cons x8) + (cons x7) (cons x6) (cons x5) (cons x4) (cons x3) (cons x2) + (cons x1) (cons x0) (cons fs) (cons types)))) + (applyTo [this ^clojure.lang.ISeq xs] (.applyTo dynf (cons types (cons fs xs)))))) + +(c/defn >anon-fn [types gen-fs dynf] + (let [f (AnonFn. types nil dynf)] + (.setFs f (gen-fs f)))) + ;; ===== Arg type/class extraction/comparison ===== ;; #?(:clj @@ -375,11 +449,11 @@ declared-output-type [:output-type _]} ::unanalyzed-overload overload|id index? fn|overload-types (us/vec-of ::types-decl-datum) - fn|type t/type? + fn|type (us/nilable t/type?) > ::overload] (let [;; Not sure if `nil` is the right approach for the value recursive-ast-node-reference - (when-not (= kind :extend-defn!) (uast/symbol {} fn|name nil fn|type)) + (when (= kind :defn) (uast/symbol {} fn|name nil fn|type)) env (->> (zipmap (keys args-form) arg-types) (uc/map' (c/fn [[arg-binding arg-type]] [arg-binding (uast/unbound nil arg-binding arg-type)])) @@ -493,19 +567,21 @@ (c/defn overload-types>arg-types [?!fn|types #_(t/or ::fn|types (t/of urx/reactive? ::fn|types)), overload-index #_index? #_> #_(objects-of type?)] - (apply uarr/*<> (-> ?!fn|types ?norx-deref :overload-types (get overload-index) :arg-types))) + (apply *<> (-> ?!fn|types ?norx-deref :overload-types (get overload-index) :arg-types))) (c/defn overload-types>ftype [fn|ns-name #_simple-symbol? - fn|name #_simple-symbol? + ?fn|name #_(s/nilable simple-symbol?) overload-types #_(vec-of ::type-datum) fn|output-type #_t/type?] - (->> overload-types - (uc/lmap (c/fn [{:keys [arg-types pre-type output-type]}] - (cond-> arg-types - pre-type (conj :| pre-type) - output-type (conj :> output-type)))) - (apply t/ftype (uid/qualify fn|ns-name fn|name) fn|output-type))) + (let [overload-types' (->> overload-types + (uc/lmap (c/fn [{:keys [arg-types pre-type output-type]}] + (cond-> arg-types + pre-type (conj :| pre-type) + output-type (conj :> output-type)))))] + (if ?fn|name + (apply t/ftype (uid/qualify fn|ns-name ?fn|name) fn|output-type overload-types') + (apply t/ftype fn|output-type overload-types')))) (c/defn- dedupe-overload-types-data [fn|ns-name fn|name types-decl-data] (->> types-decl-data @@ -731,9 +807,10 @@ (sort-overload-types :arg-types) (dedupe-overload-types-data fn|ns-name fn|name) (uc/map-indexed (c/fn [i datum] (assoc datum :index i))))) - ;; For recursive purposes - fn|type-norx (overload-types>ftype - fn|ns-name fn|name overload-types-with-replacing-ids fn|output-type-norx) + ;; Partially for recursive purposes + fn|type-norx + (overload-types>ftype + fn|ns-name fn|name overload-types-with-replacing-ids fn|output-type-norx) ;; We should analyze everything first in order to figure out body-dependent input types ;; before we can compare them against each other, but we're ignoring body-dependent input ;; types for now @@ -1142,11 +1219,10 @@ dynamic-dispatch (>dynamic-dispatch-fn|codelist opts fn|globals fn|types) fn-codelist (->> `[;; For recursion - ~@(when (not= kind :extend-defn!) - [`(declare ~(:fn|name fn|globals))]) + ~@(when (= kind :defn) [`(declare ~(:fn|name fn|globals))]) ~@(:form direct-dispatch) ~@dynamic-dispatch] - (remove nil?))] + (remove nil?))] (case kind :fn (TODO "Haven't done t/fn yet") (:defn :extend-defn!) `(do ~@fn-codelist))))) From 92eb7de878d8cea9ecfc426fcd3079f4bb12ac41 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 14 Nov 2018 23:54:01 -0700 Subject: [PATCH 695/810] Begin to add some things to `fn` --- src/quantum/core/fn.cljc | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/quantum/core/fn.cljc b/src/quantum/core/fn.cljc index 52e8b6a2..d8d689b6 100644 --- a/src/quantum/core/fn.cljc +++ b/src/quantum/core/fn.cljc @@ -30,7 +30,11 @@ ;; ===== `fn`: Positional functions ===== ;; -#?(:clj (defaliases u fn0 fn1 fnl)) +#?(:clj (defmacro fn0 [& args] + `(t/fn fn0# [f# (t/ftype ~(mapv (fn [arg] `(t/type ~arg)) args))] (f# ~@args)))) + +#?(:clj (defmacro fn1 [f & args] `(t/fn fn1# [arg#] (~f arg# ~@args)))) ; analogous to -> +#?(:clj (defmacro fnl [f & args] `(t/fn fnl# [arg#] (~f ~@args arg#)))) ; analogous to ->> ;; ===== `fn&`: Partial functions ===== ;; From 7518c388180c45a346a84ca5e3f3014f0b04b8cd Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 14 Nov 2018 23:54:16 -0700 Subject: [PATCH 696/810] Begin to flesh out first test for `t/fn` --- .../quantum/test/untyped/core/type/defnt.cljc | 90 ++++++++++++++++++- 1 file changed, 86 insertions(+), 4 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 2a2e5888..85105802 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -9,7 +9,7 @@ [quantum.untyped.core.type.defnt :as self :refer [unsupported!]] [quantum.untyped.core.data.array - :refer [*<>]] + :refer [*<> *<>|macro]] [quantum.untyped.core.form :refer [$ code=]] [quantum.untyped.core.form.evaluate @@ -26,9 +26,10 @@ [quantum.untyped.core.vars :refer [defmeta]]) (:import - [clojure.lang ASeq ISeq LazySeq Named Reduced Seqable] - [quantum.core.data Array] - [quantum.core Numeric Primitive])) + [clojure.lang ASeq ISeq LazySeq Named Reduced Seqable] + [quantum.core.data Array] + [quantum.core Numeric Primitive] + [quantum.untyped.core.type.defnt AnonFn])) ;; Just in case (clojure.spec.test.alpha/unstrument) @@ -2482,3 +2483,84 @@ [(t/ref (t/isa? Comparable)) (t/isa? Double)] [(t/ref (t/isa? Comparable)) (t/ref (t/isa? Comparable))] [(t/value nil) (t/not (t/value nil))]])) + +(deftest test|fn + (let [actual (binding [self/*compilation-mode* :test] + (macroexpand ' + ;: FIXME this contract is not being held up when returning nil + (self/defn f0 [a (t/or tt/boolean? tt/double?) + > (t/ftype [tt/byte? :> (t/ftype [tt/char?])])] + ;; TODO When outputting this anon fn, any consumer can call it dynamically just + ;; fine but in order to call it directly, it needs to know its actual (not + ;; declared) type to know what indices map to what overloads. This means that + ;; it's not good enough for callers to know that `(t/ftype [tt/char?])` is + ;; outputted; they need to know that a `[(t/or tt/byte? tt/char?) :> ...]` is + ;; outputted. + ;; TODO this fits into a larger scheme of, should we have output types be + ;; `(t/and actual declared)` or should we just have them be `declared`? The + ;; latter is easier but it seems like the `t/fn` dispatch forces our hand + ;; towards the former. We need to think about this more. + (self/fn [b (t/or tt/byte? tt/char?) + > (t/ftype [(t/or (t/type a) tt/short?)])] + (self/fn f1 [c (t/or (t/type a) tt/short?)] + b (f1 a) (f1 c)))))) + expected + (case (env-lang) + :clj + ($ (do (declare ~'f0) + +(def ~'f0|__0 + (reify* [boolean>Object] + (~'invoke [~'_0__ ~(B 'a)] + ;; From `(self/fn [b ...])` + (self/>anon-fn + ;; TODO perhaps extern this (and parts thereof) whenever possible in `let*` + ;; statement on the very outside of the fn (so around the outer `reify*`) ? + (*<>|macro (*<>|macro (t/isa? Byte)) (*<>|macro (t/isa? Character))) + (*<>|macro + (reify* [byte>Object] + (~'invoke [~'_0__ ~(Y 'b)] + ;; From `(self/fn [c ...])` + (self/>anon-fn + (*<>|macro (*<>|macro (t/isa? Boolean)) (*<>|macro (t/isa? Short))) + (fn* [~(tag (cstr `AnonFn) 'this__)] + (*<>|macro + (reify* [boolean>Object] + (~'invoke [~'_0__ (B 'c)] + ~'b + (. (tag (cstr `boolean>Object) (Array/get (.-fs ~'this__) 0)) ~'invoke ~'a) + (. (tag (cstr `boolean>Object) (Array/get (.-fs ~'this__) 0)) ~'invoke ~'c))) + (reify* [short>Object] + (~'invoke [~'_0__ (S 'c)] + ~'b + (. (tag (cstr `boolean>Object) (Array/get (.-fs ~'this__) 0)) ~'invoke ~'a) + (. (tag (cstr `short>Object) (Array/get (.-fs ~'this__) 1)) ~'invoke ~'c))))) + (fn* ([~(O<> 'types__) ~(O<> 'fs__) ~'x00] + (ifs ((Array/get (Array/get ~'types__ 0) 0) ~'x00__) + (. ~(tag (cstr `boolean>Object) `(Array/get ~'fs__ 0)) + ~'invoke ~'x00__) + ((Array/get (Array/get ~'types__ 1) 0) ~'x00__) + (. ~(tag (cstr `short>Object) `(Array/get ~'fs__ 1)) + ~'invoke ~'x00__) + (unsupported! [~'x00__] 0))))))) + (reify* [char>Object] + (~'invoke [~'_0__ ~(C 'a)] ...))) + (fn* ([~(O<> 'types__) ~(O<> 'fs__) ~'x00__] + (ifs ((Array/get (Array/get ~'types__ 0) 0) ~'x00__) + (. ~(tag (cstr `byte>Object) `(Array/get ~'fs__ 0)) ~'invoke ~'x00__) + ((Array/get (Array/get ~'types__ 1) 0) ~'x00__) + (. ~(tag (cstr `char>Object) `(Array/get ~'fs__ 1)) ~'invoke ~'x00__) + (unsupported! [~'x00__] 0))))))) +(def ~'f0|__1 + (reify* [double>Object] + (~'invoke [~'_0__ ~(D 'a)] ...))) +[[0 0 false [] (t/ftype tt/boolean? [tt/byte? :> (t/ftype [tt/char?])])]] +(defmeta ~'f0 + {:quantum.core.type/type ~'f0|__type} + (fn* ([~'x00__] + (ifs ((Array/get f0|__0|types 0) ~'x00__) + (. f0|__0 ~'invoke ~'x00__) + ((Array/get f0|__1|types 0) ~'x00__) + (. f0|__1 ~'invoke ~'x00__) + (unsupported! `f0 [~'x00__] 0))))))))] + )) From 42c0598391ace53c4e6b04de610d6bed2356eb0b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 15 Nov 2018 21:16:53 -0700 Subject: [PATCH 697/810] Introduce named types for efficiency and clarity --- resources-dev/defnt.cljc | 7 +- src-untyped/quantum/untyped/core/print.cljc | 6 + src-untyped/quantum/untyped/core/type.cljc | 208 ++++++++------ .../untyped/core/type/reifications.cljc | 271 +++++++++++------- 4 files changed, 288 insertions(+), 204 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 3bcc72ac..8d347bc0 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -88,9 +88,10 @@ Legend: [ ] Perhaps it's the case that we can't actually have type bases but rather reactive splits. In the case of `narrowest`, it expects a split and fails without it: `[a (t/- integer? int?), b integer? > (narrowest (t/type a) (t/type b))]` - [ ] `t/ref` and `t/assume` need to be combined correctly. E.g. (t/and (t/ref ...) ...) means the - whole thing should be `t/ref`, while `(t/or (t/ref ...) (...))` does not mean the metadata - is transferred. Probably `t/assume` should be combined in the same way. + [ ] `t/ref`, `t/assume`, `t/*` need to be combined correctly with other types. + E.g. (t/and (t/ref ...) ...) means the whole thing should be `t/ref`, while `(t/or (t/ref ...) + (...))` does not mean the metadata is transferred. Probably `t/assume` and `t/*` should be + combined in the same way. - What about `(t/and (t/or t/long? (t/ref t/byte?)) pos?)` ? [ ] t/value-of - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` diff --git a/src-untyped/quantum/untyped/core/print.cljc b/src-untyped/quantum/untyped/core/print.cljc index 3b4d8e7f..2d3b1238 100644 --- a/src-untyped/quantum/untyped/core/print.cljc +++ b/src-untyped/quantum/untyped/core/print.cljc @@ -2,6 +2,7 @@ (:require #?@(:clj [[io.aviso.exception]]) + [fipp.ednize :as fedn] [quantum.untyped.core.collections :as uc] [quantum.untyped.core.core :as ucore] [quantum.untyped.core.error :as uerr @@ -63,3 +64,8 @@ ([x & args] (Group. (cons x args)))) (defn group? [x] (instance? Group x)) + +;; ===== fipp.edn ===== ;; + +(extend-protocol fedn/IEdn + nil (-edn [this] nil)) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index f2c71aa4..cde1c594 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -41,7 +41,7 @@ [quantum.untyped.core.form :refer [$]] [quantum.untyped.core.form.generate.deftype :as udt] - [quantum.untyped.core.identifiers + [quantum.untyped.core.identifiers :as uid :refer [>symbol]] [quantum.untyped.core.logic :refer [fn-and ifs whenp->]] @@ -70,7 +70,7 @@ #?(:clj (:import [quantum.untyped.core.analyze.expr Expression] [quantum.untyped.core.type.reifications - UniversalSetType EmptySetType + MetaType UniversalSetType EmptySetType NotType OrType AndType ProtocolType ClassType UnorderedType OrderedType ValueType @@ -80,13 +80,13 @@ (ucore/log-this-ns) -;; ===== TODOS ===== ;; +#?(:clj (defmacro def + ([sym t] `(uvar/def ~sym (utr/with-name ~t '~(uid/qualify *ns* sym)))) + ([sym x t] `(uvar/def ~sym ~x (utr/with-name ~t '~(uid/qualify *ns* sym)))))) -(declare - - create-logical-type meta-or with-expand-meta-ors nil? val? - and or val|by-class?) +#?(:clj (uvar/defalias def* quantum.untyped.core.type/def)) -(defonce *type-registry (atom {})) +(declare - create-logical-type meta-or with-expand-meta-ors nil? val? and or val|by-class?) ;; ===== Comparison ===== ;; @@ -107,7 +107,7 @@ ;; ----- ReactiveType (`t/rx`) ----- ;; (defns rx* [r urx/reactive?, body-codelist _ > utr/rx-type?] - (ReactiveType. uhash/default uhash/default nil body-codelist nil r)) + (ReactiveType. uhash/default uhash/default nil nil body-codelist nil r)) #?(:clj (defmacro rx @@ -142,7 +142,7 @@ (utr/or-type? t) (->> t utr/or-type>args (uc/lmap not) (apply and)) ;; DeMorgan's Law (utr/and-type? t) (->> t utr/and-type>args (uc/lmap not) (apply or )) - (NotType. uhash/default uhash/default nil t))) + (NotType. uhash/default uhash/default nil nil t))) (uvar/defalias ! not) @@ -198,16 +198,16 @@ ;; ----- ProtocolType ----- ;; (defns- isa?|protocol [p uclass/protocol?] - (ProtocolType. uhash/default uhash/default nil p nil)) + (ProtocolType. uhash/default uhash/default nil nil p)) #?(:cljs (defns- isa?|protocol|direct [p uclass/protocol?] - (DirectProtocolType. uhash/default uhash/default nil p nil))) + (DirectProtocolType. uhash/default uhash/default nil nil p))) ;; ----- ClassType ----- ;; (defns- isa?|class [c #?(:clj c/class? :cljs c/fn?)] - (ClassType. uhash/default uhash/default nil c nil)) + (ClassType. uhash/default uhash/default nil nil c)) ;; ----- OrderedType ----- ;; @@ -216,17 +216,17 @@ ([> utr/unordered-type?] (unordered [])) ([data _ > utr/unordered-type?] (ifs (utr/rx-type? data) - (rx (UnorderedType. uhash/default uhash/default nil {@data 1} nil)) + (rx (UnorderedType. uhash/default uhash/default nil nil {@data 1})) (utr/type? data) - (UnorderedType. uhash/default uhash/default nil {data 1} nil) + (UnorderedType. uhash/default uhash/default nil nil {data 1}) (c/not (sequential? data)) (err! "Finite type info must be sequential" {:type (c/type data)}) (c/not (seq-and utr/type? data)) (err! "Not every element of finite type data is a type") (seq-or utr/rx-type? data) - (rx (UnorderedType. uhash/default uhash/default nil - (->> data (uc/map+ utr/deref-when-reactive) uc/frequencies) nil)) - (UnorderedType. uhash/default uhash/default nil (frequencies data) nil))) + (rx (UnorderedType. uhash/default uhash/default nil nil + (->> data (uc/map+ utr/deref-when-reactive) uc/frequencies))) + (UnorderedType. uhash/default uhash/default nil nil (frequencies data)))) ([datum _ & data _ > utr/unordered-type?] (unordered (cons datum data)))) (defns ordered @@ -234,24 +234,24 @@ ([> utr/ordered-type?] (ordered [])) ([data _ > utr/ordered-type?] (ifs (utr/rx-type? data) - (rx (OrderedType. uhash/default uhash/default nil [@data] nil)) + (rx (OrderedType. uhash/default uhash/default nil nil [@data])) (utr/type? data) - (OrderedType. uhash/default uhash/default nil [data] nil) + (OrderedType. uhash/default uhash/default nil nil [data]) (c/not (sequential? data)) (err! "Finite type info must be sequential" {:type (c/type data)}) (c/not (seq-and utr/type? data)) (err! "Not every element of finite type data is a type") (seq-or utr/rx-type? data) - (rx (OrderedType. uhash/default uhash/default nil - (->> data (uc/map utr/deref-when-reactive)) nil)) - (OrderedType. uhash/default uhash/default nil data nil))) + (rx (OrderedType. uhash/default uhash/default nil nil + (->> data (uc/map utr/deref-when-reactive)))) + (OrderedType. uhash/default uhash/default nil nil data))) ([datum _ & data _ > utr/ordered-type?] (ordered (cons datum data)))) ;; ----- ValueType ----- ;; (defn value "Creates a type whose extension is the singleton set containing only the value `v`." - [v] (ValueType. uhash/default uhash/default nil v)) + [v] (ValueType. uhash/default uhash/default nil nil v)) (defns unvalue [t utr/type?] @@ -283,8 +283,7 @@ (case (count args) 0 empty-set 1 (first args) - (OrType. uhash/default uhash/default nil args - (atom nil))))) + (OrType. uhash/default uhash/default nil nil args (atom nil))))) (defn - ;; TODO `defns` when variadic args are actually handled correctly "Computes the difference of `t0` from `t1`: (& t0 (! t1)) @@ -310,27 +309,27 @@ (condp == c0 NotType (condp == (-> t0 utr/not-type>inner-type c/type) ClassType (condp == c1 - ClassType (AndType. uhash/default uhash/default nil + ClassType (AndType. uhash/default uhash/default nil nil [t0 (not t1)] (atom nil))) ValueType (condp == c1 - ValueType (AndType. uhash/default uhash/default nil + ValueType (AndType. uhash/default uhash/default nil nil [t0 (not t1)] (atom nil)))) OrType (condp == c1 ClassType (-|or t0 t1) ValueType (-|or t0 t1))))))))) ([t0 #_utr/type?, t1 #_utr/type? & ts #_ _ #_> #_utr/type?] (reduce - (- t0 t1) ts))) -(def type? (isa? PType)) -(def not-type? (isa? NotType)) -(def or-type? (isa? OrType)) -(def and-type? (isa? AndType)) -(def protocol-type? (isa? ProtocolType)) -(def class-type? (isa? ClassType)) -(def value-type? (isa? ValueType)) +(def* type? (isa? PType)) +(def* not-type? (isa? NotType)) +(def* or-type? (isa? OrType)) +(def* and-type? (isa? AndType)) +(def* protocol-type? (isa? ProtocolType)) +(def* class-type? (isa? ClassType)) +(def* value-type? (isa? ValueType)) ;; For use in logical operators -(def nil? (value nil)) -(def object? (isa? #?(:clj java.lang.Object :cljs js/Object))) +(def* nil? (value nil)) +(def* object? (isa? #?(:clj java.lang.Object :cljs js/Object))) ;; ===== Type metadata (not for reactive types) ===== ;; @@ -339,29 +338,54 @@ be, it is assumed that the output satisfies that type." [t #_utr/type? #_> #_utr/type?] (assert (c/not (utr/rx-type? t))) - (update-meta t assoc :quantum.core.type/assume? true)) + (if (utr/meta-type? t) + (if (.-assume_QMARK_ ^MetaType t) + t + (MetaType. (.-meta ^MetaType t) nil (.-t ^MetaType t) + true (.-ref_QMARK_ ^MetaType t) false)) ; un-`t/*`s it + (MetaType. (c/meta t) nil t true false false))) (defn unassume [t #_utr/type? #_> #_utr/type?] (assert (c/not (utr/rx-type? t))) - (update-meta t dissoc :quantum.core.type/assume?)) + (if (utr/meta-type? t) + (if-not (.-assume_QMARK_ ^MetaType t) + t + (MetaType. (.-meta ^MetaType t) nil (.-t ^MetaType t) + false (.-ref_QMARK_ ^MetaType t) (.-runtime_QMARK_ ^MetaType t))) ; un-`t/*`s it + t)) (defn * "Denote on a type that it must be enforced at runtime. For use with `defnt`." [t #_utr/type? #_> #_utr/type?] (assert (c/not (utr/rx-type? t))) - (update-meta t assoc :quantum.core.type/runtime? true)) + (if (utr/meta-type? t) + (if (.-runtime_QMARK_ ^MetaType t) + t + (MetaType. (.-meta ^MetaType t) nil (.-t ^MetaType t) + false (.-ref_QMARK_ ^MetaType t) true)) ; un-`t/assume`s it + (MetaType. (c/meta t) nil t false false true))) (defn ref "Denote on a type that it must not be expanded to use primitive values. For use with `defnt`." [t #_utr/type? #_> #_utr/type?] (assert (c/not (utr/rx-type? t))) - (update-meta t assoc :quantum.core.type/ref? true)) + (if (utr/meta-type? t) + (if (.-ref_QMARK_ ^MetaType t) + t + (MetaType. (.-meta ^MetaType t) nil (.-t ^MetaType t) + (.-assume_QMARK_ ^MetaType t) true (.-runtime_QMARK_ ^MetaType t))) + (MetaType. (c/meta t) nil t false true false))) (defn unref [t #_utr/type? #_> #_utr/type?] (assert (c/not (utr/rx-type? t))) - (update-meta t dissoc :quantum.core.type/ref?)) + (if (utr/meta-type? t) + (if-not (.-ref_QMARK_ ^MetaType t) + t + (MetaType. (.-meta ^MetaType t) nil (.-t ^MetaType t) + (.-assume_QMARK_ ^MetaType t) false (.-runtime_QMARK_ ^MetaType t))) + t)) ;; ===== Logical ===== ;; @@ -493,7 +517,7 @@ (assert (-> simplified count (c/>= 1))) ; for internal implementation correctness (if (-> simplified count (c/= 1)) (first simplified) - (construct-fn uhash/default uhash/default nil simplified (atom nil))))) + (construct-fn uhash/default uhash/default nil nil simplified (atom nil))))) (defns- create-logical-type [kind #{:or :and}, construct-fn _, type-pred _, type>args _ @@ -710,7 +734,7 @@ (let [types' (->> types uc/distinct (sort-by identity utcomp/compare) (uc/dedupe-by utcomp/=))] (ifs (empty? types') empty-set (-> types' count (c/= 1)) (first types') - (MetaOrType. uhash/default uhash/default nil types')))) + (MetaOrType. uhash/default uhash/default nil nil types')))) (defns meta-or "Essentially a combinatorial combinator: @@ -867,91 +891,91 @@ ;; ===== General ===== ;; - (def none? empty-set) - (def any? universal-set) + (def* none? empty-set) + (def* any? universal-set) ;; TODO this is incomplete for CLJS base classes ;; TODO is this necessary? - (def val|by-class? (or object? #?@(:cljs [(isa? js/String) (isa? js/Symbol)]))) - (def val? (not nil?)) + (def* val|by-class? (or object? #?@(:cljs [(isa? js/String) (isa? js/Symbol)]))) + (def* val? (not nil?)) - (def ref? (ref any?)) + (def* ref? (ref any?)) ;; ===== Meta ===== ;; ;; TODO probably move, but this is used by `quantum.untyped.core.type` etc. -#?(:clj (def primitive-class? (or (value Boolean/TYPE) - (value Byte/TYPE) - (value Character/TYPE) - (value Short/TYPE) - (value Integer/TYPE) - (value Long/TYPE) - (value Float/TYPE) - (value Double/TYPE)))) +#?(:clj (def* primitive-class? (or (value Boolean/TYPE) + (value Byte/TYPE) + (value Character/TYPE) + (value Short/TYPE) + (value Integer/TYPE) + (value Long/TYPE) + (value Float/TYPE) + (value Double/TYPE)))) ;; ===== Primitives ===== ;; ;; NOTE these are kept here because they're used in both type analysis and various test namespaces - (def boolean? (isa? #?(:clj Boolean :cljs js/Boolean))) -#?(:clj (def byte? (isa? Byte))) -#?(:clj (def char? (isa? Character))) -#?(:clj (def short? (isa? Short))) -#?(:clj (def int? (isa? Integer))) ; only primitive int, not goog.math.Integer -#?(:clj (def long? (isa? Long))) ; only primitive long, not goog.math.Long -#?(:clj (def float? (isa? Float))) - (def double? (isa? #?(:clj Double :cljs js/Number))) + (def* boolean? (isa? #?(:clj Boolean :cljs js/Boolean))) +#?(:clj (def* byte? (isa? Byte))) +#?(:clj (def* char? (isa? Character))) +#?(:clj (def* short? (isa? Short))) +#?(:clj (def* int? (isa? Integer))) ; only primitive int, not goog.math.Integer +#?(:clj (def* long? (isa? Long))) ; only primitive long, not goog.math.Long +#?(:clj (def* float? (isa? Float))) + (def* double? (isa? #?(:clj Double :cljs js/Number))) ;; These are special for CLJS protocols ;; Possibly planned to be used by `quantum.untyped.core.analyze` -#?(:cljs (def native? (or (isa? js/Boolean) - (isa? js/Number) - (isa? js/Object) - (isa? js/Array) - (isa? js/String) - (isa? js/Function) - nil?))) +#?(:cljs (def* native? (or (isa? js/Boolean) + (isa? js/Number) + (isa? js/Object) + (isa? js/Array) + (isa? js/String) + (isa? js/Function) + nil?))) ;; ===== Booleans ===== ;; ;; Used by `quantum.untyped.core.analyze` -(def true? (value true)) -(def false? (value false)) +(def* true? (value true)) +(def* false? (value false)) ;; ========== Collections ========== ;; ;; Possibly planned to be used by `quantum.untyped.core.analyze` -(def +list|built-in? +(def* +list|built-in? (or (isa? #?(:clj clojure.lang.PersistentList$EmptyList :cljs cljs.core/EmptyList)) (isa? #?(:clj clojure.lang.PersistentList :cljs cljs.core/List)))) ;; Used by `quantum.untyped.core.analyze` -(def +vector|built-in? +(def* +vector|built-in? (isa? #?(:clj clojure.lang.PersistentVector :cljs cljs.core/PersistentVector))) ;; Used by `quantum.untyped.core.analyze` -(def +unordered-map|built-in? +(def* +unordered-map|built-in? (or (isa? #?(:clj clojure.lang.PersistentHashMap :cljs cljs.core/PersistentHashMap)) (isa? #?(:clj clojure.lang.PersistentArrayMap :cljs cljs.core/PersistentArrayMap)))) ;; Used by `quantum.untyped.core.analyze` -(def +map|built-in? - (or +unordered-map|built-in? - (isa? #?(:clj clojure.lang.PersistentTreeMap :cljs cljs.core/PersistentTreeMap)))) +(def* +map|built-in? + (or +unordered-map|built-in? + (isa? #?(:clj clojure.lang.PersistentTreeMap :cljs cljs.core/PersistentTreeMap)))) ;; Used by `quantum.untyped.core.analyze` -(def +unordered-set|built-in? +(def* +unordered-set|built-in? (isa? #?(:clj clojure.lang.PersistentHashSet :cljs cljs.core/PersistentHashSet))) ;; Used by `quantum.untyped.core.analyze` -(def +set|built-in? +(def* +set|built-in? (or +unordered-set|built-in? (isa? #?(:clj clojure.lang.PersistentTreeSet :cljs cljs.core/PersistentTreeSet)))) ;; ===== Functions ===== ;; ;; Used by `quantum.untyped.core.analyze` -(def fn? #?(:clj (isa? clojure.lang.Fn) - :cljs (or (isa? js/Function) (isa? cljs.core/Fn)))) +(def* fn? #?(:clj (isa? clojure.lang.Fn) + :cljs (or (isa? js/Function) (isa? cljs.core/Fn)))) ;; Used by `quantum.untyped.core.analyze` via `t/callable?` (uvar/def ifn? @@ -960,7 +984,7 @@ (isa?|direct #?(:clj clojure.lang.IFn :cljs cljs.core/IFn))) ;; Used by `quantum.untyped.core.analyze` via `t/callable?` -(def fnt? (and fn? (>expr (fn-> c/meta :quantum.core.type/type type?)))) +(def* fnt? (and fn? (>expr (fn-> c/meta :quantum.core.type/type type?)))) ;; TODO should we allow java.lang.Runnable, java.util.concurrent.Callable, and other ;; functional interfaces to be `callable?`? @@ -973,32 +997,32 @@ ;; ===== Metadata ===== ;; ;; Used by `quantum.untyped.core.analyze.ast` -(def with-metable? (isa? #?(:clj clojure.lang.IObj :cljs cljs.core/IWithMeta))) +(def* with-metable? (isa? #?(:clj clojure.lang.IObj :cljs cljs.core/IWithMeta))) ;; ===== Errors ===== ;; ;; Used by `quantum.untyped.core.analyze` -(def throwable? "Able to be used with `throw`" #?(:clj (isa? java.lang.Throwable) :cljs any?)) +(def* throwable? "Able to be used with `throw`" #?(:clj (isa? java.lang.Throwable) :cljs any?)) ;; ===== Literals ===== ;; ;; Used by `quantum.untyped.core.analyze`, including via `t/literal?` -(def regex? (isa? #?(:clj java.util.regex.Pattern :cljs js/RegExp))) +(def* regex? (isa? #?(:clj java.util.regex.Pattern :cljs js/RegExp))) ;; Used by `quantum.untyped.core.analyze`, including via `t/literal?` -(def keyword? (isa? #?(:clj clojure.lang.Keyword :cljs cljs.core/Keyword))) +(def* keyword? (isa? #?(:clj clojure.lang.Keyword :cljs cljs.core/Keyword))) ;; Used by `quantum.untyped.core.analyze` via `t/literal?` -(def string? (isa? #?(:clj java.lang.String :cljs js/String))) +(def* string? (isa? #?(:clj java.lang.String :cljs js/String))) ;; Used by `quantum.untyped.core.analyze` via `t/literal?` -(def symbol? (isa? #?(:clj clojure.lang.Symbol :cljs cljs.core/Symbol))) +(def* symbol? (isa? #?(:clj clojure.lang.Symbol :cljs cljs.core/Symbol))) ;; Used by `quantum.untyped.core.analyze` via `t/literal?` -#?(:clj (def tagged-literal? (isa? clojure.lang.TaggedLiteral))) +#?(:clj (def* tagged-literal? (isa? clojure.lang.TaggedLiteral))) ;; Used by `quantum.untyped.core.analyze` -(def literal? +(def* literal? (or nil? boolean? symbol? keyword? string? #?(:clj long?) double? #?(:clj (isa? clojure.lang.BigInt)) #?(:clj (isa? BigDecimal)) regex? #?(:clj tagged-literal?))) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 2906f2ac..94c3c212 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -1,4 +1,10 @@ (ns quantum.untyped.core.type.reifications + "Some notes on these types: + - Here `c/=` tests for structural equivalence + - If a type is named, its name must be a qualified symbol and is assumed to be globally + resolvable. + - If you define a named type, `>form` it, and redefine the type, the value will change when you + `eval` the form" (:refer-clojure :exclude [==]) (:require @@ -7,6 +13,8 @@ [fipp.ednize :as fedn] [quantum.untyped.core.analyze.expr #?@(:cljs [:refer [Expression]])] + [quantum.untyped.core.collections + :refer [>vec]] [quantum.untyped.core.collections.logic :refer [seq-and-2]] [quantum.untyped.core.compare @@ -21,9 +29,12 @@ [quantum.untyped.core.form :as uform :refer [>form]] [quantum.untyped.core.form.generate.deftype :as udt] + [quantum.untyped.core.identifiers + :refer [>symbol]] [quantum.untyped.core.loops :refer [reduce-2]] [quantum.untyped.core.numeric :as unum] + [quantum.untyped.core.print] ; for fipp.edn extensions [quantum.untyped.core.refs :as uref :refer [!]] [quantum.untyped.core.spec :as us]) @@ -32,21 +43,41 @@ (ucore/log-this-ns) -(defprotocol PType) +(defprotocol PType (with-name [this name'])) (defn type? [x #_> #_boolean?] (satisfies? PType x)) -(defn- accounting-for-meta [t meta-] - (if meta- - (cond->> (with-meta t - (dissoc meta- - :quantum.core.type/assume? :quantum.core.type/ref? :quantum.core.type/runtime?)) - (:quantum.core.type/assume? meta-) (list 'quantum.untyped.core.type/assume) - (:quantum.core.type/ref? meta-) (list 'quantum.untyped.core.type/ref) - (:quantum.core.type/runtime? meta-) (list 'quantum.untyped.core.type/*)) - t)) +(defn- ?with-name [form ?name] (if ?name (list 't/named ?name form) form)) -;; Here `c/=` tests for structural equivalence +;; ----- MetaType ----- ;; + +(udt/deftype MetaType + [ meta #_(t/? ::meta) + name #_qualified-symbol? + t #_t/type? + ^boolean assume? + ^boolean ref? + ^boolean runtime?] + {PType {with-name ([this name'] (MetaType. meta name' t assume? ref? runtime?))} + ?Meta {meta ([this] meta) + with-meta ([this meta'] (MetaType. meta' name t assume? ref? runtime?))} + ?Equals {= ([this that] (or (== this that) + (if (instance? MetaType that) + (= t (.-t ^MetaType that)) + (= that t))))} + uform/PGenForm {>form ([this] (or name + (list 'new 'quantum.untyped.core.type.reifications.MetaType + (>form meta) name (>form t) assume? ref? runtime?)))} + fedn/IOverride nil + fedn/IEdn {-edn ([this] (-> (cond->> (fedn/-edn t) + assume? (list 't/assume) + ref? (list 't/ref) + runtime? (list 't/*)) + (?with-name name)))}}) + +(defns meta-type? [x _ > boolean?] (instance? MetaType x)) + +(defns meta-type>inner-type [t meta-type?] (.-t ^MetaType t)) ;; ----- UniversalSetType (`t/U`) ----- ;; @@ -54,17 +85,14 @@ ^{:doc "Represents the set of all sets that do not include themselves (including the empty set). Equivalent to `(constantly true)`."} UniversalSetType [meta #_(t/? ::meta)] - {PType nil + {PType {with-name ([this _] this)} ?Fn {invoke ([_ x] true)} - ?Meta {meta ([this] meta) - with-meta ([this meta'] (UniversalSetType. meta'))} ?Hash {hash ([this] (hash UniversalSetType)) hash-code ([this] (uhash/code UniversalSetType))} ?Equals {= ([this that] (or (== this that) (instance? UniversalSetType that)))} - uform/PGenForm {>form ([this] (-> 'quantum.untyped.core.type/any? - (accounting-for-meta meta)))} + uform/PGenForm {>form ([this] 'quantum.untyped.core.type/any?)} fedn/IOverride nil - fedn/IEdn {-edn ([this] (>form this))}}) + fedn/IEdn {-edn ([this] 't/any?)}}) (def universal-set (UniversalSetType. nil)) @@ -74,17 +102,16 @@ ^{:doc "Represents the empty set. Equivalent to `(constantly false)`."} EmptySetType [meta #_(t/? ::meta)] - {PType nil + {PType {with-name ([this _] this)} ?Fn {invoke ([_ x] false)} ?Meta {meta ([this] meta) with-meta ([this meta'] (EmptySetType. meta'))} ?Hash {hash ([this] (hash EmptySetType)) hash-code ([this] (uhash/code EmptySetType))} ?Equals {= ([this that] (or (== this that) (instance? EmptySetType that)))} - uform/PGenForm {>form ([this] (-> 'quantum.untyped.core.type/none? - (accounting-for-meta meta)))} + uform/PGenForm {>form ([this] 'quantum.untyped.core.type/none?)} fedn/IOverride nil - fedn/IEdn {-edn ([this] (>form this))}}) + fedn/IEdn {-edn ([this] 't/none?)}}) (def empty-set (EmptySetType. nil)) @@ -94,21 +121,23 @@ [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_(t/? ::meta) - t #_t/type?] - {PType nil + name #_(t/? qualified-symbol?) + t #_t/type?] + {PType {with-name ([this name'] (NotType. hash hash-code meta name' t))} ?Fn {invoke ([_ x] (not (t x)))} ?Meta {meta ([this] meta) - with-meta ([this meta'] (NotType. hash hash-code meta' t))} + with-meta ([this meta'] (NotType. hash hash-code meta' name t))} ?Hash {hash ([this] (uhash/caching-set-ordered! hash NotType t)) hash-code ([this] (uhash/caching-set-code! hash-code NotType t))} ?Equals {= ([this that] (or (== this that) (and (instance? NotType that) (= t (.-t ^NotType that)))))} - uform/PGenForm {>form ([this] (-> (list 'quantum.untyped.core.type/not (>form t)) - (accounting-for-meta meta)))} + uform/PGenForm {>form ([this] + (or name (list 'new 'quantum.untyped.core.type.reifications.NotType + hash hash-code (>form meta) name (>form t))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (>form this))}}) + fedn/IEdn {-edn ([this] (-> (list 't/not (fedn/-edn t)) (?with-name name)))}}) (defns not-type? [x _ > boolean?] (instance? NotType x)) @@ -120,9 +149,11 @@ [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_(t/? ::meta) + name #_(t/? qualified-symbol?) args #_(t/and t/indexed? (t/seq t/type?)) *logical-complement] - {PType nil + {PType {with-name ([this name'] (OrType. hash hash-code meta name' args + *logical-complement))} ?Fn {invoke ([_ x] (reduce (fn [_ t] (let [satisfies-type? (t x)] @@ -130,17 +161,20 @@ true ; vacuously args))} ?Meta {meta ([this] meta) - with-meta ([this meta'] (OrType. hash hash-code meta' args *logical-complement))} + with-meta ([this meta'] (OrType. hash hash-code meta' name args + *logical-complement))} ?Hash {hash ([this] (uhash/caching-set-ordered! hash OrType args)) hash-code ([this] (uhash/caching-set-code! hash-code OrType args))} ?Equals {= ([this that] (or (== this that) (and (instance? OrType that) (= args (.-args ^OrType that)))))} - uform/PGenForm {>form ([this] (-> (list* 'quantum.untyped.core.type/or (map >form args)) - (accounting-for-meta meta)))} + uform/PGenForm {>form ([this] + (or name (list 'new 'quantum.untyped.core.type.reifications.OrType + hash hash-code (>form meta) name (-> args >vec >form) + `(atom nil))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (>form this))}}) + fedn/IEdn {-edn ([this] (-> (list* 't/or (map fedn/-edn args)) (?with-name name)))}}) (defns or-type? [x _ > boolean?] (instance? OrType x)) @@ -152,25 +186,29 @@ [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_(t/? ::meta) + name #_(t/? qualified-symbol?) args #_(t/and t/indexed? (t/seq t/type?)) *logical-complement] - {PType nil + {PType {with-name ([this name'] (AndType. hash hash-code meta name' args + *logical-complement))} ?Fn {invoke ([_ x] (reduce (fn [_ t] (or (t x) (reduced false))) true ; vacuously args))} ?Meta {meta ([this] meta) - with-meta ([this meta'] (AndType. hash hash-code meta' args - *logical-complement))} + with-meta ([this meta'] (AndType. hash hash-code meta' name args + *logical-complement))} ?Hash {hash ([this] (uhash/caching-set-ordered! hash AndType args)) hash-code ([this] (uhash/caching-set-code! hash-code AndType args))} ?Equals {= ([this that] (or (== this that) (and (instance? AndType that) (= args (.-args ^AndType that)))))} - uform/PGenForm {>form ([this] (-> (list* 'quantum.untyped.core.type/and (map >form args)) - (accounting-for-meta meta)))} + uform/PGenForm {>form ([this] + (or name (list 'new 'quantum.untyped.core.type.reifications.AndType + hash hash-code (>form meta) name (-> args >vec >form) + `(atom nil))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (>form this))}}) + fedn/IEdn {-edn ([this] (-> (list* 't/and (map fedn/-edn args)) (?with-name name)))}}) (defns and-type? [x _ > boolean?] (instance? AndType x)) @@ -186,24 +224,25 @@ [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_(t/? ::meta) - p #_t/protocol? - name #_(t/? symbol?)] - {PType nil + name #_(t/? qualified-symbol?) + p #_t/protocol?] + {PType {with-name ([this name'] (ProtocolType. hash hash-code meta name' p))} ?Fn {invoke ([_ x] (satisfies? p x))} ?Meta {meta ([this] meta) - with-meta ([this meta'] (ProtocolType. hash hash-code meta' p name))} + with-meta ([this meta'] (ProtocolType. hash hash-code meta' name p))} ?Hash {hash ([this] (uhash/caching-set-ordered! hash ProtocolType p)) hash-code ([this] (uhash/caching-set-code! hash-code ProtocolType p))} ?Equals {= ([this that #_any?] (or (== this that) (and (instance? ProtocolType that) (= p (.-p ^ProtocolType that)))))} - uform/PGenForm {>form ([this] (-> (list 'quantum.untyped.core.type/isa?|protocol (:on p)) - (accounting-for-meta meta)))} + uform/PGenForm {>form ([this] + (or name (list 'new + 'quantum.untyped.core.type.reifications.ProtocolType + hash hash-code (>form meta) name (-> p :var >symbol))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (if name - (-> name (accounting-for-meta meta)) - (>form this)))}}) + fedn/IEdn {-edn ([this] (-> (list 't/isa?|protocol (-> p :var >symbol)) + (?with-name name)))}}) (defns protocol-type? [x _] (instance? ProtocolType x)) @@ -219,24 +258,25 @@ [^number ^:! hash ^number ^:! hash-code meta #_(t/? ::meta) - p #_t/protocol? - name #_(t/? symbol?)] - {PType nil + name #_(t/? qualified-symbol?) + p #_t/protocol?] + {PType {with-name ([this name'] (DirectProtocolType. hash hash-code meta name' p))} ?Fn {invoke ([_ x] (implements? p x))} ?Meta {meta ([this] meta) - with-meta ([this meta'] (ProtocolType. hash hash-code meta' p name))} - ?Hash {hash ([this] (uhash/caching-set-ordered! hash ProtocolType p)) - hash-code ([this] (uhash/caching-set-code! hash-code ProtocolType p))} + with-meta ([this meta'] (DirectProtocolType. hash hash-code meta' name p))} + ?Hash {hash ([this] (uhash/caching-set-ordered! hash DirectProtocolType p)) + hash-code ([this] (uhash/caching-set-code! hash-code DirectProtocolType p))} ?Equals {= ([this that #_any?] (or (== this that) - (and (instance? ProtocolType that) - (= p (.-p ^ProtocolType that)))))} - uform/PGenForm {>form ([this] (-> (list 'quantum.untyped.core.type/isa?|protocol (:on p)) - (accounting-for-meta meta)))} + (and (instance? DirectProtocolType that) + (= p (.-p ^DirectProtocolType that)))))} + uform/PGenForm {>form ([this] + (or name (list 'new + 'quantum.untyped.core.type.reifications.DirectProtocolType + hash hash-code (>form meta) name (-> p :var >symbol))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (if name - (-> name (accounting-for-meta meta)) - (>form this)))}})) + fedn/IEdn {-edn ([this] (-> (list 't/isa?|protocol|direct (-> p :var >symbol)) + (?with-name name)))}})) #?(:cljs (defns direct-protocol-type? [x _] (instance? DirectProtocolType x))) @@ -248,24 +288,23 @@ [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_meta/meta? - ^Class c #_t/class? - name #_(t/? symbol?)] - {PType nil + name #_(t/? qualified-symbol?) + ^Class c #_t/class?] + {PType {with-name ([this name'] (ClassType. hash hash-code meta name' c))} ?Fn {invoke ([_ x] (instance? c x))} ?Meta {meta ([this] meta) - with-meta ([this meta'] (ClassType. hash hash-code meta' c name))} + with-meta ([this meta'] (ClassType. hash hash-code meta' name c))} ?Hash {hash ([this] (uhash/caching-set-ordered! hash ClassType c)) hash-code ([this] (uhash/caching-set-code! hash-code ClassType c))} ?Equals {= ([this that #_any?] (or (== this that) (and (instance? ClassType that) (= c (.-c ^ClassType that)))))} - uform/PGenForm {>form ([this] (-> (list 'quantum.untyped.core.type/isa? (>form c)) - (accounting-for-meta meta)))} + uform/PGenForm {>form ([this] + (or name (list 'new 'quantum.untyped.core.type.reifications.ClassType + hash hash-code (>form meta) name (>form c))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (if name - (-> name (accounting-for-meta meta)) - (>form this)))}}) + fedn/IEdn {-edn ([this] (-> (list 't/isa? (fedn/-edn c)) (?with-name name)))}}) (defns class-type? [x _] (instance? ClassType x)) @@ -298,24 +337,24 @@ [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_meta/meta? - data #_(t/type (dc/map-of t/type? (t/and integer? (> 1))) "Val is frequency of type") - name #_(t/? symbol?)] - {PType nil + name #_(t/? qualified-symbol?) + data #_(t/type (dc/map-of t/type? (t/and integer? (> 1))) "Val is frequency of type")] + {PType {with-name ([this name'] (UnorderedType. hash hash-code meta name' data))} ?Fn {invoke ([_ xs] (satisfies-unordered-type? xs data))} ?Meta {meta ([this] meta) - with-meta ([this meta'] (UnorderedType. hash hash-code meta' data name))} + with-meta ([this meta'] (UnorderedType. hash hash-code meta' name data))} ?Hash {hash ([this] (uhash/caching-set-ordered! hash UnorderedType data)) hash-code ([this] (uhash/caching-set-code! hash-code UnorderedType data))} ?Equals {= ([this that #_any?] (or (== this that) (and (instance? UnorderedType that) (= data (.-data ^UnorderedType that)))))} - uform/PGenForm {>form ([this] (-> (list 'quantum.untyped.core.type/unordered (>form data)) - (accounting-for-meta meta)))} + uform/PGenForm {>form ([this] + (or name + (list 'new 'quantum.untyped.core.type.reifications.UnorderedType + hash hash-code (>form meta) name (>form data))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (if name - (-> name (accounting-for-meta meta)) - (>form this)))}}) + fedn/IEdn {-edn ([this] (-> (list 't/unordered (fedn/-edn data)) (?with-name name)))}}) (defn unordered-type? [x] (instance? UnorderedType x)) @@ -327,26 +366,26 @@ [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_meta/meta? - data #_dc/sequential? - name #_(t/? symbol?)] - {PType nil + name #_(t/? qualified-symbol?) + data #_dc/sequential?] + {PType {with-name ([this name'] (OrderedType. hash hash-code meta name' data))} ?Fn {invoke ([_ xs] (and (seqable? xs) ; TODO `dc/reducible?` (seq-and-2 (fn [t x] (t x)) (sequence data) (sequence xs))))} ?Meta {meta ([this] meta) - with-meta ([this meta'] (OrderedType. hash hash-code meta' data name))} + with-meta ([this meta'] (OrderedType. hash hash-code meta' name data))} ?Hash {hash ([this] (uhash/caching-set-ordered! hash OrderedType data)) hash-code ([this] (uhash/caching-set-code! hash-code OrderedType data))} ?Equals {= ([this that #_any?] (or (== this that) (and (instance? OrderedType that) (= data (.-data ^OrderedType that)))))} - uform/PGenForm {>form ([this] (-> (list 'quantum.untyped.core.type/ordered (>form data)) - (accounting-for-meta meta)))} + uform/PGenForm {>form ([this] + (or name + (list 'new 'quantum.untyped.core.type.reifications.OrderedType + hash hash-code (>form meta) name (-> data >vec >form))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (if name - (-> name (accounting-for-meta meta)) - (>form this)))}}) + fedn/IEdn {-edn ([this] (-> (list 't/ordered (fedn/-edn data)) (?with-name name)))}}) (defn ordered-type? [x] (instance? OrderedType x)) @@ -358,21 +397,23 @@ [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_(t/? ::meta) - v #_any?] - {PType nil + name #_(t/? qualified-symbol?) + v #_any?] + {PType {with-name ([this name'] (ValueType. hash hash-code meta name' v))} ?Fn {invoke ([_ x] (= x v))} ?Meta {meta ([this] meta) - with-meta ([this meta'] (ValueType. hash hash-code meta' v))} + with-meta ([this meta'] (ValueType. hash hash-code meta' name v))} ?Hash {hash ([this] (uhash/caching-set-ordered! hash ValueType v)) hash-code ([this] (uhash/caching-set-code! hash-code ValueType v))} ?Equals {= ([this that #_any?] (or (== this that) (and (instance? ValueType that) (= v (.-v ^ValueType that)))))} - uform/PGenForm {>form ([this] (-> (list 'quantum.untyped.core.type/value (>form v)) - (accounting-for-meta meta)))} + uform/PGenForm {>form ([this] + (or name (list 'new 'quantum.untyped.core.type.reifications.ValueType + hash hash-code (>form meta) name (>form v))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (>form this))}}) + fedn/IEdn {-edn ([this] (-> (list 't/value (fedn/-edn v)) (?with-name name)))}}) (defns value-type? [x _] (instance? ValueType x)) @@ -380,6 +421,7 @@ ;; ----- FnType ----- ;; +;; TODO add `hash` and `hash-code` (udt/deftype FnType [meta #_(t/? ::meta) name #_(t/? qualified-symbol?) @@ -387,20 +429,19 @@ arities-form arities #_(s/map-of nneg-int? (s/seq-of (s/kv {:input-types (s/vec-of type?) :output-type type?})))] - {PType nil + {PType {with-name ([this name'] (FnType. meta name' output-type arities-form arities))} ;; Outputs whether the args match any input spec ?Fn {invoke ([this args] (TODO))} ?Meta {meta ([this] meta) with-meta ([this meta'] (FnType. meta' name output-type arities-form arities))} - uform/PGenForm {>form ([this] - (-> (if (nil? name) - (list* 'quantum.untyped.core.type/ftype - (>form output-type) (>form arities-form)) - (list* 'quantum.untyped.core.type/ftype - name (>form output-type) (>form arities-form))) - (accounting-for-meta meta)))} + uform/PGenForm {>form ([this] (or name + (list 'new 'quantum.untyped.core.type.reifications.FnType + (>form meta) name (>form output-type) + (>form arities-form) (>form arities))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (>form this))}}) + fedn/IEdn {-edn ([this] (-> (list* 't/ftype (fedn/-edn output-type) + (fedn/-edn arities-form)) + (?with-name name)))}}) (defns fn-type? [x _ > boolean?] (instance? FnType x)) @@ -417,7 +458,7 @@ :output-type-pair (us/? (us/cat :ident #{:>} :type type?))) (us/conformer (fn [x] (-> x (update :output-type-pair :type) - (update :input-types vec) + (update :input-types >vec) (set/rename-keys {:output-type-pair :output-type})))))) ;; ----- MetaOrType ----- ;; @@ -426,18 +467,23 @@ [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_(t/? ::meta) + name #_(t/? qualified-symbol?) types #_(t/seq-of form?)] - {PType nil + {PType {with-name ([this name'] (MetaOrType. hash hash-code meta name' types))} ?Meta {meta ([this] meta) - with-meta ([this meta'] (MetaOrType. hash hash-code meta' types))} + with-meta ([this meta'] (MetaOrType. hash hash-code meta' name types))} ?Hash {hash ([this] (uhash/caching-set-ordered! hash MetaOrType types)) hash-code ([this] (uhash/caching-set-code! hash-code MetaOrType types))} ?Equals {= ([this that #_any?] (or (== this that) (and (instance? MetaOrType that) (= types (.-types ^MetaOrType that)))))} + uform/PGenForm {>form ([this] + (or name + (list 'new 'quantum.untyped.core.type.reifications.MetaOrType + hash hash-code (>form meta) name (>form types))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (list 'quantum.untyped.core.type/meta-or types))}}) + fedn/IEdn {-edn ([this] (-> (list 't/meta-or types) (?with-name name)))}}) (defn meta-or-type? [x] (instance? MetaOrType x)) @@ -456,13 +502,16 @@ [#?(:clj ^int ^:! hash :cljs ^number ^:! hash) #?(:clj ^int ^:! hash-code :cljs ^number ^:! hash-code) meta #_(t/? ::meta) + name #_(t/? qualified-symbol?) body-codelist #_(t/seq-of form?) ^:! v #_(t/? type?) rx #_(t/isa? urx/PReactive)] - {PType nil + {PType {with-name ([this name'] + (ReactiveType. hash hash-code meta name' body-codelist v rx))} urx/PReactive nil ?Meta {meta ([this] meta) - with-meta ([this meta'] (ReactiveType. hash hash-code meta' body-codelist v rx))} + with-meta ([this meta'] + (ReactiveType. hash hash-code meta' name body-codelist v rx))} ?Hash {hash ([this] (uhash/caching-set-ordered! hash ReactiveType rx)) hash-code ([this] (uhash/caching-set-code! hash-code ReactiveType rx))} ?Equals {= ([this that #_any?] @@ -470,8 +519,12 @@ (and (instance? ReactiveType that) (= rx (.-rx ^ReactiveType that)))))} ?Deref {deref ([this] (doto @rx validate-type))} + uform/PGenForm {>form ([this] + (or name (err! "Can't call `>form` on anonymous reactive type" + {:t this})))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (list `reactive-type {:value (urx/norx-deref this)}))}}) + fedn/IEdn {-edn ([this] (-> (list 't/reactive-type {:value (urx/norx-deref this)}) + (?with-name name)))}}) (defn rx-type? [x] (instance? ReactiveType x)) From 089cd6f2bf5c37caf184bca99f65cb1ab561731e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 15 Nov 2018 21:52:08 -0700 Subject: [PATCH 698/810] `t/dotyped` and `t/def` --- src-untyped/quantum/untyped/core/analyze.cljc | 3 ++ .../quantum/untyped/core/type/defnt.cljc | 31 ++++++++++++++++++- src/quantum/core/type.cljc | 7 ++--- 3 files changed, 36 insertions(+), 5 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 1d00d777..868f6415 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -928,6 +928,9 @@ def (TODO "def" {:form form}) deftype* (TODO "deftype*" {:form form}) do (analyze-seq|do env form) + ;; To avoid having to re-analyze + (quantum.untyped.core.type.defnt/dotyped quantum.core.type/dotyped) + (analyze-seq|do env (list* 'do (rest form))) fn* (TODO "fn*" {:form form}) if (analyze-seq|if env form) let* (analyze-seq|let* env form) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 6e2ce4f5..5e9ff5a1 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -62,6 +62,35 @@ [quantum.core Numeric] [quantum.core.data Array])) +;; TODO move +#?(:clj +(defmacro dotyped + "Like `do`, but evaluates `args` in a typed context." + [& args] (-> `(do ~@args) uana/analyze :form))) + +;; TODO move +#?(:clj +(defmacro def + "Like `def`, but allows for docstring and metadata placement like `defn`, and performs type + analysis. For values that satisfy `t/type?`, calls `utr/with-name` on them with the provided + `sym`." + ([sym] (list 'def sym)) + ([sym v] `(quantum.untyped.core.type.defnt/def ~sym nil nil ~v)) + ([sym doc-or-meta v] + (if (string? doc-or-meta) + `(quantum.untyped.core.type.defnt/def ~sym ~doc-or-meta nil ~v) + `(quantum.untyped.core.type.defnt/def ~sym nil ~doc-or-meta ~v))) + ([sym doc-val meta-val v] + (list 'def + (if (or doc-val meta-val) + (with-meta sym (-> meta-val (cond-> doc-val (assoc :doc doc-val)) uana/analyze :form)) + sym) + (let [node (uana/analyze v)] + (if (and (-> node :type utr/value-type?) + (-> node :type t/unvalue t/type?)) + `(utr/with-name ~(:form node) '~(uid/qualify *ns* sym)) + (:form node))))))) + ;; TODO move (def index? #(and (integer? %) (>= % 0))) (def count? index?) @@ -73,7 +102,7 @@ (us/def :quantum.core.defnt/extend-defn! (us/and (us/spec (us/cat :quantum.core.defnt/fn|extended-name :quantum.core.defnt/fn|extended-name - :quantum.core.defnt/overloads :quantum.core.defnt/overloads)) + :quantum.core.defnt/overloads :quantum.core.defnt/overloads)) (uss/fn-like|postchecks|gen :quantum.core.defnt/overloads) :quantum.core.defnt/postchecks)) diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index c54bb187..ab6192fa 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -3,7 +3,6 @@ (:refer-clojure :exclude [* - < <= = >= > and any? defn fn fn? isa? not or ref seq? symbol? type var?]) (:require - [quantum.untyped.core.analyze :as uana] [quantum.untyped.core.type.defnt :as udefnt] [quantum.untyped.core.type :as ut] ;; TODO TYPED prefer e.g. `deft-alias` @@ -13,7 +12,9 @@ ;; TODO if we ever spec-instrument we need to be careful of these aliases as they'll no longer be ;; valid -(defaliases udefnt fn defn extend-defn!) +(defalias def udefnt/def) + +(defaliases udefnt dotyped fn defn extend-defn!) (defaliases ut type type? @@ -65,5 +66,3 @@ ;; TODO TYPED move #_(:clj (defalias false? core/false?)) - -#?(:clj (defmacro dotyped [& args] (-> `(do ~@args) uana/analyze :form))) From 38d401b80ab52ab14868cb9e1d4a51eef4aa93a9 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 15 Nov 2018 21:52:36 -0700 Subject: [PATCH 699/810] Fulfill todo --- resources-dev/defnt.cljc | 4 ---- 1 file changed, 4 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 8d347bc0..4e536295 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -231,10 +231,6 @@ Legend: only bound within typed contexts. [ ] t/defrecord [ ] t/def-concrete-type (i.e. `t/deftype`) - [ ] t/def - - TODO what would this even look like? I guess it would just declare the sym, meta, and type - - It would also have the benefit of creating a typed context - - Without an argument, it would work like `declare` [-] t/fn [-] t/ftype [ ] conditionally optional arities etc. From 544f391bd0b31ca25c2db464b1f312d106ca3ae3 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 16 Nov 2018 09:54:13 -0700 Subject: [PATCH 700/810] Support printed types --- src-untyped/quantum/untyped/core/print.cljc | 5 ++++- src-untyped/quantum/untyped/core/type/defnt.cljc | 6 ++++-- test/quantum/test/untyped/core/type/defnt.cljc | 2 +- 3 files changed, 9 insertions(+), 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/print.cljc b/src-untyped/quantum/untyped/core/print.cljc index 2d3b1238..def7617b 100644 --- a/src-untyped/quantum/untyped/core/print.cljc +++ b/src-untyped/quantum/untyped/core/print.cljc @@ -68,4 +68,7 @@ ;; ===== fipp.edn ===== ;; (extend-protocol fedn/IEdn - nil (-edn [this] nil)) + nil (-edn [this] nil) + #?(:clj clojure.lang.PersistentVector + :cljs cljs.core/PersistentVector) + (-edn [this] this)) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 5e9ff5a1..c2d4fcb6 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -4,6 +4,7 @@ (:require [clojure.core :as c] [clojure.string :as str] + [fipp.ednize :as fedn] ;; TODO excise this reference [quantum.core.type.core :as tcore] ;; TODO excise this reference @@ -957,9 +958,10 @@ fn|meta' (merge fn|meta {:quantum.core.type/type (uid/qualify fn|ns-name fn|type-name)}) overload-types|form (when (= compilation-mode :test) - (->> fn|types :overload-types >form + (->> fn|types :overload-types (uc/map (c/fn [{:keys [id index inline? arg-types output-type]}] - [id index inline? arg-types output-type]))))] + [id index inline? arg-types output-type])) + fedn/-edn))] ;; TODO determine whether CLJS needs (update-in m [:jsdoc] conj "@param {...*} var_args") (if (= kind :extend-defn!) [overload-types|form diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 85105802..21b48838 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -71,7 +71,7 @@ (tag "java.lang.management.RuntimeMXBean" '(. java.lang.management.ManagementFactory getRuntimeMXBean)) 'getName))))) - [{:id 0 :index 0 :arg-types [] :output-type (t/or (t/value nil) (t/isa? String))}] + [[0 0 false [] :output-type (t/or t/nil? t/string?)]] (defmeta ~'pid|test {:quantum.core.type/type pid|test|__type} (fn* ([] (. pid|test|__0 ~'invoke))))))] From c363cb521a9084a24fe7c6120454422035a9fb02 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 16 Nov 2018 11:57:35 -0700 Subject: [PATCH 701/810] First test re-passes! --- src-untyped/quantum/untyped/core/print.cljc | 10 ++++++---- src-untyped/quantum/untyped/core/test.cljc | 3 ++- .../quantum/untyped/core/type/reifications.cljc | 9 ++++++++- test/quantum/test/untyped/core/type/defnt.cljc | 2 +- 4 files changed, 17 insertions(+), 7 deletions(-) diff --git a/src-untyped/quantum/untyped/core/print.cljc b/src-untyped/quantum/untyped/core/print.cljc index def7617b..1e10f879 100644 --- a/src-untyped/quantum/untyped/core/print.cljc +++ b/src-untyped/quantum/untyped/core/print.cljc @@ -68,7 +68,9 @@ ;; ===== fipp.edn ===== ;; (extend-protocol fedn/IEdn - nil (-edn [this] nil) - #?(:clj clojure.lang.PersistentVector - :cljs cljs.core/PersistentVector) - (-edn [this] this)) + nil (-edn [this] nil) + #?(:clj java.lang.Boolean + :cljs boolean) (-edn [this] this) + #?@(:clj [java.lang.Long (-edn [this] this)]) + #?(:clj clojure.lang.PersistentVector + :cljs cljs.core/PersistentVector) (-edn [this] (mapv fedn/-edn this))) diff --git a/src-untyped/quantum/untyped/core/test.cljc b/src-untyped/quantum/untyped/core/test.cljc index f12c074f..cfb7cde9 100644 --- a/src-untyped/quantum/untyped/core/test.cljc +++ b/src-untyped/quantum/untyped/core/test.cljc @@ -47,7 +47,8 @@ (or (= c0 c1) (do (pr! "FAIL: should be `(= code0 code1)`" (pr-str c0) (pr-str c1)) false)) (and (or similar-class? - (do (pr! "FAIL: should be similar class" (pr-str c0) (pr-str c1)) + (do (pr! "FAIL: should be similar class" + {:c0 (type c0) :x0 (pr-str c0) :c1 (type c1) :x1 (pr-str c1)}) false)) (or (if (or (set? c0) (map? c0)) (uc/seq= (sort c0) (sort c1) code=) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 94c3c212..e49564f0 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -47,7 +47,14 @@ (defn type? [x #_> #_boolean?] (satisfies? PType x)) -(defn- ?with-name [form ?name] (if ?name (list 't/named ?name form) form)) +(def ^:dynamic *expand-names?* false) + +(defn- ?with-name [form ?name] + (if ?name + (if *expand-names?* + (list 't/named ?name form) + ?name) + form)) ;; ----- MetaType ----- ;; diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 21b48838..17c57676 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -71,7 +71,7 @@ (tag "java.lang.management.RuntimeMXBean" '(. java.lang.management.ManagementFactory getRuntimeMXBean)) 'getName))))) - [[0 0 false [] :output-type (t/or t/nil? t/string?)]] + [[0 0 false [] (~'t/or t/nil? t/string?)]] (defmeta ~'pid|test {:quantum.core.type/type pid|test|__type} (fn* ([] (. pid|test|__0 ~'invoke))))))] From c03481d4f377551e29c5c735f05d776573f11f50 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 16 Nov 2018 12:21:03 -0700 Subject: [PATCH 702/810] Flesh out `-edn` overloads --- src-untyped/quantum/untyped/core/print.cljc | 33 +++++++++++++++++---- 1 file changed, 28 insertions(+), 5 deletions(-) diff --git a/src-untyped/quantum/untyped/core/print.cljc b/src-untyped/quantum/untyped/core/print.cljc index 1e10f879..7c5ab266 100644 --- a/src-untyped/quantum/untyped/core/print.cljc +++ b/src-untyped/quantum/untyped/core/print.cljc @@ -68,9 +68,32 @@ ;; ===== fipp.edn ===== ;; (extend-protocol fedn/IEdn - nil (-edn [this] nil) - #?(:clj java.lang.Boolean - :cljs boolean) (-edn [this] this) - #?@(:clj [java.lang.Long (-edn [this] this)]) + nil (-edn [x] nil) + #?(:clj java.lang.Boolean + :cljs boolean) (-edn [x] x) + #?@(:clj [java.lang.Integer (-edn [x] x) + java.lang.Long (-edn [x] x)]) + #?(:clj java.lang.Double + :cljs number) (-edn [x] x) + #?(:clj java.lang.String + :cljs string) (-edn [x] x) + #?(:clj clojure.lang.Symbol + :cljs cljs.core/Symbol) (-edn [x] x) + #?(:clj clojure.lang.Keyword + :cljs cljs.core/Keyword) (-edn [x] x) + #?(:clj clojure.lang.PersistentArrayMap + :cljs cljs.core/PersistentArrayMap) + (-edn [x] (->> x (map (fn [[k v]] [(fedn/-edn k) (fedn/-edn v)])) (into (array-map)))) + #?(:clj clojure.lang.PersistentHashMap + :cljs cljs.core/PersistentHashMap) + (-edn [x] (->> x (map (fn [[k v]] [(fedn/-edn k) (fedn/-edn v)])) (into (hash-map)))) #?(:clj clojure.lang.PersistentVector - :cljs cljs.core/PersistentVector) (-edn [this] (mapv fedn/-edn this))) + :cljs cljs.core/PersistentVector) + (-edn [x] (->> x (mapv fedn/-edn))) + #?(:clj clojure.lang.PersistentList + :cljs cljs.core/PersistentList) + (-edn [x] (->> x (map fedn/-edn) list*)) + #?@(:clj [clojure.lang.PersistentList$EmptyList (fedn/-edn [x] x)]) + #?@(:clj [clojure.lang.ASeq (-edn [x] (->> x (map fedn/-edn)))]) + #?@(:clj [clojure.lang.LazySeq (-edn [x] (->> x (map fedn/-edn)))]) + #?@(:clj [Class (-edn [x] (-> x .getName symbol))])) From 7e7cadd57f648700e75ef5aa39557c908f21c450 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 16 Nov 2018 12:21:13 -0700 Subject: [PATCH 703/810] `maybe-look-up-type-from-class` to save memory --- src-untyped/quantum/untyped/core/analyze.cljc | 29 +++++++++++++++---- 1 file changed, 24 insertions(+), 5 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 868f6415..c6629729 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -44,6 +44,22 @@ (def special-metadata-keys #{:val}) +#?(:clj +(defns- maybe-look-up-type-from-class + "To save on memory — rather than creating a new `t/isa?` for every primitive class, uses the ones + already created in `quantum.untyped.core.type`." + [^Class c class? > t/type?] + (case (.getName c) + "java.lang.Boolean" t/boolean? + "java.lang.Byte" t/byte? + "java.lang.Short" t/short? + "java.lang.Character" t/char? + "java.lang.Integer" t/int? + "java.lang.Long" t/long? + "java.lang.Float" t/float? + "java.lang.Double" t/double? + (t/isa? c)))) + ;; TODO move? (defns class>type "For converting a class in a reflective method, constructor, or field declaration to a type. @@ -51,14 +67,16 @@ non-null." [x class? > t/type?] (let [matching-boxed-class (t/unboxed-class->boxed-class x)] - (-> (or matching-boxed-class x) t/isa? (cond-> (not matching-boxed-class) t/?)))) + (-> (or matching-boxed-class x) + maybe-look-up-type-from-class + (cond-> (not matching-boxed-class) t/?)))) (defn- assume-val-for-form? [form] (-> form meta :val true?)) (defns- maybe-with-assume-val [c class?, form _ > t/type?] (let [matching-boxed-class (t/unboxed-class->boxed-class c)] (-> (or matching-boxed-class c) - t/isa? + maybe-look-up-type-from-class (cond-> (and (not matching-boxed-class) (not (assume-val-for-form? form))) t/?)))) ;; TODO move? @@ -539,7 +557,7 @@ :form (list* 'new c|form (map :form args|analyzed)) :class c :args args|analyzed - :type (t/isa? c)}))))))) + :type (maybe-look-up-type-from-class c)}))))))) ;; TODO move this (defns truthy-node? [{:as ast t [:type _]} _ > (t/? t/boolean?)] @@ -674,7 +692,7 @@ (defns- caller>overload-type-data-for-arity [env ::env, caller|node uast/node?, caller|type _, inputs-ct _] - (if-let [fn|name (utr/fn-type>name caller|type)] + (if-let [fn|name (utr/fn-type>fn-name caller|type)] (let [overload-types-name (symbol (namespace fn|name) (str (name fn|name) "|__types"))] (if-let [fn|types (get env overload-types-name)] (->> fn|types (uc/filter #(-> % :arg-types count (= inputs-ct)))) @@ -695,7 +713,7 @@ (defns- >direct-dispatch|reify-call [caller|node uast/node?, caller|type _, type-datum _, args-codelist (us/seq-of t/any?)] - (if-let [fn|name (utr/fn-type>name caller|type)] + (if-let [fn|name (utr/fn-type>fn-name caller|type)] `(. ~(overload-type-datum>reify-name type-datum fn|name) ~direct-dispatch-method-sym ~@args-codelist) (err! "No name found for typed fn corresponding to caller; cannot create direct dispatch call" @@ -1071,6 +1089,7 @@ ([form _] (analyze {} form)) ([env ::env, form _] (uref/set! !!analyze-depth 0) + #_(pr! (kw-map env form)) (analyze* env form))) ;; ===== Arglist analysis ===== ;; From d823a06dc47efe0a191c463140621c398e741302 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 16 Nov 2018 12:21:27 -0700 Subject: [PATCH 704/810] Clear up fn-name vs. name on `t/ftype` --- src-untyped/quantum/untyped/core/type.cljc | 10 ++++----- .../untyped/core/type/reifications.cljc | 21 ++++++++++++------- 2 files changed, 19 insertions(+), 12 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index cde1c594..386e8585 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -530,10 +530,10 @@ ;; ===== `t/ftype` ===== ;; (defn ftype [& args] - (let [name- (when (-> args first c/symbol?) + (let [?fn-name (when (-> args first c/symbol?) (first args)) - rest-args (if name- (rest args) args) - out-type (if (-> rest-args first c/sequential?) + rest-args (if ?fn-name (rest args) args) + output-type (if (-> rest-args first c/sequential?) universal-set (first rest-args)) arities-form (if (-> rest-args first c/sequential?) @@ -542,9 +542,9 @@ arities (->> arities-form (uc/map+ (c/fn [arity-form] (-> (us/conform ::fn-type|arity arity-form) - (update :output-type #(c/or % out-type universal-set))))) + (update :output-type #(c/or % output-type universal-set))))) (uc/group-by #(-> % :input-types count)))] - (FnType. nil name- out-type arities-form arities))) + (FnType. nil nil ?fn-name output-type arities-form arities))) (defns compare|in [x0 utr/fn-type?, x1 utr/fn-type? > uset/comparison?] (let [ct->overloads|x0 (utr/fn-type>arities x0) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index e49564f0..dd996dbc 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -432,27 +432,34 @@ (udt/deftype FnType [meta #_(t/? ::meta) name #_(t/? qualified-symbol?) + fn-name #_(t/? qualified-symbol?) output-type #_t/type? arities-form arities #_(s/map-of nneg-int? (s/seq-of (s/kv {:input-types (s/vec-of type?) :output-type type?})))] - {PType {with-name ([this name'] (FnType. meta name' output-type arities-form arities))} + {PType {with-name ([this name'] + (FnType. meta name' fn-name output-type arities-form arities))} ;; Outputs whether the args match any input spec ?Fn {invoke ([this args] (TODO))} ?Meta {meta ([this] meta) - with-meta ([this meta'] (FnType. meta' name output-type arities-form arities))} + with-meta ([this meta'] + (FnType. meta' name fn-name output-type arities-form arities))} uform/PGenForm {>form ([this] (or name (list 'new 'quantum.untyped.core.type.reifications.FnType - (>form meta) name (>form output-type) + (>form meta) name fn-name (>form output-type) (>form arities-form) (>form arities))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (-> (list* 't/ftype (fedn/-edn output-type) - (fedn/-edn arities-form)) - (?with-name name)))}}) + fedn/IEdn {-edn ([this] (if fn-name + (-> (list* 't/ftype fn-name (fedn/-edn output-type) + (fedn/-edn arities-form)) + (?with-name name)) + (-> (list* 't/ftype (fedn/-edn output-type) + (fedn/-edn arities-form)) + (?with-name name))))}}) (defns fn-type? [x _ > boolean?] (instance? FnType x)) -(defns fn-type>name [^FnType x fn-type?] (.-name x)) +(defns fn-type>fn-name [^FnType x fn-type?] (.-fn-name x)) (defns fn-type>arities [^FnType x fn-type?] (.-arities x)) From 9ba7b371903a8e55eda35b57e752013295a8d3ee Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 16 Nov 2018 12:34:46 -0700 Subject: [PATCH 705/810] Don't auto-collapse symbols --- src-untyped/quantum/untyped/core/analyze.cljc | 22 ++------ .../quantum/untyped/core/print/prettier.cljc | 6 +-- src-untyped/quantum/untyped/core/type.cljc | 21 +++++++- .../untyped/core/type/reifications.cljc | 54 +++++++++++-------- .../quantum/test/untyped/core/type/defnt.cljc | 18 +++---- 5 files changed, 67 insertions(+), 54 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index c6629729..6c5be47d 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -44,22 +44,6 @@ (def special-metadata-keys #{:val}) -#?(:clj -(defns- maybe-look-up-type-from-class - "To save on memory — rather than creating a new `t/isa?` for every primitive class, uses the ones - already created in `quantum.untyped.core.type`." - [^Class c class? > t/type?] - (case (.getName c) - "java.lang.Boolean" t/boolean? - "java.lang.Byte" t/byte? - "java.lang.Short" t/short? - "java.lang.Character" t/char? - "java.lang.Integer" t/int? - "java.lang.Long" t/long? - "java.lang.Float" t/float? - "java.lang.Double" t/double? - (t/isa? c)))) - ;; TODO move? (defns class>type "For converting a class in a reflective method, constructor, or field declaration to a type. @@ -68,7 +52,7 @@ [x class? > t/type?] (let [matching-boxed-class (t/unboxed-class->boxed-class x)] (-> (or matching-boxed-class x) - maybe-look-up-type-from-class + t/maybe-look-up-type-from-class (cond-> (not matching-boxed-class) t/?)))) (defn- assume-val-for-form? [form] (-> form meta :val true?)) @@ -76,7 +60,7 @@ (defns- maybe-with-assume-val [c class?, form _ > t/type?] (let [matching-boxed-class (t/unboxed-class->boxed-class c)] (-> (or matching-boxed-class c) - maybe-look-up-type-from-class + t/maybe-look-up-type-from-class (cond-> (and (not matching-boxed-class) (not (assume-val-for-form? form))) t/?)))) ;; TODO move? @@ -557,7 +541,7 @@ :form (list* 'new c|form (map :form args|analyzed)) :class c :args args|analyzed - :type (maybe-look-up-type-from-class c)}))))))) + :type (t/maybe-look-up-type-from-class c)}))))))) ;; TODO move this (defns truthy-node? [{:as ast t [:type _]} _ > (t/? t/boolean?)] diff --git a/src-untyped/quantum/untyped/core/print/prettier.cljc b/src-untyped/quantum/untyped/core/print/prettier.cljc index b7f4a211..613dce8b 100644 --- a/src-untyped/quantum/untyped/core/print/prettier.cljc +++ b/src-untyped/quantum/untyped/core/print/prettier.cljc @@ -2,7 +2,7 @@ (:require [fipp.edn] [fipp.visit] - [fipp.ednize] + [fipp.ednize :as fedn] [quantum.untyped.core.fn :refer [rcomp]] [quantum.untyped.core.ns] @@ -11,8 +11,8 @@ [quantum.untyped.core.vars])) #?(:clj -(defmethod print-method fipp.ednize.IEdn [^fipp.ednize.IEdn v ^java.io.Writer w] - (print-method (._edn v) w))) +(defmethod print-method fipp.ednize.IEdn [v ^java.io.Writer w] + (print-method (fedn/-edn v) w))) #?(:clj (prefer-method print-method fipp.ednize.IEdn clojure.lang.IRecord)) #?(:clj (prefer-method print-method fipp.ednize.IEdn clojure.lang.IPersistentMap)) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 386e8585..89bb94ff 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -86,7 +86,8 @@ #?(:clj (uvar/defalias def* quantum.untyped.core.type/def)) -(declare - create-logical-type meta-or with-expand-meta-ors nil? val? and or val|by-class?) +(declare - create-logical-type maybe-look-up-type-from-class meta-or with-expand-meta-ors nil? val? + and or val|by-class?) ;; ===== Comparison ===== ;; @@ -850,7 +851,7 @@ (->> (type>classes t include-subtypes-of-value-type?) (uc/mapcat+ class>boxed-subclasses+) uc/distinct+ - (uc/map+ isa?) + (uc/map+ maybe-look-up-type-from-class) (ur/join #{})))))) #?(:clj @@ -935,6 +936,22 @@ (isa? js/Function) nil?))) +#?(:clj +(defns maybe-look-up-type-from-class + "To save on memory — rather than creating a new `t/isa?` for every primitive class, uses the ones + already created in `quantum.untyped.core.type`." + [^Class c c/class? > utr/type?] + (case (.getName c) + "java.lang.Boolean" boolean? + "java.lang.Byte" byte? + "java.lang.Short" short? + "java.lang.Character" char? + "java.lang.Integer" int? + "java.lang.Long" long? + "java.lang.Float" float? + "java.lang.Double" double? + (isa? c)))) + ;; ===== Booleans ===== ;; ;; Used by `quantum.untyped.core.analyze` diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index dd996dbc..96ff0940 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -52,7 +52,7 @@ (defn- ?with-name [form ?name] (if ?name (if *expand-names?* - (list 't/named ?name form) + (list 'quantum.untyped.core.type/named ?name form) ?name) form)) @@ -77,9 +77,9 @@ (>form meta) name (>form t) assume? ref? runtime?)))} fedn/IOverride nil fedn/IEdn {-edn ([this] (-> (cond->> (fedn/-edn t) - assume? (list 't/assume) - ref? (list 't/ref) - runtime? (list 't/*)) + assume? (list 'quantum.untyped.core.type/assume) + ref? (list 'quantum.untyped.core.type/ref) + runtime? (list 'quantum.untyped.core.type/*)) (?with-name name)))}}) (defns meta-type? [x _ > boolean?] (instance? MetaType x)) @@ -99,7 +99,7 @@ ?Equals {= ([this that] (or (== this that) (instance? UniversalSetType that)))} uform/PGenForm {>form ([this] 'quantum.untyped.core.type/any?)} fedn/IOverride nil - fedn/IEdn {-edn ([this] 't/any?)}}) + fedn/IEdn {-edn ([this] 'quantum.untyped.core.type/any?)}}) (def universal-set (UniversalSetType. nil)) @@ -118,7 +118,7 @@ ?Equals {= ([this that] (or (== this that) (instance? EmptySetType that)))} uform/PGenForm {>form ([this] 'quantum.untyped.core.type/none?)} fedn/IOverride nil - fedn/IEdn {-edn ([this] 't/none?)}}) + fedn/IEdn {-edn ([this] 'quantum.untyped.core.type/none?)}}) (def empty-set (EmptySetType. nil)) @@ -144,7 +144,8 @@ (or name (list 'new 'quantum.untyped.core.type.reifications.NotType hash hash-code (>form meta) name (>form t))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (-> (list 't/not (fedn/-edn t)) (?with-name name)))}}) + fedn/IEdn {-edn ([this] (-> (list 'quantum.untyped.core.type/not (fedn/-edn t)) + (?with-name name)))}}) (defns not-type? [x _ > boolean?] (instance? NotType x)) @@ -181,7 +182,8 @@ hash hash-code (>form meta) name (-> args >vec >form) `(atom nil))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (-> (list* 't/or (map fedn/-edn args)) (?with-name name)))}}) + fedn/IEdn {-edn ([this] (-> (list* 'quantum.untyped.core.type/or (map fedn/-edn args)) + (?with-name name)))}}) (defns or-type? [x _ > boolean?] (instance? OrType x)) @@ -215,7 +217,8 @@ hash hash-code (>form meta) name (-> args >vec >form) `(atom nil))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (-> (list* 't/and (map fedn/-edn args)) (?with-name name)))}}) + fedn/IEdn {-edn ([this] (-> (list* 'quantum.untyped.core.type/and (map fedn/-edn args)) + (?with-name name)))}}) (defns and-type? [x _ > boolean?] (instance? AndType x)) @@ -248,7 +251,8 @@ 'quantum.untyped.core.type.reifications.ProtocolType hash hash-code (>form meta) name (-> p :var >symbol))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (-> (list 't/isa?|protocol (-> p :var >symbol)) + fedn/IEdn {-edn ([this] (-> (list 'quantum.untyped.core.type/isa?|protocol + (-> p :var >symbol)) (?with-name name)))}}) (defns protocol-type? [x _] (instance? ProtocolType x)) @@ -282,7 +286,8 @@ 'quantum.untyped.core.type.reifications.DirectProtocolType hash hash-code (>form meta) name (-> p :var >symbol))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (-> (list 't/isa?|protocol|direct (-> p :var >symbol)) + fedn/IEdn {-edn ([this] (-> (list 'quantum.untyped.core.type/isa?|protocol|direct + (-> p :var >symbol)) (?with-name name)))}})) #?(:cljs (defns direct-protocol-type? [x _] (instance? DirectProtocolType x))) @@ -311,7 +316,8 @@ (or name (list 'new 'quantum.untyped.core.type.reifications.ClassType hash hash-code (>form meta) name (>form c))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (-> (list 't/isa? (fedn/-edn c)) (?with-name name)))}}) + fedn/IEdn {-edn ([this] (-> (list 'quantum.untyped.core.type/isa? (fedn/-edn c)) + (?with-name name)))}}) (defns class-type? [x _] (instance? ClassType x)) @@ -361,7 +367,9 @@ (list 'new 'quantum.untyped.core.type.reifications.UnorderedType hash hash-code (>form meta) name (>form data))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (-> (list 't/unordered (fedn/-edn data)) (?with-name name)))}}) + fedn/IEdn {-edn ([this] + (-> (list 'quantum.untyped.core.type/unordered (fedn/-edn data)) + (?with-name name)))}}) (defn unordered-type? [x] (instance? UnorderedType x)) @@ -392,7 +400,8 @@ (list 'new 'quantum.untyped.core.type.reifications.OrderedType hash hash-code (>form meta) name (-> data >vec >form))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (-> (list 't/ordered (fedn/-edn data)) (?with-name name)))}}) + fedn/IEdn {-edn ([this] (-> (list 'quantum.untyped.core.type/ordered (fedn/-edn data)) + (?with-name name)))}}) (defn ordered-type? [x] (instance? OrderedType x)) @@ -420,7 +429,8 @@ (or name (list 'new 'quantum.untyped.core.type.reifications.ValueType hash hash-code (>form meta) name (>form v))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (-> (list 't/value (fedn/-edn v)) (?with-name name)))}}) + fedn/IEdn {-edn ([this] (-> (list 'quantum.untyped.core.type/value (fedn/-edn v)) + (?with-name name)))}}) (defns value-type? [x _] (instance? ValueType x)) @@ -450,11 +460,11 @@ (>form arities-form) (>form arities))))} fedn/IOverride nil fedn/IEdn {-edn ([this] (if fn-name - (-> (list* 't/ftype fn-name (fedn/-edn output-type) - (fedn/-edn arities-form)) + (-> (list* 'quantum.untyped.core.type/ftype fn-name + (fedn/-edn output-type) (fedn/-edn arities-form)) (?with-name name)) - (-> (list* 't/ftype (fedn/-edn output-type) - (fedn/-edn arities-form)) + (-> (list* 'quantum.untyped.core.type/ftype + (fedn/-edn output-type) (fedn/-edn arities-form)) (?with-name name))))}}) (defns fn-type? [x _ > boolean?] (instance? FnType x)) @@ -497,7 +507,8 @@ (list 'new 'quantum.untyped.core.type.reifications.MetaOrType hash hash-code (>form meta) name (>form types))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (-> (list 't/meta-or types) (?with-name name)))}}) + fedn/IEdn {-edn ([this] (-> (list 'quantum.untyped.core.type/meta-or types) + (?with-name name)))}}) (defn meta-or-type? [x] (instance? MetaOrType x)) @@ -537,7 +548,8 @@ (or name (err! "Can't call `>form` on anonymous reactive type" {:t this})))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (-> (list 't/reactive-type {:value (urx/norx-deref this)}) + fedn/IEdn {-edn ([this] (-> (list 'quantum.untyped.core.type/reactive-type + {:value (urx/norx-deref this)}) (?with-name name)))}}) (defn rx-type? [x] (instance? ReactiveType x)) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 17c57676..bb5aa7c9 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -114,15 +114,15 @@ (def ~(tag (cstr `Object>Object) 'identity|__8) (reify* [Object>Object] (~(O 'invoke) [~'_8__ ~(O 'x)] ~(O 'x)))) - [[0 0 true [(t/isa? Boolean)] (t/isa? Boolean)] - [1 1 true [(t/isa? Byte)] (t/isa? Byte)] - [2 2 true [(t/isa? Short)] (t/isa? Short)] - [3 3 true [(t/isa? Character)] (t/isa? Character)] - [4 4 true [(t/isa? Integer)] (t/isa? Integer)] - [5 5 true [(t/isa? Long)] (t/isa? Long)] - [6 6 true [(t/isa? Float)] (t/isa? Float)] - [7 7 true [(t/isa? Double)] (t/isa? Double)] - [8 8 true [t/any?] t/any?]] + [[0 0 true [t/boolean?] t/boolean?] + [1 1 true [t/byte?] t/byte?] + [2 2 true [t/short?] t/short?] + [3 3 true [t/char?] t/char?] + [4 4 true [t/int?] t/int?] + [5 5 true [t/long?] t/long?] + [6 6 true [t/float?] t/float?] + [7 7 true [t/double?] t/double?] + [8 8 true [t/any?] t/any?]] (defmeta ~'identity {:quantum.core.type/type identity|__type} From 041627a7c801a0d184088893a32757d60617089c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 16 Nov 2018 12:46:15 -0700 Subject: [PATCH 706/810] Compare MetaType with everything else --- src-untyped/quantum/untyped/core/type.cljc | 13 ++-- .../quantum/untyped/core/type/compare.cljc | 62 +++++++++++++++---- .../quantum/test/untyped/core/type/defnt.cljc | 18 +++--- 3 files changed, 68 insertions(+), 25 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 89bb94ff..b4439aa7 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -61,7 +61,11 @@ #?@(:cljs [UniversalSetType EmptySetType NotType OrType AndType ProtocolType DirectProtocolType ClassType - ValueType])]] + UnorderedType OrderedType + ValueType + FnType + MetaType MetaOrType + ReactiveType])]] [quantum.untyped.core.vars :as uvar :refer [def- defmacro- update-meta]]) #?(:cljs (:require-macros @@ -70,12 +74,13 @@ #?(:clj (:import [quantum.untyped.core.analyze.expr Expression] [quantum.untyped.core.type.reifications - MetaType UniversalSetType EmptySetType + UniversalSetType EmptySetType NotType OrType AndType - ProtocolType ClassType UnorderedType OrderedType + ProtocolType ClassType + UnorderedType OrderedType ValueType FnType - MetaOrType + MetaType MetaOrType ReactiveType]))) (ucore/log-this-ns) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index 3aefe4b6..efbae960 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -37,8 +37,12 @@ fn-type? #?@(:cljs [UniversalSetType EmptySetType NotType OrType AndType - ProtocolType ClassType - ValueType])]] + ProtocolType DirectProtocolType ClassType + UnorderedType OrderedType + ValueType + FnType + MetaType MetaOrType + ReactiveType])]] [quantum.untyped.core.vars :refer [def-]]) #?(:clj (:import @@ -47,7 +51,10 @@ UniversalSetType EmptySetType NotType OrType AndType ProtocolType ClassType - ValueType]))) + ValueType + FnType + MetaType MetaOrType + ReactiveType]))) (ucore/log-this-ns) @@ -353,6 +360,17 @@ =ident <>ident)) +;; ----- MetaType ----- ;; + +(defns- compare|meta+meta [t0 utr/meta-type?, t1 utr/meta-type?] + (compare (utr/meta-type>inner-type t0) (utr/meta-type>inner-type t1))) + +(defns- compare|meta+non-meta [t0 utr/meta-type?, t1 type?] + (compare (utr/meta-type>inner-type t0) t1)) + +(defns- compare|non-meta+meta [t0 type?, t1 utr/meta-type?] + (compare t0 (utr/meta-type>inner-type t1))) + ;; ===== Dispatch ===== ;; (def- compare|dispatch @@ -366,7 +384,8 @@ Expression compare|universal+expr ProtocolType compare|universal+protocol ClassType compare|universal+class - ValueType compare|universal+value} + ValueType compare|universal+value + MetaType compare|non-meta+meta} EmptySetType {UniversalSetType (inverted compare|universal+empty) EmptySetType fn= @@ -376,7 +395,8 @@ Expression compare|empty+expr ProtocolType compare|empty+protocol ClassType compare|empty+class - ValueType compare|empty+value} + ValueType compare|empty+value + MetaType compare|non-meta+meta} NotType {UniversalSetType (inverted compare|universal+not) EmptySetType (inverted compare|empty+not) @@ -386,7 +406,8 @@ Expression fn>< ; TODO not entirely true ProtocolType compare|not+protocol ClassType compare|not+class - ValueType compare|not+value} + ValueType compare|not+value + MetaType compare|non-meta+meta} OrType {UniversalSetType (inverted compare|universal+or) EmptySetType (inverted compare|empty+or) @@ -396,7 +417,8 @@ Expression fn>< ; TODO not entirely true ProtocolType compare|todo ClassType (inverted compare|class+or) - ValueType (inverted compare|value+or)} + ValueType (inverted compare|value+or) + MetaType compare|non-meta+meta} AndType {UniversalSetType (inverted compare|universal+and) EmptySetType (inverted compare|empty+and) @@ -406,7 +428,8 @@ Expression fn>< ; TODO not entirely true ProtocolType compare|todo ClassType (inverted compare|class+and) - ValueType (inverted compare|value+and)} + ValueType (inverted compare|value+and) + MetaType compare|non-meta+meta} ;; TODO review this Expression {UniversalSetType (inverted compare|universal+expr) @@ -417,7 +440,8 @@ Expression compare|expr+expr ProtocolType fn>< ; TODO not entirely true ClassType fn>< ; TODO not entirely true - ValueType compare|expr+value} + ValueType compare|expr+value + MetaType compare|non-meta+meta} ProtocolType {UniversalSetType (inverted compare|universal+protocol) EmptySetType (inverted compare|empty+protocol) @@ -427,7 +451,8 @@ Expression fn>< ; TODO not entirely true ProtocolType compare|protocol+protocol ClassType compare|protocol+class - ValueType (inverted compare|value+protocol)} + ValueType (inverted compare|value+protocol) + MetaType compare|non-meta+meta} ClassType {UniversalSetType (inverted compare|universal+class) EmptySetType (inverted compare|empty+class) @@ -437,7 +462,8 @@ Expression fn>< ; TODO not entirely true ProtocolType (inverted compare|protocol+class) ClassType compare|class+class - ValueType compare|class+value} + ValueType compare|class+value + MetaType compare|non-meta+meta} ValueType {UniversalSetType (inverted compare|universal+value) EmptySetType (inverted compare|empty+value) @@ -447,7 +473,19 @@ Expression (inverted compare|expr+value) ProtocolType compare|value+protocol ClassType (inverted compare|class+value) - ValueType compare|value+value}})) + ValueType compare|value+value + MetaType compare|non-meta+meta} + MetaType + {UniversalSetType compare|meta+non-meta + EmptySetType compare|meta+non-meta + NotType compare|meta+non-meta + OrType compare|meta+non-meta + AndType compare|meta+non-meta + Expression compare|meta+non-meta + ProtocolType compare|meta+non-meta + ClassType compare|meta+non-meta + ValueType compare|meta+non-meta + MetaType compare|meta+meta}})) ;; ===== Operators ===== ;; diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index bb5aa7c9..0116b397 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -71,7 +71,7 @@ (tag "java.lang.management.RuntimeMXBean" '(. java.lang.management.ManagementFactory getRuntimeMXBean)) 'getName))))) - [[0 0 false [] (~'t/or t/nil? t/string?)]] + [[0 0 false [] (t/or t/nil? t/string?)]] (defmeta ~'pid|test {:quantum.core.type/type pid|test|__type} (fn* ([] (. pid|test|__0 ~'invoke))))))] @@ -978,14 +978,14 @@ (~(L 'invoke) [~'_7__ ~(O 'x)] (. ~(tag "java.lang.Number" 'x) ~'longValue)))) - [[0 0 true [(t/isa? Byte)] (t/isa? Long)] - [1 1 true [(t/isa? Short)] (t/isa? Long)] - [2 2 true [(t/isa? Character)] (t/isa? Long)] - [3 3 true [(t/isa? Integer)] (t/isa? Long)] - [4 4 true [(t/isa? Long)] (t/isa? Long)] - [5 5 true [(t/isa? Float)] (t/isa? Long)] - [6 6 true [(t/isa? Double)] (t/isa? Long)] - [7 7 true [(t/ref (t/isa? Number))] (t/isa? Long)]] + [[0 0 true [t/byte?] t/long?] + [1 1 true [t/short?] t/long?] + [2 2 true [t/char?] t/long?] + [3 3 true [t/int?] t/long?] + [4 4 true [t/long?] t/long?] + [5 5 true [t/float?] t/long?] + [6 6 true [t/double?] t/long?] + [7 7 true [(t/ref (t/isa? Number))] t/long?]] (defmeta ~'>long* {:source "clojure.lang.RT.uncheckedLongCast" From 9cb26b9d3a64a6a144fea87f207ed07fd81ba4c7 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 16 Nov 2018 13:17:48 -0700 Subject: [PATCH 707/810] Transition metadata to `MetaType` --- resources-dev/defnt.cljc | 8 +-- src-untyped/quantum/untyped/core/analyze.cljc | 4 +- .../quantum/untyped/core/analyze/ast.cljc | 2 +- src-untyped/quantum/untyped/core/type.cljc | 54 +++++++++++-------- .../quantum/untyped/core/type/defnt.cljc | 8 +-- .../untyped/core/type/reifications.cljc | 2 +- src/quantum/core/collections_typed.cljc | 2 +- src/quantum/core/data/meta.cljc | 2 +- src/quantum/core/type.cljc | 4 +- src/quantum/core/vars.cljc | 10 ++-- .../quantum/test/untyped/core/type/defnt.cljc | 22 ++++---- 11 files changed, 63 insertions(+), 55 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 4e536295..2ed9ab1c 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -88,13 +88,13 @@ Legend: [ ] Perhaps it's the case that we can't actually have type bases but rather reactive splits. In the case of `narrowest`, it expects a split and fails without it: `[a (t/- integer? int?), b integer? > (narrowest (t/type a) (t/type b))]` - [ ] `t/ref`, `t/assume`, `t/*` need to be combined correctly with other types. + [ ] `t/ref`, `t/assume`, `t/run` need to be combined correctly with other types. E.g. (t/and (t/ref ...) ...) means the whole thing should be `t/ref`, while `(t/or (t/ref ...) - (...))` does not mean the metadata is transferred. Probably `t/assume` and `t/*` should be + (...))` does not mean the metadata is transferred. Probably `t/assume` and `t/run` should be combined in the same way. - What about `(t/and (t/or t/long? (t/ref t/byte?)) pos?)` ? [ ] t/value-of - - `[x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))]` + - `[x with-metable?, meta' meta? > (t/run with-metable?) #_(TODO TYPED (t/value-of x))]` [ ] (comp/t== x) - dependent type such that the passed input must be identical to x [ ] `?` : type inference @@ -104,7 +104,7 @@ Legend: ([n dn/std-integer?, xs ?] ...) - [ ] No trailing `>` means `> ?`f [ ] Non-boxed `def`s: `(var/def- min-float (Numeric/negate Float/MAX_VALUE))` - [ ] `(t/validate x (t/* t/string?))` for `(t/* t/string?)` needs to be more performant + [ ] `(t/validate x (t/run t/string?))` for `(t/run t/string?)` needs to be more performant - Don't re-create type on each call (see `defnt/unanalyzed-overload>overload`) [ ] replace `deref` with `ref/deref` in typed contexts? So we can do `@` still - Type Logic and Predicates diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 6c5be47d..204c6416 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -731,7 +731,7 @@ :body body-node :type (:type body-node)})] ;; TODO fix this; apparently it's not enough or maybe `assume` isn't being propagated - (cond-> node (-> overload-type-datum :output-type meta :quantum.core.type/assume?) + (cond-> node (-> overload-type-datum :output-type t/assume?) (update :type #(t/and % (:output-type overload-type-datum))))) {:input-nodes input-nodes :form (>direct-dispatch|reify-call @@ -836,7 +836,7 @@ (t/value t/and) (apply-arg-type-combine t/and input-nodes) (t/value t/-) (apply-arg-type-combine t/- input-nodes) (t/value t/?) (apply-arg-type-combine t/? input-nodes) - (t/value t/*) (apply-arg-type-combine t/* input-nodes) + (t/value t/run) (apply-arg-type-combine t/run input-nodes) (t/value t/ref) (apply-arg-type-combine t/ref input-nodes) (t/value t/unref) (apply-arg-type-combine t/unref input-nodes) (t/value t/assume) (apply-arg-type-combine t/assume input-nodes) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 619fad4e..070c7b8d 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -29,7 +29,7 @@ ;; TODO for now (uxp/iexpr? t)) nil - (let [cs (cond-> (t/type>classes t) (-> t meta :quantum.core.type/ref?) (conj nil))] + (let [cs (cond-> (t/type>classes t) (t/type-ref? t) (conj nil))] (case (count cs) 1 (let [c (first cs)] (when-let [not-primitive? (not (contains? t/boxed-class->unboxed-symbol c))] diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index b4439aa7..0719698c 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -339,60 +339,66 @@ ;; ===== Type metadata (not for reactive types) ===== ;; -(defn assume +(defns assume "Denotes that, whatever the declared output type (to which `assume` is applied) of a function may be, it is assumed that the output satisfies that type." - [t #_utr/type? #_> #_utr/type?] + [t utr/type? > utr/type?] (assert (c/not (utr/rx-type? t))) (if (utr/meta-type? t) - (if (.-assume_QMARK_ ^MetaType t) + (if (.-assume? ^MetaType t) t (MetaType. (.-meta ^MetaType t) nil (.-t ^MetaType t) - true (.-ref_QMARK_ ^MetaType t) false)) ; un-`t/*`s it + true (.-ref? ^MetaType t) false)) ; un-`t/run`s it (MetaType. (c/meta t) nil t true false false))) -(defn unassume [t #_utr/type? #_> #_utr/type?] +(defns assume? [t utr/type? > c/boolean?] (c/and (utr/meta-type? t) (.-assume? ^MetaType t))) + +(defns unassume [t utr/type? > utr/type?] (assert (c/not (utr/rx-type? t))) (if (utr/meta-type? t) - (if-not (.-assume_QMARK_ ^MetaType t) + (if-not (.-assume? ^MetaType t) t (MetaType. (.-meta ^MetaType t) nil (.-t ^MetaType t) - false (.-ref_QMARK_ ^MetaType t) (.-runtime_QMARK_ ^MetaType t))) ; un-`t/*`s it + false (.-ref? ^MetaType t) (.-runtime? ^MetaType t))) ; un-`t/run`s it t)) -(defn * +(defns run "Denote on a type that it must be enforced at runtime. For use with `defnt`." - [t #_utr/type? #_> #_utr/type?] + [t utr/type? > utr/type?] (assert (c/not (utr/rx-type? t))) (if (utr/meta-type? t) - (if (.-runtime_QMARK_ ^MetaType t) + (if (.-runtime? ^MetaType t) t (MetaType. (.-meta ^MetaType t) nil (.-t ^MetaType t) - false (.-ref_QMARK_ ^MetaType t) true)) ; un-`t/assume`s it + false (.-ref? ^MetaType t) true)) ; un-`t/assume`s it (MetaType. (c/meta t) nil t false false true))) -(defn ref +(defns run? [t utr/type? > c/boolean?] (c/and (utr/meta-type? t) (.-runtime? ^MetaType t))) + +(defns ref "Denote on a type that it must not be expanded to use primitive values. For use with `defnt`." - [t #_utr/type? #_> #_utr/type?] + [t utr/type? > utr/type?] (assert (c/not (utr/rx-type? t))) (if (utr/meta-type? t) - (if (.-ref_QMARK_ ^MetaType t) + (if (.-ref? ^MetaType t) t (MetaType. (.-meta ^MetaType t) nil (.-t ^MetaType t) - (.-assume_QMARK_ ^MetaType t) true (.-runtime_QMARK_ ^MetaType t))) + (.-assume? ^MetaType t) true (.-runtime? ^MetaType t))) (MetaType. (c/meta t) nil t false true false))) -(defn unref [t #_utr/type? #_> #_utr/type?] +(defns unref [t utr/type? > utr/type?] (assert (c/not (utr/rx-type? t))) (if (utr/meta-type? t) - (if-not (.-ref_QMARK_ ^MetaType t) + (if-not (.-ref? ^MetaType t) t (MetaType. (.-meta ^MetaType t) nil (.-t ^MetaType t) - (.-assume_QMARK_ ^MetaType t) false (.-runtime_QMARK_ ^MetaType t))) + (.-assume? ^MetaType t) false (.-runtime? ^MetaType t))) t)) +(defns type-ref? [t utr/type? > c/boolean?] (c/and (utr/meta-type? t) (.-ref? ^MetaType t))) + ;; ===== Logical ===== ;; (defns >logical-complement @@ -791,7 +797,9 @@ (defns- -type>classes [t utr/type?, include-classes-of-value-type? c/boolean?, classes c/set? > (us/set-of (us/nilable #?(:clj c/class? :cljs c/fn?)))] - (cond (utr/class-type? t) + (cond (utr/meta-type? t) + (recur (utr/meta-type>inner-type t) include-classes-of-value-type? classes) + (utr/class-type? t) (conj classes (utr/class-type>class t)) (utr/protocol-type? t) ;; probably better than specifying *all* implementing classes @@ -810,7 +818,7 @@ (utr/or-type? t) (reduce (c/fn [classes' t'] (-type>classes t' include-classes-of-value-type? classes')) classes (utr/or-type>args t)) - (c/= t val?) + (c/= t val?) ; TODO make this less ad-hoc (-type>classes val|by-class? include-classes-of-value-type? classes) :else (err! "Not sure how to handle type" t))) @@ -843,7 +851,7 @@ Distinct from primitive-expansion / primitivization." [t type? > (us/set-of (us/nilable c/class?))] (let [cs (type>classes t)] - (if (c/or (contains? cs nil) (-> t c/meta :quantum.core.type/ref?)) + (if (c/or (contains? cs nil) (type-ref? t)) cs (->> cs (uc/map+ class>most-primitive-class) (ur/join #{})))))) @@ -851,7 +859,7 @@ (defns type>primitive-subtypes ([t type? > (us/set-of type?)] (type>primitive-subtypes t true)) ([t type?, include-subtypes-of-value-type? c/boolean? > (us/set-of type?)] - (if (-> t c/meta :quantum.core.type/ref?) + (if (type-ref? t) #{} (->> (type>classes t include-subtypes-of-value-type?) (uc/mapcat+ class>boxed-subclasses+) @@ -861,7 +869,7 @@ #?(:clj (defns primitive-type? [t type? > c/boolean?] - (c/and (-> t c/meta :quantum.core.type/ref? c/not) + (c/and (-> t type-ref? c/not) (let [cs (type>classes t)] (c/and (-> cs count (c/= 1)) (contains? boxed-class->unboxed-symbol (first cs))))))) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index c2d4fcb6..8a9bdab1 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -384,7 +384,7 @@ java.lang.Object (-> (first cs') (cond-> (and (not (contains? cs nil)) - (not (-> t meta :quantum.core.type/ref?))) + (not (t/type-ref? t))) t/class>most-primitive-class)))))) (defns- with-validate-output-type [declared-output-type t/type?, body-node uast/node? > t/type?] @@ -393,8 +393,8 @@ :declared-output-type declared-output-type}] (case (t/compare (:type body-node) declared-output-type) (-1 0) declared-output-type - 1 (if (or (-> declared-output-type meta :quantum.core.type/runtime?) - (-> declared-output-type meta :quantum.core.type/assume?)) + 1 (if (or (-> declared-output-type t/run?) + (-> declared-output-type t/assume?)) declared-output-type (err! "Body type incompatible with declared output type" err-info)) (2 3) (err! "Body type incompatible with declared output type" err-info)))) @@ -507,7 +507,7 @@ output-class (type>class output-type) body-form (-> (:form body-node) - (cond-> (-> output-type meta :quantum.core.type/runtime?) + (cond-> (t/run? output-type) ;; TODO here the output type is being re-created each time (unless the fn's overall ;; output type is being preferred) because it could reference inputs, but we ;; should probably analyze to determine whether it references inputs so we can, diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 96ff0940..f70cf53f 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -79,7 +79,7 @@ fedn/IEdn {-edn ([this] (-> (cond->> (fedn/-edn t) assume? (list 'quantum.untyped.core.type/assume) ref? (list 'quantum.untyped.core.type/ref) - runtime? (list 'quantum.untyped.core.type/*)) + runtime? (list 'quantum.untyped.core.type/run)) (?with-name name)))}}) (defns meta-type? [x _ > boolean?] (instance? MetaType x)) diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index 1c447033..fcc32836 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -389,7 +389,7 @@ ([x p/nil? > #?(:clj p/long? :cljs dn/std-fixint?)] 0) #?(:cljs ([xs dstr/string? > (t/assume dn/std-fixint?)] (.-length xs))) #?(:cljs ([xs dstr/!string? > (t/assume dn/std-fixint?)] (.getLength xs))) - ([xs dc/icounted? > #?(:clj p/int? :cljs (t/* dn/std-fixint?))] + ([xs dc/icounted? > #?(:clj p/int? :cljs (t/run dn/std-fixint?))] (#?(:clj .count :cljs cljs.core/-count) xs)) #?(:clj ([xs dstr/char-seq? > p/int?] (.length xs))) ([xs tup/tuple? > #?(:clj p/int? :cljs (t/assume dn/std-fixint?))] diff --git a/src/quantum/core/data/meta.cljc b/src/quantum/core/data/meta.cljc index f54a43b2..b3469661 100644 --- a/src/quantum/core/data/meta.cljc +++ b/src/quantum/core/data/meta.cljc @@ -19,7 +19,7 @@ (t/defn ^:inline with-meta "Returns an object of the same type and value as ->`x`, with ->`meta'` as its metadata." > with-metable? - ([x with-metable?, meta' meta? > (t/* with-metable?) #_(TODO TYPED (t/value-of x))] + ([x with-metable?, meta' meta? > (t/run with-metable?) #_(TODO TYPED (t/value-of x))] (#?(:clj .withMeta :cljs cljs.core/-with-meta) x meta')) #?(:cljs ([x (t/isa? js/Function), meta' meta?] (cljs.core/MetaFn. x meta')))) diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index ab6192fa..034520e3 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -1,7 +1,7 @@ (ns quantum.core.type "This is this the namespace upon which all other fully-typed namespaces rest." (:refer-clojure :exclude - [* - < <= = >= > and any? defn fn fn? isa? not or ref seq? symbol? type var?]) + [- < <= = >= > and any? defn fn fn? isa? not or ref seq? symbol? type var?]) (:require [quantum.untyped.core.type.defnt :as udefnt] [quantum.untyped.core.type :as ut] @@ -19,7 +19,7 @@ (defaliases ut type type? ;; Generators - ? *, isa? isa?|direct + ? run, isa? isa?|direct ; fn ; TODO TYPED rename ftype input-type input-type|meta-or input-type|or diff --git a/src/quantum/core/vars.cljc b/src/quantum/core/vars.cljc index 2d443145..f18076b9 100644 --- a/src/quantum/core/vars.cljc +++ b/src/quantum/core/vars.cljc @@ -34,7 +34,7 @@ (t/defn >ns "Supersedes `clojure.core/the-ns`." ([x namespace? > namespace?] x) - ([x id/symbol? > (t/* namespace?)] (>?ns x)))) + ([x id/symbol? > (t/run namespace?)] (>?ns x)))) #?(:clj (t/extend-defn! id/>name (^:inline [x namespace?] (-> x .getName id/>name)))) @@ -65,13 +65,13 @@ already-existing namespace of the same name. Supersedes `clojure.core/create-ns`." - [x id/symbol? > (t/* namespace?)] (clojure.lang.Namespace/findOrCreate x))) + [x id/symbol? > (t/run namespace?)] (clojure.lang.Namespace/findOrCreate x))) #?(:clj (t/defn remove-ns! "Removes the namespace named by the symbol. Use with caution. Cannot be used to remove the `clojure.core` namespace." - [x id/symbol? > (t/* namespace?)] (clojure.lang.Namespace/remove x))) + [x id/symbol? > (t/run namespace?)] (clojure.lang.Namespace/remove x))) ;; ===== Modification ===== ;; @@ -127,11 +127,11 @@ if supplied. The namespace must exist. The var will adopt any metadata from ->`name-val`. Returns the var." > var? - ([ns-val (t/or id/symbol? namespace?), var-name id/symbol? > (t/* var?)] + ([ns-val (t/or id/symbol? namespace?), var-name id/symbol? > (t/run var?)] (let [var-ref (clojure.lang.Var/intern (>ns ns-val) var-name)] (when (>meta var-name) (.setMeta var-ref (>meta var-name))) var-ref)) - ([ns-val (t/or id/symbol? namespace?), var-name id/symbol?, var-val t/ref? > (t/* var?)] + ([ns-val (t/or id/symbol? namespace?), var-name id/symbol?, var-val t/ref? > (t/run var?)] (let [var-ref (clojure.lang.Var/intern (>ns ns-val) var-name var-val)] (when (>meta var-name) (.setMeta var-ref (>meta var-name))) var-ref)))) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 0116b397..0e53ba78 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -31,6 +31,8 @@ [quantum.core Numeric Primitive] [quantum.untyped.core.type.defnt AnonFn])) +;; TODO test `:inline` + ;; Just in case (clojure.spec.test.alpha/unstrument) (do (require '[orchestra.spec.test :as st]) @@ -81,8 +83,6 @@ (eval '(do (is (t/string? (pid|test))) (throws (pid|test 1)))))))) -;; TODO test `:inline` - (deftest test|identity (let [actual (binding [self/*compilation-mode* :test] @@ -164,8 +164,8 @@ (macroexpand ' (self/defn #_:inline name > t/string? ([x t/string?] x) - #?(:clj ([x (t/isa? Named) > (t/* t/string?)] (.getName x)) - :cljs ([x (t/isa? INamed) > (t/* t/string?)] (-name x)))))) + #?(:clj ([x (t/isa? Named) > (t/run t/string?)] (.getName x)) + :cljs ([x (t/isa? INamed) > (t/run t/string?)] (-name x)))))) expected (case (env-lang) :clj @@ -176,16 +176,16 @@ (def ~(tag (cstr `Object>Object) 'name|__0) (reify* [Object>Object] (~(O 'invoke) [~'_0__ ~(O 'x)] ~(ST 'x)))) - ;; [x (t/isa? Named)] > (t/* t/string?) + ;; [x (t/isa? Named)] > (t/run t/string?) (def ~(tag (cstr `Object>Object) 'name|__1) (reify* [Object>Object] (~(O 'invoke) [~'_1__ ~(O 'x)] (t/validate ~(ST (list '. (tag "clojure.lang.Named" 'x) 'getName)) - ~'(t/* t/string?))))) + ~'(t/run t/string?))))) [{:id 0 :index 0 :arg-types [(t/isa? String)] :output-type (t/isa? String)} - {:id 1 :index 1 :arg-types [(t/isa? Named)] :output-type (t/* (t/isa? String))}] + {:id 1 :index 1 :arg-types [(t/isa? Named)] :output-type (t/run (t/isa? String))}] (defmeta ~'name {:quantum.core.type/type name|__type} @@ -476,7 +476,7 @@ ;; -> (t/- (t/ref (t/isa? Number)) (t/- tt/primitive? tt/boolean?))] (def ~(O<> '>int*|__1|input0|types) - (*<> ~(with-meta `(t/isa? Number) {:quantum.core.type/ref? true}))) + (*<> (t/ref (t/isa? Number)))) (def ~'>int*|__1|0 (reify* [Object>int] (~(I 'invoke) [~'_7__ ~(O 'x)] @@ -1062,7 +1062,7 @@ (testing "functionality" (eval actual))))) (self/defn >big-integer > (t/isa? java.math.BigInteger) - ([x tt/ratio? > (t/* (t/isa? java.math.BigInteger))] (.bigIntegerValue x))) + ([x tt/ratio? > (t/run (t/isa? java.math.BigInteger))] (.bigIntegerValue x))) ;; NOTE would use `>long` but that's already an interface (deftest test|>long-checked @@ -1485,7 +1485,7 @@ ([] "") ([x t/nil?] "") ;; could have inferred but there may be other objects who have overridden .toString - #?(#_:clj #_([x (t/isa? Object) > (t/* t/string?)] (.toString x)) + #?(#_:clj #_([x (t/isa? Object) > (t/run t/string?)] (.toString x)) ;; Can't infer that it returns a string (without a pre-constructed list of built-in fns) ;; As such, must explicitly mark :cljs ([x t/any? > (t/assume t/string?)] (.join #js [x] ""))) @@ -1596,7 +1596,7 @@ ([xs t/iterable?] (clojure.lang.RT/chunkIteratorSeq (.iterator xs))) ([xs t/char-seq?] (clojure.lang.StringSeq/create xs)) ([xs (t/isa? java.util.Map)] (seq (.entrySet xs))) - ([xs t/array? > (t/* (t/? (t/isa? ISeq)))] + ([xs t/array? > (t/run (t/? (t/isa? ISeq)))] ;; We do this only because `clojure.lang.ArraySeq/createFromObject` is private but perhaps it ;; would be wise from a performance perspective to bypass that with e.g. a fast version of ;; reflection From 56f9ecb5e1be13dcd246c04ef4abbda6162cdc2b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 16 Nov 2018 14:11:48 -0700 Subject: [PATCH 708/810] Elaborate on avoiding var indirection --- project-base.clj | 5 +- resources-dev/defnt.cljc | 3 +- src-untyped/quantum/untyped/core/analyze.cljc | 59 ++++++++++--------- 3 files changed, 35 insertions(+), 32 deletions(-) diff --git a/project-base.clj b/project-base.clj index 1ced8ef4..8c78210b 100644 --- a/project-base.clj +++ b/project-base.clj @@ -828,8 +828,9 @@ {:jvm-opts (into ["-Dquantum.core.system|profile=dev"] (>jvm-opts :dev)) :resource-paths ["resources-dev"] :source-paths ["src-dev"] - :dependencies '[[org.clojure/tools.nrepl "0.2.13"]] - :plugins '[[lein-nodisassemble "0.1.3"]]} + :dependencies '[[org.clojure/tools.nrepl "0.2.13"] + [com.clojure-goes-fast/clj-java-decompiler "0.1.1"]] + :plugins '[[lein-nodisassemble "0.1.3"]]} :test {:jvm-opts (>jvm-opts :test)} :prod diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 2ed9ab1c..0ef0b11c 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -103,7 +103,8 @@ Legend: ([n dn/std-integer?, xs dc/counted?] (count xs)) ([n dn/std-integer?, xs ?] ...) - [ ] No trailing `>` means `> ?`f - [ ] Non-boxed `def`s: `(var/def- min-float (Numeric/negate Float/MAX_VALUE))` + [ ] Non-boxed (primitive) `t/def`s: `(var/def- min-float (Numeric/negate Float/MAX_VALUE))` + - direct linking doesn't help with this; the way around this is seems to be to do `let` bindings for all captured non-dynamic vars, and unbox the var-values that are primitive [ ] `(t/validate x (t/run t/string?))` for `(t/run t/string?)` needs to be more performant - Don't re-create type on each call (see `defnt/unanalyzed-overload>overload`) [ ] replace `deref` with `ref/deref` in typed contexts? So we can do `@` still diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 204c6416..f06022f2 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -620,32 +620,32 @@ However since all branches of the `t/or` are guaranteed to result in a successful dispatch (i.e. `t/nil?` and `t/iterable?`) then dynamic dispatch will go forward without an error." [{:as ret :keys [dispatchable-overload-types-seq]} input|analyzed i caller|node body] - (if (-> input|analyzed :type utr/or-type?) - (let [or-types (-> input|analyzed :type utr/or-type>args) - {:keys [dispatchable-overload-types-seq' non-dispatchable-or-types]} - (->> dispatchable-overload-types-seq - (reduce - (fn [ret {:as overload :keys [arg-types]}] - (if-let [or-types-that-match - (->> or-types (uc/lfilter #(t/<= % (get arg-types i))) seq)] - (-> ret - (update :dispatchable-overload-types-seq' conj overload) - (update :non-dispatchable-or-types - #(apply disj % or-types-that-match))) - ret)) - {:dispatchable-overload-types-seq' [] - :non-dispatchable-or-types (set or-types)}))] - (if (or (empty? dispatchable-overload-types-seq') - (uc/contains? non-dispatchable-or-types)) - (err! "No overloads satisfy the inputs, whether direct or dynamic" - {:caller caller|node - :inputs body - :failing-input-form (:form input|analyzed) - :failing-input-type (:type input|analyzed)}) - (assoc ret :dispatchable-overload-types-seq dispatchable-overload-types-seq' - :dispatch-type :dynamic))) - (err! "Cannot currently do a dynamic dispatch on a non-`t/or` input type" - {:input|analyzed input|analyzed}))) + (if-not (-> input|analyzed :type utr/or-type?) + (err! "Cannot currently do a dynamic dispatch on a non-`t/or` input type" + {:input|analyzed input|analyzed}) + (let [or-types (-> input|analyzed :type utr/or-type>args) + {:keys [dispatchable-overload-types-seq' non-dispatchable-or-types]} + (->> dispatchable-overload-types-seq + (reduce + (fn [ret {:as overload :keys [arg-types]}] + (if-let [or-types-that-match + (->> or-types (uc/lfilter #(t/<= % (get arg-types i))) seq)] + (-> ret + (update :dispatchable-overload-types-seq' conj overload) + (update :non-dispatchable-or-types + #(apply disj % or-types-that-match))) + ret)) + {:dispatchable-overload-types-seq' [] + :non-dispatchable-or-types (set or-types)}))] + (if (or (empty? dispatchable-overload-types-seq') + (uc/contains? non-dispatchable-or-types)) + (err! "No overloads satisfy the inputs, whether direct or dynamic" + {:caller caller|node + :inputs body + :failing-input-form (:form input|analyzed) + :failing-input-type (:type input|analyzed)}) + (assoc ret :dispatchable-overload-types-seq dispatchable-overload-types-seq' + :dispatch-type :dynamic))))) (defn- filter-direct-dispatchable-overload-types [{:as ret :keys [dispatchable-overload-types-seq]} input|analyzed i caller|node args-form] @@ -655,7 +655,8 @@ (fn [{:keys [arg-types]}] (t/<= (:type input|analyzed) (get arg-types i)))) seq)] - (assoc ret :dispatchable-overload-types-seq dispatchable-overload-types-seq') + (assoc ret :dispatchable-overload-types-seq dispatchable-overload-types-seq' + :dispatch-type :direct) (if (-> caller|node :unanalyzed-form meta :dyn) (filter-dynamic-dispatchable-overload-types ret input|analyzed i caller|node args-form) (err! (str "No overloads satisfy the inputs via direct dispatch; " @@ -760,7 +761,7 @@ (reducei (fn [{:as ret :keys [dispatch-type]} input|analyzed i] (if (= :fnt caller-kind) - (let [{:as ret' :keys [dispatchable-overload-types-seq input-nodes]} + (let [{:as ret' :keys [dispatchable-overload-types-seq dispatch-type input-nodes]} (-> (case dispatch-type :direct (filter-direct-dispatchable-overload-types ret input|analyzed i caller|node args-form) @@ -774,7 +775,7 @@ (-> ret' (assoc :form (list* (:form caller|node) (uc/lmap :form input-nodes)) :type (>dispatch|output-type dispatch-type - dispatchable-overload-types-seq)) + dispatchable-overload-types-seq)) (dissoc :caller|node :dispatch-type :dispatchable-overload-types-seq))) ret')) From fbdabe108f13ff421ac613e11811a346b38be9d3 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 16 Nov 2018 15:58:55 -0700 Subject: [PATCH 709/810] Fix `all-values?` in analysis --- src-untyped/quantum/untyped/core/analyze.cljc | 21 +++++++++---------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index f06022f2..06248bbb 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -234,10 +234,9 @@ (uc/map+ (fn [form-v] (analyze* env form-v))) (educe (fn ([ret] ret) ([{:as ret :keys [all-values?]} v] - (-> ret - (cond-> (and all-values? (-> v :type utr/value-type?)) - (assoc :all-values? true)) - (update :nodes conj v)))) + (let [all-values?' (and all-values? (-> v :type utr/value-type?))] + (-> ret (assoc :all-values? all-values?') + (update :nodes conj v))))) {:all-values? true :nodes []})) t (if all-values? (->> nodes @@ -266,16 +265,16 @@ (uc/map+ (fn [[form-k form-v]] [(analyze* env form-k) (analyze* env form-v)])) (educe (fn ([ret] ret) ([{:as ret :keys [all-values?]} [k v :as kv]] - (-> ret - (cond-> (and all-values? - (-> k :type utr/value-type?) - (-> v :type utr/value-type?)) - (assoc :all-values? true)) - (update :nodes conj kv)))) + (let [all-values?' (and all-values? + (-> k :type utr/value-type?) + (-> v :type utr/value-type?))] + (-> ret (assoc :all-values? all-values?') + (update :nodes conj kv))))) {:all-values? true :nodes []})) t (if all-values? (->> nodes - (uc/map+ (fn [[k v]] [(-> k :type t/unvalue) (-> v :type t/unvalue)])) + (uc/map+ (fn [[k v]] + [(-> k :type t/unvalue) (-> v :type t/unvalue)])) (join {}) t/value) (t/and t/+map|built-in? From 423efd319e64e50048b2b93854b5a8f1178bd7b3 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 16 Nov 2018 15:59:07 -0700 Subject: [PATCH 710/810] Add `>form` overloads for primitives --- src-untyped/quantum/untyped/core/form.cljc | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index 4e641258..01fe3a4d 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -36,8 +36,14 @@ nil (>form [x] nil) #?(:clj java.lang.Boolean :cljs boolean) (>form [x] x) - #?@(:clj [java.lang.Integer (>form [x] x) - java.lang.Long (>form [x] x)]) + ;; If a byte etc. is emitted from a macro, then it emits + ;; `RT.readString("#=(java.lang.Byte. \"1\")")`. Below is a better way. + #?@(:clj [java.lang.Byte (>form [x] (list `unchecked-byte (long x))) + java.lang.Short (>form [x] (list `unchecked-short (long x))) + java.lang.Character (>form [x] (list `unchecked-char (long x))) + java.lang.Integer (>form [x] (list `unchecked-int (long x))) + java.lang.Long (>form [x] x) + java.lang.Float (>form [x] (list `unchecked-short (long x)))]) #?(:clj java.lang.Double :cljs number) (>form [x] x) #?(:clj java.lang.String From dadbf46cde3d1b5220cac2fa12fd39aa3b97c2a3 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 16 Nov 2018 15:59:41 -0700 Subject: [PATCH 711/810] `compare|class+finite` --- .../quantum/untyped/core/type/compare.cljc | 57 ++++++++++++++++++- .../untyped/core/type/reifications.cljc | 5 +- src/quantum/core/data/array.cljc | 16 +++--- src/quantum/core/type.cljc | 1 + 4 files changed, 67 insertions(+), 12 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index efbae960..7a28c9d4 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -15,6 +15,7 @@ :refer [==]] [quantum.untyped.core.core :as ucore] [quantum.untyped.core.data.bits :as ubit] + [quantum.untyped.core.data.hash :as uhash] [quantum.untyped.core.data.set :as uset :refer [ident >ident comparison?]] [quantum.untyped.core.defnt @@ -51,6 +52,7 @@ UniversalSetType EmptySetType NotType OrType AndType ProtocolType ClassType + UnorderedType OrderedType ValueType FnType MetaType MetaOrType @@ -334,11 +336,56 @@ #?(:clj (compare|class+class* (utr/class-type>class t0) (utr/class-type>class t1)) :cljs (TODO))) +;; This is used to make comparisons work with `UnorderedType` and `OrderedType`. +;; TODO we should not be using `seqable?` but rather `(t/input-type reduce :_ :_ :?)`. See also the +;; implementations of `UnorderedType` and `OrderedType`. +(def- seqable-except-array? + (OrType. + uhash/default uhash/default nil `seqable-except-array? + [#?(:clj (ClassType. uhash/default uhash/default nil nil clojure.lang.ISeq)) + #?(:clj (ClassType. uhash/default uhash/default nil nil clojure.lang.Seqable) + :cljs (ProtocolType. uhash/default uhash/default nil nil cljs.core/ISeqable)) + #?(:clj (ClassType. uhash/default uhash/default nil nil java.lang.Iterable)) + #_array? ; TODO handle later + (ClassType. uhash/default uhash/default nil nil #?(:clj java.lang.String :cljs js/String)) + #?(:clj (ClassType. uhash/default uhash/default nil nil java.util.Map))] + (atom nil))) + +(defns- compare|class+finite [t0 class-type?, t1 utr/ordered-type? > comparison?] + ;; TODO technically we need to have it satisfy `dc/reducible?`, not merely `c/seqable?` + ;; — see also note in UnorderedType's implementation about this + (case (int (compare t0 seqable-except-array?)) + ;; `(combine-comparisons ident)` + ;; t/< w.r.t. seqable; t/> w.r.t contents (TODO unless contents have restrictions) + -1 >ident)` + ;; t/= w.r.t. seqable; t/> w.r.t contents (TODO unless contents have restrictions) + 0 ident >ident)` + ;; t/> w.r.t. seqable; t/> w.r.t contents (TODO unless contents have restrictions) + 1 >ident + ;; `(combine-comparisons >< w.r.t. seqable; t/>< w.r.t contents (TODO unless contents have restrictions) + 2 >ident <>ident)` + ;; t/<> w.r.t. seqable; t/<> w.r.t contents + 3 <>ident)) + +(defns- compare|class+unordered [t0 class-type?, t1 utr/unordered-type? > comparison?] + (compare|class+finite t0 t1)) + +(defns- compare|class+ordered [t0 class-type?, t1 utr/ordered-type? > comparison?] + (compare|class+finite t0 t1)) + (defns- compare|class+value [t0 class-type?, t1 value-type? > comparison?] (let [c (utr/class-type>class t0) v (utr/value-type>value t1)] (if (instance? c v) >ident <>ident))) +;; ----- UnorderedType ----- ;; + +;; ----- OrderedType ----- ;; + ;; ----- ValueType ----- ;; (defns- compare|value+value @@ -462,8 +509,14 @@ Expression fn>< ; TODO not entirely true ProtocolType (inverted compare|protocol+class) ClassType compare|class+class + UnorderedType compare|class+unordered + OrderedType compare|class+ordered ValueType compare|class+value MetaType compare|non-meta+meta} + UnorderedType + {ClassType (inverted compare|class+unordered)} + OrderedType + {ClassType (inverted compare|class+ordered)} ValueType {UniversalSetType (inverted compare|universal+value) EmptySetType (inverted compare|empty+value) @@ -551,10 +604,10 @@ ;; ===== FnType ===== ;; -;; TODO unknown if this is `and`- or `or`-style combination (defns combine-comparisons "Used in `t/compare|in` and `t/compare|out`. Might be used for other things too in the future. - Commutative in the 2-ary arity." + Commutative in the 2-ary arity. + A `t/and`-style combination." ([cs _ #_(seq-of uset/comparison?) > uset/comparison?] ;; TODO it's possible to `reduced` early here depending (if (empty? cs) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index f70cf53f..8fad2c96 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -326,7 +326,7 @@ ;; ----- UnorderedType ----- ;; (defn- satisfies-unordered-type? [xs data] - (and (seqable? xs) ; TODO `dc/reducible?` + (and (seqable? xs) ; TODO we should rather use `(t/input-type reduce :_ :_ :?)` (let [!frequencies (! {}) each-input-matches-one-type-not-exceeding-frequency? (->> xs @@ -400,7 +400,8 @@ (list 'new 'quantum.untyped.core.type.reifications.OrderedType hash hash-code (>form meta) name (-> data >vec >form))))} fedn/IOverride nil - fedn/IEdn {-edn ([this] (-> (list 'quantum.untyped.core.type/ordered (fedn/-edn data)) + fedn/IEdn {-edn ([this] (-> (list 'quantum.untyped.core.type/ordered + (-> data >vec fedn/-edn)) (?with-name name)))}}) (defn ordered-type? [x] (instance? OrderedType x)) diff --git a/src/quantum/core/data/array.cljc b/src/quantum/core/data/array.cljc index db788666..e32f6716 100644 --- a/src/quantum/core/data/array.cljc +++ b/src/quantum/core/data/array.cljc @@ -135,14 +135,14 @@ ;; TODO differentiate between "all supported n-D arrays" and "all n-D arrays" (def objects-nd? (t/or objects? - #?@(:clj [(>array-nd-type 'object 2) - (>array-nd-type 'object 3) - (>array-nd-type 'object 4) - (>array-nd-type 'object 5) - (>array-nd-type 'object 6) - (>array-nd-type 'object 7) - (>array-nd-type 'object 8) - (>array-nd-type 'object 9) + #?@(:clj [(>array-nd-type 'object 2) + (>array-nd-type 'object 3) + (>array-nd-type 'object 4) + (>array-nd-type 'object 5) + (>array-nd-type 'object 6) + (>array-nd-type 'object 7) + (>array-nd-type 'object 8) + (>array-nd-type 'object 9) (>array-nd-type 'object 10)]))) (def std-array? (t/or array-1d? diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index 034520e3..a1175536 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -24,6 +24,7 @@ ftype input-type input-type|meta-or input-type|or output-type output-type|meta-or output-type|or + unordered ordered value unvalue ;; Combinators and or - if not From d3ca162a7a692c1d8276f91716a3550ae3f8d23f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 16 Nov 2018 15:59:53 -0700 Subject: [PATCH 712/810] Add `clj-java-decompiler` --- project-base.clj | 1 + 1 file changed, 1 insertion(+) diff --git a/project-base.clj b/project-base.clj index 8c78210b..20f7b5b4 100644 --- a/project-base.clj +++ b/project-base.clj @@ -406,6 +406,7 @@ :repl-options {:init '(do (require + '[clj-java-decompiler.core :refer [decompile]] '[no.disassemble :refer [disassemble]] 'quantum.untyped.core.error 'quantum.untyped.core.meta.debug From 121462ba193f6812ed17035da1824732d7cf37f6 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 16 Nov 2018 16:00:08 -0700 Subject: [PATCH 713/810] `t/def` documentation enhancement --- src-untyped/quantum/untyped/core/type/defnt.cljc | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 8a9bdab1..40f0bb74 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -72,9 +72,10 @@ ;; TODO move #?(:clj (defmacro def - "Like `def`, but allows for docstring and metadata placement like `defn`, and performs type - analysis. For values that satisfy `t/type?`, calls `utr/with-name` on them with the provided - `sym`." + "Like `def`, but: + - Allows for docstring and metadata placement like `defn`. + - Performs type analysis. + - For values that satisfy `t/type?`, calls `utr/with-name` on them with the provided `sym`." ([sym] (list 'def sym)) ([sym v] `(quantum.untyped.core.type.defnt/def ~sym nil nil ~v)) ([sym doc-or-meta v] From c52079ed830f5d61e124bb9e1880563f57b95bcd Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 16 Nov 2018 16:00:19 -0700 Subject: [PATCH 714/810] Begin to add primitive data readers --- src/data_readers.cljc | 9 ++++++- src/quantum/core/data/primitive.cljc | 39 ++++++++++++++++++++++++++++ 2 files changed, 47 insertions(+), 1 deletion(-) diff --git a/src/data_readers.cljc b/src/data_readers.cljc index 5a981107..c4b2cca8 100644 --- a/src/data_readers.cljc +++ b/src/data_readers.cljc @@ -1 +1,8 @@ -{r quantum.core.data.numeric/read-rational} +{b quantum.core.data.primitive/read-byte + c quantum.core.data.primitive/read-char + s quantum.core.data.primitive/read-short + i quantum.core.data.primitive/read-int + l quantum.core.data.primitive/read-long + f quantum.core.data.primitive/read-float + d quantum.core.data.primitive/read-double + r quantum.core.data.numeric/read-rational} diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 113ba1e6..582960a9 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -9,6 +9,7 @@ [quantum.core.type :as t] [quantum.untyped.core.logic :refer [ifs]] + [quantum.untyped.core.numeric :as unum] [quantum.untyped.core.type :as ut] ;; TODO TYPED excise reference [quantum.untyped.core.vars :as var @@ -413,3 +414,41 @@ b double?] (if (c?/> a b) a b))) #?(:clj ( [a double? , b double?] (Math/max a b))) #?(:cljs ( [a double? , b double? > (t/assume double?)] (js/Math.max a b)))) + +;; ===== Readers ===== ;; + +(t/defn read-byte + "Used for the `#b` literal. Only a literal long, double, or char may be converted to byte, as long + as it is in the numeric range of a byte, as with `num/>byte`. + + Using e.g. `#b 1` outside of a typed context results in a runtime call to + `RT.readString(\"#=(java.lang.Byte. \\\"1\\\")\")` which is undesirable with respect to + performance." +#?(:clj ([x char?] (read-byte (unchecked-long x)))) +#?(:clj ([x long?] + (if-not (and (c?/<= x (>max-value byte?)) + (c?/>= x (>min-value byte?))) + (throw (ex-info "Form input to `#b` is not in the numeric range of a byte" + {:form x})) + (unchecked-byte x)))) + ([x double?] + (if-not (and (c?/<= x (>max-value byte?)) + (c?/>= x (>min-value byte?)) + (unum/integer-value? x)) + (throw (ex-info "Form input to `#b` is not in the numeric range of a byte" + {:form x})) + (unchecked-byte x)))) + +; c quantum.core.data.primitive/read-char +; s quantum.core.data.primitive/read-short +; i quantum.core.data.primitive/read-int +; l quantum.core.data.primitive/read-long +; f quantum.core.data.primitive/read-float +; d quantum.core.data.primitive/read-double + +(t/and (t/isa? String) (t/unordered (t/value 1))) +-> (t/and (t/isa? String) (t/unordered (t/value 1))) +(t/or (t/isa? String) (t/unordered (t/value 1))) +-> (t/or (t/isa? String) (t/unordered (t/value 1))) +(t/or tcomp/seqable-except-array? (t/unordered (t/value 1))) +-> (t/unordered (t/value 1)) From 173501b6f2d8e8d737155138ae6a6d25dd76fc2d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Fri, 16 Nov 2018 16:18:33 -0700 Subject: [PATCH 715/810] All primitives are now supported in analysis / form emission --- src-untyped/quantum/untyped/core/analyze/ast.cljc | 8 ++++++-- src-untyped/quantum/untyped/core/form.cljc | 1 + src-untyped/quantum/untyped/core/print.cljc | 8 ++++++-- src-untyped/quantum/untyped/core/type.cljc | 5 ++++- 4 files changed, 17 insertions(+), 5 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 070c7b8d..dfb9685c 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -8,6 +8,8 @@ [quantum.untyped.core.compare :as comp :refer [==]] [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.form + :refer [>form]] [quantum.untyped.core.form.type-hint :as ufth] [quantum.untyped.core.type :as t] [quantum.untyped.core.type.reifications :as utr])) @@ -79,7 +81,7 @@ (defrecord ^{:doc "AST node whose `type` is `(t/value form)`."} - Literal [env #_::env, form #_t/literal?, type #_t/type?] + Literal [env #_::env, unanalyzed-form #_t/literal?, form #_form?, type #_t/type?] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -87,7 +89,9 @@ (defn literal ([form t] (literal nil form t)) - ([env form t] (Literal. env (ufth/with-type-hint form (>type-hint form t)) t))) + ([env form t] + (let [form' (>form form)] + (Literal. env form (ufth/with-type-hint form' (>type-hint form' t)) t)))) (defn literal? [x] (instance? Literal x)) diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index 01fe3a4d..ed40645d 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -11,6 +11,7 @@ (ucore/log-this-ns) +;; TODO this semi-interacts with `print-dup` in the context of macros; unify them (defprotocol PGenForm (>form [this] "Returns the form associated with the object. If evaluated, the form should evaluate to something exactly equivalent to the diff --git a/src-untyped/quantum/untyped/core/print.cljc b/src-untyped/quantum/untyped/core/print.cljc index 7c5ab266..ea9d0be9 100644 --- a/src-untyped/quantum/untyped/core/print.cljc +++ b/src-untyped/quantum/untyped/core/print.cljc @@ -71,8 +71,12 @@ nil (-edn [x] nil) #?(:clj java.lang.Boolean :cljs boolean) (-edn [x] x) - #?@(:clj [java.lang.Integer (-edn [x] x) - java.lang.Long (-edn [x] x)]) + #?@(:clj [java.lang.Byte (-edn [x] x) + java.lang.Short (-edn [x] x) + java.lang.Character (-edn [x] x) + java.lang.Integer (-edn [x] x) + java.lang.Long (-edn [x] x) + java.lang.Float (-edn [x] x)]) #?(:clj java.lang.Double :cljs number) (-edn [x] x) #?(:clj java.lang.String diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 0719698c..e1a1dbb9 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -1053,7 +1053,10 @@ ;; Used by `quantum.untyped.core.analyze` (def* literal? - (or nil? boolean? symbol? keyword? string? + (or nil? boolean? char? string? symbol? keyword? + ;; These primitives are allowed even though macros emit them incorrectly, because they're + ;; converted via `>form` during analysis + #?(:clj byte?) #?(:clj short?) #?(:clj int?) #?(:clj float?) #?(:clj long?) double? #?(:clj (isa? clojure.lang.BigInt)) #?(:clj (isa? BigDecimal)) regex? #?(:clj tagged-literal?))) From 0b25fbaa1e28ed8daaf3261fed1963498750e0c5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 11:35:45 -0700 Subject: [PATCH 716/810] Overhaul type comparisons --- .../quantum/untyped/core/type/compare.cljc | 404 +++++++++++------- 1 file changed, 238 insertions(+), 166 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index 7a28c9d4..fe385cc4 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -62,6 +62,8 @@ (declare compare < <= = not= >= > >< <>) +(def inverted (fn [f] (fn [t0 t1] (uset/invert-comparison (f t1 t0))))) + ;; ===== (Comparison) idents ===== ;; (def- fn< (fn' ident)) (reduced [>ident nil]) (let [found' (-> found (ubit/conj c) long) ret' (ifs (ubit/contains? found' >ident)) - <>ident - >ident)) <>ident >ident) - (ifs (ubit/contains? found' ident - (ubit/contains? found' >ident) >ident - c) - + (if (ubit/contains? found' ident c) c)] [ret' found'])))) - [3 ubit/empty] + [<>ident ubit/empty] ts)))) +(defns- compare|value+type [t0 utr/value-type?, t1 type? > comparison?] + (if (t1 (utr/value-type>value t0)) ident)) + +(defns- compare|meta+non-meta [t0 utr/meta-type?, t1 type? > comparison?] + (compare (utr/meta-type>inner-type t0) t1)) + +(defns- compare|non-meta+meta [t0 type?, t1 utr/meta-type? > comparison?] + (compare t0 (utr/meta-type>inner-type t1))) + ;; ----- UniversalSet ----- ;; -(def- compare|universal+empty fn>) +(def- compare|universal+universal fn=) +(def- compare|universal+empty fn>) (defns- compare|universal+not [t0 type?, t1 not-type? > comparison?] (let [t1|inner (utr/not-type>inner-type t1)] @@ -129,25 +135,40 @@ (= t1|inner empty-set) =ident (compare t0 t1|inner)))) -(def- compare|universal+or fn>) -(def- compare|universal+and fn>) -(def- compare|universal+expr compare|todo) -(def- compare|universal+protocol fn>) -(def- compare|universal+class fn>) -(def- compare|universal+value fn>) +(def- compare|universal+or fn>) +(def- compare|universal+and fn>) +(def- compare|universal+expr compare|todo) +(def- compare|universal+protocol fn>) +(def- compare|universal+class fn>) +(def- compare|universal+unordered fn>) +(def- compare|universal+ordered fn>) +(def- compare|universal+value fn>) +(def- compare|universal+meta compare|non-meta+meta) ;; ----- EmptySet ----- ;; -(def- compare|empty+not fn<>) -(def- compare|empty+or fn<>) -(def- compare|empty+and fn<>) -(def- compare|empty+expr compare|todo) -(def- compare|empty+protocol fn<>) -(def- compare|empty+class fn<>) -(def- compare|empty+value fn<>) +(def- compare|empty+not fn<>) +(def- compare|empty+or fn<>) +(def- compare|empty+and fn<>) +(def- compare|empty+expr compare|todo) +(def- compare|empty+protocol fn<>) +(def- compare|empty+class fn<>) +(def- compare|empty+unordered fn<>) +(def- compare|empty+ordered fn<>) +(def- compare|empty+value fn<>) +(def- compare|empty+meta compare|non-meta+meta) ;; ----- NotType ----- ;; +(defns- compare|not+atomic [t0 not-type?, t1 type? > comparison?] + (let [t0|inner (utr/not-type>inner-type t0)] + (if (= t0|inner empty-set) + >ident + (case (int (compare t0|inner t1)) + ( 1 0) <>ident + (-1 2) >ident)))) + (defns- compare|not+not [t0 not-type?, t1 not-type? > comparison?] (let [c (int (compare (utr/not-type>inner-type t0) (utr/not-type>inner-type t1)))] (case c @@ -157,8 +178,7 @@ 2 > comparison?] @@ -166,13 +186,13 @@ (if (= t0|inner empty-set) >ident <>ident))) (defns- compare|not+class [t0 not-type?, t1 class-type? > comparison?] - (let [t0|inner (utr/not-type>inner-type t0)] - (if (= t0|inner empty-set) - >ident - (case (int (compare t0|inner t1)) - ( 1 0) <>ident - (-1 2) >ident)))) + (compare|not+atomic t0 t1)) + +(defns- compare|not+unordered [t0 not-type?, t1 class-type? > comparison?] + (compare|not+atomic t0 t1)) + +(defns- compare|not+ordered [t0 not-type?, t1 class-type? > comparison?] + (compare|not+atomic t0 t1)) (defns- compare|not+value [t0 not-type?, t1 value-type? > comparison?] (let [t0|inner (utr/not-type>inner-type t0)] @@ -183,6 +203,8 @@ (1 0) <>ident 3 >ident)))) +(def- compare|not+meta compare|non-meta+meta) + ;; ----- OrType ----- ;; (defns- compare|or+or-like @@ -206,16 +228,22 @@ (let [r (->> t1 .-args (seq-and (fn1 < t0)))] (if r >ident <>ident))) -(def- compare|class+or compare|atomic+or) -(def- compare|value+or compare|atomic+or) +(def- compare|or+class (inverted compare|atomic+or)) +(def- compare|or+unordered (inverted compare|atomic+or)) +(def- compare|or+ordered (inverted compare|atomic+or)) +(def- compare|or+value (inverted compare|value+type)) +(def- compare|or+meta compare|non-meta+meta) ;; ----- AndType ----- ;; (defns- compare|and+and [^AndType t0 and-type?, ^AndType t1 and-type? > comparison?] (TODO)) -(def- compare|class+and compare|atomic+and) -(def- compare|value+and compare|atomic+and) +(def- compare|and+class (inverted compare|atomic+and)) +(def- compare|and+unordered (inverted compare|atomic+and)) +(def- compare|and+ordered (inverted compare|atomic+and)) +(def- compare|and+value (inverted compare|value+type)) +(def- compare|and+meta compare|non-meta+meta) ;; ----- Expression ----- ;; @@ -223,6 +251,8 @@ (def- compare|expr+value fn><) ; TODO not entirely true +(def- compare|expr+meta compare|non-meta+meta) + ;; ----- ProtocolType ----- ;; ;; Protocols cannot extend protocols. ;; A protocol may be seen as `(->> p extenders (map >type) (apply t/or))`." @@ -290,11 +320,10 @@ (compare|or+or-via-class (extenders p0) [c1])) :cljs (TODO)))) -;; TODO transition to `compare|protocol+value` when stable -(defns- compare|value+protocol [t0 value-type?, t1 protocol-type? > comparison?] - (let [v (utr/value-type>value t0) - p (utr/protocol-type>protocol t1)] - (if (satisfies? p v) ident))) +(defns- compare|protocol+value [t0 protocol-type?, t1 value-type? > comparison?] + (uset/invert-comparison (compare|value+type t1 t0))) + +(def- compare|protocol+meta compare|non-meta+meta) ;; ----- ClassType ----- ;; @@ -382,10 +411,18 @@ v (utr/value-type>value t1)] (if (instance? c v) >ident <>ident))) +(def- compare|class+meta compare|non-meta+meta) + ;; ----- UnorderedType ----- ;; +(def- compare|unordered+value (inverted compare|value+type)) +(def- compare|unordered+meta compare|non-meta+meta) + ;; ----- OrderedType ----- ;; +(def- compare|ordered+value (inverted compare|value+type)) +(def- compare|ordered+meta compare|non-meta+meta) + ;; ----- ValueType ----- ;; (defns- compare|value+value @@ -407,138 +444,173 @@ =ident <>ident)) +(def- compare|value+meta compare|non-meta+meta) + ;; ----- MetaType ----- ;; (defns- compare|meta+meta [t0 utr/meta-type?, t1 utr/meta-type?] (compare (utr/meta-type>inner-type t0) (utr/meta-type>inner-type t1))) -(defns- compare|meta+non-meta [t0 utr/meta-type?, t1 type?] - (compare (utr/meta-type>inner-type t0) t1)) - -(defns- compare|non-meta+meta [t0 type?, t1 utr/meta-type?] - (compare t0 (utr/meta-type>inner-type t1))) - ;; ===== Dispatch ===== ;; (def- compare|dispatch - (let [inverted (fn [f] (fn [t0 t1] (uset/invert-comparison (f t1 t0))))] - {UniversalSetType - {UniversalSetType fn= - EmptySetType compare|universal+empty - NotType compare|universal+not - OrType compare|universal+or - AndType compare|universal+and - Expression compare|universal+expr - ProtocolType compare|universal+protocol - ClassType compare|universal+class - ValueType compare|universal+value - MetaType compare|non-meta+meta} - EmptySetType - {UniversalSetType (inverted compare|universal+empty) - EmptySetType fn= - NotType compare|empty+not - OrType compare|empty+or - AndType compare|empty+and - Expression compare|empty+expr - ProtocolType compare|empty+protocol - ClassType compare|empty+class - ValueType compare|empty+value - MetaType compare|non-meta+meta} - NotType - {UniversalSetType (inverted compare|universal+not) - EmptySetType (inverted compare|empty+not) - NotType compare|not+not - OrType compare|not+or - AndType compare|not+and - Expression fn>< ; TODO not entirely true - ProtocolType compare|not+protocol - ClassType compare|not+class - ValueType compare|not+value - MetaType compare|non-meta+meta} - OrType - {UniversalSetType (inverted compare|universal+or) - EmptySetType (inverted compare|empty+or) - NotType (inverted compare|not+or) - OrType compare|or+or - AndType compare|or+and - Expression fn>< ; TODO not entirely true - ProtocolType compare|todo - ClassType (inverted compare|class+or) - ValueType (inverted compare|value+or) - MetaType compare|non-meta+meta} - AndType - {UniversalSetType (inverted compare|universal+and) - EmptySetType (inverted compare|empty+and) - NotType compare|todo - OrType (inverted compare|or+and) - AndType compare|and+and - Expression fn>< ; TODO not entirely true - ProtocolType compare|todo - ClassType (inverted compare|class+and) - ValueType (inverted compare|value+and) - MetaType compare|non-meta+meta} - ;; TODO review this - Expression - {UniversalSetType (inverted compare|universal+expr) - EmptySetType (inverted compare|empty+expr) - NotType fn>< ; TODO not entirely true - OrType fn>< ; TODO not entirely true - AndType fn>< ; TODO not entirely true - Expression compare|expr+expr - ProtocolType fn>< ; TODO not entirely true - ClassType fn>< ; TODO not entirely true - ValueType compare|expr+value - MetaType compare|non-meta+meta} - ProtocolType - {UniversalSetType (inverted compare|universal+protocol) - EmptySetType (inverted compare|empty+protocol) - NotType (inverted compare|not+protocol) - OrType compare|todo - AndType compare|todo - Expression fn>< ; TODO not entirely true - ProtocolType compare|protocol+protocol - ClassType compare|protocol+class - ValueType (inverted compare|value+protocol) - MetaType compare|non-meta+meta} - ClassType - {UniversalSetType (inverted compare|universal+class) - EmptySetType (inverted compare|empty+class) - NotType (inverted compare|not+class) - OrType compare|class+or - AndType compare|class+and - Expression fn>< ; TODO not entirely true - ProtocolType (inverted compare|protocol+class) - ClassType compare|class+class - UnorderedType compare|class+unordered - OrderedType compare|class+ordered - ValueType compare|class+value - MetaType compare|non-meta+meta} - UnorderedType - {ClassType (inverted compare|class+unordered)} - OrderedType - {ClassType (inverted compare|class+ordered)} - ValueType - {UniversalSetType (inverted compare|universal+value) - EmptySetType (inverted compare|empty+value) - NotType (inverted compare|not+value) - OrType compare|value+or - AndType compare|value+and - Expression (inverted compare|expr+value) - ProtocolType compare|value+protocol - ClassType (inverted compare|class+value) - ValueType compare|value+value - MetaType compare|non-meta+meta} - MetaType - {UniversalSetType compare|meta+non-meta - EmptySetType compare|meta+non-meta - NotType compare|meta+non-meta - OrType compare|meta+non-meta - AndType compare|meta+non-meta - Expression compare|meta+non-meta - ProtocolType compare|meta+non-meta - ClassType compare|meta+non-meta - ValueType compare|meta+non-meta - MetaType compare|meta+meta}})) + {UniversalSetType + {UniversalSetType compare|universal+universal + EmptySetType compare|universal+empty + NotType compare|universal+not + OrType compare|universal+or + AndType compare|universal+and + Expression compare|universal+expr + ProtocolType compare|universal+protocol + ClassType compare|universal+class + UnorderedType compare|universal+unordered + OrderedType compare|universal+ordered + ValueType compare|universal+value + MetaType compare|universal+meta} + EmptySetType + {UniversalSetType (inverted compare|universal+empty) + EmptySetType fn= + NotType compare|empty+not + OrType compare|empty+or + AndType compare|empty+and + Expression compare|empty+expr + ProtocolType compare|empty+protocol + ClassType compare|empty+class + UnorderedType compare|empty+unordered + OrderedType compare|empty+ordered + ValueType compare|empty+value + MetaType compare|empty+meta} + NotType + {UniversalSetType (inverted compare|universal+not) + EmptySetType (inverted compare|empty+not) + NotType compare|not+not + OrType compare|not+or + AndType compare|not+and + Expression fn>< ; TODO not entirely true + ProtocolType compare|not+protocol + ClassType compare|not+class + UnorderedType compare|not+unordered + OrderedType compare|not+ordered + ValueType compare|not+value + MetaType compare|not+meta} + OrType + {UniversalSetType (inverted compare|universal+or) + EmptySetType (inverted compare|empty+or) + NotType (inverted compare|not+or) + OrType compare|or+or + AndType compare|or+and + Expression fn>< ; TODO not entirely true + ProtocolType compare|todo + ClassType compare|or+class + UnorderedType compare|or+unordered + OrderedType compare|or+ordered + ValueType compare|or+value + MetaType compare|or+meta} + AndType + {UniversalSetType (inverted compare|universal+and) + EmptySetType (inverted compare|empty+and) + NotType compare|todo + OrType (inverted compare|or+and) + AndType compare|and+and + Expression fn>< ; TODO not entirely true + ProtocolType compare|todo + ClassType compare|and+class + UnorderedType compare|and+unordered + OrderedType compare|and+ordered + ValueType compare|and+value + MetaType compare|and+meta} + ;; TODO review this + Expression + {UniversalSetType (inverted compare|universal+expr) + EmptySetType (inverted compare|empty+expr) + NotType fn>< ; TODO not entirely true + OrType fn>< ; TODO not entirely true + AndType fn>< ; TODO not entirely true + Expression compare|expr+expr + ProtocolType fn>< ; TODO not entirely true + ClassType fn>< ; TODO not entirely true + UnorderedType fn>< ; TODO not entirely true + OrderedType fn>< ; TODO not entirely true + ValueType compare|expr+value + MetaType compare|expr+meta} + ProtocolType + {UniversalSetType (inverted compare|universal+protocol) + EmptySetType (inverted compare|empty+protocol) + NotType (inverted compare|not+protocol) + OrType compare|todo + AndType compare|todo + Expression fn>< ; TODO not entirely true + ProtocolType compare|protocol+protocol + ClassType compare|protocol+class + UnorderedType compare|todo + OrderedType compare|todo + ValueType compare|protocol+value + MetaType compare|protocol+meta} + ClassType + {UniversalSetType (inverted compare|universal+class) + EmptySetType (inverted compare|empty+class) + NotType (inverted compare|not+class) + OrType (inverted compare|or+class) + AndType (inverted compare|and+class) + Expression fn>< ; TODO not entirely true + ProtocolType (inverted compare|protocol+class) + ClassType compare|class+class + UnorderedType compare|class+unordered + OrderedType compare|class+ordered + ValueType compare|class+value + MetaType compare|class+meta} + UnorderedType + {UniversalSetType (inverted compare|universal+unordered) + EmptySetType (inverted compare|empty+unordered) + NotType (inverted compare|not+unordered) + OrType (inverted compare|or+unordered) + AndType (inverted compare|and+unordered) + Expression compare|todo + ProtocolType compare|todo + ClassType (inverted compare|class+unordered) + UnorderedType compare|todo + OrderedType compare|todo + ValueType compare|unordered+value + MetaType compare|unordered+meta} + OrderedType + {UniversalSetType (inverted compare|universal+ordered) + EmptySetType (inverted compare|empty+ordered) + NotType (inverted compare|not+ordered) + OrType (inverted compare|or+ordered) + AndType (inverted compare|and+ordered) + Expression compare|todo + ProtocolType compare|todo + ClassType (inverted compare|class+ordered) + UnorderedType compare|todo + OrderedType compare|todo + ValueType compare|ordered+value + MetaType compare|ordered+meta} + ValueType + {UniversalSetType (inverted compare|universal+value) + EmptySetType (inverted compare|empty+value) + NotType (inverted compare|not+value) + OrType (inverted compare|or+value) + AndType (inverted compare|and+value) + Expression (inverted compare|expr+value) + ProtocolType (inverted compare|protocol+value) + ClassType (inverted compare|class+value) + UnorderedType (inverted compare|unordered+value) + OrderedType (inverted compare|ordered+value) + ValueType compare|value+value + MetaType compare|value+meta} + MetaType + {UniversalSetType (inverted compare|universal+meta) + EmptySetType (inverted compare|empty+meta) + NotType (inverted compare|not+meta) + OrType (inverted compare|or+meta) + AndType (inverted compare|and+meta) + Expression (inverted compare|expr+meta) + ProtocolType (inverted compare|protocol+meta) + ClassType (inverted compare|class+meta) + UnorderedType (inverted compare|unordered+meta) + OrderedType (inverted compare|ordered+meta) + ValueType (inverted compare|value+meta) + MetaType compare|meta+meta}}) ;; ===== Operators ===== ;; From c1e64c745cf94ae58066376b7cb071a42eecc709 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 11:35:58 -0700 Subject: [PATCH 717/810] `ex-info` -> constructor in data.primitive --- src/quantum/core/data/primitive.cljc | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 582960a9..94c5ef21 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -428,15 +428,15 @@ #?(:clj ([x long?] (if-not (and (c?/<= x (>max-value byte?)) (c?/>= x (>min-value byte?))) - (throw (ex-info "Form input to `#b` is not in the numeric range of a byte" - {:form x})) + (throw (new #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) + "Form input to `#b` is not in the numeric range of a byte" {:form x} nil)) (unchecked-byte x)))) ([x double?] (if-not (and (c?/<= x (>max-value byte?)) (c?/>= x (>min-value byte?)) (unum/integer-value? x)) - (throw (ex-info "Form input to `#b` is not in the numeric range of a byte" - {:form x})) + (throw (new #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) + "Form input to `#b` is not in the numeric range of a byte" {:form x} nil)) (unchecked-byte x)))) ; c quantum.core.data.primitive/read-char From 545908dc076d8c7dca7e40244fec1dd6afd46c80 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 11:36:05 -0700 Subject: [PATCH 718/810] Add named types in tests --- test/quantum/test/untyped/core/type.cljc | 58 ++++++++++++------------ 1 file changed, 29 insertions(+), 29 deletions(-) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index aa6c8558..50e4ab85 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -82,40 +82,40 @@ (gen-interface :name i.><1) (gen-interface :name i.><2) -(def i|>a+b (t/isa? i.>a+b)) -(def i|>a0 (t/isa? i.>a0)) -(def i|>a1 (t/isa? i.>a1)) -(def i|>b0 (t/isa? i.>b0)) -(def i|>b1 (t/isa? i.>b1)) -(def i|a (t/isa? i.a)) -(def i|b (t/isa? i.b)) -(def i|<0 (t/isa? i.><0)) -(def i|><1 (t/isa? i.><1)) -(def i|><2 (t/isa? i.><2)) +(t/def i|>a+b (t/isa? i.>a+b)) +(t/def i|>a0 (t/isa? i.>a0)) +(t/def i|>a1 (t/isa? i.>a1)) +(t/def i|>b0 (t/isa? i.>b0)) +(t/def i|>b1 (t/isa? i.>b1)) +(t/def i|a (t/isa? i.a)) +(t/def i|b (t/isa? i.b)) +(t/def i|<0 (t/isa? i.><0)) +(t/def i|><1 (t/isa? i.><1)) +(t/def i|><2 (t/isa? i.><2)) ) ;; ----- Hierarchy within existing non-interfaces ----- ;; -(do (def >a+b (t/isa? java.util.AbstractCollection)) - (def >a (t/isa? java.util.AbstractList)) - (def >b (t/isa? java.util.AbstractSet)) - (def a (t/isa? java.util.ArrayList)) - (def b (t/isa? java.util.HashSet)) - (def <0 byte?) - (def ><1 short?) - (def ><2 long?)) - -(def Uc (t/isa? java.lang.Object)) +(do (t/def >a+b (t/isa? java.util.AbstractCollection)) + (t/def >a (t/isa? java.util.AbstractList)) + (t/def >b (t/isa? java.util.AbstractSet)) + (t/def a (t/isa? java.util.ArrayList)) + (t/def b (t/isa? java.util.HashSet)) + (t/def <0 byte?) + (t/def ><1 short?) + (t/def ><2 long?)) + +(t/def Uc (t/isa? java.lang.Object)) ;; ----- Example protocols ----- ;; From 48e78fb1b0e863420a4aaf85fc82dd21a293c252 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 11:36:17 -0700 Subject: [PATCH 719/810] Begin to fix comparisons --- .../test/untyped/core/type/compare.cljc | 70 ++++++++++--------- 1 file changed, 36 insertions(+), 34 deletions(-) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 859eff85..653791d2 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -72,10 +72,10 @@ "To generate all commutative possibilities for a given type." [t t/type? > (s/seq-of t/type?)] (ifs (t/and-type? t) (->> t utr/and-type>args ucombo/permutations - (map #(utr/->AndType uhash/default uhash/default nil (vec %) + (map #(utr/->AndType uhash/default uhash/default nil nil (vec %) (atom nil)))) (t/or-type? t) (->> t utr/or-type>args ucombo/permutations - (map #(utr/->OrType uhash/default uhash/default nil (vec %) + (map #(utr/->OrType uhash/default uhash/default nil nil (vec %) (atom nil)))) [t])) @@ -370,54 +370,56 @@ (testing "#{<>}, #{<>}" ;; comparisons: <> <> <> <> (test-comparison <>ident (| a b) (| ><0 ><1))))) - ;; TODO fix tests/impl - #_(testing "+ AndType" - ;; Comparison annotations achieved by first comparing each element of the first/left - ;; to the entire second/right, then comparing each element of the second/right to the - ;; entire first/left + ;; FIXME fix tests/impl in order to proceed + ;; - non `i|`s should become `i|`s. + ;; - complete comparisons via `comparison-combinations` + (testing "+ AndType" + ;; Comparison annotations achieved by first comparing each element of the first/left to the + ;; entire second/right, then comparing each element of the second/right to the entire + ;; first/left (testing "#{= <+} -> #{<+}" (testing "+ #{<+}" - ;; comparisons: [-1, -1], [-1, -1] - (test-comparison 1 (| a >a+b >a0) (& >a+b >a0)) - ;; comparisons: [-1, -1, 3], [-1, -1] - (test-comparison >ident (| a >a+b >a0 >a1) (& >a+b >a0)) - ;; comparisons: [-1, -1], [-1, -1, 3] - (test-comparison <>ident (| a >a+b >a0) (& >a+b >a0 >a1)) - ;; comparisons: [-1, -1, -1], [-1, -1, -1] - (test-comparison >ident (| a >a+b >a0 >a1) (& >a+b >a0 >a1))) + ;; comparisons: [1, 1], [-1, -1] + (test-comparison =ident (| i|a i|>a+b i|>a0) (& i|>a+b i|>a0)) + ;; comparisons: ; [-1, -1, 3], [-1, -1] + (test-comparison >ident (| i|a i|>a+b i|>a0 i|>a1) (& i|>a+b i|>a0)) + ;; comparisons: ; [-1, -1], [-1, -1, 3] + (test-comparison <>ident (| i|a i|>a+b i|>a0) (& i|>a+b i|>a0 i|>a1)) + ;; comparisons: ; [-1, -1, -1], [-1, -1, -1] + (test-comparison >ident (| i|a i|>a+b i|>a0 i|>a1) (& i|>a+b i|>a0 i|>a1))) (testing "+ #{∅+}" - ;; comparisons: [3, 3, 3], [3, 3] + ;; comparisons: ; [3, 3, 3], [3, 3] (test-comparison <>ident (| a >a+b >a0) (& ><0 ><1))) (testing "+ #{<+ ∅+}" - ;; comparisons: [-1, 3], [-1, 3, 3] + ;; comparisons: ; [-1, 3], [-1, 3, 3] (test-comparison <>ident (| a >a+b >a0) (& >a+b ><0 ><1)) - ;; comparisons: [-1, 3, 3], [-1, 3, 3] + ;; comparisons: ; [-1, 3, 3], [-1, 3, 3] (test-comparison <>ident (| a >a+b >a0 >a1) (& >a+b ><0 ><1)) - ;; comparisons: [-1, -1], [-1, -1, 3, 3] + ;; comparisons: ; [-1, -1], [-1, -1, 3, 3] (test-comparison <>ident (| a >a+b >a0) (& >a+b >a0 ><0 ><1)) - ;; comparisons: [-1, -1, 3], [-1, -1, 3, 3] + ;; comparisons: ; [-1, -1, 3], [-1, -1, 3, 3] (test-comparison <>ident (| a >a+b >a0 >a1) (& >a+b >a0 ><0 ><1)) - ;; comparisons: [-1, -1], [-1, -1, 3, 3, 3] + ;; comparisons: ; [-1, -1], [-1, -1, 3, 3, 3] (test-comparison <>ident (| a >a+b >a0) (& >a+b >a0 >a1 ><0 ><1)) - ;; comparisons: [-1, -1, -], [-1, -1, -1, 3, 3] + ;; comparisons: ; [-1, -1, -], [-1, -1, -1, 3, 3] (test-comparison <>ident (| a >a+b >a0 >a1) (& >a+b >a0 >a1 ><0 ><1))) (testing "+ #{= ∅+}" - ;; comparisons: [3, 3], [-1, 3] + ;; comparisons: ; [3, 3], [-1, 3] (test-comparison <>ident (| a >a+b >a0) (& a ><0)) - ;; comparisons: [3, 3], [-1, 3, 3] + ;; comparisons: ; [3, 3], [-1, 3, 3] (test-comparison <>ident (| a >a+b >a0) (& a ><0 ><1))) (testing "+ #{>+ ∅+}" - ;; comparisons: [3, 3], [-1, 3, 3] + ;; comparisons: ; [3, 3], [-1, 3, 3] (test-comparison <>ident (| a >a+b >a0) (& <0 ><1)) - ;; comparisons: [3, 3, 3], [-1, 3, 3] + ;; comparisons: ; [3, 3, 3], [-1, 3, 3] (test-comparison <>ident (| a >a+b >a0 >a1) (& <0 ><1)) - ;; comparisons: [3, 3], [-1, -1, 3, 3] + ;; comparisons: ; [3, 3], [-1, -1, 3, 3] (test-comparison <>ident (| a >a+b >a0) (& <0 ><1)) - ;; comparisons: [3, 3, 3], [-1, -1, 3, 3] + ;; comparisons: ; [3, 3, 3], [-1, -1, 3, 3] (test-comparison <>ident (| a >a+b >a0 >a1) (& <0 ><1)) - ;; comparisons: [3, 3], [-1, -1, 3, 3, 3] + ;; comparisons: ; [3, 3], [-1, -1, 3, 3, 3] (test-comparison <>ident (| a >a+b >a0) (& <0 ><1)) - ;; comparisons: [3, 3, 3], [-1, -1, -1, 3, 3] + ;; comparisons: ; [3, 3, 3], [-1, -1, -1, 3, 3] (test-comparison <>ident (| a >a+b >a0 >a1) (& <0 ><1))))) (testing "+ Expression") (testing "+ ProtocolType") @@ -559,11 +561,11 @@ (testing "#{>}" (test-comparison >ident i|a (& i| ><}" - (test-comparison ><0 i|><1)) - (test-comparison >ident i|a (& i|<0 i|><1)) + (test-comparison >ident a (& (t/isa? javax.management.AttributeList) tt/java-set?)) + (test-comparison >ident tt/comparable? (& (t/isa? java.nio.ByteBuffer) tt/java-set?))) (testing "#{> >< <>}" - (test-comparison ><0 a))) + (test-comparison >ident i|a (& i|<0 a))) (testing "#{> <>}") ; <- TODO comparison should be 1 (testing "#{><}" (test-comparison ><0 i|><1)) From 5efc9ac9c5b03ee2ae70ef57d81415654d03f313 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 11:57:18 -0700 Subject: [PATCH 720/810] Trace out complete comparisons via `comparison-combinations` --- .../test/untyped/core/type/compare.cljc | 322 ++++++++++++++---- 1 file changed, 249 insertions(+), 73 deletions(-) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 653791d2..d4f1ca98 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -297,79 +297,255 @@ ;; Comparison annotations achieved by first comparing each element of the first/left ;; to the entire second/right, then comparing each element of the second/right to the ;; entire first/left - ;; TODO add complete comparisons via `comparison-combinations` - (testing "#{<}, #{<}" - ;; comparisons: < < < < - (test-comparison =ident (| a b) (| a b)) - ;; comparisons: < < < < - (test-comparison =ident (| i|>a+b i|>a0) (| i|>a+b i|>a0))) - (testing "#{<}, #{<, ><}" - ;; comparisons: < < < < >< >< - (test-comparison a+b i|>a0) (| i|>a+b i|>a0 i|><0 i|><1)) - ;; comparisons: < < < < >< >< >< - (test-comparison a+b i|>a0) (| i|>a+b i|>a0 i|>a1 i|><0 i|><1)) - ;; comparisons: < < < < < < >< >< - (test-comparison a+b i|>a0 i|>a1) (| i|>a+b i|>a0 i|>a1 i|><0 i|><1))) - (testing "#{<, ><}, #{<}" - ;; comparisons: < < >< < < - (test-comparison >ident (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|>a0)) - ;; comparisons: >< < < < < - (test-comparison >ident (| i|a i|><0 i|><1) (| i|><0 i|><1))) - (testing "#{<, ><}, #{<, ><}" - ;; comparisons: < >< < >< - (test-comparison >a+b i|>a0) (| i|>a+b i|><0)) - ;; comparisons: < >< >< < >< >< - (test-comparison >a+b i|>a0 i|>a1) (| i|>a+b i|><0 i|><1)) - ;; comparisons: < < >< < < >< >< - (test-comparison >a+b i|>a0 i|>a1) (| i|>a+b i|>a0 i|><0 i|><1)) - ;; comparisons: < < >< < >< - (test-comparison >a+b i|>a0) (| i|a i|><0)) - ;; comparisons: < >< >< < >< >< - (test-comparison >a+b i|>a0) (| i|a i|><0 i|><1)) - ;; comparisons: >< < < >< - (test-comparison ><0) (| i|><0 i|><1)) - ;; comparisons: >< < >< >< < - (test-comparison ><1 i|><2) (| i|><0 i|><1)) - ;; comparisons: >< >< < < >< - (test-comparison ><0 i|><1) (| i|><1 i|><2))) - (testing "#{<, ><}, #{><}" - ;; comparisons: < >< >< >< - (test-comparison ><0) (| i|>a+b i|>a0)) - ;; comparisons: < >< >< >< >< - (test-comparison ><0 i|><1) (| i|>a+b i|>a0)) - ;; comparisons: < >< >< >< >< - (test-comparison ><0) (| i|>a+b i|>a0 i|>a1)) - ;; comparisons: < >< >< >< >< >< - (test-comparison ><0 i|><1) (| i|>a+b i|>a0 i|>a1))) - (testing "#{<, <>}, #{<, <>}" - ;; comparisons: < <> < <> - (test-comparison ><1)) - ;; comparisons: <> < < <> - (test-comparison ><1))) - (testing "#{<, <>}, #{><, <>}" - ;; comparisons: <, <> >< <> <> - (test-comparison >a ><0 ><1))) - (testing "#{><}, #{<, ><}" - ;; comparisons: >< >< >< < >< >< - (test-comparison >a+b i|>a0) (| i|<0 i|><1)) - ;; comparisons: >< >< >< >< < >< >< - (test-comparison >a+b i|>a0 i|>a1) (| i|<0 i|><1)) - ;; comparisons: >< >< >< < < >< >< - (test-comparison >a+b i|>a0) (| i|<0 i|><1)) - ;; comparisons: >< >< >< >< < < >< >< - (test-comparison >a+b i|>a0 i|>a1) (| i|<0 i|><1)) - ;; comparisons: >< >< >< < < < >< >< - (test-comparison >a+b i|>a0) (| i|<0 i|><1)) - ;; comparisons: >< >< >< >< < < < >< >< - (test-comparison >a+b i|>a0 i|>a1) (| i|<0 i|><1))) - (testing "#{><}, #{><}" - ;; comparisons: >< >< >< >< - (test-comparison ><2) (| i|><0 i|><1)) - ;; comparisons: >< >< >< >< - (test-comparison ><0) (| i|><1 i|><2))) - (testing "#{<>}, #{<>}" - ;; comparisons: <> <> <> <> - (test-comparison <>ident (| a b) (| ><0 ><1))))) + ;; TODO fill in these comparisons + (testing "#{<}" + (testing "+ #{<}" + ;; comparisons: < < < < + (test-comparison =ident (| a b) (| a b)) + ;; comparisons: < < < < + (test-comparison =ident (| i|>a+b i|>a0) (| i|>a+b i|>a0))) + #_(testing "+ #{< =}") ; not possible for `OrType` + #_(testing "+ #{< = >}") ; not possible for `OrType` + #_(testing "+ #{< = > ><}") ; not possible for `OrType` + #_(testing "+ #{< = > >< <>}") ; not possible for `OrType` + #_(testing "+ #{< = > <>}") ; not possible for `OrType` + #_(testing "+ #{< = ><}") ; not possible for `OrType` + #_(testing "+ #{< = >< <>}") ; not possible for `OrType` + #_(testing "+ #{< = <>}") ; not possible for `OrType` + (testing "+ #{< >}") + (testing "+ #{< > ><}") + (testing "+ #{< > >< <>}") + (testing "+ #{< > <>}") + (testing "+ #{< ><}" + ;; comparisons: < < < < >< >< + (test-comparison a+b i|>a0) (| i|>a+b i|>a0 i|><0 i|><1)) + ;; comparisons: < < < < >< >< >< + (test-comparison a+b i|>a0) (| i|>a+b i|>a0 i|>a1 i|><0 i|><1)) + ;; comparisons: < < < < < < >< >< + (test-comparison a+b i|>a0 i|>a1) (| i|>a+b i|>a0 i|>a1 i|><0 i|><1))) + (testing "+ #{< >< <>}") + (testing "+ #{< <>}") + (testing "+ #{=}") + #_(testing "+ #{= >}") ; not possible for `OrType` + #_(testing "+ #{= > ><}") ; not possible for `OrType` + #_(testing "+ #{= > >< <>}") ; not possible for `OrType` + #_(testing "+ #{= > <>}") ; not possible for `OrType` + (testing "+ #{= ><}") + (testing "+ #{= >< <>}") + (testing "+ #{= <>}") + (testing "+ #{>}") + (testing "+ #{> ><}") + (testing "+ #{> >< <>}") + (testing "+ #{> <>}") + (testing "+ #{><}") + (testing "+ #{>< <>}") + (testing "+ #{<>}")) + #_(testing "#{< =}") ; not possible for `OrType` + #_(testing "#{< = >}") ; not possible for `OrType` + #_(testing "#{< = > ><}") ; not possible for `OrType` + #_(testing "#{< = > >< <>}") ; not possible for `OrType` + #_(testing "#{< = > <>}") ; not possible for `OrType` + #_(testing "#{< = ><}")) ; not possible for `OrType` + #_(testing "#{< = >< <>}") ; not possible for `OrType` + #_(testing "#{< = <>}") ; not possible for `OrType` + (testing "#{< >}") + (testing "#{< > ><}") + (testing "#{< > >< <>}") + (testing "#{< > <>}") + (testing "#{< ><}" + (testing "+ #{<}" + ;; comparisons: < < >< < < + (test-comparison >ident (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|>a0)) + ;; comparisons: >< < < < < + (test-comparison >ident (| i|a i|><0 i|><1) (| i|><0 i|><1))) + #_(testing "+ #{< =}") ; not possible for `OrType` + #_(testing "+ #{< = >}") ; not possible for `OrType` + #_(testing "+ #{< = > ><}") ; not possible for `OrType` + #_(testing "+ #{< = > >< <>}") ; not possible for `OrType` + #_(testing "+ #{< = > <>}") ; not possible for `OrType` + #_(testing "+ #{< = ><}") ; not possible for `OrType` + #_(testing "+ #{< = >< <>}") ; not possible for `OrType` + #_(testing "+ #{< = <>}") ; not possible for `OrType` + (testing "+ #{< >}") + (testing "+ #{< > ><}") + (testing "+ #{< > >< <>}") + (testing "+ #{< > <>}") + (testing "+ #{< ><}" + ;; comparisons: < >< < >< + (test-comparison >a+b i|>a0) (| i|>a+b i|><0)) + ;; comparisons: < >< >< < >< >< + (test-comparison >a+b i|>a0 i|>a1) (| i|>a+b i|><0 i|><1)) + ;; comparisons: < < >< < < >< >< + (test-comparison >a+b i|>a0 i|>a1) (| i|>a+b i|>a0 i|><0 i|><1)) + ;; comparisons: < < >< < >< + (test-comparison >a+b i|>a0) (| i|a i|><0)) + ;; comparisons: < >< >< < >< >< + (test-comparison >a+b i|>a0) (| i|a i|><0 i|><1)) + ;; comparisons: >< < < >< + (test-comparison ><0) (| i|><0 i|><1)) + ;; comparisons: >< < >< >< < + (test-comparison ><1 i|><2) (| i|><0 i|><1)) + ;; comparisons: >< >< < < >< + (test-comparison ><0 i|><1) (| i|><1 i|><2))) + (testing "+ #{< >< <>}") + (testing "+ #{< <>}") + (testing "+ #{=}") + #_(testing "+ #{= >}") ; not possible for `OrType` + #_(testing "+ #{= > ><}") ; not possible for `OrType` + #_(testing "+ #{= > >< <>}") ; not possible for `OrType` + #_(testing "+ #{= > <>}") ; not possible for `OrType` + (testing "+ #{= ><}") + (testing "+ #{= >< <>}") + (testing "+ #{= <>}") + (testing "+ #{>}") + (testing "+ #{> ><}") + (testing "+ #{> >< <>}") + (testing "+ #{> <>}") + (testing "+ #{><}" + ;; comparisons: < >< >< >< + (test-comparison ><0) (| i|>a+b i|>a0)) + ;; comparisons: < >< >< >< >< + (test-comparison ><0 i|><1) (| i|>a+b i|>a0)) + ;; comparisons: < >< >< >< >< + (test-comparison ><0) (| i|>a+b i|>a0 i|>a1)) + ;; comparisons: < >< >< >< >< >< + (test-comparison ><0 i|><1) (| i|>a+b i|>a0 i|>a1))) + (testing "+ #{>< <>}") + (testing "+ #{<>}")) + (testing "#{< >< <>}") + (testing "#{< <>}" + (testing "+ #{<}") + #_(testing "+ #{< =}") ; not possible for `OrType` + #_(testing "+ #{< = >}") ; not possible for `OrType` + #_(testing "+ #{< = > ><}") ; not possible for `OrType` + #_(testing "+ #{< = > >< <>}") ; not possible for `OrType` + #_(testing "+ #{< = > <>}") ; not possible for `OrType` + #_(testing "+ #{< = ><}") ; not possible for `OrType` + #_(testing "+ #{< = >< <>}") ; not possible for `OrType` + #_(testing "+ #{< = <>}") ; not possible for `OrType` + (testing "+ #{< >}") + (testing "+ #{< > ><}") + (testing "+ #{< > >< <>}") + (testing "+ #{< > <>}") + (testing "+ #{< ><}") + (testing "+ #{< >< <>}") + (testing "+ #{< <>}" + ;; comparisons: < <> < <> + (test-comparison ><1)) + ;; comparisons: <> < < <> + (test-comparison ><1))) + (testing "+ #{=}") + #_(testing "+ #{= >}") ; not possible for `OrType` + #_(testing "+ #{= > ><}") ; not possible for `OrType` + #_(testing "+ #{= > >< <>}") ; not possible for `OrType` + #_(testing "+ #{= > <>}") ; not possible for `OrType` + (testing "+ #{= ><}") + (testing "+ #{= >< <>}") + (testing "+ #{= <>}") + (testing "+ #{>}") + (testing "+ #{> ><}") + (testing "+ #{> >< <>}") + (testing "+ #{> <>}") + (testing "+ #{><}") + (testing "+ #{>< <>}" + ;; comparisons: <, <> >< <> <> + (test-comparison >a ><0 ><1))) + (testing "+ #{<>}")) + (testing "#{=}") + #_(testing "#{= >}") ; not possible for `OrType` + #_(testing "#{= > ><}") ; not possible for `OrType` + #_(testing "#{= > >< <>}") ; not possible for `OrType` + #_(testing "#{= > <>}") ; not possible for `OrType` + (testing "#{= ><}") + (testing "#{= >< <>}") + (testing "#{= <>}") + (testing "#{>}") + (testing "#{> ><}") + (testing "#{> >< <>}") + (testing "#{> <>}") + (testing "#{><}" + (testing "+ #{<}") + #_(testing "+ #{< =}") ; not possible for `OrType` + #_(testing "+ #{< = >}") ; not possible for `OrType` + #_(testing "+ #{< = > ><}") ; not possible for `OrType` + #_(testing "+ #{< = > >< <>}") ; not possible for `OrType` + #_(testing "+ #{< = > <>}") ; not possible for `OrType` + #_(testing "+ #{< = ><}") ; not possible for `OrType` + #_(testing "+ #{< = >< <>}") ; not possible for `OrType` + #_(testing "+ #{< = <>}") ; not possible for `OrType` + (testing "+ #{< >}") + (testing "+ #{< > ><}") + (testing "+ #{< > >< <>}") + (testing "+ #{< > <>}") + (testing "+ #{<, ><}" + ;; comparisons: >< >< >< < >< >< + (test-comparison >a+b i|>a0) (| i|<0 i|><1)) + ;; comparisons: >< >< >< >< < >< >< + (test-comparison >a+b i|>a0 i|>a1) (| i|<0 i|><1)) + ;; comparisons: >< >< >< < < >< >< + (test-comparison >a+b i|>a0) (| i|<0 i|><1)) + ;; comparisons: >< >< >< >< < < >< >< + (test-comparison >a+b i|>a0 i|>a1) (| i|<0 i|><1)) + ;; comparisons: >< >< >< < < < >< >< + (test-comparison >a+b i|>a0) (| i|<0 i|><1)) + ;; comparisons: >< >< >< >< < < < >< >< + (test-comparison >a+b i|>a0 i|>a1) (| i|<0 i|><1))) + (testing "+ #{< >< <>}") + (testing "+ #{< <>}") + (testing "+ #{=}") + #_(testing "+ #{= >}") ; not possible for `OrType` + #_(testing "+ #{= > ><}") ; not possible for `OrType` + #_(testing "+ #{= > >< <>}") ; not possible for `OrType` + #_(testing "+ #{= > <>}") ; not possible for `OrType` + (testing "+ #{= ><}") + (testing "+ #{= >< <>}") + (testing "+ #{= <>}") + (testing "+ #{>}") + (testing "+ #{> ><}") + (testing "+ #{> >< <>}") + (testing "+ #{> <>}") + (testing "+ #{><}" + ;; comparisons: >< >< >< >< + (test-comparison ><2) (| i|><0 i|><1)) + ;; comparisons: >< >< >< >< + (test-comparison ><0) (| i|><1 i|><2))) + (testing "+ #{>< <>}") + (testing "+ #{<>}")) + (testing "#{>< <>}") + (testing "#{<>}" + (testing "+ #{<}") + #_(testing "+ #{< =}") ; not possible for `OrType` + #_(testing "+ #{< = >}") ; not possible for `OrType` + #_(testing "+ #{< = > ><}") ; not possible for `OrType` + #_(testing "+ #{< = > >< <>}") ; not possible for `OrType` + #_(testing "+ #{< = > <>}") ; not possible for `OrType` + #_(testing "+ #{< = ><}") ; not possible for `OrType` + #_(testing "+ #{< = >< <>}") ; not possible for `OrType` + #_(testing "+ #{< = <>}") ; not possible for `OrType` + (testing "+ #{< >}") + (testing "+ #{< > ><}") + (testing "+ #{< > >< <>}") + (testing "+ #{< > <>}") + (testing "+ #{<, ><}") + (testing "+ #{< >< <>}") + (testing "+ #{< <>}") + (testing "+ #{=}") + #_(testing "+ #{= >}") ; not possible for `OrType` + #_(testing "+ #{= > ><}") ; not possible for `OrType` + #_(testing "+ #{= > >< <>}") ; not possible for `OrType` + #_(testing "+ #{= > <>}") ; not possible for `OrType` + (testing "+ #{= ><}") + (testing "+ #{= >< <>}") + (testing "+ #{= <>}") + (testing "+ #{>}") + (testing "+ #{> ><}") + (testing "+ #{> >< <>}") + (testing "+ #{> <>}") + (testing "+ #{><}") + (testing "+ #{>< <>}") + (testing "+ #{<>}" + ;; comparisons: <> <> <> <> + (test-comparison <>ident (| a b) (| ><0 ><1))))) ;; FIXME fix tests/impl in order to proceed ;; - non `i|`s should become `i|`s. ;; - complete comparisons via `comparison-combinations` From 8771a7bc0d252e5dc9fa64af8e980080fdd35213 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 12:19:07 -0700 Subject: [PATCH 721/810] Continue to refine comparison tests for or+and --- .../test/untyped/core/type/compare.cljc | 549 +++++++++++------- 1 file changed, 338 insertions(+), 211 deletions(-) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index d4f1ca98..7f2bc48e 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -197,18 +197,18 @@ (testing "#{<}" ;; TODO Technically something like this but can't do the below b/c of simplification #_(test-comparison }") ; Impossible for `OrType` - #_(testing "#{< = > ><}") ; Impossible for `OrType` - #_(testing "#{< = > >< <>}") ; Impossible for `OrType` - #_(testing "#{< = > <>}") ; Impossible for `OrType` - #_(testing "#{< = ><}") ; Impossible for `OrType` - #_(testing "#{< = >< <>}") ; Impossible for `OrType` - #_(testing "#{< = <>}") ; Impossible for `OrType` - #_(testing "#{< >}") ; Impossible for `OrType` - #_(testing "#{< > ><}") ; Impossible for `OrType` - #_(testing "#{< > >< <>}") ; Impossible for `OrType` - #_(testing "#{< > <>}") ; Impossible for `OrType` + #_(testing "#{< =}") ; impossible for `OrType` + #_(testing "#{< = >}") ; impossible for `OrType` + #_(testing "#{< = > ><}") ; impossible for `OrType` + #_(testing "#{< = > >< <>}") ; impossible for `OrType` + #_(testing "#{< = > <>}") ; impossible for `OrType` + #_(testing "#{< = ><}") ; impossible for `OrType` + #_(testing "#{< = >< <>}") ; impossible for `OrType` + #_(testing "#{< = <>}") ; impossible for `OrType` + #_(testing "#{< >}") ; impossible for `OrType` + #_(testing "#{< > ><}") ; impossible for `OrType` + #_(testing "#{< > >< <>}") ; impossible for `OrType` + #_(testing "#{< > <>}") ; impossible for `OrType` (testing "#{< ><}" #_(test-comparison a+b i|>a0 i|><0 i|><1)) #_(test-comparison a0 (| i|>a+b i|>a0))) @@ -216,11 +216,11 @@ #_(test-comparison a+b i|>a0 i|><0 i|><1 t/string?))) (testing "#{< <>}" #_(test-comparison a ><0 ><1))) - #_(testing "#{=}") ; Impossible for `OrType` - #_(testing "#{= >}") ; Impossible for `OrType` - #_(testing "#{= > ><}") ; Impossible for `OrType` - #_(testing "#{= > >< <>}") ; Impossible for `OrType` - #_(testing "#{= > <>}") ; Impossible for `OrType` + #_(testing "#{=}") ; impossible for `OrType` + #_(testing "#{= >}") ; impossible for `OrType` + #_(testing "#{= > ><}") ; impossible for `OrType` + #_(testing "#{= > >< <>}") ; impossible for `OrType` + #_(testing "#{= > <>}") ; impossible for `OrType` (testing "#{= ><}" (test-comparison <0 i|><1)) (test-comparison <0 i|><1))) @@ -304,18 +304,18 @@ (test-comparison =ident (| a b) (| a b)) ;; comparisons: < < < < (test-comparison =ident (| i|>a+b i|>a0) (| i|>a+b i|>a0))) - #_(testing "+ #{< =}") ; not possible for `OrType` - #_(testing "+ #{< = >}") ; not possible for `OrType` - #_(testing "+ #{< = > ><}") ; not possible for `OrType` - #_(testing "+ #{< = > >< <>}") ; not possible for `OrType` - #_(testing "+ #{< = > <>}") ; not possible for `OrType` - #_(testing "+ #{< = ><}") ; not possible for `OrType` - #_(testing "+ #{< = >< <>}") ; not possible for `OrType` - #_(testing "+ #{< = <>}") ; not possible for `OrType` - (testing "+ #{< >}") - (testing "+ #{< > ><}") - (testing "+ #{< > >< <>}") - (testing "+ #{< > <>}") + #_(testing "+ #{< =}") ; impossible for `OrType` + #_(testing "+ #{< = >}") ; impossible for `OrType` + #_(testing "+ #{< = > ><}") ; impossible for `OrType` + #_(testing "+ #{< = > >< <>}") ; impossible for `OrType` + #_(testing "+ #{< = > <>}") ; impossible for `OrType` + #_(testing "+ #{< = ><}") ; impossible for `OrType` + #_(testing "+ #{< = >< <>}") ; impossible for `OrType` + #_(testing "+ #{< = <>}") ; impossible for `OrType` + #_(testing "+ #{< >}") ; impossible for `OrType` + #_(testing "+ #{< > ><}") ; impossible for `OrType` + #_(testing "+ #{< > >< <>}") ; impossible for `OrType` + #_(testing "+ #{< > <>}") ; impossible for `OrType` (testing "+ #{< ><}" ;; comparisons: < < < < >< >< (test-comparison a+b i|>a0) (| i|>a+b i|>a0 i|><0 i|><1)) @@ -325,11 +325,11 @@ (test-comparison a+b i|>a0 i|>a1) (| i|>a+b i|>a0 i|>a1 i|><0 i|><1))) (testing "+ #{< >< <>}") (testing "+ #{< <>}") - (testing "+ #{=}") - #_(testing "+ #{= >}") ; not possible for `OrType` - #_(testing "+ #{= > ><}") ; not possible for `OrType` - #_(testing "+ #{= > >< <>}") ; not possible for `OrType` - #_(testing "+ #{= > <>}") ; not possible for `OrType` + #_(testing "+ #{=}") ; impossible for `OrType` + #_(testing "+ #{= >}") ; impossible for `OrType` + #_(testing "+ #{= > ><}") ; impossible for `OrType` + #_(testing "+ #{= > >< <>}") ; impossible for `OrType` + #_(testing "+ #{= > <>}") ; impossible for `OrType` (testing "+ #{= ><}") (testing "+ #{= >< <>}") (testing "+ #{= <>}") @@ -340,36 +340,36 @@ (testing "+ #{><}") (testing "+ #{>< <>}") (testing "+ #{<>}")) - #_(testing "#{< =}") ; not possible for `OrType` - #_(testing "#{< = >}") ; not possible for `OrType` - #_(testing "#{< = > ><}") ; not possible for `OrType` - #_(testing "#{< = > >< <>}") ; not possible for `OrType` - #_(testing "#{< = > <>}") ; not possible for `OrType` - #_(testing "#{< = ><}")) ; not possible for `OrType` - #_(testing "#{< = >< <>}") ; not possible for `OrType` - #_(testing "#{< = <>}") ; not possible for `OrType` - (testing "#{< >}") - (testing "#{< > ><}") - (testing "#{< > >< <>}") - (testing "#{< > <>}") + #_(testing "#{< =}") ; impossible for `OrType` + #_(testing "#{< = >}") ; impossible for `OrType` + #_(testing "#{< = > ><}") ; impossible for `OrType` + #_(testing "#{< = > >< <>}") ; impossible for `OrType` + #_(testing "#{< = > <>}") ; impossible for `OrType` + #_(testing "#{< = ><}")) ; impossible for `OrType` + #_(testing "#{< = >< <>}") ; impossible for `OrType` + #_(testing "#{< = <>}") ; impossible for `OrType` + #_(testing "#{< >}") ; impossible for `OrType` + #_(testing "#{< > ><}") ; impossible for `OrType` + #_(testing "#{< > >< <>}") ; impossible for `OrType` + #_(testing "#{< > <>}") ; impossible for `OrType` (testing "#{< ><}" (testing "+ #{<}" ;; comparisons: < < >< < < (test-comparison >ident (| i|>a+b i|>a0 i|>a1) (| i|>a+b i|>a0)) ;; comparisons: >< < < < < (test-comparison >ident (| i|a i|><0 i|><1) (| i|><0 i|><1))) - #_(testing "+ #{< =}") ; not possible for `OrType` - #_(testing "+ #{< = >}") ; not possible for `OrType` - #_(testing "+ #{< = > ><}") ; not possible for `OrType` - #_(testing "+ #{< = > >< <>}") ; not possible for `OrType` - #_(testing "+ #{< = > <>}") ; not possible for `OrType` - #_(testing "+ #{< = ><}") ; not possible for `OrType` - #_(testing "+ #{< = >< <>}") ; not possible for `OrType` - #_(testing "+ #{< = <>}") ; not possible for `OrType` - (testing "+ #{< >}") - (testing "+ #{< > ><}") - (testing "+ #{< > >< <>}") - (testing "+ #{< > <>}") + #_(testing "+ #{< =}") ; impossible for `OrType` + #_(testing "+ #{< = >}") ; impossible for `OrType` + #_(testing "+ #{< = > ><}") ; impossible for `OrType` + #_(testing "+ #{< = > >< <>}") ; impossible for `OrType` + #_(testing "+ #{< = > <>}") ; impossible for `OrType` + #_(testing "+ #{< = ><}") ; impossible for `OrType` + #_(testing "+ #{< = >< <>}") ; impossible for `OrType` + #_(testing "+ #{< = <>}") ; impossible for `OrType` + #_(testing "+ #{< >}") ; impossible for `OrType` + #_(testing "+ #{< > ><}") ; impossible for `OrType` + #_(testing "+ #{< > >< <>}") ; impossible for `OrType` + #_(testing "+ #{< > <>}") ; impossible for `OrType` (testing "+ #{< ><}" ;; comparisons: < >< < >< (test-comparison >a+b i|>a0) (| i|>a+b i|><0)) @@ -389,11 +389,11 @@ (test-comparison ><0 i|><1) (| i|><1 i|><2))) (testing "+ #{< >< <>}") (testing "+ #{< <>}") - (testing "+ #{=}") - #_(testing "+ #{= >}") ; not possible for `OrType` - #_(testing "+ #{= > ><}") ; not possible for `OrType` - #_(testing "+ #{= > >< <>}") ; not possible for `OrType` - #_(testing "+ #{= > <>}") ; not possible for `OrType` + #_(testing "+ #{=}") ; impossible for `OrType` + #_(testing "+ #{= >}") ; impossible for `OrType` + #_(testing "+ #{= > ><}") ; impossible for `OrType` + #_(testing "+ #{= > >< <>}") ; impossible for `OrType` + #_(testing "+ #{= > <>}") ; impossible for `OrType` (testing "+ #{= ><}") (testing "+ #{= >< <>}") (testing "+ #{= <>}") @@ -415,18 +415,18 @@ (testing "#{< >< <>}") (testing "#{< <>}" (testing "+ #{<}") - #_(testing "+ #{< =}") ; not possible for `OrType` - #_(testing "+ #{< = >}") ; not possible for `OrType` - #_(testing "+ #{< = > ><}") ; not possible for `OrType` - #_(testing "+ #{< = > >< <>}") ; not possible for `OrType` - #_(testing "+ #{< = > <>}") ; not possible for `OrType` - #_(testing "+ #{< = ><}") ; not possible for `OrType` - #_(testing "+ #{< = >< <>}") ; not possible for `OrType` - #_(testing "+ #{< = <>}") ; not possible for `OrType` - (testing "+ #{< >}") - (testing "+ #{< > ><}") - (testing "+ #{< > >< <>}") - (testing "+ #{< > <>}") + #_(testing "+ #{< =}") ; impossible for `OrType` + #_(testing "+ #{< = >}") ; impossible for `OrType` + #_(testing "+ #{< = > ><}") ; impossible for `OrType` + #_(testing "+ #{< = > >< <>}") ; impossible for `OrType` + #_(testing "+ #{< = > <>}") ; impossible for `OrType` + #_(testing "+ #{< = ><}") ; impossible for `OrType` + #_(testing "+ #{< = >< <>}") ; impossible for `OrType` + #_(testing "+ #{< = <>}") ; impossible for `OrType` + #_(testing "+ #{< >}") ; impossible for `OrType` + #_(testing "+ #{< > ><}") ; impossible for `OrType` + #_(testing "+ #{< > >< <>}") ; impossible for `OrType` + #_(testing "+ #{< > <>}") ; impossible for `OrType` (testing "+ #{< ><}") (testing "+ #{< >< <>}") (testing "+ #{< <>}" @@ -434,11 +434,11 @@ (test-comparison ><1)) ;; comparisons: <> < < <> (test-comparison ><1))) - (testing "+ #{=}") - #_(testing "+ #{= >}") ; not possible for `OrType` - #_(testing "+ #{= > ><}") ; not possible for `OrType` - #_(testing "+ #{= > >< <>}") ; not possible for `OrType` - #_(testing "+ #{= > <>}") ; not possible for `OrType` + #_(testing "+ #{=}") ; impossible for `OrType` + #_(testing "+ #{= >}") ; impossible for `OrType` + #_(testing "+ #{= > ><}") ; impossible for `OrType` + #_(testing "+ #{= > >< <>}") ; impossible for `OrType` + #_(testing "+ #{= > <>}") ; impossible for `OrType` (testing "+ #{= ><}") (testing "+ #{= >< <>}") (testing "+ #{= <>}") @@ -451,11 +451,11 @@ ;; comparisons: <, <> >< <> <> (test-comparison >a ><0 ><1))) (testing "+ #{<>}")) - (testing "#{=}") - #_(testing "#{= >}") ; not possible for `OrType` - #_(testing "#{= > ><}") ; not possible for `OrType` - #_(testing "#{= > >< <>}") ; not possible for `OrType` - #_(testing "#{= > <>}") ; not possible for `OrType` + #_(testing "#{=}") ; impossible for `OrType` + #_(testing "#{= >}") ; impossible for `OrType` + #_(testing "#{= > ><}") ; impossible for `OrType` + #_(testing "#{= > >< <>}") ; impossible for `OrType` + #_(testing "#{= > <>}") ; impossible for `OrType` (testing "#{= ><}") (testing "#{= >< <>}") (testing "#{= <>}") @@ -465,18 +465,18 @@ (testing "#{> <>}") (testing "#{><}" (testing "+ #{<}") - #_(testing "+ #{< =}") ; not possible for `OrType` - #_(testing "+ #{< = >}") ; not possible for `OrType` - #_(testing "+ #{< = > ><}") ; not possible for `OrType` - #_(testing "+ #{< = > >< <>}") ; not possible for `OrType` - #_(testing "+ #{< = > <>}") ; not possible for `OrType` - #_(testing "+ #{< = ><}") ; not possible for `OrType` - #_(testing "+ #{< = >< <>}") ; not possible for `OrType` - #_(testing "+ #{< = <>}") ; not possible for `OrType` - (testing "+ #{< >}") - (testing "+ #{< > ><}") - (testing "+ #{< > >< <>}") - (testing "+ #{< > <>}") + #_(testing "+ #{< =}") ; impossible for `OrType` + #_(testing "+ #{< = >}") ; impossible for `OrType` + #_(testing "+ #{< = > ><}") ; impossible for `OrType` + #_(testing "+ #{< = > >< <>}") ; impossible for `OrType` + #_(testing "+ #{< = > <>}") ; impossible for `OrType` + #_(testing "+ #{< = ><}") ; impossible for `OrType` + #_(testing "+ #{< = >< <>}") ; impossible for `OrType` + #_(testing "+ #{< = <>}") ; impossible for `OrType` + #_(testing "+ #{< >}") ; impossible for `OrType` + #_(testing "+ #{< > ><}") ; impossible for `OrType` + #_(testing "+ #{< > >< <>}") ; impossible for `OrType` + #_(testing "+ #{< > <>}") ; impossible for `OrType` (testing "+ #{<, ><}" ;; comparisons: >< >< >< < >< >< (test-comparison >a+b i|>a0) (| i|<0 i|><1)) @@ -492,11 +492,11 @@ (test-comparison >a+b i|>a0 i|>a1) (| i|<0 i|><1))) (testing "+ #{< >< <>}") (testing "+ #{< <>}") - (testing "+ #{=}") - #_(testing "+ #{= >}") ; not possible for `OrType` - #_(testing "+ #{= > ><}") ; not possible for `OrType` - #_(testing "+ #{= > >< <>}") ; not possible for `OrType` - #_(testing "+ #{= > <>}") ; not possible for `OrType` + #_(testing "+ #{=}") ; impossible for `OrType` + #_(testing "+ #{= >}") ; impossible for `OrType` + #_(testing "+ #{= > ><}") ; impossible for `OrType` + #_(testing "+ #{= > >< <>}") ; impossible for `OrType` + #_(testing "+ #{= > <>}") ; impossible for `OrType` (testing "+ #{= ><}") (testing "+ #{= >< <>}") (testing "+ #{= <>}") @@ -505,35 +505,35 @@ (testing "+ #{> >< <>}") (testing "+ #{> <>}") (testing "+ #{><}" - ;; comparisons: >< >< >< >< - (test-comparison ><2) (| i|><0 i|><1)) - ;; comparisons: >< >< >< >< - (test-comparison ><0) (| i|><1 i|><2))) + ;; comparisons: >< >< >< >< + (test-comparison ><2) (| i|><0 i|><1)) + ;; comparisons: >< >< >< >< + (test-comparison ><0) (| i|><1 i|><2))) (testing "+ #{>< <>}") (testing "+ #{<>}")) (testing "#{>< <>}") (testing "#{<>}" (testing "+ #{<}") - #_(testing "+ #{< =}") ; not possible for `OrType` - #_(testing "+ #{< = >}") ; not possible for `OrType` - #_(testing "+ #{< = > ><}") ; not possible for `OrType` - #_(testing "+ #{< = > >< <>}") ; not possible for `OrType` - #_(testing "+ #{< = > <>}") ; not possible for `OrType` - #_(testing "+ #{< = ><}") ; not possible for `OrType` - #_(testing "+ #{< = >< <>}") ; not possible for `OrType` - #_(testing "+ #{< = <>}") ; not possible for `OrType` - (testing "+ #{< >}") - (testing "+ #{< > ><}") - (testing "+ #{< > >< <>}") - (testing "+ #{< > <>}") + #_(testing "+ #{< =}") ; impossible for `OrType` + #_(testing "+ #{< = >}") ; impossible for `OrType` + #_(testing "+ #{< = > ><}") ; impossible for `OrType` + #_(testing "+ #{< = > >< <>}") ; impossible for `OrType` + #_(testing "+ #{< = > <>}") ; impossible for `OrType` + #_(testing "+ #{< = ><}") ; impossible for `OrType` + #_(testing "+ #{< = >< <>}") ; impossible for `OrType` + #_(testing "+ #{< = <>}") ; impossible for `OrType` + #_(testing "+ #{< >}") ; impossible for `OrType` + #_(testing "+ #{< > ><}") ; impossible for `OrType` + #_(testing "+ #{< > >< <>}") ; impossible for `OrType` + #_(testing "+ #{< > <>}") ; impossible for `OrType` (testing "+ #{<, ><}") (testing "+ #{< >< <>}") (testing "+ #{< <>}") - (testing "+ #{=}") - #_(testing "+ #{= >}") ; not possible for `OrType` - #_(testing "+ #{= > ><}") ; not possible for `OrType` - #_(testing "+ #{= > >< <>}") ; not possible for `OrType` - #_(testing "+ #{= > <>}") ; not possible for `OrType` + #_(testing "+ #{=}") ; impossible for `OrType` + #_(testing "+ #{= >}") ; impossible for `OrType` + #_(testing "+ #{= > ><}") ; impossible for `OrType` + #_(testing "+ #{= > >< <>}") ; impossible for `OrType` + #_(testing "+ #{= > <>}") ; impossible for `OrType` (testing "+ #{= ><}") (testing "+ #{= >< <>}") (testing "+ #{= <>}") @@ -544,76 +544,203 @@ (testing "+ #{><}") (testing "+ #{>< <>}") (testing "+ #{<>}" - ;; comparisons: <> <> <> <> - (test-comparison <>ident (| a b) (| ><0 ><1))))) + ;; comparisons: <> <> <> <> + (test-comparison <>ident (| a b) (| ><0 ><1))))) ;; FIXME fix tests/impl in order to proceed + ;; - the comparisons need to be assessed ;; - non `i|`s should become `i|`s. ;; - complete comparisons via `comparison-combinations` (testing "+ AndType" ;; Comparison annotations achieved by first comparing each element of the first/left to the ;; entire second/right, then comparing each element of the second/right to the entire ;; first/left - (testing "#{= <+} -> #{<+}" - (testing "+ #{<+}" - ;; comparisons: [1, 1], [-1, -1] - (test-comparison =ident (| i|a i|>a+b i|>a0) (& i|>a+b i|>a0)) - ;; comparisons: ; [-1, -1, 3], [-1, -1] - (test-comparison >ident (| i|a i|>a+b i|>a0 i|>a1) (& i|>a+b i|>a0)) - ;; comparisons: ; [-1, -1], [-1, -1, 3] - (test-comparison <>ident (| i|a i|>a+b i|>a0) (& i|>a+b i|>a0 i|>a1)) - ;; comparisons: ; [-1, -1, -1], [-1, -1, -1] - (test-comparison >ident (| i|a i|>a+b i|>a0 i|>a1) (& i|>a+b i|>a0 i|>a1))) + (testing "#{<}" + (testing "+ #{<}") + #_(testing "+ #{< =}") ; impossible for `AndType` + #_(testing "+ #{< = >}") ; impossible for `AndType` + #_(testing "+ #{< = > ><}") ; impossible for `AndType` + #_(testing "+ #{< = > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = > <>}") ; impossible for `AndType` + #_(testing "+ #{< = ><}") ; impossible for `AndType` + #_(testing "+ #{< = >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = <>}") ; impossible for `AndType` + #_(testing "+ #{< >}") ; impossible for `AndType` + #_(testing "+ #{< > ><}") ; impossible for `AndType` + #_(testing "+ #{< > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< > <>}") ; impossible for `AndType` + (testing "+ #{<, ><}") + (testing "+ #{< >< <>}") + (testing "+ #{< <>}") + #_(testing "+ #{=}") ; impossible for `AndType` + #_(testing "+ #{= >}") ; impossible for `AndType` + #_(testing "+ #{= > ><}") ; impossible for `AndType` + #_(testing "+ #{= > >< <>}") ; impossible for `AndType` + #_(testing "+ #{= > <>}") ; impossible for `AndType` + (testing "+ #{= ><}") + (testing "+ #{= >< <>}") + (testing "+ #{= <>}") + (testing "+ #{>}") + (testing "+ #{> ><}") + (testing "+ #{> >< <>}") + (testing "+ #{> <>}") + (testing "+ #{><}") + (testing "+ #{>< <>}") + (testing "+ #{<>}")) + #_(testing "#{< =}") ; impossible for `OrType` + #_(testing "#{< = >}") ; impossible for `OrType` + #_(testing "#{< = > ><}") ; impossible for `OrType` + #_(testing "#{< = > >< <>}") ; impossible for `OrType` + #_(testing "#{< = > <>}") ; impossible for `OrType` + #_(testing "#{< = ><}") ; impossible for `OrType` + #_(testing "#{< = >< <>}") ; impossible for `OrType` + #_(testing "#{< = <>}") ; impossible for `OrType` + #_(testing "#{< >}") ; impossible for `OrType` + #_(testing "#{< > ><}") ; impossible for `OrType` + #_(testing "#{< > >< <>}") ; impossible for `OrType` + #_(testing "#{< > <>}") ; impossible for `OrType` + (testing "#{<, ><}") + (testing "#{< >< <>}") + (testing "#{< <>}") + #_(testing "#{=}") ; impossible for `OrType` + #_(testing "#{= >}") ; impossible for `OrType` + #_(testing "#{= > ><}") ; impossible for `OrType` + #_(testing "#{= > >< <>}") ; impossible for `OrType` + #_(testing "#{= > <>}") ; impossible for `OrType` + (testing "#{= ><}") + (testing "#{= >< <>}") + (testing "#{= <>}") + (testing "#{>}" + (testing "+ #{<}" (t/compare i|>a1 (| i|>a+b i|>a0)) + ;; comparisons: > > < < + (test-comparison >ident (| i|>a+b i|>a0) (& i|>a+b i|>a0)) + ;; comparisons: > > > < < < + (test-comparison >ident (| i|>a+b i|>a0 i|>a1) (& i|>a+b i|>a0 i|>a1))) + #_(testing "+ #{< =}") ; impossible for `AndType` + #_(testing "+ #{< = >}") ; impossible for `AndType` + #_(testing "+ #{< = > ><}") ; impossible for `AndType` + #_(testing "+ #{< = > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = > <>}") ; impossible for `AndType` + #_(testing "+ #{< = ><}") ; impossible for `AndType` + #_(testing "+ #{< = >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = <>}") ; impossible for `AndType` + #_(testing "+ #{< >}") ; impossible for `AndType` + #_(testing "+ #{< > ><}") ; impossible for `AndType` + #_(testing "+ #{< > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< > <>}") ; impossible for `AndType` + (testing "+ #{<, ><}" + ;; comparisons: > > < < >< + (test-comparison #_<>ident (| i|>a+b i|>a0) (& i|>a+b i|>a0 i|>a1))) + (testing "+ #{< >< <>}") + (testing "+ #{< <>}") + #_(testing "+ #{=}") ; impossible for `AndType` + #_(testing "+ #{= >}") ; impossible for `AndType` + #_(testing "+ #{= > ><}") ; impossible for `AndType` + #_(testing "+ #{= > >< <>}") ; impossible for `AndType` + #_(testing "+ #{= > <>}") ; impossible for `AndType` + (testing "+ #{= ><}") + (testing "+ #{= >< <>}") + (testing "+ #{= <>}") + (testing "+ #{>}") + (testing "+ #{> ><}") + (testing "+ #{> >< <>}") + (testing "+ #{> <>}") + (testing "+ #{><}") + (testing "+ #{>< <>}") + (testing "+ #{<>}")) + (testing "#{> ><}" + (testing "+ #{<}" + ;; comparisons: > > >< < < + (test-comparison #_>ident (| i|>a+b i|>a0 i|>a1) (& i|>a+b i|>a0))) + #_(testing "+ #{< =}") ; impossible for `AndType` + #_(testing "+ #{< = >}") ; impossible for `AndType` + #_(testing "+ #{< = > ><}") ; impossible for `AndType` + #_(testing "+ #{< = > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = > <>}") ; impossible for `AndType` + #_(testing "+ #{< = ><}") ; impossible for `AndType` + #_(testing "+ #{< = >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = <>}") ; impossible for `AndType` + #_(testing "+ #{< >}") ; impossible for `AndType` + #_(testing "+ #{< > ><}") ; impossible for `AndType` + #_(testing "+ #{< > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< > <>}") ; impossible for `AndType` + (testing "+ #{<, ><}") + (testing "+ #{< >< <>}") + (testing "+ #{< <>}") + #_(testing "+ #{=}") ; impossible for `AndType` + #_(testing "+ #{= >}") ; impossible for `AndType` + #_(testing "+ #{= > ><}") ; impossible for `AndType` + #_(testing "+ #{= > >< <>}") ; impossible for `AndType` + #_(testing "+ #{= > <>}") ; impossible for `AndType` + (testing "+ #{= ><}") + (testing "+ #{= >< <>}") + (testing "+ #{= <>}") + (testing "+ #{>}") + (testing "+ #{> ><}") + (testing "+ #{> >< <>}") + (testing "+ #{> <>}") + (testing "+ #{><}") + (testing "+ #{>< <>}") + (testing "+ #{<>}")) + (testing "#{> >< <>}") + (testing "#{> <>}") + (testing "#{><}") + (testing "#{>< <>}") + (testing "#{<>}") + + + + (testing "#{<}" (testing "+ #{∅+}" ;; comparisons: ; [3, 3, 3], [3, 3] - (test-comparison <>ident (| a >a+b >a0) (& ><0 ><1))) + (test-comparison #_<>ident (| a >a+b >a0) (& ><0 ><1))) (testing "+ #{<+ ∅+}" ;; comparisons: ; [-1, 3], [-1, 3, 3] - (test-comparison <>ident (| a >a+b >a0) (& >a+b ><0 ><1)) + (test-comparison #_<>ident (| a >a+b >a0) (& >a+b ><0 ><1)) ;; comparisons: ; [-1, 3, 3], [-1, 3, 3] - (test-comparison <>ident (| a >a+b >a0 >a1) (& >a+b ><0 ><1)) + (test-comparison #_<>ident (| a >a+b >a0 >a1) (& >a+b ><0 ><1)) ;; comparisons: ; [-1, -1], [-1, -1, 3, 3] - (test-comparison <>ident (| a >a+b >a0) (& >a+b >a0 ><0 ><1)) + (test-comparison #_<>ident (| a >a+b >a0) (& >a+b >a0 ><0 ><1)) ;; comparisons: ; [-1, -1, 3], [-1, -1, 3, 3] - (test-comparison <>ident (| a >a+b >a0 >a1) (& >a+b >a0 ><0 ><1)) + (test-comparison #_<>ident (| a >a+b >a0 >a1) (& >a+b >a0 ><0 ><1)) ;; comparisons: ; [-1, -1], [-1, -1, 3, 3, 3] - (test-comparison <>ident (| a >a+b >a0) (& >a+b >a0 >a1 ><0 ><1)) + (test-comparison #_<>ident (| a >a+b >a0) (& >a+b >a0 >a1 ><0 ><1)) ;; comparisons: ; [-1, -1, -], [-1, -1, -1, 3, 3] - (test-comparison <>ident (| a >a+b >a0 >a1) (& >a+b >a0 >a1 ><0 ><1))) + (test-comparison #_<>ident (| a >a+b >a0 >a1) (& >a+b >a0 >a1 ><0 ><1))) (testing "+ #{= ∅+}" ;; comparisons: ; [3, 3], [-1, 3] - (test-comparison <>ident (| a >a+b >a0) (& a ><0)) + (test-comparison #_<>ident (| a >a+b >a0) (& a ><0)) ;; comparisons: ; [3, 3], [-1, 3, 3] - (test-comparison <>ident (| a >a+b >a0) (& a ><0 ><1))) + (test-comparison #_<>ident (| a >a+b >a0) (& a ><0 ><1))) (testing "+ #{>+ ∅+}" ;; comparisons: ; [3, 3], [-1, 3, 3] - (test-comparison <>ident (| a >a+b >a0) (& <0 ><1)) + (test-comparison #_<>ident (| a >a+b >a0) (& <0 ><1)) ;; comparisons: ; [3, 3, 3], [-1, 3, 3] - (test-comparison <>ident (| a >a+b >a0 >a1) (& <0 ><1)) + (test-comparison #_<>ident (| a >a+b >a0 >a1) (& <0 ><1)) ;; comparisons: ; [3, 3], [-1, -1, 3, 3] - (test-comparison <>ident (| a >a+b >a0) (& <0 ><1)) + (test-comparison #_<>ident (| a >a+b >a0) (& <0 ><1)) ;; comparisons: ; [3, 3, 3], [-1, -1, 3, 3] - (test-comparison <>ident (| a >a+b >a0 >a1) (& <0 ><1)) + (test-comparison #_<>ident (| a >a+b >a0 >a1) (& <0 ><1)) ;; comparisons: ; [3, 3], [-1, -1, 3, 3, 3] - (test-comparison <>ident (| a >a+b >a0) (& <0 ><1)) + (test-comparison #_<>ident (| a >a+b >a0) (& <0 ><1)) ;; comparisons: ; [3, 3, 3], [-1, -1, -1, 3, 3] - (test-comparison <>ident (| a >a+b >a0 >a1) (& <0 ><1))))) + (test-comparison #_<>ident (| a >a+b >a0 >a1) (& <0 ><1))))) (testing "+ Expression") (testing "+ ProtocolType") (testing "+ ClassType" (testing "#{<}" (test-comparison a+b i|>a0 i|>a1))) - #_(testing "#{< =}") ; Impossible for `OrType` - #_(testing "#{< = >}") ; Impossible for `OrType` - #_(testing "#{< = > ><}") ; Impossible for `OrType` - #_(testing "#{< = > >< <>}") ; Impossible for `OrType` - #_(testing "#{< = > <>}") ; Impossible for `OrType` - #_(testing "#{< = ><}") ; Impossible for `OrType` - #_(testing "#{< = >< <>}") ; Impossible for `OrType` - #_(testing "#{< = <>}") ; Impossible for `OrType` - #_(testing "#{< >}") ; Impossible for `OrType` - #_(testing "#{< > ><}") ; Impossible for `OrType` - #_(testing "#{< > >< <>}") ; Impossible for `OrType` - #_(testing "#{< > <>}") ; Impossible for `OrType` + #_(testing "#{< =}") ; impossible for `OrType` + #_(testing "#{< = >}") ; impossible for `OrType` + #_(testing "#{< = > ><}") ; impossible for `OrType` + #_(testing "#{< = > >< <>}") ; impossible for `OrType` + #_(testing "#{< = > <>}") ; impossible for `OrType` + #_(testing "#{< = ><}") ; impossible for `OrType` + #_(testing "#{< = >< <>}") ; impossible for `OrType` + #_(testing "#{< = <>}") ; impossible for `OrType` + #_(testing "#{< >}") ; impossible for `OrType` + #_(testing "#{< > ><}") ; impossible for `OrType` + #_(testing "#{< > >< <>}") ; impossible for `OrType` + #_(testing "#{< > <>}") ; impossible for `OrType` (testing "#{< ><}" (test-comparison a+b i|>a0 i|><0 i|><1)) (test-comparison a0 (| i|>a+b i|>a0))) @@ -621,11 +748,11 @@ (test-comparison a+b i|>a0 i|><0 i|><1 t/string?))) (testing "#{< <>}" (test-comparison a ><0 ><1))) - #_(testing "#{=}") ; Impossible for `OrType` - #_(testing "#{= >}") ; Impossible for `OrType` - #_(testing "#{= > ><}") ; Impossible for `OrType` - #_(testing "#{= > >< <>}") ; Impossible for `OrType` - #_(testing "#{= > <>}") ; Impossible for `OrType` + #_(testing "#{=}") ; impossible for `OrType` + #_(testing "#{= >}") ; impossible for `OrType` + #_(testing "#{= > ><}") ; impossible for `OrType` + #_(testing "#{= > >< <>}") ; impossible for `OrType` + #_(testing "#{= > <>}") ; impossible for `OrType` (testing "#{= ><}" (test-comparison <0 i|><1))) (testing "#{= >< <>}" @@ -700,18 +827,18 @@ (test-comparison a0 i|>a1)))) (testing "#{<}" (test-comparison a0 i|>a1))) - #_(testing "#{< =}") ; Impossible for `AndType` - #_(testing "#{< = >}") ; Impossible for `AndType` - #_(testing "#{< = > ><}") ; Impossible for `AndType` - #_(testing "#{< = > >< <>}") ; Impossible for `AndType` - #_(testing "#{< = > <>}") ; Impossible for `AndType` - #_(testing "#{< = ><}") ; Impossible for `AndType` - #_(testing "#{< = >< <>}") ; Impossible for `AndType` - #_(testing "#{< = <>}") ; Impossible for `AndType` - #_(testing "#{< >}") ; Impossible for `AndType` - #_(testing "#{< > ><}") ; Impossible for `AndType` - #_(testing "#{< > >< <>}") ; Impossible for `AndType` - #_(testing "#{< > <>}") ; Impossible for `AndType` + #_(testing "#{< =}") ; impossible for `AndType` + #_(testing "#{< = >}") ; impossible for `AndType` + #_(testing "#{< = > ><}") ; impossible for `AndType` + #_(testing "#{< = > >< <>}") ; impossible for `AndType` + #_(testing "#{< = > <>}") ; impossible for `AndType` + #_(testing "#{< = ><}") ; impossible for `AndType` + #_(testing "#{< = >< <>}") ; impossible for `AndType` + #_(testing "#{< = <>}") ; impossible for `AndType` + #_(testing "#{< >}") ; impossible for `AndType` + #_(testing "#{< > ><}") ; impossible for `AndType` + #_(testing "#{< > >< <>}") ; impossible for `AndType` + #_(testing "#{< > <>}") ; impossible for `AndType` (testing "#{< ><}" (test-comparison >a+b i|>a0 i|>a1 i|><0 i|><1))) (testing "#{< >< <>}" @@ -721,11 +848,11 @@ (test-comparison <>ident t/string? (& tt/char-seq? tt/java-set?)) (test-comparison <>ident ><0 (& (! ><1) (! ><0))) (test-comparison <>ident a (& (! a) (! b)))) - #_(testing "#{=}") ; Impossible for `AndType` - #_(testing "#{= >}") ; Impossible for `AndType` - #_(testing "#{= > ><}") ; Impossible for `AndType` - #_(testing "#{= > >< <>}") ; Impossible for `AndType` - #_(testing "#{= > <>}") ; Impossible for `AndType` + #_(testing "#{=}") ; impossible for `AndType` + #_(testing "#{= >}") ; impossible for `AndType` + #_(testing "#{= > ><}") ; impossible for `AndType` + #_(testing "#{= > >< <>}") ; impossible for `AndType` + #_(testing "#{= > <>}") ; impossible for `AndType` (testing "#{= ><}" (test-comparison >ident i|a (& i|a i|><0 i|><1)) (test-comparison >ident tt/char-seq? (& tt/char-seq? tt/java-set?)) @@ -752,37 +879,37 @@ (testing "+ ValueType" (testing "#{<}" (test-comparison }") ; not possible for `AndType`; `>` not possible for `ValueType` - #_(testing "#{< = > ><}") ; not possible for `AndType`; `>` and `><` not possible for `ValueType` - #_(testing "#{< = > >< <>}") ; not possible for `AndType`; `>` and `><` not possible for `ValueType` - #_(testing "#{< = > <>}") ; not possible for `AndType`; `>` not possible for `ValueType` - #_(testing "#{< = ><}") ; not possible for `AndType`; `><` not possible for `ValueType` - #_(testing "#{< = >< <>}") ; not possible for `AndType`; `><` not possible for `ValueType` - #_(testing "#{< = <>}") ; not possible for `AndType` - #_(testing "#{< >}") ; not possible for `AndType`; `>` not possible for `ValueType` - #_(testing "#{< > ><}") ; not possible for `AndType`; `>` and `><` not possible for `ValueType` - #_(testing "#{< > >< <>}") ; not possible for `AndType`; `>` and `><` not possible for `ValueType` - #_(testing "#{< > <>}") ; not possible for `AndType`; `>` not possible for `ValueType` - #_(testing "#{< ><}") ; `><` not possible for `ValueType` - #_(testing "#{< >< <>}") ; `><` not possible for `ValueType` + #_(testing "#{< =}") ; impossible for `AndType` + #_(testing "#{< = >}") ; impossible for `AndType`; `>` impossible for `ValueType` + #_(testing "#{< = > ><}") ; impossible for `AndType`; `>` and `><` impossible for `ValueType` + #_(testing "#{< = > >< <>}") ; impossible for `AndType`; `>` and `><` impossible for `ValueType` + #_(testing "#{< = > <>}") ; impossible for `AndType`; `>` impossible for `ValueType` + #_(testing "#{< = ><}") ; impossible for `AndType`; `><` impossible for `ValueType` + #_(testing "#{< = >< <>}") ; impossible for `AndType`; `><` impossible for `ValueType` + #_(testing "#{< = <>}") ; impossible for `AndType` + #_(testing "#{< >}") ; impossible for `AndType`; `>` impossible for `ValueType` + #_(testing "#{< > ><}") ; impossible for `AndType`; `>` and `><` impossible for `ValueType` + #_(testing "#{< > >< <>}") ; impossible for `AndType`; `>` and `><` impossible for `ValueType` + #_(testing "#{< > <>}") ; impossible for `AndType`; `>` impossible for `ValueType` + #_(testing "#{< ><}") ; `><` impossible for `ValueType` + #_(testing "#{< >< <>}") ; `><` impossible for `ValueType` (testing "#{< <>}" (test-comparison <>ident (t/value "a") (& tt/char-seq? a)) (test-comparison <>ident (t/value "a") (& tt/char-seq? tt/java-set?))) - #_(testing "#{=}") ; not possible for `AndType` - #_(testing "#{= >}") ; not possible for `AndType`; `>` not possible for `ValueType` - #_(testing "#{= > ><}") ; not possible for `AndType`; `>` and `><` not possible for `ValueType` - #_(testing "#{= > >< <>}") ; not possible for `AndType`; `>` and `><` not possible for `ValueType` - #_(testing "#{= > <>}") ; not possible for `AndType`; `>` not possible for `ValueType` - #_(testing "#{= ><}") ; `><` not possible for `ValueType` - #_(testing "#{= >< <>}") ; `><` not possible for `ValueType` + #_(testing "#{=}") ; impossible for `AndType` + #_(testing "#{= >}") ; impossible for `AndType`; `>` impossible for `ValueType` + #_(testing "#{= > ><}") ; impossible for `AndType`; `>` and `><` impossible for `ValueType` + #_(testing "#{= > >< <>}") ; impossible for `AndType`; `>` and `><` impossible for `ValueType` + #_(testing "#{= > <>}") ; impossible for `AndType`; `>` impossible for `ValueType` + #_(testing "#{= ><}") ; `><` impossible for `ValueType` + #_(testing "#{= >< <>}") ; `><` impossible for `ValueType` (testing "#{= <>}") - #_(testing "#{>}") ; `>` not possible for `ValueType` - #_(testing "#{> ><}") ; `>` and `><` not possible for `ValueType` - #_(testing "#{> >< <>}") ; `>` and `><` not possible for `ValueType` - #_(testing "#{> <>}") ; `>` not possible for `ValueType` - #_(testing "#{><}") ; `><` not possible for `ValueType` - #_(testing "#{>< <>}") ; `><` not possible for `ValueType` + #_(testing "#{>}") ; `>` impossible for `ValueType` + #_(testing "#{> ><}") ; `>` and `><` impossible for `ValueType` + #_(testing "#{> >< <>}") ; `>` and `><` impossible for `ValueType` + #_(testing "#{> <>}") ; `>` impossible for `ValueType` + #_(testing "#{><}") ; `><` impossible for `ValueType` + #_(testing "#{>< <>}") ; `><` impossible for `ValueType` (testing "#{<>}" (test-comparison <>ident (t/value "a") (& a tt/java-set?))))) (testing "Expression" From 2683ad0179fb18d3a3f0fe84d37d413f49413f7c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 15:47:08 -0700 Subject: [PATCH 722/810] `compare|or+and` improved slightly --- .../quantum/untyped/core/data/bits.cljc | 2 +- .../quantum/untyped/core/type/compare.cljc | 30 ++++- .../test/untyped/core/type/compare.cljc | 117 +++++++++++++----- 3 files changed, 118 insertions(+), 31 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/bits.cljc b/src-untyped/quantum/untyped/core/data/bits.cljc index f27e82fa..628a5247 100644 --- a/src-untyped/quantum/untyped/core/data/bits.cljc +++ b/src-untyped/quantum/untyped/core/data/bits.cljc @@ -32,7 +32,7 @@ (defn conj ([] empty) - ([v] (conj empty v)) + ([xs] xs) ([xs v] (bit-set xs v)) ([xs v0 v1] (-> xs (conj v0) (conj v1)))) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index fe385cc4..9879d030 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -26,6 +26,8 @@ :refer [fn' fn1]] [quantum.untyped.core.logic :refer [ifs]] + [quantum.untyped.core.reducers + :refer [educe]] [quantum.untyped.core.spec :as us] ;; TODO remove this dependency [quantum.untyped.core.type.core :as utcore] @@ -224,9 +226,33 @@ (defns- compare|or+or [^OrType t0 or-type?, ^OrType t1 or-type? > comparison?] (compare|or+or-like (.-args t0) (.-args t1) (fn1 < t0) (fn1 < t1) (fn1 <> t1))) +;; TODO this might not actually be right +;; TODO performance can be improved here (defns- compare|or+and [^OrType t0 or-type?, ^AndType t1 and-type? > comparison?] - (let [r (->> t1 .-args (seq-and (fn1 < t0)))] - (if r >ident <>ident))) + (let [t0+t1 (->> t0 .-args (uc/map+ #(compare % t1)) (educe ubit/conj ubit/empty)) + t1+t0 (->> t1 .-args (uc/map+ #(compare % t0)) (educe ubit/conj ubit/empty))] + (ifs (or (and (ubit/contains? t0+t1 >ident) + (not (ubit/contains? t0+t1 ident)) + (not (ubit/contains? t1+t0 >ident + (or (and (ubit/contains? t0+t1 ident)) + (not (ubit/contains? t0+t1 >ident) + (not (ubit/contains? t1+t0 ident))) + (and (ubit/contains? t1+t0 >ident)))) + >ident))) (def- compare|or+class (inverted compare|atomic+or)) (def- compare|or+unordered (inverted compare|atomic+or)) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 7f2bc48e..17f0c07f 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -546,10 +546,7 @@ (testing "+ #{<>}" ;; comparisons: <> <> <> <> (test-comparison <>ident (| a b) (| ><0 ><1))))) - ;; FIXME fix tests/impl in order to proceed - ;; - the comparisons need to be assessed - ;; - non `i|`s should become `i|`s. - ;; - complete comparisons via `comparison-combinations` + ;; TODO complete comparisons via `comparison-combinations` (testing "+ AndType" ;; Comparison annotations achieved by first comparing each element of the first/left to the ;; entire second/right, then comparing each element of the second/right to the entire @@ -610,10 +607,10 @@ (testing "#{= >< <>}") (testing "#{= <>}") (testing "#{>}" - (testing "+ #{<}" (t/compare i|>a1 (| i|>a+b i|>a0)) + (testing "+ #{<}" ;; comparisons: > > < < (test-comparison >ident (| i|>a+b i|>a0) (& i|>a+b i|>a0)) - ;; comparisons: > > > < < < + ;; comparisons: > > > < < < (test-comparison >ident (| i|>a+b i|>a0 i|>a1) (& i|>a+b i|>a0 i|>a1))) #_(testing "+ #{< =}") ; impossible for `AndType` #_(testing "+ #{< = >}") ; impossible for `AndType` @@ -628,8 +625,12 @@ #_(testing "+ #{< > >< <>}") ; impossible for `AndType` #_(testing "+ #{< > <>}") ; impossible for `AndType` (testing "+ #{<, ><}" - ;; comparisons: > > < < >< - (test-comparison #_<>ident (| i|>a+b i|>a0) (& i|>a+b i|>a0 i|>a1))) + ;; comparisons: > > < < >< + (test-comparison >ident (| i|>a+b i|>a0) (& i|>a+b i|>a0 i|>a1)) + ;; comparisons: > > < >< + (test-comparison >ident (| i|>a+b i|>a0) (& i|a i|><0)) + ;; comparisons: > > < >< >< + (test-comparison >ident (| i|>a+b i|>a0) (& i|a i|><0 i|><1))) (testing "+ #{< >< <>}") (testing "+ #{< <>}") #_(testing "+ #{=}") ; impossible for `AndType` @@ -649,8 +650,8 @@ (testing "+ #{<>}")) (testing "#{> ><}" (testing "+ #{<}" - ;; comparisons: > > >< < < - (test-comparison #_>ident (| i|>a+b i|>a0 i|>a1) (& i|>a+b i|>a0))) + ;; comparisons: > > >< < < + (test-comparison >ident (| i|>a+b i|>a0 i|>a1) (& i|>a+b i|>a0))) #_(testing "+ #{< =}") ; impossible for `AndType` #_(testing "+ #{< = >}") ; impossible for `AndType` #_(testing "+ #{< = > ><}") ; impossible for `AndType` @@ -682,36 +683,96 @@ (testing "+ #{>< <>}") (testing "+ #{<>}")) (testing "#{> >< <>}") - (testing "#{> <>}") - (testing "#{><}") + (testing "#{> <>}" + (testing "+ #{<}") + #_(testing "+ #{< =}") ; impossible for `AndType` + #_(testing "+ #{< = >}") ; impossible for `AndType` + #_(testing "+ #{< = > ><}") ; impossible for `AndType` + #_(testing "+ #{< = > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = > <>}") ; impossible for `AndType` + #_(testing "+ #{< = ><}") ; impossible for `AndType` + #_(testing "+ #{< = >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = <>}") ; impossible for `AndType` + #_(testing "+ #{< >}") ; impossible for `AndType` + #_(testing "+ #{< > ><}") ; impossible for `AndType` + #_(testing "+ #{< > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< > <>}") ; impossible for `AndType` + (testing "+ #{<, ><}" + ;; comparisons: > <> < >< + (test-comparison >ident (| i|>a+b t/nil?) (& i|a i|><1))) + (testing "+ #{< >< <>}") + (testing "+ #{< <>}") + #_(testing "+ #{=}") ; impossible for `AndType` + #_(testing "+ #{= >}") ; impossible for `AndType` + #_(testing "+ #{= > ><}") ; impossible for `AndType` + #_(testing "+ #{= > >< <>}") ; impossible for `AndType` + #_(testing "+ #{= > <>}") ; impossible for `AndType` + (testing "+ #{= ><}") + (testing "+ #{= >< <>}") + (testing "+ #{= <>}") + (testing "+ #{>}") + (testing "+ #{> ><}") + (testing "+ #{> >< <>}") + (testing "+ #{> <>}") + (testing "+ #{><}") + (testing "+ #{>< <>}") + (testing "+ #{<>}")) + (testing "#{><}" + (testing "+ #{<}") + #_(testing "+ #{< =}") ; impossible for `AndType` + #_(testing "+ #{< = >}") ; impossible for `AndType` + #_(testing "+ #{< = > ><}") ; impossible for `AndType` + #_(testing "+ #{< = > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = > <>}") ; impossible for `AndType` + #_(testing "+ #{< = ><}") ; impossible for `AndType` + #_(testing "+ #{< = >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = <>}") ; impossible for `AndType` + #_(testing "+ #{< >}") ; impossible for `AndType` + #_(testing "+ #{< > ><}") ; impossible for `AndType` + #_(testing "+ #{< > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< > <>}") ; impossible for `AndType` + (testing "+ #{<, ><}") + (testing "+ #{< >< <>}") + (testing "+ #{< <>}") + #_(testing "+ #{=}") ; impossible for `AndType` + #_(testing "+ #{= >}") ; impossible for `AndType` + #_(testing "+ #{= > ><}") ; impossible for `AndType` + #_(testing "+ #{= > >< <>}") ; impossible for `AndType` + #_(testing "+ #{= > <>}") ; impossible for `AndType` + (testing "+ #{= ><}") + (testing "+ #{= >< <>}") + (testing "+ #{= <>}") + (testing "+ #{>}") + (testing "+ #{> ><}") + (testing "+ #{> >< <>}") + (testing "+ #{> <>}") + (testing "+ #{><}" + ;; comparisons: >< >< >< >< >< + (test-comparison >a+b i|>a0) (& i|><0 i|><1))) + (testing "+ #{>< <>}") + (testing "+ #{<>}")) (testing "#{>< <>}") (testing "#{<>}") - + ;; FIXME incorporate the below + ;; - the comparisons need to be assessed + ;; - non `i|`s should become `i|`s (testing "#{<}" - (testing "+ #{∅+}" - ;; comparisons: ; [3, 3, 3], [3, 3] - (test-comparison #_<>ident (| a >a+b >a0) (& ><0 ><1))) (testing "+ #{<+ ∅+}" ;; comparisons: ; [-1, 3], [-1, 3, 3] - (test-comparison #_<>ident (| a >a+b >a0) (& >a+b ><0 ><1)) + (test-comparison #_<>ident (| i|>a+b i|>a0) (& i|>a+b i|><0 i|><1)) ;; comparisons: ; [-1, 3, 3], [-1, 3, 3] - (test-comparison #_<>ident (| a >a+b >a0 >a1) (& >a+b ><0 ><1)) + (test-comparison #_<>ident (| i|>a+b i|>a0 i|>a1) (& i|>a+b i|><0 i|><1)) ;; comparisons: ; [-1, -1], [-1, -1, 3, 3] - (test-comparison #_<>ident (| a >a+b >a0) (& >a+b >a0 ><0 ><1)) + (test-comparison #_<>ident (| i|>a+b i|>a0) (& i|>a+b i|>a0 i|><0 i|><1)) ;; comparisons: ; [-1, -1, 3], [-1, -1, 3, 3] - (test-comparison #_<>ident (| a >a+b >a0 >a1) (& >a+b >a0 ><0 ><1)) + (test-comparison #_<>ident (| i|>a+b i|>a0 i|>a1) (& i|>a+b i|>a0 i|><0 i|><1)) ;; comparisons: ; [-1, -1], [-1, -1, 3, 3, 3] - (test-comparison #_<>ident (| a >a+b >a0) (& >a+b >a0 >a1 ><0 ><1)) + (test-comparison #_<>ident (| i|>a+b i|>a0) (& i|>a+b i|>a0 i|>a1 i|><0 i|><1)) ;; comparisons: ; [-1, -1, -], [-1, -1, -1, 3, 3] - (test-comparison #_<>ident (| a >a+b >a0 >a1) (& >a+b >a0 >a1 ><0 ><1))) - (testing "+ #{= ∅+}" - ;; comparisons: ; [3, 3], [-1, 3] - (test-comparison #_<>ident (| a >a+b >a0) (& a ><0)) - ;; comparisons: ; [3, 3], [-1, 3, 3] - (test-comparison #_<>ident (| a >a+b >a0) (& a ><0 ><1))) - (testing "+ #{>+ ∅+}" + (test-comparison #_<>ident (| i|>a+b i|>a0 i|>a1) (& i|>a+b i|>a0 i|>a1 i|><0 i|><1))) + (testing "+ #{>+ ∅+}" (t/compare i|a (& i|a i|><0 i|><1)) ;; comparisons: ; [3, 3], [-1, 3, 3] (test-comparison #_<>ident (| a >a+b >a0) (& <0 ><1)) ;; comparisons: ; [3, 3, 3], [-1, 3, 3] From 80b60f3d9561c129975731b1511b530f2d4e19bd Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 17:39:40 -0700 Subject: [PATCH 723/810] Add to error data --- src-untyped/quantum/untyped/core/analyze.cljc | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 06248bbb..7d1e7670 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -401,7 +401,8 @@ [arg|analyzed|type] (repeat (- (count args|form) (inc (count args|analyzed))) - :unanalyzed)))}) + :unanalyzed))) + (keyword kinds-str) call-sites-for-ct}) (-> ret (assoc :call-sites call-sites') (update :args|analyzed conj arg|analyzed))))) @@ -1073,7 +1074,6 @@ ([form _] (analyze {} form)) ([env ::env, form _] (uref/set! !!analyze-depth 0) - #_(pr! (kw-map env form)) (analyze* env form))) ;; ===== Arglist analysis ===== ;; From b5391511b20d0c4ccf72a9cd592b967581b33703 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 17:39:50 -0700 Subject: [PATCH 724/810] Fix >form error --- src-untyped/quantum/untyped/core/form.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/form.cljc b/src-untyped/quantum/untyped/core/form.cljc index ed40645d..0e4aaddb 100644 --- a/src-untyped/quantum/untyped/core/form.cljc +++ b/src-untyped/quantum/untyped/core/form.cljc @@ -44,7 +44,7 @@ java.lang.Character (>form [x] (list `unchecked-char (long x))) java.lang.Integer (>form [x] (list `unchecked-int (long x))) java.lang.Long (>form [x] x) - java.lang.Float (>form [x] (list `unchecked-short (long x)))]) + java.lang.Float (>form [x] (list `unchecked-float (long x)))]) #?(:clj java.lang.Double :cljs number) (>form [x] x) #?(:clj java.lang.String From 0220b464c30f428e17b27ff1ec56e3d888e269c0 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 17:39:55 -0700 Subject: [PATCH 725/810] Reorder --- src/data_readers.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/data_readers.cljc b/src/data_readers.cljc index c4b2cca8..491fbf5e 100644 --- a/src/data_readers.cljc +++ b/src/data_readers.cljc @@ -1,6 +1,6 @@ {b quantum.core.data.primitive/read-byte - c quantum.core.data.primitive/read-char s quantum.core.data.primitive/read-short + c quantum.core.data.primitive/read-char i quantum.core.data.primitive/read-int l quantum.core.data.primitive/read-long f quantum.core.data.primitive/read-float From 65b7eaa2d81b27090cf349e8a2067c346079ba7b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 17:40:09 -0700 Subject: [PATCH 726/810] Implement all readers --- src/quantum/core/data/primitive.cljc | 109 ++++++++++++++++++++------- 1 file changed, 83 insertions(+), 26 deletions(-) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 94c5ef21..a22e421c 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -418,37 +418,94 @@ ;; ===== Readers ===== ;; (t/defn read-byte - "Used for the `#b` literal. Only a literal long, double, or char may be converted to byte, as long - as it is in the numeric range of a byte, as with `num/>byte`. + "Used for the `#b` literal. Only a literal long, double, or char may be converted to a byte, as + long as it is in the numeric range of a byte, as with `num/>byte`. Using e.g. `#b 1` outside of a typed context results in a runtime call to `RT.readString(\"#=(java.lang.Byte. \\\"1\\\")\")` which is undesirable with respect to performance." -#?(:clj ([x char?] (read-byte (unchecked-long x)))) -#?(:clj ([x long?] - (if-not (and (c?/<= x (>max-value byte?)) - (c?/>= x (>min-value byte?))) + ([x (t/or #?(:clj char?) #?(:clj long?) double?)] + (if-not (and (c?/>= x -128) (c?/<= x 127) (unum/integer-value? x)) + (throw (new #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) + "Form input to `#b` is not in the numeric range of a byte" {:form x} nil)) + (#?(:clj Primitive/uncheckedByteCast :cljs unchecked-byte) x)))) + +(t/defn read-short + "Used for the `#s` literal. Only a literal long, double, or char may be converted to a short, as + long as it is in the numeric range of a short, as with `num/>short`. + + Using e.g. `#s 1` outside of a typed context results in a runtime call to + `RT.readString(\"#=(java.lang.Short. \\\"1\\\")\")` which is undesirable with respect to + performance." + ([x (t/or #?(:clj char?) #?(:clj long?) double?)] + (if-not (and (c?/>= x -32768) (c?/<= x 32767) (unum/integer-value? x)) + (throw (new #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) + "Form input to `#s` is not in the numeric range of a short" {:form x} nil)) + (#?(:clj Primitive/uncheckedShortCast :cljs unchecked-short) x)))) + +(t/defn read-char + "Used for the `#c` literal. Only a literal long, double, or char may be converted to a char, as + long as it is in the numeric range of a char, as with `num/>char`. + + Using e.g. `#c 1` outside of a typed context results in a runtime call to + `RT.readString(\"#=(java.lang.Character. \\\"1\\\")\")` which is undesirable with respect to + performance." +#?(:clj ([x char?] x)) + ([x (t/or #?(:clj long?) double?)] + (if-not (and (c?/>= x 0) (c?/<= x 65535) (unum/integer-value? x)) + (throw (new #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) + "Form input to `#c` is not in the numeric range of a char" {:form x} nil)) + (unchecked-char x)))) + +(t/defn read-int + "Used for the `#i` literal. Only a literal long, double, or char may be converted to an int, as + long as it is in the numeric range of a int, as with `num/>int`. + + Using e.g. `#i 1` outside of a typed context results in a runtime call to + `RT.readString(\"#=(java.lang.Integer. \\\"1\\\")\")` which is undesirable with respect to + performance." +#?(:clj ([x char?] (Primitive/uncheckedIntCast x))) + ([x (t/or #?(:clj long?) double?)] + (if-not (and (c?/>= x -2147483648) (c?/<= x 2147483647) (unum/integer-value? x)) (throw (new #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) - "Form input to `#b` is not in the numeric range of a byte" {:form x} nil)) - (unchecked-byte x)))) + "Form input to `#i` is not in the numeric range of a int" {:form x} nil)) + (unchecked-int x)))) + +(t/defn read-long + "Used for the `#l` literal. Only a literal long, double, or char may be converted to a long, as + long as it is in the numeric range of a long, as with `num/>long`." +#?(:clj ([x char?] (Primitive/uncheckedLongCast x))) +#?(:clj ([x long?] x)) ([x double?] - (if-not (and (c?/<= x (>max-value byte?)) - (c?/>= x (>min-value byte?)) + (if-not (and (c?/>= x (>min-safe-integer-value double?)) + (c?/<= x (>max-safe-integer-value double?)) (unum/integer-value? x)) (throw (new #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) - "Form input to `#b` is not in the numeric range of a byte" {:form x} nil)) - (unchecked-byte x)))) - -; c quantum.core.data.primitive/read-char -; s quantum.core.data.primitive/read-short -; i quantum.core.data.primitive/read-int -; l quantum.core.data.primitive/read-long -; f quantum.core.data.primitive/read-float -; d quantum.core.data.primitive/read-double - -(t/and (t/isa? String) (t/unordered (t/value 1))) --> (t/and (t/isa? String) (t/unordered (t/value 1))) -(t/or (t/isa? String) (t/unordered (t/value 1))) --> (t/or (t/isa? String) (t/unordered (t/value 1))) -(t/or tcomp/seqable-except-array? (t/unordered (t/value 1))) --> (t/unordered (t/value 1)) + "Form input to `#l` is not in the numeric range of a long" {:form x} nil)) + (unchecked-long x)))) + +(t/defn read-float + "Used for the `#f` literal. Only a literal long, double, or char may be converted to a float, as + long as it is in the numeric range of a float, as with `num/>float`. + + Using e.g. `#f 1` outside of a typed context results in a runtime call to + `RT.readString(\"#=(java.lang.Float. \\\"1\\\")\")` which is undesirable with respect to + performance." +#?(:clj ([x char?] (Primitive/uncheckedFloatCast x))) + ([x (t/or #?(:clj long?) double?)] + (if-not (and (c?/>= x -3.4028235e+38) (c?/<= x 3.4028235e+38) (unum/integer-value? x)) + (throw (new #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) + "Form input to `#f` is not in the numeric range of a float" {:form x} nil)) + (unchecked-float x)))) + +(t/defn read-double + "Used for the `#d` literal. Only a literal long, double, or char may be converted to a double, as + long as it is in the numeric range of a double, as with `num/>double`." +#?(:clj ([x char?] (Primitive/uncheckedDoubleCast x))) +#?(:clj ([x long?] + (if-not (and (c?/>= x (>min-safe-integer-value double?)) + (c?/<= x (>max-safe-integer-value double?))) + (throw (new #?(:clj clojure.lang.ExceptionInfo :cljs cljs.core/ExceptionInfo) + "Form input to `#d` is not in the numeric range of a double" {:form x} nil)) + (unchecked-double x)))) + ([x double?] x)) From 57d46d3b827554eec23c1bc73463ffcb663e66b6 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 17:52:53 -0700 Subject: [PATCH 727/810] Add `declare` for direct dispatch overloads --- .../quantum/untyped/core/type/defnt.cljc | 41 ++++++++++++------- 1 file changed, 26 insertions(+), 15 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 40f0bb74..8f5191ec 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -251,10 +251,10 @@ (us/def ::reify|name simple-symbol?) ; hinted with the interface name (us/def ::reify - (us/kv {:form t/any? - :interface class? - :name ::reify|name - :overload ::overload})) + (us/kv {:form t/any? + :hinted-name ::reify|name + :interface class? + :overload ::overload})) (us/def ::direct-dispatch-data (us/kv {:overload-types-decl ::overload-types-decl @@ -401,7 +401,10 @@ (2 3) (err! "Body type incompatible with declared output type" err-info)))) (c/defn compare-arg-types [t0 #_t/type?, t1 #_t/type? #_> #_ucomp/comparison?] - (if-let [c0 (uana/sort-guide t0)] + (uset/normalize-comparison (t/compare t0 t1)) + ;; With `sort-guide`, `t/nil?` < `t/boolean?`, `t/boolean?` < `t/val?`, but `t/nil?` <> `t/val?` + ;; so results in a comparator violation + #_(if-let [c0 (uana/sort-guide t0)] (if-let [c1 (uana/sort-guide t1)] (ifs (< c0 c1) -1 (> c0 c1) 1 0) (uset/normalize-comparison (t/compare t0 t1))) @@ -588,10 +591,10 @@ (~(ufth/with-type-hint uana/direct-dispatch-method-sym (ufth/>arglist-embeddable-tag output-class|reify)) ~arglist-code ~body-form)))] - {:form form - :interface interface - :name reify|name - :overload overload}))) + {:form form + :hinted-name reify|name + :interface interface + :overload overload}))) ;; ----- Type declarations ----- ;; @@ -870,7 +873,8 @@ (defns- >direct-dispatch [{:as opts :keys [gen-gensym _, lang _, kind _]} ::opts fn|globals ::fn|globals - fn|types ::fn|types] + fn|types ::fn|types + > ::direct-dispatch] (case lang :clj (let [direct-dispatch-data-seq (->> !overload-queue @@ -879,11 +883,18 @@ {:overload-types-decl (>overload-types-decl opts fn|globals type-decl-datum fn|types) :reify (overload>reify overload opts fn|globals id)}))) - form (->> direct-dispatch-data-seq - (uc/mapcat - (c/fn [{:as direct-dispatch-data :keys [overload-types-decl]}] - [(:form overload-types-decl) - (-> direct-dispatch-data :reify :form)])))] + declare-form-seq + (when-let [hinted-names + (->> direct-dispatch-data-seq + (uc/lmap (fn-> :reify :hinted-name)) + seq)] + [(list* `declare hinted-names)]) + form (concat declare-form-seq + (->> direct-dispatch-data-seq + (uc/mapcat + (c/fn [{:as direct-dispatch-data :keys [overload-types-decl]}] + [(:form overload-types-decl) + (-> direct-dispatch-data :reify :form)]))))] (kw-map form direct-dispatch-data-seq)) :cljs (TODO))) From fb4a1b989c2749aa7294e074156f2cb1504466fd Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 20:22:51 -0700 Subject: [PATCH 728/810] Add todo --- resources-dev/defnt.cljc | 1 + 1 file changed, 1 insertion(+) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 0ef0b11c..187b3bac 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -181,6 +181,7 @@ Legend: protocols can be extended - TODO CLJS needs to implement it better [-] Analysis/Optimization + - maybe redefine `untyped.core.type` in a typed way? `t/def` doesn't realize certain things are `t/type?` - dead code elimination - in `let*`, we should elide variables that are unused and that have no side effects (or at least warn) From 945c34639365aed8f9f27b77c960c55d3ba10783 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 20:23:11 -0700 Subject: [PATCH 729/810] Fix some bugs --- src-untyped/quantum/untyped/core/analyze.cljc | 54 ++++++++++--------- src-untyped/quantum/untyped/core/type.cljc | 37 ++++++------- 2 files changed, 46 insertions(+), 45 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 7d1e7670..8f91f0b6 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -488,11 +488,9 @@ [env ::env, [_ _, target-form _, ?method-or-field _ & ?args _ :as form] _] (let [target (analyze* env target-form) method-or-field (if (symbol? ?method-or-field) ?method-or-field (first ?method-or-field)) - ;; To get around a weird behavior in Clojure, at least in 1.9 - method-or-field (if (and (= target-form 'clojure.lang.RT) - (= method-or-field 'clojure.core/longCast)) - 'longCast - method-or-field) + ;; To get around a weird behavior in `ufeval/macroexpand` in which e.g. `uncheckedLongCast` + ;; becomes `clojure.core/uncheckedLongCast` + method-or-field (-> method-or-field name symbol) args-forms (if (symbol? ?method-or-field) ?args (rest ?method-or-field))] (if (t/= (:type target) t/nil?) (err! "Cannot use the dot operator on a target of nil type." {:form form}) @@ -760,26 +758,32 @@ (uc/map+ #(analyze* env %)) (reducei (fn [{:as ret :keys [dispatch-type]} input|analyzed i] - (if (= :fnt caller-kind) - (let [{:as ret' :keys [dispatchable-overload-types-seq dispatch-type input-nodes]} - (-> (case dispatch-type - :direct (filter-direct-dispatchable-overload-types - ret input|analyzed i caller|node args-form) - :dynamic (filter-dynamic-dispatchable-overload-types - ret input|analyzed i caller|node args-form)) - (update :input-nodes conj input|analyzed))] - (if-let [last-input? (= i (dec inputs-ct))] - (if (= dispatch-type :direct) - (>direct-dispatch env (first dispatchable-overload-types-seq) - caller|node caller|type input-nodes) - (-> ret' - (assoc :form (list* (:form caller|node) (uc/lmap :form input-nodes)) - :type (>dispatch|output-type dispatch-type - dispatchable-overload-types-seq)) - (dissoc :caller|node :dispatch-type - :dispatchable-overload-types-seq))) - ret')) - (update ret :input-nodes conj input|analyzed))) + (let [last-input? (= i (dec inputs-ct))] + (if (= :fnt caller-kind) + (let [{:as ret' + :keys [dispatchable-overload-types-seq dispatch-type input-nodes]} + (-> (case dispatch-type + :direct (filter-direct-dispatchable-overload-types + ret input|analyzed i caller|node args-form) + :dynamic (filter-dynamic-dispatchable-overload-types + ret input|analyzed i caller|node args-form)) + (update :input-nodes conj input|analyzed))] + (if last-input? + (if (= dispatch-type :direct) + (>direct-dispatch env (first dispatchable-overload-types-seq) + caller|node caller|type input-nodes) + (-> ret' + (assoc :form (list* (:form caller|node) + (uc/lmap :form input-nodes)) + :type (>dispatch|output-type dispatch-type + dispatchable-overload-types-seq)) + (dissoc :caller|node :dispatch-type + :dispatchable-overload-types-seq))) + ret')) + (let [{:as ret' :keys [input-nodes]} + (update ret :input-nodes conj input|analyzed)] + (cond-> ret' last-input? + (assoc :form (list* (:form caller|node) (uc/lmap :form input-nodes)))))))) {:input-nodes [] ;; We could do a little smarter analysis here but we'll keep it simple for now :type (when-not (= :fnt caller-kind) t/any?) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index e1a1dbb9..74942d32 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -339,10 +339,10 @@ ;; ===== Type metadata (not for reactive types) ===== ;; -(defns assume +(defn assume "Denotes that, whatever the declared output type (to which `assume` is applied) of a function may be, it is assumed that the output satisfies that type." - [t utr/type? > utr/type?] + [t #_utr/type? #_> #_utr/type?] (assert (c/not (utr/rx-type? t))) (if (utr/meta-type? t) (if (.-assume? ^MetaType t) @@ -353,7 +353,7 @@ (defns assume? [t utr/type? > c/boolean?] (c/and (utr/meta-type? t) (.-assume? ^MetaType t))) -(defns unassume [t utr/type? > utr/type?] +(defn unassume [t #_utr/type? #_> #_utr/type?] (assert (c/not (utr/rx-type? t))) (if (utr/meta-type? t) (if-not (.-assume? ^MetaType t) @@ -362,10 +362,10 @@ false (.-ref? ^MetaType t) (.-runtime? ^MetaType t))) ; un-`t/run`s it t)) -(defns run +(defn run "Denote on a type that it must be enforced at runtime. For use with `defnt`." - [t utr/type? > utr/type?] + [t #_utr/type? #_> #_utr/type?] (assert (c/not (utr/rx-type? t))) (if (utr/meta-type? t) (if (.-runtime? ^MetaType t) @@ -376,10 +376,10 @@ (defns run? [t utr/type? > c/boolean?] (c/and (utr/meta-type? t) (.-runtime? ^MetaType t))) -(defns ref +(defn ref "Denote on a type that it must not be expanded to use primitive values. For use with `defnt`." - [t utr/type? > utr/type?] + [t #_utr/type? #_> #_utr/type?] (assert (c/not (utr/rx-type? t))) (if (utr/meta-type? t) (if (.-ref? ^MetaType t) @@ -388,7 +388,7 @@ (.-assume? ^MetaType t) true (.-runtime? ^MetaType t))) (MetaType. (c/meta t) nil t false true false))) -(defns unref [t utr/type? > utr/type?] +(defn unref [t #_utr/type? #_> #_utr/type?] (assert (c/not (utr/rx-type? t))) (if (utr/meta-type? t) (if-not (.-ref? ^MetaType t) @@ -636,13 +636,12 @@ (f t args)))) (defn- input-type|meta-or|norx [t match-spec #_::match-spec] - (let [i|? (->> match-spec (reducei (c/fn [_ t i] (when (find-spec? t) (reduced i))) nil))] - (with-expand-meta-ors match-spec - (fn [match-spec'] - (->> match-spec' - (match-spec>type-data-seq t) - (uc/map (c/fn [{:keys [input-types]}] (get input-types i|?))) - meta-or))))) + (let [i|? (->> match-spec (reducei (c/fn [_ t i] (when (find-spec? t) (reduced i))) nil)) + type-args + (->> match-spec + (match-spec>type-data-seq t) + (uc/map (c/fn [{:keys [input-types]}] (get input-types i|?))))] + (with-expand-meta-ors type-args meta-or))) (defns input-type|meta-or [t (us/or* utr/fn-type? utr/rx-type?), match-spec _ #_::match-spec @@ -674,11 +673,9 @@ `reduce` when the third input satisfies `string?`." ([t & args] (err! "Can't use `input-type` outside of arglist contexts"))) -(defn- output-type|meta-or|norx [t args] - (with-expand-meta-ors args - (fn->> (match-spec>type-data-seq t) - (uc/map :output-type) - meta-or))) +(defn- output-type|meta-or|norx [t match-spec] + (let [type-args (->> match-spec (match-spec>type-data-seq t) (uc/map :output-type))] + (with-expand-meta-ors type-args meta-or))) (defns output-type|meta-or [t (us/or* utr/fn-type? utr/rx-type?) args (us/seq-of (us/or* #{:_} type?)) > type?] From b54161f0a64291308bc6d5c08c3d1676b70379d7 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 20:23:32 -0700 Subject: [PATCH 730/810] Some cleanups --- src/quantum/core/data/numeric.cljc | 36 +++++++------- src/quantum/core/data/primitive.cljc | 4 +- src/quantum/core/numeric/operators.cljc | 4 +- src/quantum/core/numeric/strict_args.cljc | 57 ----------------------- 4 files changed, 22 insertions(+), 79 deletions(-) delete mode 100644 src/quantum/core/numeric/strict_args.cljc diff --git a/src/quantum/core/data/numeric.cljc b/src/quantum/core/data/numeric.cljc index 95343c09..baf55ee2 100644 --- a/src/quantum/core/data/numeric.cljc +++ b/src/quantum/core/data/numeric.cljc @@ -41,13 +41,13 @@ ;; Incorporated `clojure.core/int?` ;; Incorporated `cljs.core/int?` -(var/def fixint? "The set of all fixed-precision (though not necessarily primitive) integers." +(t/def fixint? "The set of all fixed-precision (though not necessarily primitive) integers." (t/or #?@(:clj [p/byte? p/short?]) p/int? p/long?)) -#?(:clj (def java-bigint? (t/isa? java.math.BigInteger))) -#?(:clj (def clj-bigint? (t/isa? clojure.lang.BigInt))) +#?(:clj (t/def java-bigint? (t/isa? java.math.BigInteger))) +#?(:clj (t/def clj-bigint? (t/isa? clojure.lang.BigInt))) -(var/def bigint? "The set of all 'big' (arbitrary-precision) integers." +(t/def bigint? "The set of all 'big' (arbitrary-precision) integers." #?(:clj ;; TODO bring in a better implementation per the ns docstring? (t/or clj-bigint? java-bigint?) ;; TODO bring in implementation per the ns docstring @@ -56,7 +56,7 @@ ;; Incorporated `clojure.lang.Util/isInteger` ;; Incorporated `clojure.core/integer?` ;; Incorporated `cljs.core/integer?` -(def integer? (t/or fixint? bigint?)) +(t/def integer? (t/or fixint? bigint?)) ;; ----- Decimals ----- ;; @@ -73,45 +73,45 @@ ;; Incorporated `clojure.core/float?` ;; Incorporated `cljs.core/float?` -(var/def fixdec? "The set of all fixed-precision decimals." +(t/def fixdec? "The set of all fixed-precision decimals." (t/or #?(:clj p/float?) p/double?)) ;; Incorporated `clojure.core/decimal?` -(var/def bigdec? "The set of all 'big' (arbitrary-precision) decimals." +(t/def bigdec? "The set of all 'big' (arbitrary-precision) decimals." #?(:clj ;; TODO bring in a better implementation per the ns docstring? (t/isa? BigDecimal) ;; TODO bring in implementation per the ns docstring :cljs t/none?)) -(def decimal? (t/or fixdec? bigdec?)) +(t/def decimal? (t/or fixdec? bigdec?)) ;; ----- Precision ----- ;; -(var/def fixnum? "The set of all fixed-precision numbers." +(t/def fixnum? "The set of all fixed-precision numbers." (t/or fixint? fixdec?)) -(var/def fixed-numeric? +(t/def fixed-numeric? "The set of all fixed-precision numeric things. Something 'numeric' is something that may be treated as a number but may not actually *be* one." (t/or fixnum? p/char?)) -(var/def bignum? "The set of all 'big' (arbitrary-precision) numbers." +(t/def bignum? "The set of all 'big' (arbitrary-precision) numbers." (t/or fixint? fixdec?)) ;; ----- Ratios ----- ;; -(def ratio? #?(:clj (t/isa? clojure.lang.Ratio) - ;; TODO bring in implementation per the ns docstring - :cljs t/none?)) +(t/def ratio? #?(:clj (t/isa? clojure.lang.Ratio) + ;; TODO bring in implementation per the ns docstring + :cljs t/none?)) ;; ----- General ----- ;; -(def exact? (t/or integer? ratio?)) +(t/def exact? (t/or integer? ratio?)) -(def number? (t/or #?@(:clj [(t/isa? java.lang.Number)] - :cljs [integer? decimal? ratio?]))) +(t/def number? (t/or #?@(:clj [(t/isa? java.lang.Number)] + :cljs [integer? decimal? ratio?]))) -(var/def numeric? +(t/def numeric? "Something 'numeric' is something that may be treated as a number but may not actually *be* one." (t/or number? #?(:clj p/char?))) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index a22e421c..35c6b41a 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -184,7 +184,7 @@ ([x (t/or int? (t/value int?)) > int?] (>min-value x)) ([x (t/or long? (t/value long?)) > long?] (>min-value x)) ;; [2 ^ ( + 1)] - 1 - ([x (t/or float? (t/value float?)) > float?] (float -16777216.0))]) + ([x (t/or float? (t/value float?)) > float?] (unchecked-float -16777216.0))]) ([x (t/or double? (t/value double?)) > double?] -9007199254740991.0)) (t/defn ^:inline >max-safe-integer-value @@ -194,7 +194,7 @@ ([x (t/or int? (t/value int?)) > int?] (>max-value x)) ([x (t/or long? (t/value long?)) > long?] (>max-value x)) ;; [2 ^ ( + 1)] - 1 - ([x (t/or float? (t/value float?)) > float?] (float 16777216.0))]) + ([x (t/or float? (t/value float?)) > float?] (unchecked-float 16777216.0))]) ([x (t/or double? (t/value double?)) > double?] 9007199254740991.0)) ;; ===== Primitive type properties ===== ;; diff --git a/src/quantum/core/numeric/operators.cljc b/src/quantum/core/numeric/operators.cljc index 1038a889..35fa28f9 100644 --- a/src/quantum/core/numeric/operators.cljc +++ b/src/quantum/core/numeric/operators.cljc @@ -25,7 +25,7 @@ ;; TODO TYPED excise reference [quantum.untyped.core.form :refer [#?(:clj core-symbol)]] - [quantum.untyped.core.log :as log]) + [quantum.untyped.core.log :as ulog]) #?(:cljs (:require-macros [quantum.core.numeric.operators :as self :refer [+ - *]])) @@ -34,7 +34,7 @@ [quantum.core Numeric] [java.math BigInteger BigDecimal]))) -(log/this-ns) +(ulog/this-ns) ;; ===== (Up-to-)binary operators ===== ;; diff --git a/src/quantum/core/numeric/strict_args.cljc b/src/quantum/core/numeric/strict_args.cljc deleted file mode 100644 index b3024491..00000000 --- a/src/quantum/core/numeric/strict_args.cljc +++ /dev/null @@ -1,57 +0,0 @@ -(ns - quantum.core.numeric.strict-args - "Useful numeric functions. Floor, ceil, round, sin, abs, neg, etc. - All vars in this namespace are strict-arg vars (i.e., are guaranteed - not to rely on protocol dispatch.)" - {:attribution "alexandergunnarson"} - (:refer-clojure :exclude - [* *' + +' - -' / < > <= >= == rem inc dec zero? neg? pos? pos-int? - min max quot mod format - #?@(:clj [bigint biginteger bigdec numerator denominator inc' dec'])]) - (:require - [clojure.core :as c] - [quantum.core.data.numeric :as dn] - [quantum.core.vars :as var - :refer [defalias defaliases]] - [quantum.core.numeric.convert ] - [quantum.core.numeric.misc ] - [quantum.core.numeric.operators :as op] - [quantum.core.numeric.predicates] - [quantum.core.numeric.trig ] - [quantum.core.numeric.truncate :as trunc]) -#?(:cljs - (:require-macros - [quantum.core.numeric.strict-args :as self])) -#?(:clj - (:import - [java.nio ByteBuffer] - [quantum.core Numeric] ; loops? - [net.jafama FastMath] - clojure.lang.BigInt - java.math.BigDecimal))) -;_____________________________________________________________________ -;==================={ OPERATORS }====================== -;°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°°° -#?(:clj (defalias +* op/+*&)) -#?(:clj (defalias +' op/+'&)) -#?(:clj (defalias + op/+& )) - -#?(:clj (defalias -* op/-*&)) -#?(:clj (defalias -' op/-'&)) -#?(:clj (defalias - op/-& )) - -#?(:clj (defalias ** op/**&)) -#?(:clj (defalias *' op/*'&)) -#?(:clj (defalias * op/*& )) - -#?(:clj (defalias div* op/div*&)) -#?(:clj (defalias div' op/div'&)) -#?(:clj (defalias / op/div& )) - -#_(defaliases quantum.core.numeric.operators - #?@(:clj [;inc*$ #_inc' inc$ - ;dec*$ #_dec' dec$ - ; abs'$ abs$ - ]) - ;inc'$ dec'$ - ) From 5fe1fd5fba58ab5c4fffee97e1fe1dfcdc4746dc Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 21:56:28 -0700 Subject: [PATCH 731/810] `t/def-` --- .../quantum/untyped/core/type/defnt.cljc | 23 ++++++-- src/quantum/core/data/primitive.cljc | 56 +++++++++---------- src/quantum/core/type.cljc | 2 +- 3 files changed, 46 insertions(+), 35 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 8f5191ec..7a3f537e 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -77,15 +77,16 @@ - Performs type analysis. - For values that satisfy `t/type?`, calls `utr/with-name` on them with the provided `sym`." ([sym] (list 'def sym)) - ([sym v] `(quantum.untyped.core.type.defnt/def ~sym nil nil ~v)) + ([sym v] (list 'quantum.untyped.core.type.defnt/def sym nil nil v)) ([sym doc-or-meta v] (if (string? doc-or-meta) - `(quantum.untyped.core.type.defnt/def ~sym ~doc-or-meta nil ~v) - `(quantum.untyped.core.type.defnt/def ~sym nil ~doc-or-meta ~v))) - ([sym doc-val meta-val v] + (list 'quantum.untyped.core.type.defnt/def sym doc-or-meta nil v) + (list 'quantum.untyped.core.type.defnt/def sym nil doc-or-meta v))) + ([sym doc meta-val v] (list 'def - (if (or doc-val meta-val) - (with-meta sym (-> meta-val (cond-> doc-val (assoc :doc doc-val)) uana/analyze :form)) + (if (or doc meta-val) + (update-meta sym merge + (-> meta-val (cond-> doc (assoc :doc doc)) uana/analyze :form)) sym) (let [node (uana/analyze v)] (if (and (-> node :type utr/value-type?) @@ -93,6 +94,16 @@ `(utr/with-name ~(:form node) '~(uid/qualify *ns* sym)) (:form node))))))) +#?(:clj +(defmacro def- + "Like `t/def`, but creates a private var." + ([sym] (list 'def (update-meta sym merge {:private true}))) + ([sym v] (list 'quantum.untyped.core.type.defnt/def (update-meta sym merge {:private true}) v)) + ([sym doc-or-meta v] (list 'quantum.untyped.core.type.defnt/def + (update-meta sym merge {:private true}) doc-or-meta v)) + ([sym doc meta-val v] (list 'quantum.untyped.core.type.defnt/def + (update-meta sym merge {:private true}) doc meta-val v)))) + ;; TODO move (def index? #(and (integer? %) (>= % 0))) (def count? index?) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 35c6b41a..1155e826 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -20,63 +20,63 @@ [quantum.core Numeric Primitive]))) ;; TODO for CLJS nil/val, we need to check via `js/==` not `js/===` -(def nil? ut/nil?) -(def val? ut/val?) +(t/def nil? ut/nil?) +(t/def val? ut/val?) ;; ===== Predicates ===== ;; -#?(:clj (def boolean? (t/isa? #?(:clj Boolean :cljs js/Boolean)))) +#?(:clj (t/def boolean? (t/isa? #?(:clj Boolean :cljs js/Boolean)))) -#?(:clj (def byte? (t/isa? Byte))) +#?(:clj (t/def byte? (t/isa? Byte))) -#?(:clj (def short? (t/isa? Short))) +#?(:clj (t/def short? (t/isa? Short))) -#?(:clj (def char? (t/isa? Character))) +#?(:clj (t/def char? (t/isa? Character))) - (var/def int? + (t/def int? "For CLJS, `int?` is not primitive even though it mimics the boxed version of the Java `int` primitive. It is included in this namespace merely for cohesion." (t/isa? #?(:clj Integer :cljs goog.math.Integer))) - (var/def long? + (t/def long? "For CLJS, `long?` is not primitive even though it mimics the boxed version of the Java `long` primitive. It is included in this namespace merely for cohesion." (t/isa? #?(:clj Long :cljs goog.math.Long))) -#?(:clj (def float? (t/isa? Float))) +#?(:clj (t/def float? (t/isa? Float))) - (def double? (t/isa? #?(:clj Double :cljs js/Number))) + (t/def double? (t/isa? #?(:clj Double :cljs js/Number))) - (var/def primitive? + (t/def primitive? "For CLJS, `int?` and `long?` are not primitive even though they mimic Java primitives. For CLJS, does not include built-in platform types like js/String that are considered 'primitive' in some contexts." (t/or boolean? #?@(:clj [byte? short? char? int? long? float?]) double?)) - (def primitive-type? + (t/def primitive-type? (t/or (t/value boolean?) #?@(:clj [(t/value byte?) (t/value short?) (t/value char?) (t/value int?) (t/value long?) (t/value float?)]) (t/value double?))) - (var/def integer? "Specifically primitive integers." + (t/def integer? "Specifically primitive integers." (t/or #?@(:clj [byte? short? int? long?]))) - (var/def decimal? "Specifically primitive decimals." + (t/def decimal? "Specifically primitive decimals." (t/or #?(:clj float?) double?)) - (var/def numeric? + (t/def numeric? "Specifically primitive numeric things. Something 'numeric' is something that may be treated as a number but may not actually *be* one." (t/- primitive? boolean?)) - (def numeric-type? (t/- primitive-type? (t/value boolean?))) + (t/def numeric-type? (t/- primitive-type? (t/value boolean?))) (defaliases ut true? false?) ;; ===== Boxing/unboxing ===== ;; #?(:clj -(def unboxed-class->boxed-class +(t/def unboxed-class->boxed-class {Boolean/TYPE Boolean Byte/TYPE Byte Character/TYPE Character @@ -87,7 +87,7 @@ Float/TYPE Float})) #?(:clj -(def boxed-class->unboxed-class +(t/def boxed-class->unboxed-class {Integer Integer/TYPE Long Long/TYPE Float Float/TYPE @@ -133,14 +133,14 @@ ;; ===== Bit lengths ===== ;; -(var/def boolean-bits "Implementationally might not be bit-manipulable but logically 1 bit" 1) -(def byte-bits 8) -(def short-bits 16) -(def char-bits 16) -(def int-bits 32) -(def long-bits 64) -(def float-bits 32) -(def double-bits 64) +(t/def boolean-bits "Implementationally might not be bit-manipulable but logically 1 bit" 1) +(t/def byte-bits 8) +(t/def short-bits 16) +(t/def char-bits 16) +(t/def int-bits 32) +(t/def long-bits 64) +(t/def float-bits 32) +(t/def double-bits 64) ;; ===== Extreme magnitudes and values ===== ;; @@ -155,8 +155,8 @@ #?(:clj Double/MIN_VALUE :cljs js/Number.MIN_VALUE))) ;; TODO TYPED these are probably getting boxed -#?(:clj (var/def- min-float (Numeric/negate Float/MAX_VALUE))) - (var/def- min-double (- #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) +#?(:clj (t/def- min-float (Numeric/negate Float/MAX_VALUE))) + (t/def- min-double (- #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) (t/defn ^:inline >min-value #?(:clj ([x (t/or byte? (t/value byte?)) > byte?] Byte/MIN_VALUE)) diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index a1175536..11803fef 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -14,7 +14,7 @@ (defalias def udefnt/def) -(defaliases udefnt dotyped fn defn extend-defn!) +(defaliases udefnt def- dotyped fn defn extend-defn!) (defaliases ut type type? From c2c43a33de161404242afe2f7a439b892acf76c0 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 21:56:41 -0700 Subject: [PATCH 732/810] Compare `t/ftype`s with each other --- src-untyped/quantum/untyped/core/type.cljc | 74 +++++++------------ .../quantum/untyped/core/type/compare.cljc | 63 +++++++++++++++- .../untyped/core/type/reifications.cljc | 20 +++-- 3 files changed, 99 insertions(+), 58 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 74942d32..5df2d25a 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -96,7 +96,7 @@ ;; ===== Comparison ===== ;; -(uvar/defaliases utcomp compare < <= = not= >= > >< <>) +(uvar/defaliases utcomp compare < <= = not= >= > >< <> compare|in compare|out) ;; ===== Type Reification Constructors ===== ;; @@ -127,7 +127,7 @@ (defns- separate-rx-and-apply "Only works for commutative functions." - [f c/fn?, type-args (fn-> count (c/> 1)) > utr/type?] + [f c/fn?, type-args c/sequential? > utr/type?] ;; For efficiency, so as much as possible gets run outside a reaction (if-let [rx-args (->> type-args (filter utr/rx-type?) seq)] (if-let [norx-args (->> type-args (remove utr/rx-type?) seq)] @@ -478,13 +478,13 @@ (educe (c/fn ([accum] accum) ([accum [t* c*]] - #_(prl! kind conj-s? prefer-orig-args? t' types t* c*) (case kind :or (create-logical-type|inner|or accum t* c*) :and (create-logical-type|inner|and accum t* c*)))) - {:conj-t? ;; If `t` is a `NotType`, and kind is `:and`, then it will be - ;; applied by being `-` from all args, not by being `conj`ed - (c/not (c/and (c/= kind :and) (utr/not-type? t))) + {:conj-t? ;; If `t` is a `NotType`, and kind is `:and`, then it will + ;; be applied by being `-` from all args, not by being + ;; `conj`ed + (c/not (c/and (c/= kind :and) (utr/not-type? t))) :prefer-orig-args? false :t' t :types []}))] @@ -555,40 +555,21 @@ (uc/map+ (c/fn [arity-form] (-> (us/conform ::fn-type|arity arity-form) (update :output-type #(c/or % output-type universal-set))))) - (uc/group-by #(-> % :input-types count)))] - (FnType. nil nil ?fn-name output-type arities-form arities))) - -(defns compare|in [x0 utr/fn-type?, x1 utr/fn-type? > uset/comparison?] - (let [ct->overloads|x0 (utr/fn-type>arities x0) - ct->overloads|x1 (utr/fn-type>arities x1) - cts-only-in-x0 (uset/- (-> ct->overloads|x0 keys set) (-> ct->overloads|x1 keys set)) - cts-only-in-x1 (uset/- (-> ct->overloads|x1 keys set) (-> ct->overloads|x0 keys set)) - comparison|cts (uset/compare cts-only-in-x0 cts-only-in-x1) - cts-in-both (->> ct->overloads|x0 (filter (fn-> first ct->overloads|x1))) - overloads->ored-input-types - ;; Yes, there must be a more performant way to do this - (c/fn [overloads] (->> overloads (uc/lmap :input-types) (apply uc/lmap or)))] - (utcomp/combine-comparisons - comparison|cts - (->> cts-in-both - (map (c/fn [[ct overloads|x0]] - (if (zero? ct) - 0 - (utcomp/combine-comparisons - (uc/lmap utcomp/compare - (->> overloads|x0 overloads->ored-input-types) - (->> ct ct->overloads|x1 overloads->ored-input-types)))))) - utcomp/combine-comparisons)))) - -(defns fn-type>output-type [x utr/fn-type? > type?] - (->> x utr/fn-type>arities - vals - (apply concat) - (uc/lmap :output-type) - (apply or))) - -(defns compare|out [x0 utr/fn-type?, x1 utr/fn-type? > uset/comparison?] - (utcomp/compare (fn-type>output-type x0) (fn-type>output-type x1))) + (uc/group-by #(-> % :input-types count))) + ored-input-types + (->> arities + (uc/map-vals' + (c/fn [overloads] + (->> overloads (uc/lmap :input-types) (apply uc/lmap or)))) + delay) + ored-output-type + (->> arities + vals + (apply concat) + (uc/lmap :output-type) + (apply or) + delay)] + (FnType. nil nil ?fn-name output-type arities-form arities ored-input-types ored-output-type))) (us/def ::match-spec (us/seq-of (us/or* #{:_ :?} type? @@ -738,12 +719,12 @@ meta-or))) (defns- meta-or|norx - > utr/type? - [types (us/seq-of utr/type?)] + [types (us/seq-of utr/type?) > utr/type?] (let [types' (->> types uc/distinct (sort-by identity utcomp/compare) (uc/dedupe-by utcomp/=))] - (ifs (empty? types') empty-set - (-> types' count (c/= 1)) (first types') - (MetaOrType. uhash/default uhash/default nil nil types')))) + (case (bounded-count 2 types') + 0 empty-set + 1 (first types') + (MetaOrType. uhash/default uhash/default nil nil types')))) (defns meta-or "Essentially a combinatorial combinator: @@ -757,8 +738,7 @@ - Dedupes inputs that are either structurally `=` or `t/=`. - Does not currently handle nested `meta-or`s." > utr/type? - [types (us/seq-of utr/type?)] - (separate-rx-and-apply meta-or|norx types)) + [types (us/seq-of utr/type?)] (separate-rx-and-apply meta-or|norx types)) ;; TODO figure out the best place to put this #?(:clj diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index 9879d030..1d433f01 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -142,6 +142,7 @@ (def- compare|universal+expr compare|todo) (def- compare|universal+protocol fn>) (def- compare|universal+class fn>) +(def- compare|universal+fn fn>) (def- compare|universal+unordered fn>) (def- compare|universal+ordered fn>) (def- compare|universal+value fn>) @@ -155,6 +156,7 @@ (def- compare|empty+expr compare|todo) (def- compare|empty+protocol fn<>) (def- compare|empty+class fn<>) +(def- compare|empty+fn fn<>) (def- compare|empty+unordered fn<>) (def- compare|empty+ordered fn<>) (def- compare|empty+value fn<>) @@ -209,6 +211,9 @@ ;; ----- OrType ----- ;; +;; TODO performance can be improved here by doing fewer comparisons +;; Possibly look at `quantum.untyped.core.type.defnt/compare-args-types` for reference? +;; Expected to handle possibly non-distinct types within `ts0` and `ts1` (defns- compare|or+or-like [ts0 _, ts1 _, ts1 fn? > comparison?] (let [l (->> ts0 (seq-and ident > comparison?] (compare|or+or-like (.-args t0) (.-args t1) (fn1 < t0) (fn1 < t1) (fn1 <> t1))) @@ -406,7 +409,8 @@ #?(:clj (ClassType. uhash/default uhash/default nil nil java.util.Map))] (atom nil))) -(defns- compare|class+finite [t0 class-type?, t1 utr/ordered-type? > comparison?] +(defns- compare|class+finite + [t0 class-type?, t1 _ #_(t/or unordered-type? ordered-type?) > comparison?] ;; TODO technically we need to have it satisfy `dc/reducible?`, not merely `c/seqable?` ;; — see also note in UnorderedType's implementation about this (case (int (compare t0 seqable-except-array?)) @@ -439,6 +443,33 @@ (def- compare|class+meta compare|non-meta+meta) +;; ----- FnType ----- ;; + +(defns compare|in [t0 utr/fn-type?, t1 utr/fn-type? > uset/comparison?] + (let [ct->overloads|t0 (utr/fn-type>arities t0) + ct->overloads|t1 (utr/fn-type>arities t1) + cts-only-in-t0 (uset/- (-> ct->overloads|t0 keys set) (-> ct->overloads|t1 keys set)) + cts-only-in-t1 (uset/- (-> ct->overloads|t1 keys set) (-> ct->overloads|t0 keys set)) + comparison|cts (uset/compare cts-only-in-t0 cts-only-in-t1) + cts-in-both (->> ct->overloads|t0 keys (filter ct->overloads|t1))] + (combine-comparisons + comparison|cts + (->> cts-in-both + (map (c/fn [ct] + (if (zero? ct) + 0 + (combine-comparisons + (uc/lmap compare + (-> t0 utr/fn-type>ored-input-types (get ct)) + (-> t1 utr/fn-type>ored-input-types (get ct))))))) + combine-comparisons)))) + +(defns compare|out [t0 utr/fn-type?, t1 utr/fn-type? > uset/comparison?] + (compare (utr/fn-type>ored-output-type t0) (utr/fn-type>ored-output-type t1))) + +(defns- compare|fn+fn [t0 utr/fn-type?, t1 utr/fn-type? > comparison?] + (combine-comparisons (compare|in t0 t1) (compare|out t0 t1))) + ;; ----- UnorderedType ----- ;; (def- compare|unordered+value (inverted compare|value+type)) @@ -489,6 +520,7 @@ Expression compare|universal+expr ProtocolType compare|universal+protocol ClassType compare|universal+class + FnType compare|universal+fn UnorderedType compare|universal+unordered OrderedType compare|universal+ordered ValueType compare|universal+value @@ -502,6 +534,7 @@ Expression compare|empty+expr ProtocolType compare|empty+protocol ClassType compare|empty+class + FnType compare|empty+fn UnorderedType compare|empty+unordered OrderedType compare|empty+ordered ValueType compare|empty+value @@ -515,6 +548,7 @@ Expression fn>< ; TODO not entirely true ProtocolType compare|not+protocol ClassType compare|not+class + FnType compare|todo UnorderedType compare|not+unordered OrderedType compare|not+ordered ValueType compare|not+value @@ -528,6 +562,7 @@ Expression fn>< ; TODO not entirely true ProtocolType compare|todo ClassType compare|or+class + FnType compare|todo UnorderedType compare|or+unordered OrderedType compare|or+ordered ValueType compare|or+value @@ -541,6 +576,7 @@ Expression fn>< ; TODO not entirely true ProtocolType compare|todo ClassType compare|and+class + FnType compare|todo UnorderedType compare|and+unordered OrderedType compare|and+ordered ValueType compare|and+value @@ -555,6 +591,7 @@ Expression compare|expr+expr ProtocolType fn>< ; TODO not entirely true ClassType fn>< ; TODO not entirely true + FnType compare|todo UnorderedType fn>< ; TODO not entirely true OrderedType fn>< ; TODO not entirely true ValueType compare|expr+value @@ -568,6 +605,7 @@ Expression fn>< ; TODO not entirely true ProtocolType compare|protocol+protocol ClassType compare|protocol+class + FnType compare|todo UnorderedType compare|todo OrderedType compare|todo ValueType compare|protocol+value @@ -581,10 +619,25 @@ Expression fn>< ; TODO not entirely true ProtocolType (inverted compare|protocol+class) ClassType compare|class+class + FnType compare|todo UnorderedType compare|class+unordered OrderedType compare|class+ordered ValueType compare|class+value MetaType compare|class+meta} + FnType + {UniversalSetType (inverted compare|universal+fn) + EmptySetType (inverted compare|empty+fn) + NotType compare|todo + OrType compare|todo + AndType compare|todo + Expression compare|todo + ProtocolType compare|todo + ClassType compare|todo + FnType compare|fn+fn + UnorderedType compare|todo + OrderedType compare|todo + ValueType compare|todo + MetaType compare|todo} UnorderedType {UniversalSetType (inverted compare|universal+unordered) EmptySetType (inverted compare|empty+unordered) @@ -594,6 +647,7 @@ Expression compare|todo ProtocolType compare|todo ClassType (inverted compare|class+unordered) + FnType compare|todo UnorderedType compare|todo OrderedType compare|todo ValueType compare|unordered+value @@ -607,6 +661,7 @@ Expression compare|todo ProtocolType compare|todo ClassType (inverted compare|class+ordered) + FnType compare|todo UnorderedType compare|todo OrderedType compare|todo ValueType compare|ordered+value @@ -620,6 +675,7 @@ Expression (inverted compare|expr+value) ProtocolType (inverted compare|protocol+value) ClassType (inverted compare|class+value) + FnType compare|todo UnorderedType (inverted compare|unordered+value) OrderedType (inverted compare|ordered+value) ValueType compare|value+value @@ -633,6 +689,7 @@ Expression (inverted compare|expr+meta) ProtocolType (inverted compare|protocol+meta) ClassType (inverted compare|class+meta) + FnType compare|todo UnorderedType (inverted compare|unordered+meta) OrderedType (inverted compare|ordered+meta) ValueType (inverted compare|value+meta) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 8fad2c96..5a9a3309 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -447,14 +447,18 @@ output-type #_t/type? arities-form arities #_(s/map-of nneg-int? (s/seq-of (s/kv {:input-types (s/vec-of type?) - :output-type type?})))] + :output-type type?}))) + ored-input-types #_(s/delay-of (s/map-of nneg-int? (s/seq-of type?))) + ored-output-type #_(s/delay-of type?)] {PType {with-name ([this name'] - (FnType. meta name' fn-name output-type arities-form arities))} + (FnType. meta name' fn-name output-type arities-form arities + ored-input-types ored-output-type))} ;; Outputs whether the args match any input spec ?Fn {invoke ([this args] (TODO))} ?Meta {meta ([this] meta) with-meta ([this meta'] - (FnType. meta' name fn-name output-type arities-form arities))} + (FnType. meta' name fn-name output-type arities-form arities + ored-input-types ored-output-type))} uform/PGenForm {>form ([this] (or name (list 'new 'quantum.untyped.core.type.reifications.FnType (>form meta) name fn-name (>form output-type) @@ -470,11 +474,11 @@ (defns fn-type? [x _ > boolean?] (instance? FnType x)) -(defns fn-type>fn-name [^FnType x fn-type?] (.-fn-name x)) - -(defns fn-type>arities [^FnType x fn-type?] (.-arities x)) - -(defns fn-type>output-type [^FnType x fn-type?] (.-output-type x)) +(defns fn-type>fn-name [^FnType x fn-type?] (.-fn-name x)) +(defns fn-type>arities [^FnType x fn-type?] (.-arities x)) +(defns fn-type>output-type [^FnType x fn-type?] (.-output-type x)) +(defns fn-type>ored-input-types [^FnType x fn-type?] (force (.-ored-input-types x))) +(defns fn-type>ored-output-type [^FnType x fn-type?] (force (.-ored-output-type x))) (us/def :quantum.untyped.core.type/fn-type|arity (us/and From 5fc27ef88520490fc14652a316f040953bb51d4b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 22:13:57 -0700 Subject: [PATCH 733/810] Fix comparison between ftypes --- src-untyped/quantum/untyped/core/type.cljc | 30 +++++++++++-------- .../untyped/core/type/reifications.cljc | 13 +++++--- src/quantum/core/type.cljc | 4 +-- 3 files changed, 28 insertions(+), 19 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 5df2d25a..71764fe6 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -541,6 +541,21 @@ ;; ===== `t/ftype` ===== ;; +(defn arities>ored-input-types [arities] + (->> arities + (uc/map-vals' + (c/fn [overloads] + (->> overloads (uc/lmap :input-types) (apply uc/lmap or)))) + delay)) + +(defn arities>ored-output-types [arities] + (->> arities + vals + (apply concat) + (uc/lmap :output-type) + (apply or) + delay)) + (defn ftype [& args] (let [?fn-name (when (-> args first c/symbol?) (first args)) @@ -556,19 +571,8 @@ (-> (us/conform ::fn-type|arity arity-form) (update :output-type #(c/or % output-type universal-set))))) (uc/group-by #(-> % :input-types count))) - ored-input-types - (->> arities - (uc/map-vals' - (c/fn [overloads] - (->> overloads (uc/lmap :input-types) (apply uc/lmap or)))) - delay) - ored-output-type - (->> arities - vals - (apply concat) - (uc/lmap :output-type) - (apply or) - delay)] + ored-input-types (arities>ored-input-types arities) + ored-output-type (arities>ored-output-types arities)] (FnType. nil nil ?fn-name output-type arities-form arities ored-input-types ored-output-type))) (us/def ::match-spec diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 5a9a3309..5c458554 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -459,10 +459,15 @@ with-meta ([this meta'] (FnType. meta' name fn-name output-type arities-form arities ored-input-types ored-output-type))} - uform/PGenForm {>form ([this] (or name - (list 'new 'quantum.untyped.core.type.reifications.FnType - (>form meta) name fn-name (>form output-type) - (>form arities-form) (>form arities))))} + uform/PGenForm {>form + ([this] + (or name + `(let* [arities# ~(>form arities)] + (new quantum.untyped.core.type.reifications.FnType + ~(>form meta) ~name ~fn-name ~(>form output-type) + ~(>form arities-form) arities + (quantum.untyped.core.type/arities>ored-input-types arities#) + (quantum.untyped.core.type/arities>ored-output-types arities#)))))} fedn/IOverride nil fedn/IEdn {-edn ([this] (if fn-name (-> (list* 'quantum.untyped.core.type/ftype fn-name diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index 11803fef..d138ad26 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -1,7 +1,7 @@ (ns quantum.core.type "This is this the namespace upon which all other fully-typed namespaces rest." (:refer-clojure :exclude - [- < <= = >= > and any? defn fn fn? isa? not or ref seq? symbol? type var?]) + [- < <= = >= > and any? compare defn fn fn? isa? not or ref seq? symbol? type var?]) (:require [quantum.untyped.core.type.defnt :as udefnt] [quantum.untyped.core.type :as ut] @@ -36,7 +36,7 @@ none? ref? fn? - < <= = >= > <> ><) + compare compare|in compare|out < <= = >= > <> ><) ;; TODO TYPED move From 8dbe2325d19ef987f7d9e5a7727da2621440b9d3 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 22:15:22 -0700 Subject: [PATCH 734/810] Fix compilation --- src-untyped/quantum/untyped/core/type/compare.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index 1d433f01..ca5cc320 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -62,7 +62,7 @@ (ucore/log-this-ns) -(declare compare < <= = not= >= > >< <>) +(declare compare < <= = not= >= > >< <> combine-comparisons) (def inverted (fn [f] (fn [t0 t1] (uset/invert-comparison (f t1 t0))))) From 53519fedf28f1cea8962ac7b77065a40878985fb Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 17 Nov 2018 23:02:31 -0700 Subject: [PATCH 735/810] Fix occasional type error --- src-untyped/quantum/untyped/core/compare.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/compare.cljc b/src-untyped/quantum/untyped/core/compare.cljc index b7d69a8b..9e2ab7ae 100644 --- a/src-untyped/quantum/untyped/core/compare.cljc +++ b/src-untyped/quantum/untyped/core/compare.cljc @@ -100,7 +100,7 @@ [compf xs] (if (< (int (bounded-count 3 xs)) 3) (throw (ex-info "`xs` must have at least 3 items")) - (let [^objects xs' (into-array xs) ct (count xs')] + (let [^objects xs' (to-array xs) ct (count xs')] (doseq [i0 (range 0 ct)] (doseq [i1 (range 1 ct)] (doseq [i2 (range 2 ct)] From af4c63b2f4043316a3f1079153b261f154eb48ef Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 18 Nov 2018 16:27:28 -0700 Subject: [PATCH 736/810] Add `group-deep-by-into`, `shuffle!`, `sort|insertion!` --- .../quantum/untyped/core/collections.cljc | 146 +++++++++++++++--- 1 file changed, 126 insertions(+), 20 deletions(-) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index 0df06ddb..77ba6365 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -1,14 +1,14 @@ (ns quantum.untyped.core.collections "Operations on collections." (:refer-clojure :exclude - [#?(:cljs array?) assoc-in cat conj! contains? count distinct distinct? drop first get - group-by filter flatten frequencies last map map-indexed mapcat partition-all pmap remove - reverse run! take zipmap]) + [#?(:cljs array?) assoc-in cat conj! contains? count dedupe distinct distinct? drop first + get group-by filter flatten frequencies key last map map-indexed mapcat partition-all pmap + remove reverse run! take val zipmap]) (:require - [clojure.core :as core] - [fast-zip.core :as zip] -#?(:cljs [goog.array :as garray]) - [quantum.untyped.core.core :as ucore + [clojure.core :as core] + [fast-zip.core :as zip] +#?(:cljs [goog.array :as garray]) + [quantum.untyped.core.core :as ucore :refer [sentinel]] [quantum.untyped.core.data :refer [transient?]] @@ -16,15 +16,17 @@ :refer [val?]] [quantum.untyped.core.data.array :refer [array?]] - [quantum.untyped.core.error :as uerr + [quantum.untyped.core.data.map :as umap] + [quantum.untyped.core.data.vector :as uvec] + [quantum.untyped.core.error :as uerr :refer [err!]] - [quantum.untyped.core.fn :as ufn - :refer [ntha fn' aritoid]] + [quantum.untyped.core.fn :as ufn + :refer [<- ntha fn' aritoid]] [quantum.untyped.core.logic #?(:clj :refer :cljs :refer-macros) [ifs condf1 fn-not]] ; no idea why this is required currently :/ [quantum.untyped.core.loops :refer [reduce-2]] - [quantum.untyped.core.reducers :as ur + [quantum.untyped.core.reducers :as ur :refer [defeager def-transducer>eager transducer->transformer educe]])) (ucore/log-this-ns) @@ -55,6 +57,18 @@ (defn reverse [xs] (if (reversible? xs) (rseq xs) (core/reverse xs))) +(defn key [x] + #?(:clj (if (instance? java.util.Map$Entry x) + (.getKey ^java.util.Map$Entry x) + (first x)) + :cljs (first x))) + +(defn val [x] + #?(:clj (if (instance? java.util.Map$Entry x) + (.getValue ^java.util.Map$Entry x) + (second x)) + :cljs (second x))) + ;; ===== SOCIATIVE ===== ;; (defn get @@ -265,6 +279,7 @@ (defeager remove-vals remove-vals+ 1) (defn keys+ [xs] (->> xs (map+ key))) +(defn vals+ [xs] (->> xs (map+ val))) (defn indexed+ [xs] (map-indexed+ vector xs)) (defn lindexed [xs] (lmap-indexed vector xs)) @@ -363,14 +378,71 @@ coll)] frequencies-f)) -(defn group-by - "Like `group-by` but uses `educe` internally" - [f xs] - (educe (aritoid (fn' (transient {})) persistent! - (fn [ret x] - (let [k (f x)] - (assoc! ret k (conj (get ret k []) x))))) - xs)) +(def group-by|rf (aritoid (fn [] (transient {})) persistent! nil assoc!)) +(def group-by|sub-rf (aritoid vector nil conj)) + +(def group-by|!rf + (aritoid umap/>!hash-map identity nil + #?(:clj (fn [^java.util.HashMap ret k v] (doto ret (.put k v))) :cljs assoc!))) + +(def group-by|!sub-rf uvec/alist-conj!) + +(defn group-by-into + "Like `group-by`, but uses `educe` internally, and you can choose what collection and + subcollection to group into." + ([kf rf xs] (group-by-into kf rf group-by|sub-rf xs)) + ([kf rf sub-rf xs] + (educe + (aritoid rf rf + (fn [ret x] + (let [k (kf x), v (get ret k sentinel)] + (rf ret k (sub-rf (if (identical? v sentinel) (sub-rf) v) x))))) + xs))) + +(defn group-by [kf xs] (group-by-into kf group-by|rf xs)) + +(defn group-into + ([rf xs] (group-by-into identity rf group-by|rf xs)) + ([rf sub-rf xs] (group-by-into identity rf sub-rf xs))) + +(defn group [xs] (group-by-into identity group-by|rf xs)) + +(defn- group-deep-by-into* [i n kf rf sub-rf xs] + (if (>= i n) + xs + (->> xs + (group-by-into (fn [x] (kf i x)) group-by|!rf group-by|!sub-rf) + (map-vals+ (fn [sub-xs] (group-deep-by-into* (inc i) n kf rf sub-rf sub-xs))) + (educe (aritoid rf rf (fn [ret [k v]] (rf ret k v))))))) + +(defn group-deep-by-into + "Like `group-by-into` but: + - Expects a reducible of reducibles + - Performs up to N groupings, defaulting to the max size of the inner reducibles + - `kf` takes two inputs: `depth` and `x`. + + E.g. `(group-deep-by (fn [i x] (get x i)) [[1 4] [3 2] [1 2] [3 2 5]])` + -> `{1 {2 {nil [[1 2]]} + 4 {nil [[1 4]]}} + 3 {2 {nil [[3 2]] + 5 [[3 2 5]]}}}`" + ([ kf rf xs] (group-deep-by-into kf rf group-by|sub-rf xs)) + ([ kf rf sub-rf xs] + (group-deep-by-into (->> xs (map+ count) (educe max 0)) kf rf sub-rf xs)) + ([n #_(> 0) kf rf sub-rf xs] (group-deep-by-into* 0 n kf rf sub-rf xs))) + +(defn group-deep-by + ([ kf xs] (group-deep-by-into kf group-by|rf group-by|sub-rf xs)) + ([n kf xs] (group-deep-by-into n kf group-by|rf group-by|sub-rf xs))) + +(defn group-deep-into + ([ rf xs] (group-deep-by-into (fn [i x] x) rf group-by|sub-rf xs)) + ([ rf sub-rf xs] (group-deep-by-into (fn [i x] x) rf sub-rf xs)) + ([n rf sub-rf xs] (group-deep-by-into n (fn [i x] x) rf sub-rf xs))) + +(defn group-deep + ([ xs] (group-deep-by-into (fn [i x] x) group-by|rf group-by|sub-rf xs)) + ([n xs] (group-deep-by-into n (fn [i x] x) group-by|rf group-by|sub-rf xs))) (defn lcat [xs] (apply concat xs)) @@ -459,7 +531,7 @@ (defn >combinatoric-tree "See tests for examples. - Assumes all are sorted and of the same count." + Assumes all are sorted, grouped, and of the same count." {:todo #{"Generalize to handle uneven input lengths and unsorted combination"}} ([n #_pos-int?, xs #_(t/of (t/tuple (t/spec t/any? "identifier") (t/of)))] (>combinatoric-tree @@ -485,6 +557,40 @@ x*]))) xs))))) +(defn aswap! + [#?(:clj ^"[Ljava.lang.Object;" !xs :cljs !xs) + #?(:clj ^long i :cljs ^number i) + #?(:clj ^long j :cljs ^number j)] + (let [tmp (aget !xs i)] + (doto !xs (aset i (aget !xs j)) + (aset j tmp)))) + +(defn shuffle! + "Uses the Fisher–Yates shuffle as enhanced by Durstenfeld." + [#?(:clj ^"[Ljava.lang.Object;" !xs :cljs !xs)] + (let [r #?(:clj (java.util.concurrent.ThreadLocalRandom/current) :cljs nil)] + (loop [i (-> !xs alength unchecked-dec)] + (if (> i 0) + (do (aswap! !xs i (#?@(:clj [.nextInt r] :cljs rand-int) (unchecked-inc i))) + (recur (unchecked-dec i))) + !xs)))) + +(defn sort|insertion! + {:adapted-from "https://en.wikipedia.org/wiki/Insertion_sort"} + ([#?(:clj ^"[Ljava.lang.Object;" !xs :cljs !xs)] (sort|insertion! compare !xs)) + ([compf #?(:clj ^"[Ljava.lang.Object;" !xs :cljs !xs)] + (let [ct (alength !xs)] + (loop [i 1] + (if (< i ct) + (let [x (aget !xs i)] + (loop [j (unchecked-dec i)] + (if (and (>= j 0) (pos? (int (compf (aget !xs j) x)))) + (do (aset !xs (unchecked-inc j) (aget !xs j)) + (recur (unchecked-dec j))) + (aset !xs (unchecked-inc j) x))) + (recur (unchecked-inc i))) + !xs))))) + (defn sort! "Like `sort` but coerces `xs` to an array and then sorts it in place, returning the coerced array instead of a seq on top of it. If `xs` is already an array, modifies `xs`." From 465fadb5d8a986f79de28933f2b64ea962599418 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 18 Nov 2018 16:27:38 -0700 Subject: [PATCH 737/810] `check-comparator` overhaul --- src-untyped/quantum/untyped/core/compare.cljc | 42 +++++++++---------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/src-untyped/quantum/untyped/core/compare.cljc b/src-untyped/quantum/untyped/core/compare.cljc index 9e2ab7ae..fbf311fb 100644 --- a/src-untyped/quantum/untyped/core/compare.cljc +++ b/src-untyped/quantum/untyped/core/compare.cljc @@ -91,9 +91,11 @@ ([xs] (comp-max-of compare xs)) ([compf xs] (->> xs (reduce (gen-comp-max|rf compf))))) -(defn check-comparator-transitivity +(defn check-comparator "To ensure the comparator maintains its contract and that `IllegalArgumentException Comparison - method violates its general contract!` is not thrown." + method violates its general contract!` is not thrown. + + Checks symmetry, reflexivity and transitivity." {:complexity "O(n^3) time" :adapted-from "http://code.nomad-labs.com/2015/06/02/finding-the-error-in-your-comparators-compare-method-aka-comparison-method-violates-its-general-contract/"} @@ -102,22 +104,20 @@ (throw (ex-info "`xs` must have at least 3 items")) (let [^objects xs' (to-array xs) ct (count xs')] (doseq [i0 (range 0 ct)] - (doseq [i1 (range 1 ct)] - (doseq [i2 (range 2 ct)] - (when (and (not= i0 i1) (not= i0 i2) (not= i1 i2)) - (let [x0 (aget xs' i0) - x1 (aget xs' i1) - x2 (aget xs' i2) - x0+x1 (int (compf x0 x1)) - x0+x2 (int (compf x0 x2)) - x1+x2 (int (compf x1 x2))] - (when (and (< x0+x1 0) (< x1+x2 0) (not (< x0+x2 0))) - (println "x0 comp< x1, x1 comp< x2, but x0 not comp< x2") - (println "x0:" x0) - (println "x1:" x1) - (println "x2:" x2)) - (when (and (> x0+x1 0) (> x1+x2 0) (not (> x0+x2 0))) - (println "x0 comp> x1, x1 comp> x2, but x0 not comp< x2") - (println "x0:" x0) - (println "x1:" x1) - (println "x2:" x2)))))))))) + (doseq [i1 (range 0 ct)] + (doseq [i2 (range 0 ct)] + (let [x0 (aget xs' i0) + x1 (aget xs' i1) + x2 (aget xs' i2) + x0+x1 (int (compf x0 x1)) + x0+x2 (int (compf x0 x2)) + x1+x2 (int (compf x1 x2))] + (when (and (neg? x0+x1) (neg? x1+x2) (not (neg? x0+x2))) + (throw (ex-info "x0 comp< x1, x1 comp< x2, but x0 not comp< x2" + {:x0 x0 :x1 x1 :x2 x2}))) + (when (and (zero? x0+x1) (zero? x1+x2) (not (zero? x0+x2))) + (throw (ex-info "x0 comp= x1, x1 comp= x2, but x0 not comp= x2" + {:x0 x0 :x1 x1 :x2 x2}))) + (when (and (pos? x0+x1) (pos? x1+x2) (not (pos? x0+x2))) + (throw (ex-info "x0 comp> x1, x1 comp> x2, but x0 not comp> x2" + {:x0 x0 :x1 x1 :x2 x2})))))))))) From 3993ef1f222f264307b327ae47538943ee5bdadb Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 18 Nov 2018 16:27:50 -0700 Subject: [PATCH 738/810] Fix critical hashing issue --- src-untyped/quantum/untyped/core/data/hash.cljc | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/hash.cljc b/src-untyped/quantum/untyped/core/data/hash.cljc index a2cce0f6..07aa1345 100644 --- a/src-untyped/quantum/untyped/core/data/hash.cljc +++ b/src-untyped/quantum/untyped/core/data/hash.cljc @@ -14,8 +14,8 @@ #?(:clj (clojure.lang.Util/hash x) :cljs (hash x))) -(def unordered hash-ordered-coll) -(def ordered hash-unordered-coll) +(def unordered hash-unordered-coll) +(def ordered hash-ordered-coll) (def mix mix-collection-hash) #?(:clj @@ -32,7 +32,7 @@ See also https://clojure.org/reference/data_structures." [field #_simple-symbol? & args] - `(if (identical? ~field default) + `(if (identical? ~field (unchecked-int default)) (set! ~field (unordered-args ~@args)) ~field))) @@ -52,7 +52,7 @@ See also https://clojure.org/reference/data_structures." [field #_simple-symbol? & args] - `(if (identical? ~field default) + `(if (identical? ~field (unchecked-int default)) (set! ~field (ordered-args ~@args)) ~field))) @@ -66,6 +66,6 @@ "Tries to retrive a cached hash-code value at the provided field. If not found, sets the field with a computed hash-code using the sum of the hash-codes of the provided args." [field #_simple-symbol? & args] - `(if (identical? ~field default) + `(if (identical? ~field (unchecked-int default)) (set! ~field (code-args ~@args)) ~field))) From 5428c76cc4cbc6ce1c273119a7431ecc67f7c18b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 18 Nov 2018 16:44:47 -0700 Subject: [PATCH 739/810] `sort-by|insertion!` --- src-untyped/quantum/untyped/core/collections.cljc | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index 77ba6365..2a8e8c73 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -591,10 +591,14 @@ (recur (unchecked-inc i))) !xs))))) +(defn sort-by|insertion! + ([kf !xs] (sort-by|insertion! kf compare !xs)) + ([kf compf !xs] (sort|insertion! (fn [a b] (compf (kf a) (kf b))) !xs))) + (defn sort! "Like `sort` but coerces `xs` to an array and then sorts it in place, returning the coerced array instead of a seq on top of it. If `xs` is already an array, modifies `xs`." - ([xs] (sort! compare xs)) + ([xs] (sort! compare !xs)) ([compf xs] (let [#?(:clj ^objects !xs :cljs !xs) (if (array? xs) xs (to-array xs))] (doto !xs #?(:clj (java.util.Arrays/sort ^Comparator compf) From e7fb8dce74dac87bd5a2a90ec296682ea8dad987 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 18 Nov 2018 16:45:05 -0700 Subject: [PATCH 740/810] Move CLJS `MutableHashMap` to untyped --- .../quantum/untyped/core/data/map.cljc | 127 ++++++++++++++++++ src/quantum/core/data/map.cljc | 117 +--------------- 2 files changed, 129 insertions(+), 115 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/map.cljc b/src-untyped/quantum/untyped/core/data/map.cljc index d73ac657..ddd43c0b 100644 --- a/src-untyped/quantum/untyped/core/data/map.cljc +++ b/src-untyped/quantum/untyped/core/data/map.cljc @@ -30,6 +30,119 @@ ;; ----- Hash maps ----- ;; +;; TODO TYPED — use `deftypet` and also typed internals +#?(:cljs +(deftype MutableHashMap ; There can be no `undefined` values + [meta ^:mutable ct ^js/Map m #_"Keys are int hashes; vals are map entries from k to v" + ^:mutable ^boolean has-nil? ^:mutable nil-val ^:mutable __hash] + Object + (toString [this] (str (into {} (es6-iterator-seq (.values m))))) + (equiv [this other] (-equiv this other)) + (keys [this] (es6-iterator (cljs.core/keys this))) + (entries [this] (es6-entries-iterator (seq this))) + (values [this] (es6-iterator (vals this))) + (has [this k] (contains? this k)) + (get [this k not-found] (-lookup this k not-found)) + (forEach [this f] (doseq [[k v] this] (f v k))) + ICloneable + (-clone [_] (MutableHashMap. meta ct m has-nil? nil-val __hash)) + IIterable + (-iterator [this] (-iterator (vals this))) + IWithMeta + (-with-meta [this meta-] (MutableHashMap. meta- ct m has-nil? nil-val __hash)) + IMeta + (-meta [this] meta) + IEmptyableCollection + (-empty [this] (MutableHashMap. meta 0 (js/Map.) false nil 0)) + IEquiv + (-equiv [this that] (equiv-map this that)) + IHash + (-hash [this] (caching-hash this hash-unordered-coll __hash)) + ISeqable + (-seq [this] + (when (pos? ct) + (let [s (es6-iterator-seq (.values m))] + (if has-nil? + (cons (>map-entry nil nil-val) s) + s)))) + ICounted + (-count [this] ct) + ILookup + (-lookup [this k] (-lookup this k nil)) + (-lookup [this k not-found] + (if (nil? k) + (if has-nil? nil-val not-found) + (let [kv (.get m (hash k))] + (if (undefined? kv) not-found (-val kv))))) + IAssociative + (-contains-key? [this k] + (if (nil? k) + has-nil? + (.has m (hash k)))) + IFind + (-find [this k] + (if (nil? k) + (when has-nil? (>map-entry nil nil-val)) + (let [kv (.get m (hash k))] + (if (undefined? kv) nil kv)))) + ITransientCollection + (-conj! [this entry] + (if (vector? entry) + (-assoc! this (-nth entry 0) (-nth entry 1)) + (loop [ret this es (seq entry)] + (if (nil? es) + ret + (let [e (first es)] + (if (vector? e) + (recur (-assoc! ret (-nth e 0) (-nth e 1)) + (next es)) + (throw (ex-info "conj on a map takes map entries or seqables of map entries" {})))))))) + ITransientAssociative + (-assoc! [this k v] + (cond + (undefined? v) + (throw (ex-info "Cannot `assoc` undefined value to `MutableHashMap`" {})) + (nil? k) + (if (and has-nil? (identical? v nil-val)) + this + (do (when-not has-nil? (set! ct (inc ct))) + (set! has-nil? true) + (set! nil-val v) + (set! __hash nil) ; TODO recalculate incrementally? + this)) + :else + (let [hash-k (hash k)] + (if (.has m hash-k) + this + (do (.set m (hash k) (map-entry k v)) + (set! ct (inc ct)) + (set! __hash nil) ; TODO recalculate incrementally? + this))))) + ITransientMap + (-dissoc! [this k] + (if (nil? k) + (if has-nil? + (do (set! ct (dec ct)) + (set! has-nil? false) + (set! nil-val nil) + (set! __hash nil) ; TODO recalculate incrementally? + this) + this) + (if (.delete m (hash k)) + (do (set! ct (dec ct)) + (set! __hash nil) ; TODO recalculate incrementally? + this) + this))) + IKVReduce + (-kv-reduce [this f init] + (let [init (if has-nil? (f init nil nil-val) init)] + (if (reduced? init) + @init + (unreduced (reduce (fn [ret kv] (f ret (-key kv) (-val kv))) init m))))) + IFn + (-invoke [this k] (-lookup this k)) + (-invoke [this k not-found] (-lookup this k not-found)))) + #?(:clj (def hash-map? (partial instance? clojure.lang.PersistentHashMap))) (defalias hash-map core/hash-map) @@ -37,6 +150,12 @@ #?(:clj (defalias hash-map|long->ref imap/int-map)) #?(:clj (defalias int-map hash-map|long->ref)) +(defn >!hash-map + "Creates a single-threaded, mutable hash map. + On the JVM, this is a `java.util.HashMap`. + On JS, this is a `quantum.untyped.core.data.map.HashMap`." + ([] #?(:clj (HashMap.) :cljs (MutableHashMap. nil 0 (js/Map.) false nil nil)))) + ;; ===== Ordered value-semantic maps ===== ;; ;; ---- Insertion-ordered ----- ;; @@ -68,6 +187,14 @@ (defalias avl/split-key) (defalias avl/split-at) +(defn >!sorted-map-by + "Creates a single-threaded, mutable sorted map with the specified comparator. + On the JVM, this is a `java.util.TreeMap`. + On JS, this is a `goog.structs.AvlTree`." + ([compf] #?(:clj (TreeMap. ^java.util.Comparator compf) :cljs (AvlTree. compf)))) + +(defn >!sorted-map [] (>!sorted-map-by compare)) + ;; ===== Interval Tree / Map ===== ;; ;; TODO this is just a placeholder until we can use `com.dean.clojure-interval-tree` diff --git a/src/quantum/core/data/map.cljc b/src/quantum/core/data/map.cljc index bf06f906..37a2cde0 100644 --- a/src/quantum/core/data/map.cljc +++ b/src/quantum/core/data/map.cljc @@ -362,119 +362,6 @@ ;; ----- Hash maps ----- ;; -;; TODO TYPED — use `deftypet` and also typed internals -#?(:cljs -(deftype MutableHashMap ; There can be no `undefined` values - [meta ^:mutable ct ^js/Map m #_"Keys are int hashes; vals are map entries from k to v" - ^:mutable ^boolean has-nil? ^:mutable nil-val ^:mutable __hash] - Object - (toString [this] (str (into {} (es6-iterator-seq (.values m))))) - (equiv [this other] (-equiv this other)) - (keys [this] (es6-iterator (cljs.core/keys this))) - (entries [this] (es6-entries-iterator (seq this))) - (values [this] (es6-iterator (vals this))) - (has [this k] (contains? this k)) - (get [this k not-found] (-lookup this k not-found)) - (forEach [this f] (doseq [[k v] this] (f v k))) - ICloneable - (-clone [_] (MutableHashMap. meta ct m has-nil? nil-val __hash)) - IIterable - (-iterator [this] (-iterator (vals this))) - IWithMeta - (-with-meta [this meta-] (MutableHashMap. meta- ct m has-nil? nil-val __hash)) - IMeta - (-meta [this] meta) - IEmptyableCollection - (-empty [this] (MutableHashMap. meta 0 (js/Map.) false nil 0)) - IEquiv - (-equiv [this that] (equiv-map this that)) - IHash - (-hash [this] (caching-hash this hash-unordered-coll __hash)) - ISeqable - (-seq [this] - (when (pos? ct) - (let [s (es6-iterator-seq (.values m))] - (if has-nil? - (cons (>map-entry nil nil-val) s) - s)))) - ICounted - (-count [this] ct) - ILookup - (-lookup [this k] (-lookup this k nil)) - (-lookup [this k not-found] - (if (nil? k) - (if has-nil? nil-val not-found) - (let [kv (.get m (hash k))] - (if (undefined? kv) not-found (-val kv))))) - IAssociative - (-contains-key? [this k] - (if (nil? k) - has-nil? - (.has m (hash k)))) - IFind - (-find [this k] - (if (nil? k) - (when has-nil? (>map-entry nil nil-val)) - (let [kv (.get m (hash k))] - (if (undefined? kv) nil kv)))) - ITransientCollection - (-conj! [this entry] - (if (vector? entry) - (-assoc! this (-nth entry 0) (-nth entry 1)) - (loop [ret this es (seq entry)] - (if (nil? es) - ret - (let [e (first es)] - (if (vector? e) - (recur (-assoc! ret (-nth e 0) (-nth e 1)) - (next es)) - (throw (ex-info "conj on a map takes map entries or seqables of map entries" {})))))))) - ITransientAssociative - (-assoc! [this k v] - (cond - (undefined? v) - (throw (ex-info "Cannot `assoc` undefined value to `MutableHashMap`" {})) - (nil? k) - (if (and has-nil? (identical? v nil-val)) - this - (do (when-not has-nil? (set! ct (inc ct))) - (set! has-nil? true) - (set! nil-val v) - (set! __hash nil) ; TODO recalculate incrementally? - this)) - :else - (let [hash-k (hash k)] - (if (.has m hash-k) - this - (do (.set m (hash k) (map-entry k v)) - (set! ct (inc ct)) - (set! __hash nil) ; TODO recalculate incrementally? - this))))) - ITransientMap - (-dissoc! [this k] - (if (nil? k) - (if has-nil? - (do (set! ct (dec ct)) - (set! has-nil? false) - (set! nil-val nil) - (set! __hash nil) ; TODO recalculate incrementally? - this) - this) - (if (.delete m (hash k)) - (do (set! ct (dec ct)) - (set! __hash nil) ; TODO recalculate incrementally? - this) - this))) - IKVReduce - (-kv-reduce [this f init] - (let [init (if has-nil? (f init nil nil-val) init)] - (if (reduced? init) - @init - (unreduced (reduce (fn [ret kv] (f ret (-key kv) (-val kv))) init m))))) - IFn - (-invoke [this k] (-lookup this k)) - (-invoke [this k not-found] (-lookup this k not-found)))) - (def +hash-map? (t/isa? #?(:clj clojure.lang.PersistentHashMap :cljs cljs.core/PersistentHashMap))) @@ -802,7 +689,7 @@ #_(t/isa? java.util.IdentityHashMap) (t/isa? it.unimi.dsi.fastutil.objects.Reference2ReferenceOpenHashMap) (t/isa? it.unimi.dsi.fastutil.objects.Reference2ReferenceOpenCustomHashMap)] - :cljs [MutableHashMap]))) + :cljs [umap/MutableHashMap]))) (def-preds|map|any !hash-map) @@ -819,7 +706,7 @@ On the JVM, this is a `java.util.HashMap`. On JS, this is a `quantum.untyped.core.data.map.HashMap`." > !hash-map? - ([] #?(:clj (HashMap.) :cljs (MutableHashMap. nil 0 (js/Map.) false nil nil))) + ([] #?(:clj (HashMap.) :cljs (umap/MutableHashMap. nil 0 (js/Map.) false nil nil))) ([k0 t/ref?, v0 t/ref?] (doto #?(:clj (HashMap.) :cljs (>!hash-map)) (#?(:clj .put :cljs assoc!) k0 v0))) From 776b9ee91d2ce4f47d3ab95cf6c509ce3996f60d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 18 Nov 2018 16:45:53 -0700 Subject: [PATCH 741/810] Add arity to `alist-conj!` --- src-untyped/quantum/untyped/core/data/vector.cljc | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/vector.cljc b/src-untyped/quantum/untyped/core/data/vector.cljc index ea7de09e..dfced3e6 100644 --- a/src-untyped/quantum/untyped/core/data/vector.cljc +++ b/src-untyped/quantum/untyped/core/data/vector.cljc @@ -11,8 +11,15 @@ :cljs [ xs ^number i v]) (#?(:clj .set :cljs aset) xs i v)) -(defn alist-conj! [#?(:clj ^ArrayList xs :cljs xs) v] - (doto xs (#?(:clj .add :cljs .push) v))) +(defn #?(:clj ^ArrayList alist :cljs alist) + ([] #?(:clj (ArrayList.) :cljs #js [])) + ([x] #?(:clj (doto (ArrayList.) (.add x)) :cljs #js [x]))) + +(defn alist-conj! + ([] (alist)) + ([#?(:clj ^ArrayList xs :cljs xs)] xs) + ([#?(:clj ^ArrayList xs :cljs xs) v] + (doto xs (#?(:clj .add :cljs .push) v)))) (defn #?(:clj alist-count :cljs ^number alist-count) [#?(:clj ^ArrayList xs :cljs xs)] (#?(:clj .size :cljs alength) xs)) @@ -33,7 +40,3 @@ (if (identical? (alist-get x i) (alist-get y i)) (recur (inc i)) false)))))) - -(defn #?(:clj ^ArrayList alist :cljs alist) - ([] #?(:clj (ArrayList.) :cljs #js [])) - ([x] #?(:clj (doto (ArrayList.) (.add x)) :cljs #js [x]))) From 246719da3498bb09d45ee4ca0aa0777bd454cdf5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 18 Nov 2018 16:46:35 -0700 Subject: [PATCH 742/810] Add `test|group-deep-by-into` --- test/quantum/test/untyped/core/collections.cljc | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/test/quantum/test/untyped/core/collections.cljc b/test/quantum/test/untyped/core/collections.cljc index f72a0edf..f7e19034 100644 --- a/test/quantum/test/untyped/core/collections.cljc +++ b/test/quantum/test/untyped/core/collections.cljc @@ -20,6 +20,15 @@ (def conj|!vec (aritoid (fn [] (transient [])) persistent! conj!)) +(deftest test|group-deep-by-into + (is= (self/group-deep-by (fn [i x] (get x i)) [[1 4] [3 2] [1 2]]) + {1 {2 [[1 2]], 4 [[1 4]]}, 3 {2 [[3 2]]}}) + (is= (self/group-deep-by (fn [i x] (get x i)) [[1 4] [3 2] [1 2] [3 2 5]]) + {1 {4 {nil [[1 4]]} + 2 {nil [[1 2]]}} + 3 {2 {nil [[3 2]] + 5 [[3 2 5]]}}})) + (deftest test|>combinatoric-tree (let [in '[[0 [a b a]] [1 [a b c]] From 622a6f16b5f652f3e1a713a19a41435875fe7b10 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 18 Nov 2018 16:46:48 -0700 Subject: [PATCH 743/810] Fix overload types sorting --- .../quantum/untyped/core/type/defnt.cljc | 206 ++++++++++-------- 1 file changed, 116 insertions(+), 90 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 7a3f537e..d24c683a 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -1,67 +1,68 @@ (ns quantum.untyped.core.type.defnt - (:refer-clojure :exclude - [defn fn]) - (:require - [clojure.core :as c] - [clojure.string :as str] - [fipp.ednize :as fedn] - ;; TODO excise this reference - [quantum.core.type.core :as tcore] - ;; TODO excise this reference - [quantum.core.type.defs :as tdef] - [quantum.untyped.core.analyze :as uana] - [quantum.untyped.core.analyze.ast :as uast] - [quantum.untyped.core.core - :refer [istr sentinel]] ; TODO use quantum.untyped.core.string/istr instead - [quantum.untyped.core.defnt - :refer [defns defns- fns]] - [quantum.untyped.core.collections :as uc - :refer [>set >vec]] - [quantum.untyped.core.collections.logic - :refer [seq-or]] - [quantum.untyped.core.compare :as ucomp - :refer [not==]] - [quantum.untyped.core.data - :refer [kw-map]] - [quantum.untyped.core.data.array :as uarr - :refer [*<>]] - [quantum.untyped.core.data.map :as umap] - [quantum.untyped.core.data.reactive :as urx - :refer [?norx-deref norx-deref]] - [quantum.untyped.core.data.set :as uset] - [quantum.untyped.core.data.vector :as uvec - :refer [alist-conj!]] - [quantum.untyped.core.error :as uerr - :refer [TODO err!]] - [quantum.untyped.core.fn - :refer [<- aritoid fn1 fn-> with-do with-do-let]] - [quantum.untyped.core.form :as uform - :refer [>form]] - [quantum.untyped.core.form.evaluate :as ufeval] - [quantum.untyped.core.form.generate :as ufgen] - [quantum.untyped.core.form.type-hint :as ufth] - [quantum.untyped.core.identifiers :as uid - :refer [>name >?namespace >symbol]] - [quantum.untyped.core.log :as ulog] - [quantum.untyped.core.logic :as ul - :refer [fn-or fn= if-not-let ifs ifs-let]] - [quantum.untyped.core.loops - :refer [reduce-2]] - [quantum.untyped.core.reducers :as ur - :refer [educe educei reducei]] - [quantum.untyped.core.refs :as uref - :refer [?deref]] - [quantum.untyped.core.spec :as us] - [quantum.untyped.core.specs :as uss] - [quantum.untyped.core.type :as t - :refer [?]] - [quantum.untyped.core.type.compare :as utcomp] - [quantum.untyped.core.type.reifications :as utr] - [quantum.untyped.core.vars :as uvar - :refer [update-meta]]) - (:import - [quantum.core Numeric] - [quantum.core.data Array])) + (:refer-clojure :exclude + [defn fn]) + (:require + [clojure.core :as c] + [clojure.string :as str] + [fipp.ednize :as fedn] + ;; TODO excise this reference + [quantum.core.type.core :as tcore] + ;; TODO excise this reference + [quantum.core.type.defs :as tdef] + [quantum.untyped.core.analyze :as uana] + [quantum.untyped.core.analyze.ast :as uast] + [quantum.untyped.core.core + :refer [istr sentinel]] ; TODO use quantum.untyped.core.string/istr instead + [quantum.untyped.core.defnt + :refer [defns defns- fns]] + [quantum.untyped.core.collections :as uc + :refer [>set >vec]] + [quantum.untyped.core.collections.logic + :refer [seq-or]] + [quantum.untyped.core.compare :as ucomp + :refer [not==]] + [quantum.untyped.core.data + :refer [kw-map]] + [quantum.untyped.core.data.array :as uarr + :refer [*<>]] + [quantum.untyped.core.data.map :as umap] + [quantum.untyped.core.data.reactive :as urx + :refer [?norx-deref norx-deref]] + [quantum.untyped.core.data.set :as uset] + [quantum.untyped.core.data.vector :as uvec + :refer [alist-conj!]] + [quantum.untyped.core.error :as uerr + :refer [TODO err!]] + [quantum.untyped.core.fn + :refer [<- aritoid fn' fn1 fn-> with-do with-do-let]] + [quantum.untyped.core.form :as uform + :refer [>form]] + [quantum.untyped.core.form.evaluate :as ufeval] + [quantum.untyped.core.form.generate :as ufgen] + [quantum.untyped.core.form.type-hint :as ufth] + [quantum.untyped.core.identifiers :as uid + :refer [>name >?namespace >symbol]] + [quantum.untyped.core.log :as ulog] + [quantum.untyped.core.logic :as ul + :refer [fn-or fn= if-not-let ifs ifs-let]] + [quantum.untyped.core.loops + :refer [reduce-2]] + [quantum.untyped.core.reducers :as ur + :refer [educe educei reducei]] + [quantum.untyped.core.refs :as uref + :refer [?deref]] + [quantum.untyped.core.spec :as us] + [quantum.untyped.core.specs :as uss] + [quantum.untyped.core.type :as t + :refer [?]] + [quantum.untyped.core.type.compare :as utcomp] + [quantum.untyped.core.type.reifications :as utr] + [quantum.untyped.core.vars :as uvar + :refer [update-meta]]) +#?(:clj (:import + [java.util ArrayList HashMap TreeMap] + [quantum.core Numeric] + [quantum.core.data Array]))) ;; TODO move #?(:clj @@ -412,14 +413,7 @@ (2 3) (err! "Body type incompatible with declared output type" err-info)))) (c/defn compare-arg-types [t0 #_t/type?, t1 #_t/type? #_> #_ucomp/comparison?] - (uset/normalize-comparison (t/compare t0 t1)) - ;; With `sort-guide`, `t/nil?` < `t/boolean?`, `t/boolean?` < `t/val?`, but `t/nil?` <> `t/val?` - ;; so results in a comparator violation - #_(if-let [c0 (uana/sort-guide t0)] - (if-let [c1 (uana/sort-guide t1)] - (ifs (< c0 c1) -1 (> c0 c1) 1 0) - (uset/normalize-comparison (t/compare t0 t1))) - (uset/normalize-comparison (t/compare t0 t1)))) + (uset/normalize-comparison (t/compare t0 t1))) (c/defn compare-args-types [arg-types0 #_(us/vec-of t/type?) arg-types1 #_(us/vec-of t/type?)] (let [ct-comparison (compare (count arg-types0) (count arg-types1))] @@ -432,31 +426,63 @@ arg-types0 arg-types1) ct-comparison))) +(c/defn- >comparator-respecting-arglist-counts [compf #_fn?, i #_index? #_> #_fn?] + (c/fn [a b] + (let [ct|a (count a) + ct|b (count b) + ct-comparison (compare ct|a ct|b)] + (if (zero? ct-comparison) + (if (< i ct|a) + (compf (get a i) (get b i)) + 0) + ct-comparison)))) + +(defonce thing (atom nil)) + (c/defn sort-overload-types "A naïve implementation would do an aggregate compare on the arg-types vectors, but the resulting - comparator would not be transitive due to the behavior of `<>` and `><`. For example, for the - below arg-types vectors, x0 comp< x1, x1 comp< x2, but x0 not comp< x2: + comparator would not be transitive due to the behavior of `<>` and `><`, and the arg-types + vectors would not be sorted in a 'multilevel' (by first input type, then second, etc.) way. For + example, for the below arg-types vectors, x0 comp< x1, x1 comp< x2, but x0 not comp< x2: - x0: [t/boolean? t/nil?] - x1: [(t/ref (t/isa? Comparable)) t/byte?] - x2: [t/nil? t/val?] Because of this, we are forced to do as many sorts as the max arity of the typed fn, which results in an O(m•n•log(n))) algorithm, where `m` is the max arity and `n` is the number of - overloads." + overloads. + + The comparator used here is transitive for `t/<` and `t/>` comparisons but not for `t/=`: + - x0: t/char? <> t/nil? + - x1: t/nil? <> (t/ref (t/isa? Comparable)) + - x2: t/char? < (t/ref (t/isa? Comparable)) + + Given this fact, we have to avoid `java.util.TimSort` and use a sorting implementation tolerant + to non-transitive comparators." [kf overload-types] - (let [!overload-types (to-array overload-types) - max-arity (->> !overload-types (uc/map+ count) (educe (aritoid (c/fn [] 0) max max)))] + (let [max-arity (->> overload-types (uc/map+ kf) (uc/map+ count) (educe max 0)) + ;; With `sort-guide` and/or hashing also aggregated into the main comparator, a comparator + ;; violation occurs: + ;; `t/nil?` < `t/boolean?`, `t/boolean?` < `t/val?`, but `t/nil?` <> `t/val?` + !overload-types (->> overload-types + (uc/group-deep-by-into max-arity + (c/fn [i x] (let [t (-> x kf (get i))] + (if-let [c (uana/sort-guide t)] + ;; Min int value to ensure sort-guide ones always + ;; come first + (+ -2147483648 c) + (hash t)))) + (c/fn ([] (umap/>!sorted-map)) + ([ret] (->> ret uc/vals+ uc/cat+ (educe alist-conj!))) + #?(:clj ([^TreeMap ret k v] (doto ret (.put k v))) + :cljs ([ ret k v] (doto ret (.add k v))))) + alist-conj!) + to-array)] + ;; We use insertion sort because it's tolerant to non-transitive comparators, and because + ;; the `group-deep` into sorted map will already produce a partially sorted array (dotimes [i max-arity] - (->> !overload-types - (uc/sort-by! kf - (c/fn [a b] (let [ct|a (count a) - ct|b (count b) - ct-comparison (compare ct|a ct|b)] - (if (zero? ct-comparison) - (if (< i ct|a) - (compare-arg-types (get a i) (get b i)) - 0) - ct-comparison)))))) + (uc/sort-by|insertion! kf + (>comparator-respecting-arglist-counts compare-arg-types i) !overload-types)) (>vec !overload-types))) (c/defn- dedupe-type-data @@ -1231,11 +1257,11 @@ (err! "Could not resolve fn name to extend" {:sym fn|extended-name}))) fn|ns-name (if (= kind :extend-defn!) - (-> fn|var >?namespace >symbol) - (>symbol *ns*)) + (-> fn|var >?namespace >symbol) + (>symbol *ns*)) fn|name (if (= kind :extend-defn!) - (-> fn|extended-name >name symbol) - fn|name) + (-> fn|extended-name >name symbol) + fn|name) fn|globals-name (symbol (str fn|name "|__globals"))] (if (= kind :extend-defn!) {:fn|globals (-> (uid/qualify fn|ns-name fn|globals-name) resolve var-get) From 7b7626467eb671a8470c5e08cd0af465b8141fd0 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 18 Nov 2018 22:49:53 -0700 Subject: [PATCH 744/810] Fix compilation --- src-untyped/quantum/untyped/core/collections.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index 2a8e8c73..aa968697 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -598,7 +598,7 @@ (defn sort! "Like `sort` but coerces `xs` to an array and then sorts it in place, returning the coerced array instead of a seq on top of it. If `xs` is already an array, modifies `xs`." - ([xs] (sort! compare !xs)) + ([xs] (sort! compare xs)) ([compf xs] (let [#?(:clj ^objects !xs :cljs !xs) (if (array? xs) xs (to-array xs))] (doto !xs #?(:clj (java.util.Arrays/sort ^Comparator compf) From 26bb213114705c0a6387da8970df756b8bb8f244 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 18 Nov 2018 22:49:58 -0700 Subject: [PATCH 745/810] `case-val` --- src-untyped/quantum/untyped/core/logic.cljc | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/src-untyped/quantum/untyped/core/logic.cljc b/src-untyped/quantum/untyped/core/logic.cljc index 991a2711..4bb1a222 100644 --- a/src-untyped/quantum/untyped/core/logic.cljc +++ b/src-untyped/quantum/untyped/core/logic.cljc @@ -82,6 +82,23 @@ #?(:clj (defmacro fn-implies? [a b] `(fn-logic-base implies? ~a ~b))) +;; ===== `case-val` ===== ;; + +#?(:clj +(defmacro case-val + "Like `case` but the dispatch value forms are `eval`ed at compile time rather than needing to be + compile-time literals. The results of the evaluation of the forms must each be literals." + [v & args] + (let [[branches else has-else?] + (if (-> args count even?) + [args nil false] + [(butlast args) (last args) true])] + `(case ~v + ~@(->> branches + (partition-all 2) + (mapcat (fn [[dispatch then]] [(eval dispatch) then]))) + ~@(when has-else? [else]))))) + ;; ===== `cond(f|c|p)` ===== ;; #?(:clj From 66f9054e3bb055d4932b772fc9e1234a15fb24f8 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 18 Nov 2018 22:50:40 -0700 Subject: [PATCH 746/810] `t/-` now handles `meta-or` --- src-untyped/quantum/untyped/core/type.cljc | 53 +++++++++++++--------- test/quantum/test/untyped/core/type.cljc | 35 ++++++++------ 2 files changed, 54 insertions(+), 34 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 71764fe6..7824e17d 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -284,14 +284,37 @@ ;; ------------------ -(defns- -|or [t0 utr/type?, t1 utr/type?] +(defns- -|or [t0 utr/type?, t1 utr/type? > utr/type?] (let [args (->> t0 utr/or-type>args (uc/remove (fn1 = t1)))] (case (count args) 0 empty-set 1 (first args) (OrType. uhash/default uhash/default nil nil args (atom nil))))) -(defn - ;; TODO `defns` when variadic args are actually handled correctly +(defns -|norx [t0 utr/type?, t1 utr/type? > utr/type?] + (let [c (c/int (compare t0 t1))] + (case c + (0 -1) empty-set + 3 t0 + (1 2) + (let [c0 (c/type t0) c1 (c/type t1)] + ;; TODO add dispatch? + (condp == c0 + ClassType (condp == c1 + ClassType (AndType. uhash/default uhash/default nil nil + [t0 (not t1)] (atom nil))) + NotType (condp == (-> t0 utr/not-type>inner-type c/type) + ClassType (condp == c1 + ClassType (AndType. uhash/default uhash/default nil nil + [t0 (not t1)] (atom nil))) + ValueType (condp == c1 + ValueType (AndType. uhash/default uhash/default nil nil + [t0 (not t1)] (atom nil)))) + OrType (condp == c1 + ClassType (-|or t0 t1) + ValueType (-|or t0 t1))))))) + +(defn - "Computes the difference of `t0` from `t1`: (& t0 (! t1)) If `t0` = `t1`, `∅` If `t0` < `t1`, `∅` @@ -305,24 +328,10 @@ (rx (- @t0 t1))) (if (utr/rx-type? t1) (rx (- t0 @t1)) - (let [c (c/int (compare t0 t1))] - (case c - (0 -1) empty-set - 3 t0 - (1 2) - (let [c0 (c/type t0) c1 (c/type t1)] - ;; TODO add dispatch? - (condp == c0 - NotType (condp == (-> t0 utr/not-type>inner-type c/type) - ClassType (condp == c1 - ClassType (AndType. uhash/default uhash/default nil nil - [t0 (not t1)] (atom nil))) - ValueType (condp == c1 - ValueType (AndType. uhash/default uhash/default nil nil - [t0 (not t1)] (atom nil)))) - OrType (condp == c1 - ClassType (-|or t0 t1) - ValueType (-|or t0 t1))))))))) + (with-expand-meta-ors [t0 t1] + (fn [types'] + (assert (-> types' count (c/= 2))) + (-|norx (first types') (second types'))))))) ([t0 #_utr/type?, t1 #_utr/type? & ts #_ _ #_> #_utr/type?] (reduce - (- t0 t1) ts))) (def* type? (isa? PType)) @@ -709,7 +718,7 @@ "Computes a type denoting a nilable value satisfying `t`." ([t #_utr/type? #_> #_utr/type?] (or nil? t))) -;; ===== Etc. ===== ;; +;; ===== `meta-or` ===== ;; (defns- with-expand-meta-ors [type-args (us/seq-of type?), f c/fn?] (if-not (seq-or utr/meta-or-type? type-args) @@ -744,6 +753,8 @@ > utr/type? [types (us/seq-of utr/type?)] (separate-rx-and-apply meta-or|norx types)) +;; ===== Etc. ===== ;; + ;; TODO figure out the best place to put this #?(:clj (def unboxed-class->boxed-class diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index 50e4ab85..e9a65a87 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -588,19 +588,28 @@ (is= @(t/rx (gen-t)) @(t/rx (gen-t)))))) (deftest test|meta-or - (is= (t/or (t/meta-or [byte? short? char?]) string?) - (t/meta-or [(t/or byte? string?) - (t/or short? string?) - (t/or char? string?)])) - (is= (t/or (t/meta-or [long? t/any?]) - (t/meta-or [byte? short? char?])) - (t/meta-or [(t/or long? byte?) - (t/or long? short?) - (t/or long? char?) - t/any?])) - (is= (t/and (t/meta-or [long? t/any?]) - (t/meta-or [byte? short? char?])) - (t/meta-or [t/none? byte? short? char?])) + (testing "+ `t/or`" + (is= (t/or (t/meta-or [byte? short? char?]) string?) + (t/meta-or [(t/or byte? string?) + (t/or short? string?) + (t/or char? string?)])) + (is= (t/or (t/meta-or [long? t/any?]) + (t/meta-or [byte? short? char?])) + (t/meta-or [(t/or long? byte?) + (t/or long? short?) + (t/or long? char?) + t/any?]))) + (testing "+ `t/and`" + (is= (t/and (t/meta-or [long? t/any?]) + (t/meta-or [byte? short? char?])) + (t/meta-or [t/none? byte? short? char?]))) + (testing "+ `t/-`" + (is= (t/- (t/meta-or [i|a i|b]) i|><0) + (t/meta-or [(t/- i|a i|><0) (t/- i|b i|><0)])) + (is= (t/- i|><0 (t/meta-or [i|a i|b])) + (t/meta-or [(t/- i|><0 i|a) (t/- i|><0 i|b)])) + (is= (t/- (t/meta-or [i|a i|b]) (t/meta-or [i|><0 i|><1])) + (t/meta-or [(t/- i|a i|><0) (t/- i|a i|><1) (t/- i|b i|><0) (t/- i|b i|><1)]))) (testing "Reactive types" (is= @(t/meta-or [(t/rx string?) byte?]) (t/meta-or [byte? string?]))) From 2f48c03552e361f81faef9e9f5a9d7dbfe0fa6a8 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 18 Nov 2018 22:50:58 -0700 Subject: [PATCH 747/810] Overhaul logical type comparisons --- .../quantum/untyped/core/type/compare.cljc | 117 ++++++--- .../test/untyped/core/type/compare.cljc | 226 ++++++++++++++++-- 2 files changed, 295 insertions(+), 48 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index ca5cc320..cf92adb6 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -25,7 +25,7 @@ [quantum.untyped.core.fn :refer [fn' fn1]] [quantum.untyped.core.logic - :refer [ifs]] + :refer [case-val ifs]] [quantum.untyped.core.reducers :refer [educe]] [quantum.untyped.core.spec :as us] @@ -66,7 +66,7 @@ (def inverted (fn [f] (fn [t0 t1] (uset/invert-comparison (f t1 t0))))) -;; ===== (Comparison) idents ===== ;; +;; ===== (Comparison) idents and bit-sets ===== ;; (def- fn< (fn' < (fn' > (fn' <>ident)) +(def b< (reduce ubit/conj ubit/empty [< (reduce ubit/conj ubit/empty [<|<> (reduce ubit/conj ubit/empty [ident])) +(def b<|<> (reduce ubit/conj ubit/empty [ident])) +(def b=|>< (reduce ubit/conj ubit/empty [=ident ><|<> (reduce ubit/conj ubit/empty [=ident >ident])) +(def b=|<> (reduce ubit/conj ubit/empty [=ident <>ident])) +(def b> (reduce ubit/conj ubit/empty [>ident])) +(def b>|>< (reduce ubit/conj ubit/empty [>ident >|><|<> (reduce ubit/conj ubit/empty [>ident >ident])) +(def b>|<> (reduce ubit/conj ubit/empty [>ident <>ident])) +(def b>< (reduce ubit/conj ubit/empty [><|<> (reduce ubit/conj ubit/empty [>ident])) +(def b<> (reduce ubit/conj ubit/empty [<>ident])) + +(defn bit-set>set [x] + (cond-> #{} + (ubit/contains? x ident) (conj >ident) + (ubit/contains? x >ident) (conj <>ident))) + +(defn- comparison-err! [t0+t1 t1+t0] + (err! "comparison not thought through yet" + {:t0+t1 (bit-set>set t0+t1) :t1+t0 (bit-set>set t1+t0)})) + ;; ===== Comparison Implementations ===== ;; (defns- compare|todo [t0 type?, t1 type?] @@ -175,12 +202,12 @@ (defns- compare|not+not [t0 not-type?, t1 not-type? > comparison?] (let [c (int (compare (utr/not-type>inner-type t0) (utr/not-type>inner-type t1)))] - (case c - 0 =ident - -1 >ident - 1 ident + >ident ident >ts1 fn? > comparison?] (let [l (->> ts0 (seq-and ident > comparison?] (compare|or+or-like (.-args t0) (.-args t1) (fn1 < t0) (fn1 < t1) (fn1 <> t1))) -;; TODO this might not actually be right -;; TODO performance can be improved here (defns- compare|or+and [^OrType t0 or-type?, ^AndType t1 and-type? > comparison?] (let [t0+t1 (->> t0 .-args (uc/map+ #(compare % t1)) (educe ubit/conj ubit/empty)) t1+t0 (->> t1 .-args (uc/map+ #(compare % t0)) (educe ubit/conj ubit/empty))] - (ifs (or (and (ubit/contains? t0+t1 >ident) - (not (ubit/contains? t0+t1 ident)) - (not (ubit/contains? t1+t0 >ident - (or (and (ubit/contains? t0+t1 ident)) - (not (ubit/contains? t0+t1 >ident) - (not (ubit/contains? t1+t0 ident))) - (and (ubit/contains? t1+t0 >ident)))) - >ident))) + (case-val t0+t1 + (list b< b<|>< b<|><|<> b<|<> b=|>< b=|><|<> b=|<>) + (comparison-err! t0+t1 t1+t0) + b> (case-val t1+t0 + b< >ident + b<|>< >ident + (list b<|><|<> b<|<> b=|>< b=|><|<> b=|<> b> b>|>< b>|><|<> b>|<> b>< b><|<> b<>) + (comparison-err! t0+t1 t1+t0)) + b>|>< + (case-val t1+t0 + b< >ident + (list b<|>< b<|><|<> b<|<> b=|>< b=|><|<> b=|<> b> b>|>< b>|><|<> b>|<> b>< b><|<> b<>) + (comparison-err! t0+t1 t1+t0)) + b>|><|<> + (comparison-err! t0+t1 t1+t0) + b>|<> + (case-val t1+t0 + b< (comparison-err! t0+t1 t1+t0) + b<|>< >ident + (list b<|><|<> b<|<> b=|>< b=|><|<> b=|<> b> b>|>< b>|><|<> b>|<> b>< b><|<> b<>) + (comparison-err! t0+t1 t1+t0)) + b>< (case-val t1+t0 + (list b< b<|>< b<|><|<> b<|<> b=|>< b=|><|<> b=|<> b> b>|>< b>|><|<> b>|<>) + (comparison-err! t0+t1 t1+t0) + b>< ><|<> b<>) + (comparison-err! t0+t1 t1+t0)) + (list b><|<> b<>) + (comparison-err! t0+t1 t1+t0)))) (def- compare|or+class (inverted compare|atomic+or)) (def- compare|or+unordered (inverted compare|atomic+or)) @@ -266,7 +300,24 @@ ;; ----- AndType ----- ;; (defns- compare|and+and [^AndType t0 and-type?, ^AndType t1 and-type? > comparison?] - (TODO)) + (let [t0+t1 (->> t0 .-args (uc/map+ #(compare % t1)) (educe ubit/conj ubit/empty)) + t1+t0 (->> t1 .-args (uc/map+ #(compare % t0)) (educe ubit/conj ubit/empty))] + (case-val t0+t1 + (list b< b<|>< b<|><|<> b<|<> b=|>< b=|><|<> b=|<>) + (comparison-err! t0+t1 t1+t0) + b> (case-val t1+t0 + (list b< b<|>< b<|><|<> b<|<> b=|>< b=|><|<> b=|<>) (comparison-err! t0+t1 t1+t0) + b> =ident + b>|>< >ident + (list b>|><|<> b>|<> b>< b><|<> b<>) (comparison-err! t0+t1 t1+t0)) + b>|>< + (case-val t1+t0 + (list b< b<|>< b<|><|<> b<|<> b=|>< b=|><|<> b=|<>) (comparison-err! t0+t1 t1+t0) + b> |>< >|><|<> b>|<> b>< b><|<> b<>) (comparison-err! t0+t1 t1+t0)) + (list b>|><|<> b>|<> b>< b><|<> b<>) + (comparison-err! t0+t1 t1+t0)))) (def- compare|and+class (inverted compare|atomic+and)) (def- compare|and+unordered (inverted compare|atomic+and)) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 17f0c07f..ca4ced89 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -37,7 +37,7 @@ :refer [deftest testing is is= throws]] [quantum.untyped.core.type :as t :refer [& | !]] - [quantum.untyped.core.type.compare :as tcomp] + [quantum.untyped.core.type.compare :as utcomp] [quantum.untyped.core.type.reifications :as utr])) ;; Here, `NotType` labels on `testing` mean such *after* simplification @@ -150,7 +150,8 @@ (test-comparison >ident t/universal-set (! a))) (testing "+ OrType" (test-comparison >ident t/universal-set (| ><0 ><1))) - (testing "+ AndType") + (testing "+ AndType" + (test-comparison >ident t/universal-set (& i|><0 i|><1))) (testing "+ Expression") (testing "+ ProtocolType" (doseq [t protocol-types] @@ -173,7 +174,8 @@ (test-comparison <>ident t/empty-set (! (t/value 1))))) (testing "+ OrType" (test-comparison <>ident t/empty-set (| ><0 ><1))) - (testing "+ AndType") + (testing "+ AndType" + (test-comparison <>ident t/empty-set (& i|><0 i|><1))) (testing "+ Expression") (testing "+ ProtocolType" (doseq [t protocol-types] @@ -526,7 +528,7 @@ #_(testing "+ #{< > ><}") ; impossible for `OrType` #_(testing "+ #{< > >< <>}") ; impossible for `OrType` #_(testing "+ #{< > <>}") ; impossible for `OrType` - (testing "+ #{<, ><}") + (testing "+ #{< ><}") (testing "+ #{< >< <>}") (testing "+ #{< <>}") #_(testing "+ #{=}") ; impossible for `OrType` @@ -546,7 +548,8 @@ (testing "+ #{<>}" ;; comparisons: <> <> <> <> (test-comparison <>ident (| a b) (| ><0 ><1))))) - ;; TODO complete comparisons via `comparison-combinations` + ;; TODO complete comparisons + ;; NOTE don't eliminate symmetric comparisons here as they compare different types (testing "+ AndType" ;; Comparison annotations achieved by first comparing each element of the first/left to the ;; entire second/right, then comparing each element of the second/right to the entire @@ -565,7 +568,7 @@ #_(testing "+ #{< > ><}") ; impossible for `AndType` #_(testing "+ #{< > >< <>}") ; impossible for `AndType` #_(testing "+ #{< > <>}") ; impossible for `AndType` - (testing "+ #{<, ><}") + (testing "+ #{< ><}") (testing "+ #{< >< <>}") (testing "+ #{< <>}") #_(testing "+ #{=}") ; impossible for `AndType` @@ -595,7 +598,7 @@ #_(testing "#{< > ><}") ; impossible for `OrType` #_(testing "#{< > >< <>}") ; impossible for `OrType` #_(testing "#{< > <>}") ; impossible for `OrType` - (testing "#{<, ><}") + (testing "#{< ><}") (testing "#{< >< <>}") (testing "#{< <>}") #_(testing "#{=}") ; impossible for `OrType` @@ -624,7 +627,7 @@ #_(testing "+ #{< > ><}") ; impossible for `AndType` #_(testing "+ #{< > >< <>}") ; impossible for `AndType` #_(testing "+ #{< > <>}") ; impossible for `AndType` - (testing "+ #{<, ><}" + (testing "+ #{< ><}" ;; comparisons: > > < < >< (test-comparison >ident (| i|>a+b i|>a0) (& i|>a+b i|>a0 i|>a1)) ;; comparisons: > > < >< @@ -664,7 +667,7 @@ #_(testing "+ #{< > ><}") ; impossible for `AndType` #_(testing "+ #{< > >< <>}") ; impossible for `AndType` #_(testing "+ #{< > <>}") ; impossible for `AndType` - (testing "+ #{<, ><}") + (testing "+ #{< ><}") (testing "+ #{< >< <>}") (testing "+ #{< <>}") #_(testing "+ #{=}") ; impossible for `AndType` @@ -697,7 +700,7 @@ #_(testing "+ #{< > ><}") ; impossible for `AndType` #_(testing "+ #{< > >< <>}") ; impossible for `AndType` #_(testing "+ #{< > <>}") ; impossible for `AndType` - (testing "+ #{<, ><}" + (testing "+ #{< ><}" ;; comparisons: > <> < >< (test-comparison >ident (| i|>a+b t/nil?) (& i|a i|><1))) (testing "+ #{< >< <>}") @@ -731,7 +734,7 @@ #_(testing "+ #{< > ><}") ; impossible for `AndType` #_(testing "+ #{< > >< <>}") ; impossible for `AndType` #_(testing "+ #{< > <>}") ; impossible for `AndType` - (testing "+ #{<, ><}") + (testing "+ #{< ><}") (testing "+ #{< >< <>}") (testing "+ #{< <>}") #_(testing "+ #{=}") ; impossible for `AndType` @@ -758,7 +761,7 @@ ;; FIXME incorporate the below ;; - the comparisons need to be assessed ;; - non `i|`s should become `i|`s - (testing "#{<}" + #_(testing "#{<}" (testing "+ #{<+ ∅+}" ;; comparisons: ; [-1, 3], [-1, 3, 3] (test-comparison #_<>ident (| i|>a+b i|>a0) (& i|>a+b i|><0 i|><1)) @@ -870,11 +873,206 @@ (test-comparison <>ident (t/value "a") (| t/byte? t/long?)) (test-comparison <>ident (t/value 3) (| (t/value 1) (t/value 2))))))) (testing "AndType" - (testing "+ AndType") + ;; TODO eliminate duplicate symmetric comparisons here + (testing "+ AndType" + (testing "#{<}" + (testing "+ #{<}" + ) + #_(testing "+ #{< =}") ; impossible for `AndType` + #_(testing "+ #{< = >}") ; impossible for `AndType` + #_(testing "+ #{< = > ><}") ; impossible for `AndType` + #_(testing "+ #{< = > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = > <>}") ; impossible for `AndType` + #_(testing "+ #{< = ><}") ; impossible for `AndType` + #_(testing "+ #{< = >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = <>}") ; impossible for `AndType` + #_(testing "+ #{< >}") ; impossible for `AndType` + #_(testing "+ #{< > ><}") ; impossible for `AndType` + #_(testing "+ #{< > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< > <>}") ; impossible for `AndType` + (testing "+ #{< ><}") + (testing "+ #{< >< <>}") + (testing "+ #{< <>}") + #_(testing "+ #{=}") ; impossible for `AndType` + #_(testing "+ #{= >}") ; impossible for `AndType` + #_(testing "+ #{= > ><}") ; impossible for `AndType` + #_(testing "+ #{= > >< <>}") ; impossible for `AndType` + #_(testing "+ #{= > <>}") ; impossible for `AndType` + (testing "+ #{= ><}") + (testing "+ #{= >< <>}") + (testing "+ #{= <>}") + (testing "+ #{>}") + (testing "+ #{> ><}") + (testing "+ #{> >< <>}") + (testing "+ #{> <>}") + (testing "+ #{><}") + (testing "+ #{>< <>}") + (testing "+ #{<>}")) + #_(testing "#{< =}") ; impossible for `OrType` + #_(testing "#{< = >}") ; impossible for `OrType` + #_(testing "#{< = > ><}") ; impossible for `OrType` + #_(testing "#{< = > >< <>}") ; impossible for `OrType` + #_(testing "#{< = > <>}") ; impossible for `OrType` + #_(testing "#{< = ><}") ; impossible for `OrType` + #_(testing "#{< = >< <>}") ; impossible for `OrType` + #_(testing "#{< = <>}") ; impossible for `OrType` + #_(testing "#{< >}") ; impossible for `OrType` + #_(testing "#{< > ><}") ; impossible for `OrType` + #_(testing "#{< > >< <>}") ; impossible for `OrType` + #_(testing "#{< > <>}") ; impossible for `OrType` + (testing "#{< ><}") + (testing "#{< >< <>}") + (testing "#{< <>}") + #_(testing "#{=}") ; impossible for `OrType` + #_(testing "#{= >}") ; impossible for `OrType` + #_(testing "#{= > ><}") ; impossible for `OrType` + #_(testing "#{= > >< <>}") ; impossible for `OrType` + #_(testing "#{= > <>}") ; impossible for `OrType` + (testing "#{= ><}") + (testing "#{= >< <>}") + (testing "#{= <>}") + (testing "#{>}" + (testing "+ #{<}") + #_(testing "+ #{< =}") ; impossible for `AndType` + #_(testing "+ #{< = >}") ; impossible for `AndType` + #_(testing "+ #{< = > ><}") ; impossible for `AndType` + #_(testing "+ #{< = > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = > <>}") ; impossible for `AndType` + #_(testing "+ #{< = ><}") ; impossible for `AndType` + #_(testing "+ #{< = >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = <>}") ; impossible for `AndType` + #_(testing "+ #{< >}") ; impossible for `AndType` + #_(testing "+ #{< > ><}") ; impossible for `AndType` + #_(testing "+ #{< > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< > <>}") ; impossible for `AndType` + (testing "+ #{< ><}") + (testing "+ #{< >< <>}") + (testing "+ #{< <>}") + #_(testing "+ #{=}") ; impossible for `AndType` + #_(testing "+ #{= >}") ; impossible for `AndType` + #_(testing "+ #{= > ><}") ; impossible for `AndType` + #_(testing "+ #{= > >< <>}") ; impossible for `AndType` + #_(testing "+ #{= > <>}") ; impossible for `AndType` + (testing "+ #{= ><}") + (testing "+ #{= >< <>}") + (testing "+ #{= <>}") + (testing "+ #{>}" + ;; comparisons: > > > > + (test-comparison =ident (& i|a i|b) (& i|a i|b))) + (testing "+ #{> ><}") + (testing "+ #{> >< <>}") + (testing "+ #{> <>}") + (testing "+ #{><}") + (testing "+ #{>< <>}") + (testing "+ #{<>}")) + (testing "#{> ><}" + (testing "+ #{<}") + #_(testing "+ #{< =}") ; impossible for `AndType` + #_(testing "+ #{< = >}") ; impossible for `AndType` + #_(testing "+ #{< = > ><}") ; impossible for `AndType` + #_(testing "+ #{< = > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = > <>}") ; impossible for `AndType` + #_(testing "+ #{< = ><}") ; impossible for `AndType` + #_(testing "+ #{< = >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = <>}") ; impossible for `AndType` + #_(testing "+ #{< >}") ; impossible for `AndType` + #_(testing "+ #{< > ><}") ; impossible for `AndType` + #_(testing "+ #{< > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< > <>}") ; impossible for `AndType` + (testing "+ #{< ><}") + (testing "+ #{< >< <>}") + (testing "+ #{< <>}") + #_(testing "+ #{=}") ; impossible for `AndType` + #_(testing "+ #{= >}") ; impossible for `AndType` + #_(testing "+ #{= > ><}") ; impossible for `AndType` + #_(testing "+ #{= > >< <>}") ; impossible for `AndType` + #_(testing "+ #{= > <>}") ; impossible for `AndType` + (testing "+ #{= ><}") + (testing "+ #{= >< <>}") + (testing "+ #{= <>}") + (testing "+ #{>}" + ;; comparisons: > > >< > > + (test-comparison <0) (& i|a i|b))) + (testing "+ #{> ><}" + ;; comparisons: > >< > >< + (test-comparison ><0) (& i|a i|b))) + (testing "+ #{> >< <>}") + (testing "+ #{> <>}") + (testing "+ #{><}") + (testing "+ #{>< <>}") + (testing "+ #{<>}")) + (testing "#{> >< <>}") + (testing "#{> <>}" + (testing "+ #{<}") + #_(testing "+ #{< =}") ; impossible for `AndType` + #_(testing "+ #{< = >}") ; impossible for `AndType` + #_(testing "+ #{< = > ><}") ; impossible for `AndType` + #_(testing "+ #{< = > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = > <>}") ; impossible for `AndType` + #_(testing "+ #{< = ><}") ; impossible for `AndType` + #_(testing "+ #{< = >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = <>}") ; impossible for `AndType` + #_(testing "+ #{< >}") ; impossible for `AndType` + #_(testing "+ #{< > ><}") ; impossible for `AndType` + #_(testing "+ #{< > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< > <>}") ; impossible for `AndType` + (testing "+ #{< ><}") + (testing "+ #{< >< <>}") + (testing "+ #{< <>}") + #_(testing "+ #{=}") ; impossible for `AndType` + #_(testing "+ #{= >}") ; impossible for `AndType` + #_(testing "+ #{= > ><}") ; impossible for `AndType` + #_(testing "+ #{= > >< <>}") ; impossible for `AndType` + #_(testing "+ #{= > <>}") ; impossible for `AndType` + (testing "+ #{= ><}") + (testing "+ #{= >< <>}") + (testing "+ #{= <>}") + (testing "+ #{>}") + (testing "+ #{> ><}") + (testing "+ #{> >< <>}") + (testing "+ #{> <>}") + (testing "+ #{><}") + (testing "+ #{>< <>}") + (testing "+ #{<>}")) + (testing "#{><}" + (testing "+ #{<}") + #_(testing "+ #{< =}") ; impossible for `AndType` + #_(testing "+ #{< = >}") ; impossible for `AndType` + #_(testing "+ #{< = > ><}") ; impossible for `AndType` + #_(testing "+ #{< = > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = > <>}") ; impossible for `AndType` + #_(testing "+ #{< = ><}") ; impossible for `AndType` + #_(testing "+ #{< = >< <>}") ; impossible for `AndType` + #_(testing "+ #{< = <>}") ; impossible for `AndType` + #_(testing "+ #{< >}") ; impossible for `AndType` + #_(testing "+ #{< > ><}") ; impossible for `AndType` + #_(testing "+ #{< > >< <>}") ; impossible for `AndType` + #_(testing "+ #{< > <>}") ; impossible for `AndType` + (testing "+ #{< ><}") + (testing "+ #{< >< <>}") + (testing "+ #{< <>}") + #_(testing "+ #{=}") ; impossible for `AndType` + #_(testing "+ #{= >}") ; impossible for `AndType` + #_(testing "+ #{= > ><}") ; impossible for `AndType` + #_(testing "+ #{= > >< <>}") ; impossible for `AndType` + #_(testing "+ #{= > <>}") ; impossible for `AndType` + (testing "+ #{= ><}") + (testing "+ #{= >< <>}") + (testing "+ #{= <>}") + (testing "+ #{>}") + (testing "+ #{> ><}") + (testing "+ #{> >< <>}") + (testing "+ #{> <>}") + (testing "+ #{><}") + (testing "+ #{>< <>}") + (testing "+ #{<>}")) + (testing "#{>< <>}") + (testing "#{<>}")) (testing "+ Expression") (testing "+ ProtocolType") (testing "+ ClassType" (testing "#{<}" + (test-comparison a0 i|>a1)) (testing "Boxed Primitive" (test-comparison a0 i|>a1)))) - (testing "#{<}" - (test-comparison a0 i|>a1))) #_(testing "#{< =}") ; impossible for `AndType` #_(testing "#{< = >}") ; impossible for `AndType` #_(testing "#{< = > ><}") ; impossible for `AndType` From 717da0172241316ff6ae30b2b8b3a53af92a94bf Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 18 Nov 2018 22:53:53 -0700 Subject: [PATCH 748/810] Leave unboxing of `t/def`s to todos --- src/quantum/core/data/primitive.cljc | 1 - 1 file changed, 1 deletion(-) diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index 1155e826..e906468b 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -154,7 +154,6 @@ ([x (t/or double? (t/value double?)) > double?] #?(:clj Double/MIN_VALUE :cljs js/Number.MIN_VALUE))) -;; TODO TYPED these are probably getting boxed #?(:clj (t/def- min-float (Numeric/negate Float/MAX_VALUE))) (t/def- min-double (- #?(:clj Double/MAX_VALUE :cljs js/Number.MAX_VALUE))) From 51eb166a7558034f16b884ae98ad6cc65cf98a9f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 18 Nov 2018 22:54:10 -0700 Subject: [PATCH 749/810] Continue to refine data.numeric --- src/quantum/core/data/numeric.cljc | 69 ++++++++++++++++++++---------- 1 file changed, 46 insertions(+), 23 deletions(-) diff --git a/src/quantum/core/data/numeric.cljc b/src/quantum/core/data/numeric.cljc index baf55ee2..5919e47d 100644 --- a/src/quantum/core/data/numeric.cljc +++ b/src/quantum/core/data/numeric.cljc @@ -194,13 +194,15 @@ (c?/= a (>bigdec b)))) #?(:clj ([a (t/input-type >bigdec :?) , b bigdec?] (c?/= (>bigdec a) b))) #?(:clj ([a java-bigint? , b java-bigint?] (.equals a b))) -#?(:clj ([a java-bigint? , b (t/input-type >java-bigint :?)] +#?(:clj ([a java-bigint?, b (t/- (t/input-type >java-bigint :?) java-bigint?)] (c?/= a (>java-bigint b)))) -#?(:clj ([a (t/input-type >java-bigint :?), b java-bigint?] (c?/= (>java-bigint a) b))) +#?(:clj ([a (t/- (t/input-type >java-bigint :?) java-bigint?), b java-bigint?] + (c?/= (>java-bigint a) b))) #?(:clj ([a clj-bigint? , b clj-bigint?] (.equals a b))) -#?(:clj ([a clj-bigint? , b (t/input-type >clj-bigint :?)] +#?(:clj ([a clj-bigint?, b (t/- (t/input-type >clj-bigint :?) clj-bigint?)] (c?/= a (>clj-bigint b)))) -#?(:clj ([a (t/input-type >clj-bigint :?) , b clj-bigint?] (c?/= (>clj-bigint a) b))) +#?(:clj ([a (t/- (t/input-type >clj-bigint :?) clj-bigint?), b clj-bigint?] + (c?/= (>clj-bigint a) b))) #?(:clj ([a ratio? , b ratio?] (and (c?/= ^:val (.numerator a) ^:val (.numerator b)) (c?/= ^:val (.denominator a) ^:val (.denominator b))))) @@ -248,7 +250,7 @@ #?(:clj ([a (t/input-type >java-bigint :?), b java-bigint?] (c?/<= (>java-bigint a) b))) #?(:clj ([a clj-bigint? , b clj-bigint?] (if (and (p/nil? (.bipart a)) (p/nil? (.bipart b))) - (c?/<= (.lpart a) (.lpart b)) + (c?/<= (.lpart a) (.lpart b)) (c?/comp<= (>java-bigint a) (>java-bigint b))))) #?(:clj ([a clj-bigint? , b (t/input-type >clj-bigint :?)] (c?/<= a (>clj-bigint b)))) @@ -262,33 +264,54 @@ ;; TODO primitive with non-primitive ;; TODO all the stuff the `<` extension has + (t/extend-defn! c?/> ([x numeric?] true) -#?(:clj ([a bigdec? , b bigdec?] (c?/comp> a b))) -#?(:clj ([a bigdec? , b numeric?] (c?/> a (>bigdec b)))) -#?(:clj ([a numeric? , b bigdec?] (c?/> (>bigdec a) b))) -#?(:clj ([a clj-bigint?, b clj-bigint?] +#?(:clj ([a bigdec? , b bigdec?] (c?/comp> a b))) +#?(:clj ([a bigdec? , b (t/input-type >bigdec :?)] + (c?/> a (>bigdec b)))) +#?(:clj ([a (t/input-type >bigdec :?) , b bigdec?] (c?/> (>bigdec a) b))) +#?(:clj ([a java-bigint? , b java-bigint?] (c?/comp> a b))) +#?(:clj ([a java-bigint? , b (t/input-type >java-bigint :?)] + (c?/> a (>java-bigint b)))) +#?(:clj ([a (t/input-type >java-bigint :?), b java-bigint?] (c?/> (>java-bigint a) b))) +#?(:clj ([a clj-bigint? , b clj-bigint?] (if (and (p/nil? (.bipart a)) (p/nil? (.bipart b))) (c?/> (.lpart a) (.lpart b)) (c?/comp> (>java-bigint a) (>java-bigint b))))) -#?(:clj ([a ratio? , b ratio?] - (c?/> (.multiply (.numerator a) (.numerator b)) - (.multiply (.denominator a) (.denominator b)))))) +#?(:clj ([a clj-bigint? , b (t/input-type >clj-bigint :?)] + (c?/> a (>clj-bigint b)))) +#?(:clj ([a (t/input-type >clj-bigint :?) , b clj-bigint?] (c?/> (>clj-bigint a) b))) +#?(:clj ([a ratio? , b ratio?] + (c?/> ^:val (.multiply ^:val (.numerator a) ^:val (.numerator b)) + ^:val (.multiply ^:val (.denominator a) ^:val (.denominator b))))) +#?(:clj ([a ratio? , b (t/input-type >ratio :?)] + (c?/> a (>ratio b)))) +#?(:clj ([a (t/input-type >ratio :?) , b ratio?] (c?/> (>ratio a) b)))) -;; TODO primitive with non-primitive -;; TODO all the stuff the `<` extension has (t/extend-defn! c?/>= ([x numeric?] true) -#?(:clj ([a bigdec? , b bigdec?] (c?/comp>= a b))) -#?(:clj ([a bigdec? , b numeric?] (c?/>= a (>bigdec b)))) -#?(:clj ([a numeric? , b bigdec?] (c?/>= (>bigdec a) b))) -#?(:clj ([a clj-bigint?, b clj-bigint?] +#?(:clj ([a bigdec? , b bigdec?] (c?/comp> a b))) +#?(:clj ([a bigdec? , b (t/input-type >bigdec :?)] + (c?/> a (>bigdec b)))) +#?(:clj ([a (t/input-type >bigdec :?) , b bigdec?] (c?/> (>bigdec a) b))) +#?(:clj ([a java-bigint? , b java-bigint?] (c?/comp> a b))) +#?(:clj ([a java-bigint? , b (t/input-type >java-bigint :?)] + (c?/> a (>java-bigint b)))) +#?(:clj ([a (t/input-type >java-bigint :?), b java-bigint?] (c?/> (>java-bigint a) b))) +#?(:clj ([a clj-bigint? , b clj-bigint?] (if (and (p/nil? (.bipart a)) (p/nil? (.bipart b))) - (c?/>= (.lpart a) (.lpart b)) - (c?/comp>= (>java-bigint a) (>java-bigint b))))) -#?(:clj ([a ratio? , b ratio?] - (c?/>= (.multiply (.numerator a) (.numerator b)) - (.multiply (.denominator a) (.denominator b)))))) + (c?/> (.lpart a) (.lpart b)) + (c?/comp> (>java-bigint a) (>java-bigint b))))) +#?(:clj ([a clj-bigint? , b (t/input-type >clj-bigint :?)] + (c?/> a (>clj-bigint b)))) +#?(:clj ([a (t/input-type >clj-bigint :?) , b clj-bigint?] (c?/> (>clj-bigint a) b))) +#?(:clj ([a ratio? , b ratio?] + (c?/> ^:val (.multiply ^:val (.numerator a) ^:val (.numerator b)) + ^:val (.multiply ^:val (.denominator a) ^:val (.denominator b))))) +#?(:clj ([a ratio? , b (t/input-type >ratio :?)] + (c?/> a (>ratio b)))) +#?(:clj ([a (t/input-type >ratio :?) , b ratio?] (c?/> (>ratio a) b)))) ;; TODO `c?/compare` From c5e370328c279d1d2c1d5ad96f4d9734edcf5a9f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 18 Nov 2018 23:27:32 -0700 Subject: [PATCH 750/810] Attempt to compress some data.numeric fns --- src/quantum/core/compare/core.cljc | 3 + src/quantum/core/data/numeric.cljc | 199 ++++++++++++----------------- 2 files changed, 86 insertions(+), 116 deletions(-) diff --git a/src/quantum/core/compare/core.cljc b/src/quantum/core/compare/core.cljc index c1e0ec81..96396a24 100644 --- a/src/quantum/core/compare/core.cljc +++ b/src/quantum/core/compare/core.cljc @@ -127,6 +127,9 @@ (def comparison? #?(:clj ut/int? :cljs ut/double?)) +(t/def comparator? (t/ftype comparison? [t/any? t/any?])) +(t/def boolean-comparator? (t/ftype ut/boolean? [t/any? t/any?])) + (t/defn ^:inline compare "Logical (not exclusively numeric) comparison. diff --git a/src/quantum/core/data/numeric.cljc b/src/quantum/core/data/numeric.cljc index 5919e47d..f8b4fba0 100644 --- a/src/quantum/core/data/numeric.cljc +++ b/src/quantum/core/data/numeric.cljc @@ -185,133 +185,100 @@ ;; ===== Comparison extensions ===== ;; -;; TODO primitive with non-primitive (t/extend-defn! c?/= ;; `.equals` takes into account precision even if they're numerically equivalent ;; `core/=` uses `.equals` for `BigDecimal`s -#?(:clj ([a bigdec? , b bigdec?] (c?/comp= a b))) -#?(:clj ([a bigdec? , b (t/input-type >bigdec :?)] +#?(:clj ([a bigdec? + b bigdec?] (c?/comp= a b))) +#?(:clj ([a bigdec? + b (t/- (t/input-type >bigdec :?) bigdec? java-bigint? clj-bigint? ratio?)] (c?/= a (>bigdec b)))) -#?(:clj ([a (t/input-type >bigdec :?) , b bigdec?] (c?/= (>bigdec a) b))) -#?(:clj ([a java-bigint? , b java-bigint?] (.equals a b))) -#?(:clj ([a java-bigint?, b (t/- (t/input-type >java-bigint :?) java-bigint?)] +#?(:clj ([a (t/- (t/input-type >bigdec :?) bigdec? java-bigint? clj-bigint? ratio?) + b bigdec?] (c?/= (>bigdec a) b))) +#?(:clj ([a java-bigint? + b java-bigint?] (.equals a b))) +#?(:clj ([a java-bigint? + b (t/- (t/input-type >java-bigint :?) java-bigint? clj-bigint? ratio?)] (c?/= a (>java-bigint b)))) -#?(:clj ([a (t/- (t/input-type >java-bigint :?) java-bigint?), b java-bigint?] - (c?/= (>java-bigint a) b))) -#?(:clj ([a clj-bigint? , b clj-bigint?] (.equals a b))) -#?(:clj ([a clj-bigint?, b (t/- (t/input-type >clj-bigint :?) clj-bigint?)] - (c?/= a (>clj-bigint b)))) -#?(:clj ([a (t/- (t/input-type >clj-bigint :?) clj-bigint?), b clj-bigint?] - (c?/= (>clj-bigint a) b))) -#?(:clj ([a ratio? , b ratio?] - (and (c?/= ^:val (.numerator a) ^:val (.numerator b)) - (c?/= ^:val (.denominator a) ^:val (.denominator b))))) -#?(:clj ([a ratio? , b (t/input-type >ratio :?)] - (c?/= a (>ratio b)))) -#?(:clj ([a (t/input-type >ratio :?) , b ratio?] (c?/= (>ratio a) b)))) - -;; TODO primitive with non-primitive -;; FIXME (c?/< (>clj-bigint 1) (>clj-bigint 2)) -;; `This function is unsupported for the type combination at the argument index` -(t/extend-defn! c?/< +#?(:clj ([a (t/- (t/input-type >java-bigint :?) java-bigint? clj-bigint? ratio?) + b java-bigint?] (c?/= (>java-bigint a) b))) +#?(:clj ([a clj-bigint? + b clj-bigint?] (.equals a b))) +#?(:clj ([a clj-bigint? + b (t/- (t/input-type >clj-bigint :?) clj-bigint? ratio?)] (c?/= a (>clj-bigint b)))) +#?(:clj ([a (t/- (t/input-type >clj-bigint :?) clj-bigint? ratio?) + b clj-bigint?] (c?/= (>clj-bigint a) b))) +#?(:clj ([a ratio? + b ratio?] (and (c?/= ^:val (.numerator a) ^:val (.numerator b)) + (c?/= ^:val (.denominator a) ^:val (.denominator b))))) +#?(:clj ([a ratio? + b (t/- (t/input-type >ratio :?) ratio?)] (c?/= a (>ratio b)))) +#?(:clj ([a (t/- (t/input-type >ratio :?) ratio?) + b ratio?] (c?/= (>ratio a) b)))) + +(t/def numeric-comparator? (t/ftype p/boolean? [numeric? numeric?])) + +(t/defn ^:inline numeric-compare > p/boolean? ([x numeric?] true) -#?(:clj ([a bigdec? , b bigdec?] (c?/comp< a b))) -#?(:clj ([a bigdec? , b (t/input-type >bigdec :?)] - (c?/< a (>bigdec b)))) -#?(:clj ([a (t/input-type >bigdec :?) , b bigdec?] (c?/< (>bigdec a) b))) -#?(:clj ([a java-bigint? , b java-bigint?] (c?/comp< a b))) -#?(:clj ([a java-bigint? , b (t/input-type >java-bigint :?)] - (c?/< a (>java-bigint b)))) -#?(:clj ([a (t/input-type >java-bigint :?), b java-bigint?] (c?/< (>java-bigint a) b))) -#?(:clj ([a clj-bigint? , b clj-bigint?] - (if (and (p/nil? (.bipart a)) (p/nil? (.bipart b))) - (c?/< (.lpart a) (.lpart b)) - (c?/comp< (>java-bigint a) (>java-bigint b))))) -#?(:clj ([a clj-bigint? , b (t/input-type >clj-bigint :?)] - (c?/< a (>clj-bigint b)))) -#?(:clj ([a (t/input-type >clj-bigint :?) , b clj-bigint?] (c?/< (>clj-bigint a) b))) -#?(:clj ([a ratio? , b ratio?] - (c?/< ^:val (.multiply ^:val (.numerator a) ^:val (.numerator b)) - ^:val (.multiply ^:val (.denominator a) ^:val (.denominator b))))) -#?(:clj ([a ratio? , b (t/input-type >ratio :?)] - (c?/< a (>ratio b)))) -#?(:clj ([a (t/input-type >ratio :?) , b ratio?] (c?/< (>ratio a) b)))) - -;; TODO primitive with non-primitive +#?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? + a bigdec? + b bigdec?] (compf a b))) +#?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? + a bigdec? + b (t/input-type >bigdec :?)] (numeric-compf a (>bigdec b)))) +#?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? + a (t/input-type >bigdec :?) + b bigdec?] (numeric-compf (>bigdec a) b))) +#?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? + a java-bigint? + b java-bigint?] (compf a b))) +#?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? + a java-bigint? + b (t/input-type >java-bigint :?)] (numeric-compf a (>java-bigint b)))) +#?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? + a (t/input-type >java-bigint :?) + b java-bigint?] (numeric-compf (>java-bigint a) b))) +#?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? + a clj-bigint? + b clj-bigint?] (if (and (p/nil? (.bipart a)) (p/nil? (.bipart b))) + (numeric-compf (.lpart a) (.lpart b)) + (compf (>java-bigint a) (>java-bigint b))))) +#?(:clj ([a clj-bigint? + b (t/input-type >clj-bigint :?)] (numeric-compf a (>clj-bigint b)))) +#?(:clj ([a (t/input-type >clj-bigint :?) + b clj-bigint?] (numeric-compf (>clj-bigint a) b))) +#?(:clj ([a ratio? + b ratio?] (numeric-compf + ^:val (.multiply ^:val (.numerator a) ^:val (.numerator b)) + ^:val (.multiply ^:val (.denominator a) ^:val (.denominator b))))) +#?(:clj ([a ratio? + b (t/input-type >ratio :?)] (numeric-compf a (>ratio b)))) +#?(:clj ([a (t/input-type >ratio :?) + b ratio?] (numeric-compf (>ratio a) b)))) + +(t/extend-defn! c?/< + ([x (t/input-type numeric-compare :?)] (numeric-compare x)) + ([a (t/input-type numeric-compare :_ :_ :? :_) + b (t/input-type numeric-compare :_ :_ [= (t/type a)] :?)] + (numeric-compare c?/< c?/comp< a b))) + (t/extend-defn! c?/<= - ([x numeric?] true) -#?(:clj ([a bigdec? , b bigdec?] (c?/comp<= a b))) -#?(:clj ([a bigdec? , b (t/input-type >bigdec :?)] - (c?/<= a (>bigdec b)))) -#?(:clj ([a (t/input-type >bigdec :?) , b bigdec?] (c?/<= (>bigdec a) b))) -#?(:clj ([a java-bigint? , b java-bigint?] (c?/comp<= a b))) -#?(:clj ([a java-bigint? , b (t/input-type >java-bigint :?)] - (c?/<= a (>java-bigint b)))) -#?(:clj ([a (t/input-type >java-bigint :?), b java-bigint?] (c?/<= (>java-bigint a) b))) -#?(:clj ([a clj-bigint? , b clj-bigint?] - (if (and (p/nil? (.bipart a)) (p/nil? (.bipart b))) - (c?/<= (.lpart a) (.lpart b)) - (c?/comp<= (>java-bigint a) (>java-bigint b))))) -#?(:clj ([a clj-bigint? , b (t/input-type >clj-bigint :?)] - (c?/<= a (>clj-bigint b)))) -#?(:clj ([a (t/input-type >clj-bigint :?) , b clj-bigint?] (c?/<= (>clj-bigint a) b))) -#?(:clj ([a ratio? , b ratio?] - (c?/<= ^:val (.multiply ^:val (.numerator a) ^:val (.numerator b)) - ^:val (.multiply ^:val (.denominator a) ^:val (.denominator b))))) -#?(:clj ([a ratio? , b (t/input-type >ratio :?)] - (c?/<= a (>ratio b)))) -#?(:clj ([a (t/input-type >ratio :?) , b ratio?] (c?/<= (>ratio a) b)))) - -;; TODO primitive with non-primitive -;; TODO all the stuff the `<` extension has + ([x (t/input-type numeric-compare :?)] (numeric-compare x)) + ([a (t/input-type numeric-compare :_ :_ :? :_) + b (t/input-type numeric-compare :_ :_ [= (t/type a)] :?)] + (numeric-compare c?/<= c?/comp<= a b))) (t/extend-defn! c?/> - ([x numeric?] true) -#?(:clj ([a bigdec? , b bigdec?] (c?/comp> a b))) -#?(:clj ([a bigdec? , b (t/input-type >bigdec :?)] - (c?/> a (>bigdec b)))) -#?(:clj ([a (t/input-type >bigdec :?) , b bigdec?] (c?/> (>bigdec a) b))) -#?(:clj ([a java-bigint? , b java-bigint?] (c?/comp> a b))) -#?(:clj ([a java-bigint? , b (t/input-type >java-bigint :?)] - (c?/> a (>java-bigint b)))) -#?(:clj ([a (t/input-type >java-bigint :?), b java-bigint?] (c?/> (>java-bigint a) b))) -#?(:clj ([a clj-bigint? , b clj-bigint?] - (if (and (p/nil? (.bipart a)) (p/nil? (.bipart b))) - (c?/> (.lpart a) (.lpart b)) - (c?/comp> (>java-bigint a) (>java-bigint b))))) -#?(:clj ([a clj-bigint? , b (t/input-type >clj-bigint :?)] - (c?/> a (>clj-bigint b)))) -#?(:clj ([a (t/input-type >clj-bigint :?) , b clj-bigint?] (c?/> (>clj-bigint a) b))) -#?(:clj ([a ratio? , b ratio?] - (c?/> ^:val (.multiply ^:val (.numerator a) ^:val (.numerator b)) - ^:val (.multiply ^:val (.denominator a) ^:val (.denominator b))))) -#?(:clj ([a ratio? , b (t/input-type >ratio :?)] - (c?/> a (>ratio b)))) -#?(:clj ([a (t/input-type >ratio :?) , b ratio?] (c?/> (>ratio a) b)))) + ([x (t/input-type numeric-compare :?)] (numeric-compae x)) + ([a (t/input-type numeric-compare :_ :_ :? :_) + b (t/input-type numeric-compare :_ :_ [= (t/type a)] :?)] + (numeric-compare c?/> c?/comp> a b))) (t/extend-defn! c?/>= - ([x numeric?] true) -#?(:clj ([a bigdec? , b bigdec?] (c?/comp> a b))) -#?(:clj ([a bigdec? , b (t/input-type >bigdec :?)] - (c?/> a (>bigdec b)))) -#?(:clj ([a (t/input-type >bigdec :?) , b bigdec?] (c?/> (>bigdec a) b))) -#?(:clj ([a java-bigint? , b java-bigint?] (c?/comp> a b))) -#?(:clj ([a java-bigint? , b (t/input-type >java-bigint :?)] - (c?/> a (>java-bigint b)))) -#?(:clj ([a (t/input-type >java-bigint :?), b java-bigint?] (c?/> (>java-bigint a) b))) -#?(:clj ([a clj-bigint? , b clj-bigint?] - (if (and (p/nil? (.bipart a)) (p/nil? (.bipart b))) - (c?/> (.lpart a) (.lpart b)) - (c?/comp> (>java-bigint a) (>java-bigint b))))) -#?(:clj ([a clj-bigint? , b (t/input-type >clj-bigint :?)] - (c?/> a (>clj-bigint b)))) -#?(:clj ([a (t/input-type >clj-bigint :?) , b clj-bigint?] (c?/> (>clj-bigint a) b))) -#?(:clj ([a ratio? , b ratio?] - (c?/> ^:val (.multiply ^:val (.numerator a) ^:val (.numerator b)) - ^:val (.multiply ^:val (.denominator a) ^:val (.denominator b))))) -#?(:clj ([a ratio? , b (t/input-type >ratio :?)] - (c?/> a (>ratio b)))) -#?(:clj ([a (t/input-type >ratio :?) , b ratio?] (c?/> (>ratio a) b)))) + ([x (t/input-type numeric-compare :?)] (numeric-compare x)) + ([a (t/input-type numeric-compare :_ :_ :? :_) + b (t/input-type numeric-compare :_ :_ [= (t/type a)] :?)] + (numeric-compare c?/>= c?/comp>= a b))) ;; TODO `c?/compare` From d6c8f18133ba484745cea66918f44e8f92b38bb6 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 18 Nov 2018 23:42:12 -0700 Subject: [PATCH 751/810] ftypes are now `t/compare`able (mostly) --- src-untyped/quantum/untyped/core/type.cljc | 6 +- .../quantum/untyped/core/type/compare.cljc | 62 ++++++++++--------- 2 files changed, 37 insertions(+), 31 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 7824e17d..38fe71aa 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -800,16 +800,18 @@ (cond-> classes include-classes-of-value-type? (conj (-> t utr/value-type>value c/type))) (c/= t universal-set) - #?(:clj #{nil java.lang.Object} + #?(:clj (conj classes nil java.lang.Object) :cljs (TODO "Not sure what to do in the case of universal CLJS set")) (c/= t empty-set) - #{} + classes (utr/and-type? t) (reduce (c/fn [classes' t'] (-type>classes t' include-classes-of-value-type? classes')) classes (utr/and-type>args t)) (utr/or-type? t) (reduce (c/fn [classes' t'] (-type>classes t' include-classes-of-value-type? classes')) classes (utr/or-type>args t)) + (utr/fn-type? t) + (conj classes Object) ; it's not really a clojure.lang.IFn; the dynamic dispatch is though (c/= t val?) ; TODO make this less ad-hoc (-type>classes val|by-class? include-classes-of-value-type? classes) :else diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index cf92adb6..e41257ac 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -219,11 +219,9 @@ (defns- compare|not+class [t0 not-type?, t1 class-type? > comparison?] (compare|not+atomic t0 t1)) -(defns- compare|not+unordered [t0 not-type?, t1 class-type? > comparison?] - (compare|not+atomic t0 t1)) - -(defns- compare|not+ordered [t0 not-type?, t1 class-type? > comparison?] - (compare|not+atomic t0 t1)) +(def- compare|not+fn compare|not+atomic) +(def- compare|not+unordered compare|not+atomic) +(def- compare|not+ordered compare|not+atomic) (defns- compare|not+value [t0 not-type?, t1 value-type? > comparison?] (let [t0|inner (utr/not-type>inner-type t0)] @@ -291,7 +289,9 @@ (list b><|<> b<>) (comparison-err! t0+t1 t1+t0)))) +(def- compare|or+protocol (inverted compare|atomic+or)) (def- compare|or+class (inverted compare|atomic+or)) +(def- compare|or+fn (inverted compare|atomic+or)) (def- compare|or+unordered (inverted compare|atomic+or)) (def- compare|or+ordered (inverted compare|atomic+or)) (def- compare|or+value (inverted compare|value+type)) @@ -319,7 +319,9 @@ (list b>|><|<> b>|<> b>< b><|<> b<>) (comparison-err! t0+t1 t1+t0)))) +(def- compare|and+protocol (inverted compare|atomic+and)) (def- compare|and+class (inverted compare|atomic+and)) +(def- compare|and+fn (inverted compare|atomic+and)) (def- compare|and+unordered (inverted compare|atomic+and)) (def- compare|and+ordered (inverted compare|atomic+and)) (def- compare|and+value (inverted compare|value+type)) @@ -496,7 +498,7 @@ ;; ----- FnType ----- ;; -(defns compare|in [t0 utr/fn-type?, t1 utr/fn-type? > uset/comparison?] +(defns compare|in [t0 utr/fn-type?, t1 utr/fn-type? > comparison?] (let [ct->overloads|t0 (utr/fn-type>arities t0) ct->overloads|t1 (utr/fn-type>arities t1) cts-only-in-t0 (uset/- (-> ct->overloads|t0 keys set) (-> ct->overloads|t1 keys set)) @@ -515,12 +517,14 @@ (-> t1 utr/fn-type>ored-input-types (get ct))))))) combine-comparisons)))) -(defns compare|out [t0 utr/fn-type?, t1 utr/fn-type? > uset/comparison?] +(defns compare|out [t0 utr/fn-type?, t1 utr/fn-type? > comparison?] (compare (utr/fn-type>ored-output-type t0) (utr/fn-type>ored-output-type t1))) (defns- compare|fn+fn [t0 utr/fn-type?, t1 utr/fn-type? > comparison?] (combine-comparisons (compare|in t0 t1) (compare|out t0 t1))) +(def- compare|fn+meta compare|non-meta+meta) + ;; ----- UnorderedType ----- ;; (def- compare|unordered+value (inverted compare|value+type)) @@ -599,7 +603,7 @@ Expression fn>< ; TODO not entirely true ProtocolType compare|not+protocol ClassType compare|not+class - FnType compare|todo + FnType compare|not+fn UnorderedType compare|not+unordered OrderedType compare|not+ordered ValueType compare|not+value @@ -611,9 +615,9 @@ OrType compare|or+or AndType compare|or+and Expression fn>< ; TODO not entirely true - ProtocolType compare|todo + ProtocolType compare|or+protocol ClassType compare|or+class - FnType compare|todo + FnType compare|or+fn UnorderedType compare|or+unordered OrderedType compare|or+ordered ValueType compare|or+value @@ -625,9 +629,9 @@ OrType (inverted compare|or+and) AndType compare|and+and Expression fn>< ; TODO not entirely true - ProtocolType compare|todo + ProtocolType compare|and+protocol ClassType compare|and+class - FnType compare|todo + FnType compare|and+fn UnorderedType compare|and+unordered OrderedType compare|and+ordered ValueType compare|and+value @@ -651,12 +655,12 @@ {UniversalSetType (inverted compare|universal+protocol) EmptySetType (inverted compare|empty+protocol) NotType (inverted compare|not+protocol) - OrType compare|todo - AndType compare|todo + OrType (inverted compare|or+protocol) + AndType (inverted compare|and+protocol) Expression fn>< ; TODO not entirely true ProtocolType compare|protocol+protocol ClassType compare|protocol+class - FnType compare|todo + FnType fn>< UnorderedType compare|todo OrderedType compare|todo ValueType compare|protocol+value @@ -670,7 +674,7 @@ Expression fn>< ; TODO not entirely true ProtocolType (inverted compare|protocol+class) ClassType compare|class+class - FnType compare|todo + FnType fn>< UnorderedType compare|class+unordered OrderedType compare|class+ordered ValueType compare|class+value @@ -678,17 +682,17 @@ FnType {UniversalSetType (inverted compare|universal+fn) EmptySetType (inverted compare|empty+fn) - NotType compare|todo - OrType compare|todo - AndType compare|todo + NotType (inverted compare|not+fn) + OrType (inverted compare|or+fn) + AndType (inverted compare|and+fn) Expression compare|todo - ProtocolType compare|todo - ClassType compare|todo + ProtocolType fn>< ; TODO do `t/fn`s actually satisfy any protocols? + ClassType fn>< ; TODO are `t/fn`s `clojure.lang.IFn`s? only dynamic dispatch really is FnType compare|fn+fn - UnorderedType compare|todo - OrderedType compare|todo - ValueType compare|todo - MetaType compare|todo} + UnorderedType fn>< + OrderedType fn>< + ValueType fn>< + MetaType compare|fn+meta} UnorderedType {UniversalSetType (inverted compare|universal+unordered) EmptySetType (inverted compare|empty+unordered) @@ -740,7 +744,7 @@ Expression (inverted compare|expr+meta) ProtocolType (inverted compare|protocol+meta) ClassType (inverted compare|class+meta) - FnType compare|todo + FnType (inverted compare|fn+meta) UnorderedType (inverted compare|unordered+meta) OrderedType (inverted compare|ordered+meta) ValueType (inverted compare|value+meta) @@ -814,12 +818,12 @@ "Used in `t/compare|in` and `t/compare|out`. Might be used for other things too in the future. Commutative in the 2-ary arity. A `t/and`-style combination." - ([cs _ #_(seq-of uset/comparison?) > uset/comparison?] + ([cs _ #_(seq-of comparison?) > comparison?] ;; TODO it's possible to `reduced` early here depending (if (empty? cs) =ident (reduce (fn [c' c] (combine-comparisons c' c)) (first cs) (rest cs)))) - ([c0 uset/comparison?, c1 uset/comparison? > uset/comparison?] + ([c0 comparison?, c1 comparison? > comparison?] (case (long c0) -1 (case (long c1) -1 ident) 0 (case (long c1) -1 ident, 2 >ident) @@ -828,7 +832,7 @@ 3 (case (long c1) -1 <>ident, 0 <>ident, 1 <>ident, 2 <>ident, 3 <>ident)))) (defns compare-inputs - [arg-types0 _ #_(s/vec-of t/type?), arg-types1 _ #_(s/vec-of t/type?) > uset/comparison?] + [arg-types0 _ #_(s/vec-of t/type?), arg-types1 _ #_(s/vec-of t/type?) > comparison?] (let [ct-comparison (c/compare (count arg-types0) (count arg-types1))] (if (zero? ct-comparison) ;; TODO can use educers here From fd3de7be3631475ba579823070776ce852ab223a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 19 Nov 2018 00:06:15 -0700 Subject: [PATCH 752/810] Anonymous `t/ftype`s are about to get support --- src-untyped/quantum/untyped/core/analyze.cljc | 1 + src-untyped/quantum/untyped/core/type.cljc | 6 +- .../quantum/untyped/core/type/defnt.cljc | 73 ------------------ .../untyped/core/type/reifications.cljc | 74 +++++++++++++++++++ 4 files changed, 78 insertions(+), 76 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 8f91f0b6..7fa62f94 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -841,6 +841,7 @@ (t/value t/and) (apply-arg-type-combine t/and input-nodes) (t/value t/-) (apply-arg-type-combine t/- input-nodes) (t/value t/?) (apply-arg-type-combine t/? input-nodes) + (t/value t/ftype) (apply-arg-type-combine t/ftype input-nodes) (t/value t/run) (apply-arg-type-combine t/run input-nodes) (t/value t/ref) (apply-arg-type-combine t/ref input-nodes) (t/value t/unref) (apply-arg-type-combine t/unref input-nodes) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 38fe71aa..80b11822 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -63,7 +63,7 @@ ProtocolType DirectProtocolType ClassType UnorderedType OrderedType ValueType - FnType + FnType AnonFn MetaType MetaOrType ReactiveType])]] [quantum.untyped.core.vars :as uvar @@ -79,7 +79,7 @@ ProtocolType ClassType UnorderedType OrderedType ValueType - FnType + FnType AnonFn MetaType MetaOrType ReactiveType]))) @@ -811,7 +811,7 @@ (reduce (c/fn [classes' t'] (-type>classes t' include-classes-of-value-type? classes')) classes (utr/or-type>args t)) (utr/fn-type? t) - (conj classes Object) ; it's not really a clojure.lang.IFn; the dynamic dispatch is though + (conj classes AnonFn) ; it's not really a clojure.lang.IFn; the dynamic dispatch is though (c/= t val?) ; TODO make this less ad-hoc (-type>classes val|by-class? include-classes-of-value-type? classes) :else diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index d24c683a..db68f483 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -305,79 +305,6 @@ ;; TODO simplify this class computation -;; ===== Concrete Types ===== ;; - -(defprotocol PAnonFn - (setFs [this fs'])) - -;; TODO CLJS -#?(:clj -(deftype AnonFn - [;; the types for direct dispatch overloads - ^"[Ljava.lang.Object;" types - ;; the direct dispatch fn/`reify` overloads - ^:unsynchronized-mutable ^"[Ljava.lang.Object;" fs - ;; the dynamic dispatch fn - ^clojure.lang.IFn dynf] - PAnonFn - (setFs [this fs'] (set! fs fs') this) - clojure.lang.IFn - (invoke [ this] - (.invoke dynf types fs)) - (invoke [ this x0] - (.invoke dynf types fs this x0)) - (invoke [ this x0 x1] - (.invoke dynf types fs x0 x1)) - (invoke [ this x0 x1 x2] - (.invoke dynf types fs x0 x1 x2)) - (invoke [ this x0 x1 x2 x3] - (.invoke dynf types fs x0 x1 x2 x3)) - (invoke [ this x0 x1 x2 x3 x4] - (.invoke dynf types fs x0 x1 x2 x3 x4)) - (invoke [ this x0 x1 x2 x3 x4 x5] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 - (*<> x18))) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 - (*<> x18 x19))) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 - ^"[Ljava.lang.Object;" xs] - (.applyTo dynf (->> xs (cons x19) (cons x18) (cons x17) (cons x16) (cons x15) (cons x14) - (cons x13) (cons x12) (cons x11) (cons x10) (cons x9) (cons x8) - (cons x7) (cons x6) (cons x5) (cons x4) (cons x3) (cons x2) - (cons x1) (cons x0) (cons fs) (cons types)))) - (applyTo [this ^clojure.lang.ISeq xs] (.applyTo dynf (cons types (cons fs xs)))))) - -(c/defn >anon-fn [types gen-fs dynf] - (let [f (AnonFn. types nil dynf)] - (.setFs f (gen-fs f)))) - ;; ===== Arg type/class extraction/comparison ===== ;; #?(:clj diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 5c458554..15fd1991 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -20,6 +20,8 @@ [quantum.untyped.core.compare :refer [== not==]] [quantum.untyped.core.core :as ucore] + [quantum.untyped.core.data.array :as uarr + :refer [*<>]] [quantum.untyped.core.data.hash :as uhash] [quantum.untyped.core.data.reactive :as urx] [quantum.untyped.core.defnt @@ -495,6 +497,78 @@ (update :input-types >vec) (set/rename-keys {:output-type-pair :output-type})))))) +(defprotocol PAnonFn + (setFs [this fs'])) + +;; TODO clean this up and figure out where it goes +;; TODO CLJS +#?(:clj +(deftype AnonFn + [;; the types for direct dispatch overloads + ^"[Ljava.lang.Object;" types + ;; the direct dispatch fn/`reify` overloads + ^:unsynchronized-mutable ^"[Ljava.lang.Object;" fs + ;; the dynamic dispatch fn + ^clojure.lang.IFn dynf] + PAnonFn + (setFs [this fs'] (set! fs fs') this) + clojure.lang.IFn + (invoke [ this] + (.invoke dynf types fs)) + (invoke [ this x0] + (.invoke dynf types fs this x0)) + (invoke [ this x0 x1] + (.invoke dynf types fs x0 x1)) + (invoke [ this x0 x1 x2] + (.invoke dynf types fs x0 x1 x2)) + (invoke [ this x0 x1 x2 x3] + (.invoke dynf types fs x0 x1 x2 x3)) + (invoke [ this x0 x1 x2 x3 x4] + (.invoke dynf types fs x0 x1 x2 x3 x4)) + (invoke [ this x0 x1 x2 x3 x4 x5] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17)) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 + (*<> x18))) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19] + (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 + (*<> x18 x19))) + (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 + ^"[Ljava.lang.Object;" xs] + (.applyTo dynf (->> xs (cons x19) (cons x18) (cons x17) (cons x16) (cons x15) (cons x14) + (cons x13) (cons x12) (cons x11) (cons x10) (cons x9) (cons x8) + (cons x7) (cons x6) (cons x5) (cons x4) (cons x3) (cons x2) + (cons x1) (cons x0) (cons fs) (cons types)))) + (applyTo [this ^clojure.lang.ISeq xs] (.applyTo dynf (cons types (cons fs xs)))))) + +(defn >anon-fn [types gen-fs dynf] + (let [f (AnonFn. types nil dynf)] + (.setFs f (gen-fs f)))) + ;; ----- MetaOrType ----- ;; (udt/deftype MetaOrType From f6b6890070b55dc7644f0ebfa42c7aa1d0bb4602 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 19 Nov 2018 00:07:22 -0700 Subject: [PATCH 753/810] Ensure input types do not overlap --- src/quantum/core/data/numeric.cljc | 30 +++++++++++++++++++----------- 1 file changed, 19 insertions(+), 11 deletions(-) diff --git a/src/quantum/core/data/numeric.cljc b/src/quantum/core/data/numeric.cljc index f8b4fba0..b4a9cf92 100644 --- a/src/quantum/core/data/numeric.cljc +++ b/src/quantum/core/data/numeric.cljc @@ -225,35 +225,43 @@ b bigdec?] (compf a b))) #?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? a bigdec? - b (t/input-type >bigdec :?)] (numeric-compf a (>bigdec b)))) + b (t/- (t/input-type >bigdec :?) bigdec? java-bigint? clj-bigint? ratio?)] + (numeric-compf a (>bigdec b)))) #?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? - a (t/input-type >bigdec :?) + a (t/- (t/input-type >bigdec :?) bigdec? java-bigint? clj-bigint? ratio?) b bigdec?] (numeric-compf (>bigdec a) b))) #?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? a java-bigint? b java-bigint?] (compf a b))) #?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? a java-bigint? - b (t/input-type >java-bigint :?)] (numeric-compf a (>java-bigint b)))) + b (t/- (t/input-type >java-bigint :?) java-bigint? clj-bigint? ratio?)] + (numeric-compf a (>java-bigint b)))) #?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? - a (t/input-type >java-bigint :?) + a (t/- (t/input-type >java-bigint :?) java-bigint? clj-bigint? ratio?) b java-bigint?] (numeric-compf (>java-bigint a) b))) #?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? a clj-bigint? b clj-bigint?] (if (and (p/nil? (.bipart a)) (p/nil? (.bipart b))) (numeric-compf (.lpart a) (.lpart b)) (compf (>java-bigint a) (>java-bigint b))))) -#?(:clj ([a clj-bigint? - b (t/input-type >clj-bigint :?)] (numeric-compf a (>clj-bigint b)))) -#?(:clj ([a (t/input-type >clj-bigint :?) +#?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? + a clj-bigint? + b (t/- (t/input-type >clj-bigint :?) clj-bigint? ratio?)] + (numeric-compf a (>clj-bigint b)))) +#?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? + a (t/- (t/input-type >clj-bigint :?) clj-bigint? ratio?) b clj-bigint?] (numeric-compf (>clj-bigint a) b))) -#?(:clj ([a ratio? +#?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? + a ratio? b ratio?] (numeric-compf ^:val (.multiply ^:val (.numerator a) ^:val (.numerator b)) ^:val (.multiply ^:val (.denominator a) ^:val (.denominator b))))) -#?(:clj ([a ratio? - b (t/input-type >ratio :?)] (numeric-compf a (>ratio b)))) -#?(:clj ([a (t/input-type >ratio :?) +#?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? + a ratio? + b (t/- (t/input-type >ratio :?) ratio?)] (numeric-compf a (>ratio b)))) +#?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? + a (t/- (t/input-type >ratio :?) ratio?) b ratio?] (numeric-compf (>ratio a) b)))) (t/extend-defn! c?/< From 2a50c21f0645782593111845124d9764088b5e98 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 19 Nov 2018 23:45:53 -0700 Subject: [PATCH 754/810] Ensure decompiler works --- project-base.clj | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/project-base.clj b/project-base.clj index 20f7b5b4..bddd593d 100644 --- a/project-base.clj +++ b/project-base.clj @@ -406,13 +406,15 @@ :repl-options {:init '(do (require - '[clj-java-decompiler.core :refer [decompile]] - '[no.disassemble :refer [disassemble]] + '[clj-java-decompiler.core :refer [decompile disassemble]] 'quantum.untyped.core.error 'quantum.untyped.core.meta.debug 'quantum.untyped.core.print 'quantum.untyped.core.print.prettier '[quantum.untyped.core.log :refer [prl!]]) + ;; Otherwise `decompile` won't reliably print anything + (alter-var-root #'clj-java-decompiler.core/output + (constantly (com.strobel.decompiler.PlainTextOutput. *out*))) (quantum.untyped.core.print.prettier/extend-pretty-printing!) ;; For use with Atom's Proto-REPL ;; Interned in `clojure.core` in order to not be clobbered by `refresh` @@ -830,8 +832,7 @@ :resource-paths ["resources-dev"] :source-paths ["src-dev"] :dependencies '[[org.clojure/tools.nrepl "0.2.13"] - [com.clojure-goes-fast/clj-java-decompiler "0.1.1"]] - :plugins '[[lein-nodisassemble "0.1.3"]]} + [com.clojure-goes-fast/clj-java-decompiler "0.1.1"]]} :test {:jvm-opts (>jvm-opts :test)} :prod From 6a350ad5632562ffc9117c6c2d4c4454a53a65f5 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 19 Nov 2018 23:46:02 -0700 Subject: [PATCH 755/810] *<>|sized|macro --- src-untyped/quantum/untyped/core/data/array.cljc | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src-untyped/quantum/untyped/core/data/array.cljc b/src-untyped/quantum/untyped/core/data/array.cljc index f7a25e3f..00487459 100644 --- a/src-untyped/quantum/untyped/core/data/array.cljc +++ b/src-untyped/quantum/untyped/core/data/array.cljc @@ -3,6 +3,8 @@ [array array?]) (:require [clojure.core :as core] + [quantum.untyped.core.core + :refer [case-env]] [quantum.untyped.core.loops :as uloop]) #?(:clj (:import [quantum.core Primitive] @@ -12,6 +14,13 @@ #?(:clj (-> x class .isArray) ; must be reflective :cljs (core/array? x))) +#?(:clj +(defmacro *<>|sized|macro [n] + (case-env :clj `(Array/newUninitialized1dObjectArray ~n) + :cljs `(let [arr# (cljs.core/array)] + (set! (.-length arr#) ~n) + arr#)))) + #?(:clj (defmacro *<>|macro ([] From aea39fc00b99f7fa32b44254716de1e113ce6970 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Mon, 19 Nov 2018 23:46:28 -0700 Subject: [PATCH 756/810] Dispatch getting better fleshed out --- .../untyped/core/type/reifications.cljc | 144 ++--- .../quantum/test/untyped/core/type/defnt.cljc | 508 ++++++++++-------- 2 files changed, 359 insertions(+), 293 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 15fd1991..be94662e 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -497,77 +497,87 @@ (update :input-types >vec) (set/rename-keys {:output-type-pair :output-type})))))) -(defprotocol PAnonFn - (setFs [this fs'])) - -;; TODO clean this up and figure out where it goes -;; TODO CLJS -#?(:clj -(deftype AnonFn - [;; the types for direct dispatch overloads - ^"[Ljava.lang.Object;" types - ;; the direct dispatch fn/`reify` overloads - ^:unsynchronized-mutable ^"[Ljava.lang.Object;" fs +;; ----- FixedFn + ExtensibleFn (for FnType) ----- ;; +;; TODO figure out where this goes + +(defprotocol PTypedFn + (setFs [this fs']) + (setTs [this ts'])) + +(udt/deftype TypedFn + [meta + ;; the types for direct dispatch overloads + ^:! #?(:clj ^"[Ljava.lang.Object;" ts :cljs ^array ts) + ;; the direct dispatch fns / `reify` overloads + ^:! #?(:clj ^"[Ljava.lang.Object;" fs :cljs ^array fs) ;; the dynamic dispatch fn - ^clojure.lang.IFn dynf] - PAnonFn - (setFs [this fs'] (set! fs fs') this) - clojure.lang.IFn - (invoke [ this] - (.invoke dynf types fs)) - (invoke [ this x0] - (.invoke dynf types fs this x0)) - (invoke [ this x0 x1] - (.invoke dynf types fs x0 x1)) - (invoke [ this x0 x1 x2] - (.invoke dynf types fs x0 x1 x2)) - (invoke [ this x0 x1 x2 x3] - (.invoke dynf types fs x0 x1 x2 x3)) - (invoke [ this x0 x1 x2 x3 x4] - (.invoke dynf types fs x0 x1 x2 x3 x4)) - (invoke [ this x0 x1 x2 x3 x4 x5] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17)) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 + #?(:clj ^clojure.lang.IFn dynf :cljs dynf)] + {PTypedFn + {setTs ([this ts'] (set! ts ts') this) + setFs ([this fs'] (set! fs fs') this)} + clojure.lang.IFn + {invoke + (([ this] + (.invoke dynf ts fs)) + ([ this x0] + (.invoke dynf ts fs x0)) + ([ this x0 x1] + (.invoke dynf ts fs x0 x1)) + ([ this x0 x1 x2] + (.invoke dynf ts fs x0 x1 x2)) + ([ this x0 x1 x2 x3] + (.invoke dynf ts fs x0 x1 x2 x3)) + ([ this x0 x1 x2 x3 x4] + (.invoke dynf ts fs x0 x1 x2 x3 x4)) + ([ this x0 x1 x2 x3 x4 x5] + (.invoke dynf ts fs x0 x1 x2 x3 x4 x5)) + ([ this x0 x1 x2 x3 x4 x5 x6] + (.invoke dynf ts fs x0 x1 x2 x3 x4 x5 x6)) + ([ this x0 x1 x2 x3 x4 x5 x6 x7] + (.invoke dynf ts fs x0 x1 x2 x3 x4 x5 x6 x7)) + ([ this x0 x1 x2 x3 x4 x5 x6 x7 x8] + (.invoke dynf ts fs x0 x1 x2 x3 x4 x5 x6 x7 x8)) + ([ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9] + (.invoke dynf ts fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9)) + ([ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10] + (.invoke dynf ts fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)) + ([ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11] + (.invoke dynf ts fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11)) + ([ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12] + (.invoke dynf ts fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12)) + ([ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13] + (.invoke dynf ts fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13)) + ([ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14] + (.invoke dynf ts fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14)) + ([ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15] + (.invoke dynf ts fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15)) + ([ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16] + (.invoke dynf ts fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16)) + ([ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17] + (.invoke dynf ts fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17)) + ([ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18] + (.invoke dynf ts fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 (*<> x18))) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19] - (.invoke dynf types fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 + ([ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19] + (.invoke dynf ts fs x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 (*<> x18 x19))) - (invoke [ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 + ([ this x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 ^"[Ljava.lang.Object;" xs] - (.applyTo dynf (->> xs (cons x19) (cons x18) (cons x17) (cons x16) (cons x15) (cons x14) - (cons x13) (cons x12) (cons x11) (cons x10) (cons x9) (cons x8) - (cons x7) (cons x6) (cons x5) (cons x4) (cons x3) (cons x2) - (cons x1) (cons x0) (cons fs) (cons types)))) - (applyTo [this ^clojure.lang.ISeq xs] (.applyTo dynf (cons types (cons fs xs)))))) - -(defn >anon-fn [types gen-fs dynf] - (let [f (AnonFn. types nil dynf)] - (.setFs f (gen-fs f)))) + (.applyTo dynf (->> xs (cons x19) (cons x18) (cons x17) (cons x16) (cons x15) (cons x14) + (cons x13) (cons x12) (cons x11) (cons x10) (cons x9) (cons x8) + (cons x7) (cons x6) (cons x5) (cons x4) (cons x3) (cons x2) + (cons x1) (cons x0) (cons fs) (cons ts))))) + applyTo ([this ^clojure.lang.ISeq xs] (.applyTo dynf (cons ts (cons fs xs))))} + ?Meta {meta ([this] meta) + with-meta ([this meta'] (TypedFn. meta' ts fs dynf))}}) + +(udt/deftype ExtensibleFn + [;; the types for direct dispatch overloads + ^"[Ljava.lang.Object;" ts + ;; the direct dispatch fn/`reify` overloads + ^:! ^"[Ljava.lang.Object;" fs + ;; the dynamic dispatch fn + ^clojure.lang.IFn dynf]) ;; ----- MetaOrType ----- ;; diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 0e53ba78..9c5beced 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -26,7 +26,7 @@ [quantum.untyped.core.vars :refer [defmeta]]) (:import - [clojure.lang ASeq ISeq LazySeq Named Reduced Seqable] + [clojure.lang ASeq ISeq LazySeq Named Reduced RT Seqable] [quantum.core.data Array] [quantum.core Numeric Primitive] [quantum.untyped.core.type.defnt AnonFn])) @@ -51,37 +51,58 @@ (defn O<> [form] (tag "[Ljava.lang.Object;" form)) (defn ST [form] (tag "java.lang.String" form)) +(defn >B__B [form] (tag (-> 'B__B resolve str) form)) +(defn >Y__Y [form] (tag (-> 'Y__Y resolve str) form)) +(defn >S__S [form] (tag (-> 'S__S resolve str) form)) +(defn >C__C [form] (tag (-> 'C__C resolve str) form)) +(defn >I__I [form] (tag (-> 'I__I resolve str) form)) +(defn >L__L [form] (tag (-> 'L__L resolve str) form)) +(defn >F__F [form] (tag (-> 'F__F resolve str) form)) +(defn >D__D [form] (tag (-> 'D__D resolve str) form)) +(defn >O__O [form] (tag (-> 'O__O resolve str) form)) + (defn cstr [x] (if (-> x resolve class?) (str x) (str (core/namespace x) "." (core/name x)))) +(def ts (O<> 'ts__)) +(def fs (O<> 'fs__)) + +(defn aget* [x i] (list '. 'clojure.lang.RT 'aget x i)) +(defn aset* [x i v] (list '. 'clojure.lang.RT 'aset x i v)) + #?(:clj (deftest test|pid (let [actual (binding [self/*compilation-mode* :test] (macroexpand ' - (self/defn pid|test [> (t/? t/string?)] + (self/defn pid [> (t/? t/string?)] (->> ^:val (java.lang.management.ManagementFactory/getRuntimeMXBean) (.getName))))) expected - ($ (do (declare ~'pid|test) - (def ~(tag (cstr `>Object) 'pid|test|__0) - (reify* [>Object] - (~(O 'invoke) [~'_0__] - ~(ST (list '. - (tag "java.lang.management.RuntimeMXBean" - '(. java.lang.management.ManagementFactory getRuntimeMXBean)) - 'getName))))) + ($ (do (declare ~'pid) [[0 0 false [] (t/or t/nil? t/string?)]] - (defmeta ~'pid|test - {:quantum.core.type/type pid|test|__type} - (fn* ([] (. pid|test|__0 ~'invoke))))))] + (defmeta-from ~'pid + (let* [~fs (*<>|sized|macro 0) + ~'f__ (new TypedFn + {:quantum.core.type/type ...} + pid|__!types ; defined/created within `t/defn` + fs + (fn* ([~ts ~fs] (. ~(aget* fs 0) ~'invoke))))] + ~(aset* fs 0 + `(reify* [__O] + (~(O 'invoke) [~'_0__] + ~(ST (list '. + (tag "java.lang.management.RuntimeMXBean" + '(. java.lang.management.ManagementFactory getRuntimeMXBean)) + 'getName))))) + f))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) - (eval '(do (is (t/string? (pid|test))) - (throws (pid|test 1)))))))) + (eval '(do (is (t/string? (pid))) + (throws (pid 1)))))))) (deftest test|identity (let [actual @@ -95,24 +116,24 @@ ;; [x t/any?] - (def ~(tag (cstr `boolean>boolean) 'identity|__0) - (reify* [boolean>boolean] (~(B 'invoke) [~'_0__ ~(B 'x)] ~'x))) - (def ~(tag (cstr `byte>byte) 'identity|__1) - (reify* [byte>byte] (~(Y 'invoke) [~'_1__ ~(Y 'x)] ~'x))) - (def ~(tag (cstr `short>short) 'identity|__2) - (reify* [short>short] (~(S 'invoke) [~'_2__ ~(S 'x)] ~'x))) - (def ~(tag (cstr `char>char) 'identity|__3) - (reify* [char>char] (~(C 'invoke) [~'_3__ ~(C 'x)] ~'x))) - (def ~(tag (cstr `int>int) 'identity|__4) - (reify* [int>int] (~(I 'invoke) [~'_4__ ~(I 'x)] ~'x))) - (def ~(tag (cstr `long>long) 'identity|__5) - (reify* [long>long] (~(L 'invoke) [~'_5__ ~(L 'x)] ~'x))) - (def ~(tag (cstr `float>float) 'identity|__6) - (reify* [float>float] (~(F 'invoke) [~'_6__ ~(F 'x)] ~'x))) - (def ~(tag (cstr `double>double) 'identity|__7) - (reify* [double>double] (~(D 'invoke) [~'_7__ ~(D 'x)] ~'x))) - (def ~(tag (cstr `Object>Object) 'identity|__8) - (reify* [Object>Object] (~(O 'invoke) [~'_8__ ~(O 'x)] ~(O 'x)))) + (def ~(>B__B 'identity|__0) + (reify* [B__B] (~(B 'invoke) [~'_0__ ~(B 'x)] ~'x))) + (def ~(>Y__Y 'identity|__1) + (reify* [Y__Y] (~(Y 'invoke) [~'_1__ ~(Y 'x)] ~'x))) + (def ~(>S__S 'identity|__2) + (reify* [S__S] (~(S 'invoke) [~'_2__ ~(S 'x)] ~'x))) + (def ~(>C__C 'identity|__3) + (reify* [C__C] (~(C 'invoke) [~'_3__ ~(C 'x)] ~'x))) + (def ~(>I__I 'identity|__4) + (reify* [I__I] (~(I 'invoke) [~'_4__ ~(I 'x)] ~'x))) + (def ~(>L__L 'identity|__5) + (reify* [L__L] (~(L 'invoke) [~'_5__ ~(L 'x)] ~'x))) + (def ~(>F__F 'identity|__6) + (reify* [F__F] (~(F 'invoke) [~'_6__ ~(F 'x)] ~'x))) + (def ~(>D__D 'identity|__7) + (reify* [D__D] (~(D 'invoke) [~'_7__ ~(D 'x)] ~'x))) + (def ~(>O__O 'identity|__8) + (reify* [O__O] (~(O 'invoke) [~'_8__ ~(O 'x)] ~(O 'x)))) [[0 0 true [t/boolean?] t/boolean?] [1 1 true [t/byte?] t/byte?] @@ -173,13 +194,13 @@ ;; [x t/string?] - (def ~(tag (cstr `Object>Object) 'name|__0) - (reify* [Object>Object] (~(O 'invoke) [~'_0__ ~(O 'x)] ~(ST 'x)))) + (def ~(>O__O 'name|__0) + (reify* [O__O] (~(O 'invoke) [~'_0__ ~(O 'x)] ~(ST 'x)))) ;; [x (t/isa? Named)] > (t/run t/string?) - (def ~(tag (cstr `Object>Object) 'name|__1) - (reify* [Object>Object] + (def ~(>O__O 'name|__1) + (reify* [O__O] (~(O 'invoke) [~'_1__ ~(O 'x)] (t/validate ~(ST (list '. (tag "clojure.lang.Named" 'x) 'getName)) ~'(t/run t/string?))))) @@ -225,29 +246,29 @@ ;; [x t/nil?] - (def ~(tag (cstr `Object>boolean) 'some?|__0) - (reify* [Object>boolean] (~(B 'invoke) [~'_0__ ~(O 'x)] false))) + (def ~(tag (cstr `O__B) 'some?|__0) + (reify* [O__B] (~(B 'invoke) [~'_0__ ~(O 'x)] false))) ;; [x t/any?] - (def ~(tag (cstr `boolean>boolean) 'some?|__1) - (reify* [boolean>boolean] (~(B 'invoke) [~'_1__ ~(B 'x)] true))) - (def ~(tag (cstr `byte>boolean) 'some?|__2) - (reify* [byte>boolean] (~(B 'invoke) [~'_2__ ~(Y 'x)] true))) - (def ~(tag (cstr `short>boolean) 'some?|__3) - (reify* [short>boolean] (~(B 'invoke) [~'_3__ ~(S 'x)] true))) - (def ~(tag (cstr `char>boolean) 'some?|__4) - (reify* [char>boolean] (~(B 'invoke) [~'_4__ ~(C 'x)] true))) - (def ~(tag (cstr `int>boolean) 'some?|__5) - (reify* [int>boolean] (~(B 'invoke) [~'_5__ ~(I 'x)] true))) - (def ~(tag (cstr `long>boolean) 'some?|__6) - (reify* [long>boolean] (~(B 'invoke) [~'_6__ ~(L 'x)] true))) - (def ~(tag (cstr `float>boolean) 'some?|__7) - (reify* [float>boolean] (~(B 'invoke) [~'_7__ ~(F 'x)] true))) - (def ~(tag (cstr `double>boolean) 'some?|__8) - (reify* [double>boolean] (~(B 'invoke) [~'_8__ ~(D 'x)] true))) - (def ~(tag (cstr `Object>boolean) 'some?|__9) - (reify* [Object>boolean] (~(B 'invoke) [~'_9__ ~(O 'x)] true))) + (def ~(>B__B 'some?|__1) + (reify* [B__B] (~(B 'invoke) [~'_1__ ~(B 'x)] true))) + (def ~(>Y__B 'some?|__2) + (reify* [Y__B] (~(B 'invoke) [~'_2__ ~(Y 'x)] true))) + (def ~(>S__B 'some?|__3) + (reify* [S__B] (~(B 'invoke) [~'_3__ ~(S 'x)] true))) + (def ~(>C__B 'some?|__4) + (reify* [C__B] (~(B 'invoke) [~'_4__ ~(C 'x)] true))) + (def ~(>I__B 'some?|__5) + (reify* [I__B] (~(B 'invoke) [~'_5__ ~(I 'x)] true))) + (def ~(>L__B 'some?|__6) + (reify* [L__B] (~(B 'invoke) [~'_6__ ~(L 'x)] true))) + (def ~(>F__B 'some?|__7) + (reify* [F__B] (~(B 'invoke) [~'_7__ ~(F 'x)] true))) + (def ~(>D__B 'some?|__8) + (reify* [D__B] (~(B 'invoke) [~'_8__ ~(D 'x)] true))) + (def ~(>O__B 'some?|__9) + (reify* [O__B] (~(B 'invoke) [~'_9__ ~(O 'x)] true))) [{:id 0 :index 0 :arg-types [(t/value nil)] :output-type (t/isa? Boolean)} {:id 1 :index 1 :arg-types [(t/isa? Boolean)] :output-type (t/isa? Boolean)} @@ -303,15 +324,14 @@ ($ (do ;; [x (t/isa? Reduced)] (def ~'reduced?|test|__0|0 - (reify* [Object>boolean] + (reify* [O__B] (~(B 'invoke) [~'_0__ ~(O 'x)] (let* [~(tag "clojure.lang.Reduced" 'x) ~'x] true)))) ;; [x t/any?] (def ~'reduced?|test|__1|0 - (reify* [Object>boolean boolean>boolean byte>boolean short>boolean - char>boolean int>boolean long>boolean float>boolean double>boolean] + (reify* [O__B B__B Y__B S__B C__B I__B L__B F__B D__B] (~(B 'invoke) [~'_1__ ~(O 'x)] false) (~(B 'invoke) [~'_2__ ~(B 'x)] false) (~(B 'invoke) [~'_3__ ~(Y 'x)] false) @@ -365,7 +385,7 @@ (def ~(O<> '>boolean|__0|input0|types) (*<> (t/isa? Boolean))) (def ~'>boolean|__0|0 - (reify* [boolean>boolean] + (reify* [B__B] (~(B 'invoke) [~'_0__ ~(B 'x)] ~'x))) ;; [x t/nil? -> (- t/nil? tt/boolean?)] @@ -373,7 +393,7 @@ (def ~(O<> '>boolean|__1|input0|types) (*<> (t/value nil))) (def ~'>boolean|__1|0 - (reify* [Object>boolean] + (reify* [O__B] (~(B 'invoke) [~'_1__ ~(O 'x)] false))) ;; [x t/any? -> (- t/any? t/nil? tt/boolean?)] @@ -381,8 +401,7 @@ (def ~(O<> '>boolean|__2|input0|types) (*<> t/any?)) (def ~'>boolean|__2|0 - (reify* [Object>boolean boolean>boolean byte>boolean short>boolean - char>boolean int>boolean long>boolean float>boolean double>boolean] + (reify* [O__B B__B Y__B S__B C__B I__B L__B F__B D__B] (~(B 'invoke) [~'_2__ ~(O 'x)] true) (~(B 'invoke) [~'_3__ ~(B 'x)] true) (~(B 'invoke) [~'_4__ ~(Y 'x)] true) @@ -401,12 +420,12 @@ ~'[t/any?])} ([~'x00__] (ifs ((Array/get ~'>boolean|__0|input0|types 0) ~'x00__) - (.invoke ~(tag (cstr `boolean>boolean) '>boolean|__0|0) ~'x00__) + (.invoke ~(tag (cstr `B__B) '>boolean|__0|0) ~'x00__) ((Array/get ~'>boolean|__1|input0|types 0) ~'x00__) - (.invoke ~(tag (cstr `Object>boolean) '>boolean|__1|0) ~'x00__) + (.invoke ~(tag (cstr `O__B) '>boolean|__1|0) ~'x00__) ;; TODO eliminate this check because it's not needed (`t/any?`) ((Array/get ~'>boolean|__2|input0|types 0) ~'x00__) - (.invoke ~(tag (cstr `Object>boolean) '>boolean|__2|0) ~'x00__) + (.invoke ~(tag (cstr `O__B) '>boolean|__2|0) ~'x00__) (unsupported! `>boolean [~'x00__] 0)))))) :cljs ($ (do (defn ~'>boolean [~'x] @@ -762,152 +781,152 @@ ;; [a t/comparable-primitive? b t/comparable-primitive? > tt/boolean?] - (def ~(tag (cstr `byte+byte>boolean) '>|__0) - (reify* [byte+byte>boolean] + (def ~(tag (cstr `byte+Y__B) '>|__0) + (reify* [byte+Y__B] (~(B 'invoke) [~'_0__ ~(Y 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `byte+short>boolean) '>|__1) - (reify* [byte+short>boolean] + (def ~(tag (cstr `byte+S__B) '>|__1) + (reify* [byte+S__B] (~(B 'invoke) [~'_1__ ~(Y 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `byte+char>boolean) '>|__2) - (reify* [byte+char>boolean] + (def ~(tag (cstr `byte+C__B) '>|__2) + (reify* [byte+C__B] (~(B 'invoke) [~'_2__ ~(Y 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `byte+int>boolean) '>|__3) - (reify* [byte+int>boolean] + (def ~(tag (cstr `byte+I__B) '>|__3) + (reify* [byte+I__B] (~(B 'invoke) [~'_3__ ~(Y 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `byte+long>boolean) '>|__4) - (reify* [byte+long>boolean] + (def ~(tag (cstr `byte+L__B) '>|__4) + (reify* [byte+L__B] (~(B 'invoke) [~'_4__ ~(Y 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `byte+float>boolean) '>|__5) - (reify* [byte+float>boolean] + (def ~(tag (cstr `byte+F__B) '>|__5) + (reify* [byte+F__B] (~(B 'invoke) [~'_5__ ~(Y 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `byte+double>boolean) '>|__6) - (reify* [byte+double>boolean] + (def ~(tag (cstr `byte+D__B) '>|__6) + (reify* [byte+D__B] (~(B 'invoke) [~'_6__ ~(Y 'a) ~(D 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `short+byte>boolean) '>|__7) - (reify* [short+byte>boolean] + (def ~(tag (cstr `short+Y__B) '>|__7) + (reify* [short+Y__B] (~(B 'invoke) [~'_7__ ~(S 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `short+short>boolean) '>|__8) - (reify* [short+short>boolean] + (def ~(tag (cstr `short+S__B) '>|__8) + (reify* [short+S__B] (~(B 'invoke) [~'_8__ ~(S 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `short+char>boolean) '>|__9) - (reify* [short+char>boolean] + (def ~(tag (cstr `short+C__B) '>|__9) + (reify* [short+C__B] (~(B 'invoke) [~'_9__ ~(S 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `short+int>boolean) '>|__10) - (reify* [short+int>boolean] + (def ~(tag (cstr `short+I__B) '>|__10) + (reify* [short+I__B] (~(B 'invoke) [~'_10__ ~(S 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `short+long>boolean) '>|__11) - (reify* [short+long>boolean] + (def ~(tag (cstr `short+L__B) '>|__11) + (reify* [short+L__B] (~(B 'invoke) [~'_11__ ~(S 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `short+float>boolean) '>|__12) - (reify* [short+float>boolean] + (def ~(tag (cstr `short+F__B) '>|__12) + (reify* [short+F__B] (~(B 'invoke) [~'_12__ ~(S 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `short+double>boolean) '>|__13) - (reify* [short+double>boolean] + (def ~(tag (cstr `short+D__B) '>|__13) + (reify* [short+D__B] (~(B 'invoke) [~'_13__ ~(S 'a) ~(D 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `char+byte>boolean) '>|__14) - (reify* [char+byte>boolean] + (def ~(tag (cstr `char+Y__B) '>|__14) + (reify* [char+Y__B] (~(B 'invoke) [~'_14__ ~(C 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `char+short>boolean) '>|__15) - (reify* [char+short>boolean] + (def ~(tag (cstr `char+S__B) '>|__15) + (reify* [char+S__B] (~(B 'invoke) [~'_15__ ~(C 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `char+char>boolean) '>|__16) - (reify* [char+char>boolean] + (def ~(tag (cstr `char+C__B) '>|__16) + (reify* [char+C__B] (~(B 'invoke) [~'_16__ ~(C 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `char+int>boolean) '>|__17) - (reify* [char+int>boolean] + (def ~(tag (cstr `char+I__B) '>|__17) + (reify* [char+I__B] (~(B 'invoke) [~'_17__ ~(C 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `char+long>boolean) '>|__18) - (reify* [char+long>boolean] + (def ~(tag (cstr `char+L__B) '>|__18) + (reify* [char+L__B] (~(B 'invoke) [~'_18__ ~(C 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `char+float>boolean) '>|__19) - (reify* [char+float>boolean] + (def ~(tag (cstr `char+F__B) '>|__19) + (reify* [char+F__B] (~(B 'invoke) [~'_19__ ~(C 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `char+double>boolean) '>|__20) - (reify* [char+double>boolean] + (def ~(tag (cstr `char+D__B) '>|__20) + (reify* [char+D__B] (~(B 'invoke) [~'_20__ ~(C 'a) ~(D 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `int+byte>boolean) '>|__21) - (reify* [int+byte>boolean] + (def ~(tag (cstr `int+Y__B) '>|__21) + (reify* [int+Y__B] (~(B 'invoke) [~'_21__ ~(I 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `int+short>boolean) '>|__22) - (reify* [int+short>boolean] + (def ~(tag (cstr `int+S__B) '>|__22) + (reify* [int+S__B] (~(B 'invoke) [~'_22__ ~(I 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `int+char>boolean) '>|__23) - (reify* [int+char>boolean] + (def ~(tag (cstr `int+C__B) '>|__23) + (reify* [int+C__B] (~(B 'invoke) [~'_23__ ~(I 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `int+int>boolean) '>|__24) - (reify* [int+int>boolean] + (def ~(tag (cstr `int+I__B) '>|__24) + (reify* [int+I__B] (~(B 'invoke) [~'_24__ ~(I 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `int+long>boolean) '>|__25) - (reify* [int+long>boolean] + (def ~(tag (cstr `int+L__B) '>|__25) + (reify* [int+L__B] (~(B 'invoke) [~'_25__ ~(I 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `int+float>boolean) '>|__26) - (reify* [int+float>boolean] + (def ~(tag (cstr `int+F__B) '>|__26) + (reify* [int+F__B] (~(B 'invoke) [~'_26__ ~(I 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `int+double>boolean) '>|__27) - (reify* [int+double>boolean] + (def ~(tag (cstr `int+D__B) '>|__27) + (reify* [int+D__B] (~(B 'invoke) [~'_27__ ~(I 'a) ~(D 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `long+byte>boolean) '>|__28) - (reify* [long+byte>boolean] + (def ~(tag (cstr `long+Y__B) '>|__28) + (reify* [long+Y__B] (~(B 'invoke) [~'_28__ ~(L 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `long+short>boolean) '>|__29) - (reify* [long+short>boolean] + (def ~(tag (cstr `long+S__B) '>|__29) + (reify* [long+S__B] (~(B 'invoke) [~'_29__ ~(L 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `long+char>boolean) '>|__30) - (reify* [long+char>boolean] + (def ~(tag (cstr `long+C__B) '>|__30) + (reify* [long+C__B] (~(B 'invoke) [~'_30__ ~(L 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `long+int>boolean) '>|__31) - (reify* [long+int>boolean] + (def ~(tag (cstr `long+I__B) '>|__31) + (reify* [long+I__B] (~(B 'invoke) [~'_31__ ~(L 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `long+long>boolean) '>|__32) - (reify* [long+long>boolean] + (def ~(tag (cstr `long+L__B) '>|__32) + (reify* [long+L__B] (~(B 'invoke) [~'_32__ ~(L 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `long+float>boolean) '>|__33) - (reify* [long+float>boolean] + (def ~(tag (cstr `long+F__B) '>|__33) + (reify* [long+F__B] (~(B 'invoke) [~'_33__ ~(L 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `long+double>boolean) '>|__34) - (reify* [long+double>boolean] + (def ~(tag (cstr `long+D__B) '>|__34) + (reify* [long+D__B] (~(B 'invoke) [~'_34__ ~(L 'a) ~(D 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `float+byte>boolean) '>|__35) - (reify* [float+byte>boolean] + (def ~(tag (cstr `float+Y__B) '>|__35) + (reify* [float+Y__B] (~(B 'invoke) [~'_35__ ~(F 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `float+short>boolean) '>|__36) - (reify* [float+short>boolean] + (def ~(tag (cstr `float+S__B) '>|__36) + (reify* [float+S__B] (~(B 'invoke) [~'_36__ ~(F 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `float+char>boolean) '>|__37) - (reify* [float+char>boolean] + (def ~(tag (cstr `float+C__B) '>|__37) + (reify* [float+C__B] (~(B 'invoke) [~'_37__ ~(F 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `float+int>boolean) '>|__38) - (reify* [float+int>boolean] + (def ~(tag (cstr `float+I__B) '>|__38) + (reify* [float+I__B] (~(B 'invoke) [~'_38__ ~(F 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `float+long>boolean) '>|__39) - (reify* [float+long>boolean] + (def ~(tag (cstr `float+L__B) '>|__39) + (reify* [float+L__B] (~(B 'invoke) [~'_39__ ~(F 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `float+float>boolean) '>|__40) - (reify* [float+float>boolean] + (def ~(tag (cstr `float+F__B) '>|__40) + (reify* [float+F__B] (~(B 'invoke) [~'_40__ ~(F 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `float+double>boolean) '>|__41) - (reify* [float+double>boolean] + (def ~(tag (cstr `float+D__B) '>|__41) + (reify* [float+D__B] (~(B 'invoke) [~'_41__ ~(F 'a) ~(D 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `double+byte>boolean) '>|__42) - (reify* [double+byte>boolean] + (def ~(tag (cstr `double+Y__B) '>|__42) + (reify* [double+Y__B] (~(B 'invoke) [~'_42__ ~(D 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `double+short>boolean) '>|__43) - (reify* [double+short>boolean] + (def ~(tag (cstr `double+S__B) '>|__43) + (reify* [double+S__B] (~(B 'invoke) [~'_43__ ~(D 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `double+char>boolean) '>|__44) - (reify* [double+char>boolean] + (def ~(tag (cstr `double+C__B) '>|__44) + (reify* [double+C__B] (~(B 'invoke) [~'_44__ ~(D 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `double+int>boolean) '>|__45) - (reify* [double+int>boolean] + (def ~(tag (cstr `double+I__B) '>|__45) + (reify* [double+I__B] (~(B 'invoke) [~'_45__ ~(D 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `double+long>boolean) '>|__46) - (reify* [double+long>boolean] + (def ~(tag (cstr `double+L__B) '>|__46) + (reify* [double+L__B] (~(B 'invoke) [~'_46__ ~(D 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `double+float>boolean) '>|__47) - (reify* [double+float>boolean] + (def ~(tag (cstr `double+F__B) '>|__47) + (reify* [double+F__B] (~(B 'invoke) [~'_47__ ~(D 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `double+double>boolean) '>|__48) - (reify* [double+double>boolean] + (def ~(tag (cstr `double+D__B) '>|__48) + (reify* [double+D__B] (~(B 'invoke) [~'_48__ ~(D 'a) ~(D 'b)] ~'(. Numeric gt a b)))) ~>|types-form @@ -2490,12 +2509,6 @@ ;: FIXME this contract is not being held up when returning nil (self/defn f0 [a (t/or tt/boolean? tt/double?) > (t/ftype [tt/byte? :> (t/ftype [tt/char?])])] - ;; TODO When outputting this anon fn, any consumer can call it dynamically just - ;; fine but in order to call it directly, it needs to know its actual (not - ;; declared) type to know what indices map to what overloads. This means that - ;; it's not good enough for callers to know that `(t/ftype [tt/char?])` is - ;; outputted; they need to know that a `[(t/or tt/byte? tt/char?) :> ...]` is - ;; outputted. ;; TODO this fits into a larger scheme of, should we have output types be ;; `(t/and actual declared)` or should we just have them be `declared`? The ;; latter is easier but it seems like the `t/fn` dispatch forces our hand @@ -2508,59 +2521,102 @@ (case (env-lang) :clj ($ (do (declare ~'f0) - -(def ~'f0|__0 - (reify* [boolean>Object] - (~'invoke [~'_0__ ~(B 'a)] - ;; From `(self/fn [b ...])` - (self/>anon-fn - ;; TODO perhaps extern this (and parts thereof) whenever possible in `let*` - ;; statement on the very outside of the fn (so around the outer `reify*`) ? - (*<>|macro (*<>|macro (t/isa? Byte)) (*<>|macro (t/isa? Character))) - (*<>|macro - (reify* [byte>Object] - (~'invoke [~'_0__ ~(Y 'b)] - ;; From `(self/fn [c ...])` - (self/>anon-fn - (*<>|macro (*<>|macro (t/isa? Boolean)) (*<>|macro (t/isa? Short))) - (fn* [~(tag (cstr `AnonFn) 'this__)] - (*<>|macro - (reify* [boolean>Object] - (~'invoke [~'_0__ (B 'c)] - ~'b - (. (tag (cstr `boolean>Object) (Array/get (.-fs ~'this__) 0)) ~'invoke ~'a) - (. (tag (cstr `boolean>Object) (Array/get (.-fs ~'this__) 0)) ~'invoke ~'c))) - (reify* [short>Object] - (~'invoke [~'_0__ (S 'c)] - ~'b - (. (tag (cstr `boolean>Object) (Array/get (.-fs ~'this__) 0)) ~'invoke ~'a) - (. (tag (cstr `short>Object) (Array/get (.-fs ~'this__) 1)) ~'invoke ~'c))))) - (fn* ([~(O<> 'types__) ~(O<> 'fs__) ~'x00] - (ifs ((Array/get (Array/get ~'types__ 0) 0) ~'x00__) - (. ~(tag (cstr `boolean>Object) `(Array/get ~'fs__ 0)) - ~'invoke ~'x00__) - ((Array/get (Array/get ~'types__ 1) 0) ~'x00__) - (. ~(tag (cstr `short>Object) `(Array/get ~'fs__ 1)) - ~'invoke ~'x00__) - (unsupported! [~'x00__] 0))))))) - (reify* [char>Object] - (~'invoke [~'_0__ ~(C 'a)] ...))) - (fn* ([~(O<> 'types__) ~(O<> 'fs__) ~'x00__] - (ifs ((Array/get (Array/get ~'types__ 0) 0) ~'x00__) - (. ~(tag (cstr `byte>Object) `(Array/get ~'fs__ 0)) ~'invoke ~'x00__) - ((Array/get (Array/get ~'types__ 1) 0) ~'x00__) - (. ~(tag (cstr `char>Object) `(Array/get ~'fs__ 1)) ~'invoke ~'x00__) - (unsupported! [~'x00__] 0))))))) -(def ~'f0|__1 - (reify* [double>Object] - (~'invoke [~'_0__ ~(D 'a)] ...))) -[[0 0 false [] (t/ftype tt/boolean? [tt/byte? :> (t/ftype [tt/char?])])]] -(defmeta ~'f0 - {:quantum.core.type/type ~'f0|__type} - (fn* ([~'x00__] - (ifs ((Array/get f0|__0|types 0) ~'x00__) - (. f0|__0 ~'invoke ~'x00__) - ((Array/get f0|__1|types 0) ~'x00__) - (. f0|__1 ~'invoke ~'x00__) - (unsupported! `f0 [~'x00__] 0))))))))] + [[0 0 false [] (t/ftype tt/boolean? [tt/byte? :> (t/ftype [tt/char?])])]] +(defmeta-from ~'f0 + (let* [fs (*<>|sized|macro 2) + f (new TypedFn + {:quantum.core.type/type ~'f0|__type} + (fn* ([~ts ~fs ~'x00__] + (ifs (~(aget* (aget* ts 0) 0) ~'x00__) + (. ~(aget* ts 0) ~'invoke ~'x00__) + (~(aget* (aget* ts 1) 0) ~'x00__) + (. ~(aget* ts 1) ~'invoke ~'x00__) + (unsupported! `f0 [~'x00__] 0)))))] + ~(aset* fs 0 + `(reify* [boolean>Object] + (~'invoke [~'_0__ ~(B 'a)] + ;; From `(self/fn [b ...])` + (self/>anon-fn + ;; TODO perhaps extern this (and parts thereof) whenever possible in `let*` + ;; statement on the very outside of the fn (so around the outer `reify*`) ? + (*<>|macro (*<>|macro (t/isa? Byte)) (*<>|macro (t/isa? Character))) + (*<>|macro + (reify* [byte>Object] + (~'invoke [~'_0__ ~(Y 'b)] + ;; From `(self/fn [c ...])` + (self/>anon-fn + (*<>|macro (*<>|macro (t/isa? Boolean)) (*<>|macro (t/isa? Short))) + (fn* [~(tag (cstr `AnonFn) 'this__)] + (*<>|macro + (reify* [boolean>Object] + (~'invoke [~'_0__ (B 'c)] + ~'b + (. (tag (cstr `boolean>Object) (Array/get (.-fs ~'this__) 0)) ~'invoke ~'a) + (. (tag (cstr `boolean>Object) (Array/get (.-fs ~'this__) 0)) ~'invoke ~'c))) + (reify* [short>Object] + (~'invoke [~'_0__ (S 'c)] + ~'b + (. (tag (cstr `boolean>Object) (Array/get (.-fs ~'this__) 0)) ~'invoke ~'a) + (. (tag (cstr `short>Object) (Array/get (.-fs ~'this__) 1)) ~'invoke ~'c))))) + (fn* ([~(O<> 'types__) ~(O<> 'fs__) ~'x00] + (ifs ((Array/get (Array/get ~'types__ 0) 0) ~'x00__) + (. ~(tag (cstr `boolean>Object) `(Array/get ~'fs__ 0)) + ~'invoke ~'x00__) + ((Array/get (Array/get ~'types__ 1) 0) ~'x00__) + (. ~(tag (cstr `short>Object) `(Array/get ~'fs__ 1)) + ~'invoke ~'x00__) + (unsupported! [~'x00__] 0))))))) + (reify* [char>Object] + (~'invoke [~'_0__ ~(C 'a)] ...))) + (fn* ([~(O<> 'types__) ~(O<> 'fs__) ~'x00__] + (ifs ((Array/get (Array/get ~'types__ 0) 0) ~'x00__) + (. ~(tag (cstr `byte>Object) `(Array/get ~'fs__ 0)) ~'invoke ~'x00__) + ((Array/get (Array/get ~'types__ 1) 0) ~'x00__) + (. ~(tag (cstr `char>Object) `(Array/get ~'fs__ 1)) ~'invoke ~'x00__) + (unsupported! [~'x00__] 0))))))) + ~(aset* fs 1 + `(reify* [double>Object] + (~'invoke [~'_0__ ~(D 'a)] ...))))) + +)))] )) + + +" +FIXME the below can be fixed if each `t/fn` and/or `t/defn` was encapsulated by a concrete type, +like AnonFn, that stored references to the types, overloads, etc. +We should probably have standard overload indices for ftypes (maybe we already do? we should sort +ftypes' overload-types in the same way that we sort `t/defn` overload-types. maybe that will make it +standard) so direct dispatch can be performed even in the absence of an fn-name. + +We could do: +`(. ^TheReifyType (aget (.-ts f) ) invoke <~@args>)` +- This is all fine when `f` is `=` (perhaps `t/=`?) to the declared type, but when it's `t/<`, it + may allow for more than what the declared type requires, in which case it may have more and/or + different overloads. So do something like this: + (t/defn a [f (t/ftype [t/long?])] (f 1)) + -> (def a|__0 (reify [_ ^TypedFn f ^int f|__i] (.invoke ^long>Object (RT/aget (.-overloads f) f|__i) 1))) + (t/defn b [x (t/or t/boolean? t/long?)] x) + (t/dotyped (a b)) + -> (.invoke a|__0 b|__f 1) ; meaning, use the overload at index 1. If -1 then + + This would require arglist expansion which is kind of a pain but stack allocation is always + cheaper than heap. + +TODO let's see what we can do with the expansion/inlining of `compf`. It may prove subtle/tricky? +" +{:message "No name found for typed fn corresponding to caller", + :data {:type (quantum.untyped.core.type/ftype + (quantum.untyped.core.type/isa? + java.lang.Boolean) + [(quantum.untyped.core.type/or + (quantum.untyped.core.type/isa? + java.lang.Number) + (quantum.untyped.core.type/isa? + java.lang.Character)) + (quantum.untyped.core.type/or + (quantum.untyped.core.type/isa? + java.lang.Number) + (quantum.untyped.core.type/isa? + java.lang.Character))]), + :form numeric-compf}} From ae3b8ad6e55d002e7f81989971c6f0873f7d87dc Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 20 Nov 2018 00:21:00 -0700 Subject: [PATCH 757/810] `t/fn` test/example is actually more straightforward than expected --- .../quantum/untyped/core/type/defnt.cljc | 8 +- .../untyped/core/type/reifications.cljc | 10 +- .../quantum/test/untyped/core/type/defnt.cljc | 188 +++++++++--------- 3 files changed, 101 insertions(+), 105 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index db68f483..a0bf211d 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -868,9 +868,11 @@ `(. ~reify-name ~uana/direct-dispatch-method-sym ~@args-codelist)) ;; TODO spec -(defns unsupported! [name- _ #_t/qualified-symbol?, args _ #_indexed?, i index?] - (throw (ex-info "This function is unsupported for the type combination at the argument index." - {:name name- :args args :arg-index i}))) +(defns unsupported! + ([args _ #_indexed?, i index?] (unsupported! nil args i) + ([name- _ #_t/qualified-symbol?, args _ #_indexed?, i index?] + (throw (ex-info "This function is unsupported for the type combination at the argument index." + {:name (if (nil? name-) '#anonymous name-) :args args :arg-index i})))) (defns- >combinatoric-seq+ [{:as fn|globals :keys [fn|ns-name _ fn|name _]} ::fn|globals diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index be94662e..df4270a1 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -497,7 +497,7 @@ (update :input-types >vec) (set/rename-keys {:output-type-pair :output-type})))))) -;; ----- FixedFn + ExtensibleFn (for FnType) ----- ;; +;; ----- TypedFn (for FnType) ----- ;; ;; TODO figure out where this goes (defprotocol PTypedFn @@ -571,14 +571,6 @@ ?Meta {meta ([this] meta) with-meta ([this meta'] (TypedFn. meta' ts fs dynf))}}) -(udt/deftype ExtensibleFn - [;; the types for direct dispatch overloads - ^"[Ljava.lang.Object;" ts - ;; the direct dispatch fn/`reify` overloads - ^:! ^"[Ljava.lang.Object;" fs - ;; the dynamic dispatch fn - ^clojure.lang.IFn dynf]) - ;; ----- MetaOrType ----- ;; (udt/deftype MetaOrType diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 9c5beced..cd8fe736 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -1057,13 +1057,13 @@ ;; [x tt/boolean? > (t/ref tt/boolean?)] - (def ~(tag (cstr `boolean>Object) 'ref-output-type|__0) - (reify* [boolean>Object] (~(O 'invoke) [~'_0__ ~(B 'x)] (new ~'Boolean ~'x)))) + (def ~(tag (cstr `B__O) 'ref-output-type|__0) + (reify* [B__O] (~(O 'invoke) [~'_0__ ~(B 'x)] (new ~'Boolean ~'x)))) ;; [x tt/byte? > (t/ref tt/byte?)] - (def ~(tag (cstr `byte>Object) 'ref-output-type|__1) - (reify* [byte>Object] (~(O 'invoke) [~'_1__ ~(Y 'x)] (new ~'Byte ~'x)))) + (def ~(tag (cstr `Y__O) 'ref-output-type|__1) + (reify* [Y__O] (~(O 'invoke) [~'_1__ ~(Y 'x)] (new ~'Byte ~'x)))) [[0 0 nil [(t/isa? Boolean)] (t/ref (t/isa? Boolean))] [1 1 nil [(t/isa? Byte)] (t/ref (t/isa? Byte))]] @@ -1796,17 +1796,17 @@ ;; ===== `extend-defn!` tests ===== ;; (def dependent-extensible|direct-dispatch|codelist - `[(def ~(tag (cstr `boolean+byte+short+short>Object) 'dependent-extensible|__0) - (reify* [boolean+byte+short+short>Object] + `[(def ~(tag (cstr `boolean+byte+short+S__O) 'dependent-extensible|__0) + (reify* [boolean+byte+short+S__O] (~(O 'invoke) [~'_0__ ~(B 'a) ~(Y 'b) ~(S 'c) ~(S 'd)] 1))) - (def ~(tag (cstr `boolean+byte+short+char>Object) 'dependent-extensible|__1) - (reify* [boolean+byte+short+char>Object] + (def ~(tag (cstr `boolean+byte+short+C__O) 'dependent-extensible|__1) + (reify* [boolean+byte+short+C__O] (~(O 'invoke) [~'_1__ ~(B 'a) ~(Y 'b) ~(S 'c) ~(C 'd)] 1))) (def ~(tag (cstr `boolean+byte+short+Object>Object) 'dependent-extensible|__2) (reify* [boolean+byte+short+Object>Object] (~(O 'invoke) [~'_2__ ~(B 'a) ~(Y 'b) ~(S 'c) ~(O 'd)] 1))) - (def ~(tag (cstr `boolean+byte+Object+char>Object) 'dependent-extensible|__3) - (reify* [boolean+byte+Object+char>Object] + (def ~(tag (cstr `boolean+byte+Object+C__O) 'dependent-extensible|__3) + (reify* [boolean+byte+Object+C__O] (~(O 'invoke) [~'_3__ ~(B 'a) ~(Y 'b) ~(O 'c) ~(C 'd)] 1))) (def ~(tag (cstr `boolean+byte+Object+Object>Object) 'dependent-extensible|__4) (reify* [boolean+byte+Object+Object>Object] @@ -1814,14 +1814,14 @@ (def ~(tag (cstr `boolean+byte+Object+Object>Object) 'dependent-extensible|__5) (reify* [boolean+byte+Object+Object>Object] (~(O 'invoke) [~'_5__ ~(B 'a) ~(Y 'b) ~(O 'c) ~(O 'd)] 1))) - (def ~(tag (cstr `boolean+short+short+short>Object) 'dependent-extensible|__6) - (reify* [boolean+short+short+short>Object] + (def ~(tag (cstr `boolean+short+short+S__O) 'dependent-extensible|__6) + (reify* [boolean+short+short+S__O] (~(O 'invoke) [~'_6__ ~(B 'a) ~(S 'b) ~(S 'c) ~(S 'd)] 1))) - (def ~(tag (cstr `boolean+char+short+char>Object) 'dependent-extensible|__7) - (reify* [boolean+char+short+char>Object] + (def ~(tag (cstr `boolean+char+short+C__O) 'dependent-extensible|__7) + (reify* [boolean+char+short+C__O] (~(O 'invoke) [~'_7__ ~(B 'a) ~(C 'b) ~(S 'c) ~(C 'd)] 1))) - (def ~(tag (cstr `boolean+char+Object+char>Object) 'dependent-extensible|__8) - (reify* [boolean+char+Object+char>Object] + (def ~(tag (cstr `boolean+char+Object+C__O) 'dependent-extensible|__8) + (reify* [boolean+char+Object+C__O] (~(O 'invoke) [~'_8__ ~(B 'a) ~(C 'b) ~(O 'c) ~(C 'd)] 1))) (def ~(tag (cstr `boolean+Object+short+Object>Object) 'dependent-extensible|__9) (reify* [boolean+Object+short+Object>Object] @@ -1832,17 +1832,17 @@ (def ~(tag (cstr `boolean+Object+Object+Object>Object) 'dependent-extensible|__11) (reify* [boolean+Object+Object+Object>Object] (~(O 'invoke) [~'_11__ ~(B 'a) ~(O 'b) ~(O 'c) ~(O 'd)] 1))) - (def ~(tag (cstr `byte+byte+short+short>Object) 'dependent-extensible|__12) - (reify* [byte+byte+short+short>Object] + (def ~(tag (cstr `byte+byte+short+S__O) 'dependent-extensible|__12) + (reify* [byte+byte+short+S__O] (~(O 'invoke) [~'_12__ ~(Y 'a) ~(Y 'b) ~(S 'c) ~(S 'd)] 1))) - (def ~(tag (cstr `byte+byte+short+char>Object) 'dependent-extensible|__13) - (reify* [byte+byte+short+char>Object] + (def ~(tag (cstr `byte+byte+short+C__O) 'dependent-extensible|__13) + (reify* [byte+byte+short+C__O] (~(O 'invoke) [~'_13__ ~(Y 'a) ~(Y 'b) ~(S 'c) ~(C 'd)] 1))) (def ~(tag (cstr `byte+byte+short+Object>Object) 'dependent-extensible|__14) (reify* [byte+byte+short+Object>Object] (~(O 'invoke) [~'_14__ ~(Y 'a) ~(Y 'b) ~(S 'c) ~(O 'd)] 1))) - (def ~(tag (cstr `byte+byte+Object+char>Object) 'dependent-extensible|__15) - (reify* [byte+byte+Object+char>Object] + (def ~(tag (cstr `byte+byte+Object+C__O) 'dependent-extensible|__15) + (reify* [byte+byte+Object+C__O] (~(O 'invoke) [~'_15__ ~(Y 'a) ~(Y 'b) ~(O 'c) ~(C 'd)] 1))) (def ~(tag (cstr `byte+byte+Object+Object>Object) 'dependent-extensible|__16) (reify* [byte+byte+Object+Object>Object] @@ -1850,14 +1850,14 @@ (def ~(tag (cstr `byte+byte+Object+Object>Object) 'dependent-extensible|__17) (reify* [byte+byte+Object+Object>Object] (~(O 'invoke) [~'_17__ ~(Y 'a) ~(Y 'b) ~(O 'c) ~(O 'd)] 1))) - (def ~(tag (cstr `short+short+short+short>Object) 'dependent-extensible|__18) - (reify* [short+short+short+short>Object] + (def ~(tag (cstr `short+short+short+S__O) 'dependent-extensible|__18) + (reify* [short+short+short+S__O] (~(O 'invoke) [~'_18__ ~(S 'a) ~(S 'b) ~(S 'c) ~(S 'd)] 1))) - (def ~(tag (cstr `char+char+short+char>Object) 'dependent-extensible|__19) - (reify* [char+char+short+char>Object] + (def ~(tag (cstr `char+char+short+C__O) 'dependent-extensible|__19) + (reify* [char+char+short+C__O] (~(O 'invoke) [~'_19__ ~(C 'a) ~(C 'b) ~(S 'c) ~(C 'd)] 1))) - (def ~(tag (cstr `char+char+Object+char>Object) 'dependent-extensible|__20) - (reify* [char+char+Object+char>Object] + (def ~(tag (cstr `char+char+Object+C__O) 'dependent-extensible|__20) + (reify* [char+char+Object+C__O] (~(O 'invoke) [~'_20__ ~(C 'a) ~(C 'b) ~(O 'c) ~(C 'd)] 1))) (def ~(tag (cstr `Object+Object+short+Object>Object) 'dependent-extensible|__21) (reify* [Object+Object+short+Object>Object] @@ -1996,8 +1996,8 @@ expected (case (env-lang) :clj ($ (do (declare ~'extensible) - (def ~(tag (cstr `double>Object) 'extensible|__0) - (reify* [double>Object] (~(O 'invoke) [~'_0__ ~(D 'a)] nil))) + (def ~(tag (cstr `D__O) 'extensible|__0) + (reify* [D__O] (~(O 'invoke) [~'_0__ ~(D 'a)] nil))) [{:id 0 :index 0 :arg-types [(t/isa? Double)] :output-type t/any?}] @@ -2017,8 +2017,8 @@ ([a t/boolean?])))) expected (case (env-lang) - :clj ($ (do (def ~(tag (cstr `boolean>Object) 'extensible|__1) - (reify* [boolean>Object] + :clj ($ (do (def ~(tag (cstr `B__O) 'extensible|__1) + (reify* [B__O] (~(O 'invoke) [~'_0__ ~(B 'a)] nil))) [{:id 1 :index 0 :arg-types [(t/isa? Boolean)] :output-type t/any?} @@ -2181,8 +2181,8 @@ expected (case (env-lang) :clj ($ [(do (declare ~'simple-reactive-dependee) - (def ~(tag (cstr `char>Object) 'simple-reactive-dependee|__0) - (reify* [char>Object] (~(O 'invoke) [~'_0__ ~(C 'a)] 1))) + (def ~(tag (cstr `C__O) 'simple-reactive-dependee|__0) + (reify* [C__O] (~(O 'invoke) [~'_0__ ~(C 'a)] 1))) [{:id 0 :index 0 :arg-types [(t/isa? Character)] :output-type t/any?}] (defmeta ~'simple-reactive-dependee {:quantum.core.type/type simple-reactive-dependee|__type} @@ -2191,8 +2191,8 @@ (. simple-reactive-dependee|__0 ~'invoke ~'x00__) (unsupported! `simple-reactive-dependee [~'x00__] 0)))))) (do (declare ~'simple-reactive-dependent) - (def ~(tag (cstr `char>Object) 'simple-reactive-dependent|__0) - (reify* [char>Object] (~(O 'invoke) [~'_0__ ~(C 'a)] "abc"))) + (def ~(tag (cstr `C__O) 'simple-reactive-dependent|__0) + (reify* [C__O] (~(O 'invoke) [~'_0__ ~(C 'a)] "abc"))) [{:id 0 :index 0 :arg-types [(t/isa? Character)] :output-type t/any?}] (defmeta ~'simple-reactive-dependent {:quantum.core.type/type simple-reactive-dependent|__type} @@ -2522,63 +2522,65 @@ :clj ($ (do (declare ~'f0) [[0 0 false [] (t/ftype tt/boolean? [tt/byte? :> (t/ftype [tt/char?])])]] -(defmeta-from ~'f0 - (let* [fs (*<>|sized|macro 2) - f (new TypedFn - {:quantum.core.type/type ~'f0|__type} - (fn* ([~ts ~fs ~'x00__] - (ifs (~(aget* (aget* ts 0) 0) ~'x00__) - (. ~(aget* ts 0) ~'invoke ~'x00__) - (~(aget* (aget* ts 1) 0) ~'x00__) - (. ~(aget* ts 1) ~'invoke ~'x00__) - (unsupported! `f0 [~'x00__] 0)))))] - ~(aset* fs 0 - `(reify* [boolean>Object] - (~'invoke [~'_0__ ~(B 'a)] - ;; From `(self/fn [b ...])` - (self/>anon-fn - ;; TODO perhaps extern this (and parts thereof) whenever possible in `let*` - ;; statement on the very outside of the fn (so around the outer `reify*`) ? - (*<>|macro (*<>|macro (t/isa? Byte)) (*<>|macro (t/isa? Character))) - (*<>|macro - (reify* [byte>Object] - (~'invoke [~'_0__ ~(Y 'b)] - ;; From `(self/fn [c ...])` - (self/>anon-fn - (*<>|macro (*<>|macro (t/isa? Boolean)) (*<>|macro (t/isa? Short))) - (fn* [~(tag (cstr `AnonFn) 'this__)] - (*<>|macro - (reify* [boolean>Object] - (~'invoke [~'_0__ (B 'c)] - ~'b - (. (tag (cstr `boolean>Object) (Array/get (.-fs ~'this__) 0)) ~'invoke ~'a) - (. (tag (cstr `boolean>Object) (Array/get (.-fs ~'this__) 0)) ~'invoke ~'c))) - (reify* [short>Object] - (~'invoke [~'_0__ (S 'c)] - ~'b - (. (tag (cstr `boolean>Object) (Array/get (.-fs ~'this__) 0)) ~'invoke ~'a) - (. (tag (cstr `short>Object) (Array/get (.-fs ~'this__) 1)) ~'invoke ~'c))))) - (fn* ([~(O<> 'types__) ~(O<> 'fs__) ~'x00] - (ifs ((Array/get (Array/get ~'types__ 0) 0) ~'x00__) - (. ~(tag (cstr `boolean>Object) `(Array/get ~'fs__ 0)) - ~'invoke ~'x00__) - ((Array/get (Array/get ~'types__ 1) 0) ~'x00__) - (. ~(tag (cstr `short>Object) `(Array/get ~'fs__ 1)) - ~'invoke ~'x00__) - (unsupported! [~'x00__] 0))))))) - (reify* [char>Object] - (~'invoke [~'_0__ ~(C 'a)] ...))) - (fn* ([~(O<> 'types__) ~(O<> 'fs__) ~'x00__] - (ifs ((Array/get (Array/get ~'types__ 0) 0) ~'x00__) - (. ~(tag (cstr `byte>Object) `(Array/get ~'fs__ 0)) ~'invoke ~'x00__) - ((Array/get (Array/get ~'types__ 1) 0) ~'x00__) - (. ~(tag (cstr `char>Object) `(Array/get ~'fs__ 1)) ~'invoke ~'x00__) - (unsupported! [~'x00__] 0))))))) - ~(aset* fs 1 - `(reify* [double>Object] - (~'invoke [~'_0__ ~(D 'a)] ...))))) - -)))] + (defmeta-from ~'f0 + (let* [~fs (*<>|sized|macro 2) + ~'f__0 (new TypedFn + {:quantum.core.type/type ~'f0|__type} + (fn* ([~ts ~fs ~'x00__] + (ifs (~(aget* (aget* ts 0) 0) ~'x00__) + (. ~(aget* ts 0) ~'invoke ~'x00__) + (~(aget* (aget* ts 1) 0) ~'x00__) + (. ~(aget* ts 1) ~'invoke ~'x00__) + (unsupported! `f0 [~'x00__] 0)))))] + ~(aset* fs 0 + `(reify* [B__O] + (~'invoke [~'_0__ ~(B 'a)] + ;; From `(self/fn [b ...])` + (let* [~fs (*<>|sized|macro 2) + ~'f__1 (new TypedFn nil + ;; TODO perhaps extern this (and parts thereof) whenever + ;; possible in `let*` statement on the very outside of the fn + ;; (so around the outer `reify*`) ? + (*<>|macro (*<>|macro t/byte?) (*<>|macro t/char?)) + ~fs + (fn* ([~ts ~fs ~'x00__] + (ifs (~(aget* (aget* ~ts 0) 0) ~'x00__) + (. ~(>Y__O (aget* fs 0)) ~'invoke ~'x00__) + (~(aget* (aget* ~ts 1) 0) ~'x00__) + (. ~(>C__O (aget* fs 1)) ~'invoke ~'x00__) + (unsupported! [~'x00__] 0)))))] + ~(aset* fs 0 + `(reify* [Y__O] + (~'invoke [~'_0__ ~(Y 'b)] + ;; From `(self/fn [c ...])` + (let* [~fs (*<>|sized|macro 2) + ~'f__2 (new TypedFn nil + (*<>|macro (*<>|macro t/boolean?) (*<>|macro t/short?)) + ~fs + (fn* ([~ts ~fs ~'x00] + (ifs (~(aget* (aget* ts 0) 0) ~'x00__) + (. ~(>B__O (aget* fs 0)) ~'invoke ~'x00__) + (~(aget* (aget* ts 1) 0) ~'x00__) + (. ~(>S__O (aget* fs 1)) ~'invoke ~'x00__) + (unsupported! [~'x00__] 0))))))] + ~(aset* fs 0 + `(reify* [B__O] + (~'invoke [~'_0__ (B 'c)] + ~'b + (. ~(>B__O (aget* fs 0)) ~'invoke ~'a) + (. ~(>B__O (aget* fs 0)) ~'invoke ~'c)))) + ~(aset* fs 1 + `(reify* [S__O] + (~'invoke [~'_0__ (S 'c)] + ~'b + (. ~(>B__O (aget* fs 0)) ~'invoke ~'a) + (. ~(>S__O (aget* fs 1)) ~'invoke ~'c))))))) + ~(aset* fs 1 + (reify* [C__O] + (~'invoke [~'_0__ ~(C 'a)] ...))))))) + ~(aset* fs 1 + `(reify* [D__O] + (~'invoke [~'_0__ ~(D 'a)] ...))))))))] )) From eaaa735b603add7908ae7f192c29c5b1285b2bd6 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 20 Nov 2018 00:30:19 -0700 Subject: [PATCH 758/810] Continue to refine `t/fn` example and todos --- resources-dev/defnt.cljc | 37 +++++++++---------- .../quantum/test/untyped/core/type/defnt.cljc | 27 +++++++------- 2 files changed, 31 insertions(+), 33 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 187b3bac..5a46a4c0 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -58,23 +58,10 @@ Legend: - [!] : refused - TODO implement the following: - [1] ^:inline - - if you do (Numeric/bitAnd a b) inline then bitAnd needs to know the primitive type so maybe - we do the `let*`-binding approach to typing vars? - - `let*` the vars but make it so it can auto-replace if it's just a symbol to symbol mapping - - A good example of inlining: - (t/def empty?|rf - (fn/aritoid - (t/fn [] true) - fn/identity - (t/fn [ret _, x _] (dc/reduced false)) - (t/fn [ret _, k _, v _] (dc/reduced false)))) - (t/defn empty? > p/boolean? - ([x p/nil?] true) - ([xs dc/counted?] (-> xs count num/zero?)) - ([xs (t/input-type educe :_ :_ :?)] (educe empty?|rf x))) - - Should we allow something like `^:analyze-impl` or something to mimic inline optimizations - but avoid actual inlining? + [-] t/fn + [ ] look at fn comparisons; really there's just <|=|> with <|=|> so 9 combos + [ ] add `t/fn` as a special form so we don't need to re-analyze its constituents + [ ] make local vars sanitary/safe by using more of the gensym feature [2] t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. - t/numerically-integer? @@ -110,7 +97,6 @@ Legend: [ ] replace `deref` with `ref/deref` in typed contexts? So we can do `@` still - Type Logic and Predicates - expressions (`quantum.untyped.core.analyze.expr`) - - comparison of `t/fn`s is probably possible - It is possible to check satisfaction of arities to an `t/ftype` at runtime even if the type meta is not stripped (well, at least the arity counts can be checked and primitive types in CLJ): @@ -181,6 +167,20 @@ Legend: protocols can be extended - TODO CLJS needs to implement it better [-] Analysis/Optimization + [ ] ^:inline + - A good example of inlining: + (t/def empty?|rf + (fn/aritoid + (t/fn [] true) + fn/identity + (t/fn [ret _, x _] (dc/reduced false)) + (t/fn [ret _, k _, v _] (dc/reduced false)))) + (t/defn empty? > p/boolean? + ([x p/nil?] true) + ([xs dc/counted?] (-> xs count num/zero?)) + ([xs (t/input-type educe :_ :_ :?)] (educe empty?|rf x))) + - Should we allow something like `^:analyze-impl` or something to mimic inline optimizations + but avoid actual inlining? - maybe redefine `untyped.core.type` in a typed way? `t/def` doesn't realize certain things are `t/type?` - dead code elimination - in `let*`, we should elide variables that are unused and that have no side effects (or at @@ -233,7 +233,6 @@ Legend: only bound within typed contexts. [ ] t/defrecord [ ] t/def-concrete-type (i.e. `t/deftype`) - [-] t/fn [-] t/ftype [ ] conditionally optional arities etc. [-] `t/defn` diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index cd8fe736..b53cb9ab 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -81,22 +81,21 @@ (->> ^:val (java.lang.management.ManagementFactory/getRuntimeMXBean) (.getName))))) expected - ($ (do (declare ~'pid) - [[0 0 false [] (t/or t/nil? t/string?)]] + ($ (do [[0 0 false [] (t/or t/nil? t/string?)]] (defmeta-from ~'pid - (let* [~fs (*<>|sized|macro 0) - ~'f__ (new TypedFn - {:quantum.core.type/type ...} - pid|__!types ; defined/created within `t/defn` - fs - (fn* ([~ts ~fs] (. ~(aget* fs 0) ~'invoke))))] + (let* [~fs (*<>|sized|macro 0) + ~'f__0 (new TypedFn + {:quantum.core.type/type pid|__type} + pid|__!types ; defined/created within `t/defn` + fs + (fn* ([~ts ~fs] (. ~(aget* fs 0) ~'invoke))))] ~(aset* fs 0 - `(reify* [__O] - (~(O 'invoke) [~'_0__] - ~(ST (list '. - (tag "java.lang.management.RuntimeMXBean" - '(. java.lang.management.ManagementFactory getRuntimeMXBean)) - 'getName))))) + `(reify* [__O] + (~(O 'invoke) [~'_0__] + ~(ST (list '. + (tag "java.lang.management.RuntimeMXBean" + '(. java.lang.management.ManagementFactory getRuntimeMXBean)) + 'getName))))) f))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" From a89f9c2b8c93afa7ac664d9b13b41906f74287c7 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 21 Nov 2018 14:13:42 -0700 Subject: [PATCH 759/810] Continue anon fn work --- resources-dev/defnt.cljc | 1 + .../quantum/test/untyped/core/type/defnt.cljc | 67 +++++++++++++------ 2 files changed, 49 insertions(+), 19 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 5a46a4c0..d069a856 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -61,6 +61,7 @@ Legend: [-] t/fn [ ] look at fn comparisons; really there's just <|=|> with <|=|> so 9 combos [ ] add `t/fn` as a special form so we don't need to re-analyze its constituents + [ ] t/ftype should automatically split types, while perhaps t/ftype* should just assume they're split (for use by e.g. `t/fn` and `t/defn`) [ ] make local vars sanitary/safe by using more of the gensym feature [2] t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index b53cb9ab..d32c9cc4 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -51,15 +51,19 @@ (defn O<> [form] (tag "[Ljava.lang.Object;" form)) (defn ST [form] (tag "java.lang.String" form)) -(defn >B__B [form] (tag (-> 'B__B resolve str) form)) -(defn >Y__Y [form] (tag (-> 'Y__Y resolve str) form)) -(defn >S__S [form] (tag (-> 'S__S resolve str) form)) -(defn >C__C [form] (tag (-> 'C__C resolve str) form)) -(defn >I__I [form] (tag (-> 'I__I resolve str) form)) -(defn >L__L [form] (tag (-> 'L__L resolve str) form)) -(defn >F__F [form] (tag (-> 'F__F resolve str) form)) -(defn >D__D [form] (tag (-> 'D__D resolve str) form)) -(defn >O__O [form] (tag (-> 'O__O resolve str) form)) +(defn >interface-str [sym] + (str (or (resolve form) + (str "quantum.test.untyped.core.type.defnt." sym)))) + +(defn >B__B [form] (tag (>interface-str 'B__B) form)) +(defn >Y__Y [form] (tag (>interface-str 'Y__Y) form)) +(defn >S__S [form] (tag (>interface-str 'S__S) form)) +(defn >C__C [form] (tag (>interface-str 'C__C) form)) +(defn >I__I [form] (tag (>interface-str 'I__I) form)) +(defn >L__L [form] (tag (>interface-str 'L__L) form)) +(defn >F__F [form] (tag (>interface-str 'F__F) form)) +(defn >D__D [form] (tag (>interface-str 'D__D) form)) +(defn >O__O [form] (tag (>interface-str 'O__O) form)) (defn cstr [x] (if (-> x resolve class?) @@ -2573,23 +2577,48 @@ (~'invoke [~'_0__ (S 'c)] ~'b (. ~(>B__O (aget* fs 0)) ~'invoke ~'a) - (. ~(>S__O (aget* fs 1)) ~'invoke ~'c))))))) + (. ~(>S__O (aget* fs 1)) ~'invoke ~'c)))) + ~'f__2))) ~(aset* fs 1 (reify* [C__O] - (~'invoke [~'_0__ ~(C 'a)] ...))))))) + (~'invoke [~'_0__ ~(C 'a)] ...))) + ~'f__1)))) ~(aset* fs 1 `(reify* [D__O] - (~'invoke [~'_0__ ~(D 'a)] ...))))))))] - )) + (~'invoke [~'_0__ ~(D 'a)] ...))) + ~'f__0)))))]) + (let [actual (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/defn g [f0 (t/ftype [tt/long? :> tt/float?]) + f1 (t/ftype [tt/byte? :> tt/boolean?] + [tt/string? :> tt/char?]) + > tt/char?] + (f0 7) + (f1 "11")))) + expected + (case (env-lang) + :clj + ($ (do (declare ~'g) + [[0 0 false [] (t/ftype [tt/long? :> tt/char?])]] + (defmeta-from ~'g + (let* [~fs (*<>|sized|macro 2) + ~'f__0 (new TypedFn + {:quantum.core.type/type ~'g|__type} + (fn* ([~ts ~fs ~'x00__ ~'x01__] + (ifs (~(aget* (aget* ts 0) 0) ~'x00__) + (ifs (~(aget* (aget* ts 0) 1) ~'x00__) + (. ~(aget* ts 0) ~'invoke ~'x00__ ~'x01__) + (unsupported! `g [~'x00__ ~'x01__] 1)) + (unsupported! `g [~'x00__ ~'x01__] 0)))))] + ~(aset* fs 0 + `(reify* [O__C] + (~'invoke [~'_0__ ~(B 'a)] + ...))) + ~'f__0)))))] + ...)) " -FIXME the below can be fixed if each `t/fn` and/or `t/defn` was encapsulated by a concrete type, -like AnonFn, that stored references to the types, overloads, etc. -We should probably have standard overload indices for ftypes (maybe we already do? we should sort -ftypes' overload-types in the same way that we sort `t/defn` overload-types. maybe that will make it -standard) so direct dispatch can be performed even in the absence of an fn-name. - We could do: `(. ^TheReifyType (aget (.-ts f) ) invoke <~@args>)` - This is all fine when `f` is `=` (perhaps `t/=`?) to the declared type, but when it's `t/<`, it From 3788fba174834d5902c886788f07d15caae0a63b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 21 Nov 2018 14:24:17 -0700 Subject: [PATCH 760/810] Continue with anon fn work --- .../quantum/test/untyped/core/type/defnt.cljc | 39 ++++++++++--------- 1 file changed, 20 insertions(+), 19 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index d32c9cc4..19c3f4ca 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -2510,31 +2510,31 @@ (let [actual (binding [self/*compilation-mode* :test] (macroexpand ' ;: FIXME this contract is not being held up when returning nil - (self/defn f0 [a (t/or tt/boolean? tt/double?) - > (t/ftype [tt/byte? :> (t/ftype [tt/char?])])] + (self/defn f0|test [a (t/or tt/boolean? tt/double?) + > (t/ftype [tt/byte? :> (t/ftype [tt/char?])])] ;; TODO this fits into a larger scheme of, should we have output types be ;; `(t/and actual declared)` or should we just have them be `declared`? The ;; latter is easier but it seems like the `t/fn` dispatch forces our hand ;; towards the former. We need to think about this more. (self/fn [b (t/or tt/byte? tt/char?) > (t/ftype [(t/or (t/type a) tt/short?)])] - (self/fn f1 [c (t/or (t/type a) tt/short?)] - b (f1 a) (f1 c)))))) + (self/fn f1|test [c (t/or (t/type a) tt/short?)] + b (f1|test a) (f1|test c)))))) expected (case (env-lang) :clj - ($ (do (declare ~'f0) + ($ (do (declare ~'f0|test) [[0 0 false [] (t/ftype tt/boolean? [tt/byte? :> (t/ftype [tt/char?])])]] - (defmeta-from ~'f0 + (defmeta-from ~'f0|test (let* [~fs (*<>|sized|macro 2) ~'f__0 (new TypedFn - {:quantum.core.type/type ~'f0|__type} + {:quantum.core.type/type ~'f0|test|__type} (fn* ([~ts ~fs ~'x00__] (ifs (~(aget* (aget* ts 0) 0) ~'x00__) (. ~(aget* ts 0) ~'invoke ~'x00__) (~(aget* (aget* ts 1) 0) ~'x00__) (. ~(aget* ts 1) ~'invoke ~'x00__) - (unsupported! `f0 [~'x00__] 0)))))] + (unsupported! `f0|test [~'x00__] 0)))))] ~(aset* fs 0 `(reify* [B__O] (~'invoke [~'_0__ ~(B 'a)] @@ -2589,31 +2589,32 @@ ~'f__0)))))]) (let [actual (binding [self/*compilation-mode* :test] (macroexpand ' - (self/defn g [f0 (t/ftype [tt/long? :> tt/float?]) - f1 (t/ftype [tt/byte? :> tt/boolean?] - [tt/string? :> tt/char?]) - > tt/char?] + (self/defn g|test [f0 (t/ftype [tt/long? :> tt/float?]) + f1 (t/ftype [tt/byte? :> tt/boolean?] + [tt/string? :> tt/char?]) + > tt/char?] (f0 7) (f1 "11")))) expected (case (env-lang) :clj - ($ (do (declare ~'g) + ($ (do (declare ~'g|test) [[0 0 false [] (t/ftype [tt/long? :> tt/char?])]] - (defmeta-from ~'g + (defmeta-from ~'g|test (let* [~fs (*<>|sized|macro 2) ~'f__0 (new TypedFn {:quantum.core.type/type ~'g|__type} (fn* ([~ts ~fs ~'x00__ ~'x01__] (ifs (~(aget* (aget* ts 0) 0) ~'x00__) (ifs (~(aget* (aget* ts 0) 1) ~'x00__) - (. ~(aget* ts 0) ~'invoke ~'x00__ ~'x01__) - (unsupported! `g [~'x00__ ~'x01__] 1)) - (unsupported! `g [~'x00__ ~'x01__] 0)))))] + (. ~(aget* fs 0) ~'invoke ~'x00__ ~'x01__) + (unsupported! `g|test [~'x00__ ~'x01__] 1)) + (unsupported! `g|test [~'x00__ ~'x01__] 0)))))] ~(aset* fs 0 `(reify* [O__C] - (~'invoke [~'_0__ ~(B 'a)] - ...))) + (~'invoke [~'_0__ ~(O 'f0) ~(O 'f1)] + (. ~(aget* `(.-fs ~'f0) ...) ~'invoke 7) + (. ~(aget* `(.-fs ~'f1) ...) ~'invoke "11")))) ~'f__0)))))] ...)) From ef86b54cb8125f38f443c692c0983ffccf42480f Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 21 Nov 2018 15:52:23 -0700 Subject: [PATCH 761/810] Fix compilation --- src-untyped/quantum/untyped/core/type.cljc | 6 +++--- src-untyped/quantum/untyped/core/type/defnt.cljc | 6 ++++-- 2 files changed, 7 insertions(+), 5 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 80b11822..3ee1915d 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -63,7 +63,7 @@ ProtocolType DirectProtocolType ClassType UnorderedType OrderedType ValueType - FnType AnonFn + FnType TypedFn MetaType MetaOrType ReactiveType])]] [quantum.untyped.core.vars :as uvar @@ -79,7 +79,7 @@ ProtocolType ClassType UnorderedType OrderedType ValueType - FnType AnonFn + FnType TypedFn MetaType MetaOrType ReactiveType]))) @@ -811,7 +811,7 @@ (reduce (c/fn [classes' t'] (-type>classes t' include-classes-of-value-type? classes')) classes (utr/or-type>args t)) (utr/fn-type? t) - (conj classes AnonFn) ; it's not really a clojure.lang.IFn; the dynamic dispatch is though + (conj classes TypedFn) (c/= t val?) ; TODO make this less ad-hoc (-type>classes val|by-class? include-classes-of-value-type? classes) :else diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index a0bf211d..82b93aef 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -869,10 +869,12 @@ ;; TODO spec (defns unsupported! - ([args _ #_indexed?, i index?] (unsupported! nil args i) + ([args _ #_indexed?, i index?] (unsupported! nil args i)) ([name- _ #_t/qualified-symbol?, args _ #_indexed?, i index?] (throw (ex-info "This function is unsupported for the type combination at the argument index." - {:name (if (nil? name-) '#anonymous name-) :args args :arg-index i})))) + {:name (if (nil? name-) (symbol "#anonymous") name-) + :args args + :arg-index i})))) (defns- >combinatoric-seq+ [{:as fn|globals :keys [fn|ns-name _ fn|name _]} ::fn|globals From 7dcd63c8013ae92d95b8e6aa0037f5a6b11494cd Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 21 Nov 2018 15:52:29 -0700 Subject: [PATCH 762/810] Add note for `TypedFn` --- src-untyped/quantum/untyped/core/type/reifications.cljc | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index df4270a1..3f3518ba 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -506,11 +506,12 @@ (udt/deftype TypedFn [meta - ;; the types for direct dispatch overloads + ;; The types for direct dispatch overloads ^:! #?(:clj ^"[Ljava.lang.Object;" ts :cljs ^array ts) - ;; the direct dispatch fns / `reify` overloads + ;; The direct dispatch fns / `reify` overloads + ;; Keys/indices are overload IDs, not dynamic overload-indices ^:! #?(:clj ^"[Ljava.lang.Object;" fs :cljs ^array fs) - ;; the dynamic dispatch fn + ;; The dynamic dispatch fn #?(:clj ^clojure.lang.IFn dynf :cljs dynf)] {PTypedFn {setTs ([this ts'] (set! ts ts') this) From d53cc950009a54f0991cd81909f04cd84eedb309 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 21 Nov 2018 15:52:57 -0700 Subject: [PATCH 763/810] `csym`; more fn work --- .../quantum/test/untyped/core/type/defnt.cljc | 670 +++++++++--------- 1 file changed, 353 insertions(+), 317 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 19c3f4ca..515c3a61 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -26,10 +26,10 @@ [quantum.untyped.core.vars :refer [defmeta]]) (:import - [clojure.lang ASeq ISeq LazySeq Named Reduced RT Seqable] - [quantum.core.data Array] - [quantum.core Numeric Primitive] - [quantum.untyped.core.type.defnt AnonFn])) + [clojure.lang ASeq ISeq LazySeq Named Reduced RT Seqable] + [quantum.core.data Array] + [quantum.core Numeric Primitive] + [quantum.untyped.core.type.reifications TypedFn])) ;; TODO test `:inline` @@ -51,25 +51,24 @@ (defn O<> [form] (tag "[Ljava.lang.Object;" form)) (defn ST [form] (tag "java.lang.String" form)) -(defn >interface-str [sym] - (str (or (resolve form) - (str "quantum.test.untyped.core.type.defnt." sym)))) - -(defn >B__B [form] (tag (>interface-str 'B__B) form)) -(defn >Y__Y [form] (tag (>interface-str 'Y__Y) form)) -(defn >S__S [form] (tag (>interface-str 'S__S) form)) -(defn >C__C [form] (tag (>interface-str 'C__C) form)) -(defn >I__I [form] (tag (>interface-str 'I__I) form)) -(defn >L__L [form] (tag (>interface-str 'L__L) form)) -(defn >F__F [form] (tag (>interface-str 'F__F) form)) -(defn >D__D [form] (tag (>interface-str 'D__D) form)) -(defn >O__O [form] (tag (>interface-str 'O__O) form)) - (defn cstr [x] (if (-> x resolve class?) (str x) (str (core/namespace x) "." (core/name x)))) +(defn csym [x] (-> x cstr symbol)) + +(defn >B__B [form] (tag (cstr `B__B) form)) +(defn >Y__Y [form] (tag (cstr `Y__Y) form)) +(defn >S__S [form] (tag (cstr `S__S) form)) +(defn >C__C [form] (tag (cstr `C__C) form)) +(defn >I__I [form] (tag (cstr `I__I) form)) +(defn >L__L [form] (tag (cstr `L__L) form)) +(defn >F__F [form] (tag (cstr `F__F) form)) +(defn >D__D [form] (tag (cstr `D__D) form)) +(defn >O__F [form] (tag (cstr `O__F) form)) +(defn >O__O [form] (tag (cstr `O__O) form)) + (def ts (O<> 'ts__)) (def fs (O<> 'fs__)) @@ -94,7 +93,7 @@ fs (fn* ([~ts ~fs] (. ~(aget* fs 0) ~'invoke))))] ~(aset* fs 0 - `(reify* [__O] + `(reify* [~(csym `__O)] (~(O 'invoke) [~'_0__] ~(ST (list '. (tag "java.lang.management.RuntimeMXBean" @@ -120,23 +119,23 @@ ;; [x t/any?] (def ~(>B__B 'identity|__0) - (reify* [B__B] (~(B 'invoke) [~'_0__ ~(B 'x)] ~'x))) + (reify* [~(csym `B__B)] (~(B 'invoke) [~'_0__ ~(B 'x)] ~'x))) (def ~(>Y__Y 'identity|__1) - (reify* [Y__Y] (~(Y 'invoke) [~'_1__ ~(Y 'x)] ~'x))) + (reify* [~(csym `Y__Y)] (~(Y 'invoke) [~'_1__ ~(Y 'x)] ~'x))) (def ~(>S__S 'identity|__2) - (reify* [S__S] (~(S 'invoke) [~'_2__ ~(S 'x)] ~'x))) + (reify* [~(csym `S__S)] (~(S 'invoke) [~'_2__ ~(S 'x)] ~'x))) (def ~(>C__C 'identity|__3) - (reify* [C__C] (~(C 'invoke) [~'_3__ ~(C 'x)] ~'x))) + (reify* [~(csym `C__C)] (~(C 'invoke) [~'_3__ ~(C 'x)] ~'x))) (def ~(>I__I 'identity|__4) - (reify* [I__I] (~(I 'invoke) [~'_4__ ~(I 'x)] ~'x))) + (reify* [~(csym `I__I)] (~(I 'invoke) [~'_4__ ~(I 'x)] ~'x))) (def ~(>L__L 'identity|__5) - (reify* [L__L] (~(L 'invoke) [~'_5__ ~(L 'x)] ~'x))) + (reify* [~(csym `L__L)] (~(L 'invoke) [~'_5__ ~(L 'x)] ~'x))) (def ~(>F__F 'identity|__6) - (reify* [F__F] (~(F 'invoke) [~'_6__ ~(F 'x)] ~'x))) + (reify* [~(csym `F__F)] (~(F 'invoke) [~'_6__ ~(F 'x)] ~'x))) (def ~(>D__D 'identity|__7) - (reify* [D__D] (~(D 'invoke) [~'_7__ ~(D 'x)] ~'x))) + (reify* [~(csym `D__D)] (~(D 'invoke) [~'_7__ ~(D 'x)] ~'x))) (def ~(>O__O 'identity|__8) - (reify* [O__O] (~(O 'invoke) [~'_8__ ~(O 'x)] ~(O 'x)))) + (reify* [~(csym `O__O)] (~(O 'invoke) [~'_8__ ~(O 'x)] ~(O 'x)))) [[0 0 true [t/boolean?] t/boolean?] [1 1 true [t/byte?] t/byte?] @@ -198,12 +197,12 @@ ;; [x t/string?] (def ~(>O__O 'name|__0) - (reify* [O__O] (~(O 'invoke) [~'_0__ ~(O 'x)] ~(ST 'x)))) + (reify* [~(csym `O__O)] (~(O 'invoke) [~'_0__ ~(O 'x)] ~(ST 'x)))) ;; [x (t/isa? Named)] > (t/run t/string?) (def ~(>O__O 'name|__1) - (reify* [O__O] + (reify* [~(csym `O__O)] (~(O 'invoke) [~'_1__ ~(O 'x)] (t/validate ~(ST (list '. (tag "clojure.lang.Named" 'x) 'getName)) ~'(t/run t/string?))))) @@ -250,28 +249,28 @@ ;; [x t/nil?] (def ~(tag (cstr `O__B) 'some?|__0) - (reify* [O__B] (~(B 'invoke) [~'_0__ ~(O 'x)] false))) + (reify* [~(csym `O__B)] (~(B 'invoke) [~'_0__ ~(O 'x)] false))) ;; [x t/any?] (def ~(>B__B 'some?|__1) - (reify* [B__B] (~(B 'invoke) [~'_1__ ~(B 'x)] true))) + (reify* [~(csym `B__B)] (~(B 'invoke) [~'_1__ ~(B 'x)] true))) (def ~(>Y__B 'some?|__2) - (reify* [Y__B] (~(B 'invoke) [~'_2__ ~(Y 'x)] true))) + (reify* [~(csym `Y__B)] (~(B 'invoke) [~'_2__ ~(Y 'x)] true))) (def ~(>S__B 'some?|__3) - (reify* [S__B] (~(B 'invoke) [~'_3__ ~(S 'x)] true))) + (reify* [~(csym `S__B)] (~(B 'invoke) [~'_3__ ~(S 'x)] true))) (def ~(>C__B 'some?|__4) - (reify* [C__B] (~(B 'invoke) [~'_4__ ~(C 'x)] true))) + (reify* [~(csym `C__B)] (~(B 'invoke) [~'_4__ ~(C 'x)] true))) (def ~(>I__B 'some?|__5) - (reify* [I__B] (~(B 'invoke) [~'_5__ ~(I 'x)] true))) + (reify* [~(csym `I__B)] (~(B 'invoke) [~'_5__ ~(I 'x)] true))) (def ~(>L__B 'some?|__6) - (reify* [L__B] (~(B 'invoke) [~'_6__ ~(L 'x)] true))) + (reify* [~(csym `L__B)] (~(B 'invoke) [~'_6__ ~(L 'x)] true))) (def ~(>F__B 'some?|__7) - (reify* [F__B] (~(B 'invoke) [~'_7__ ~(F 'x)] true))) + (reify* [~(csym `F__B)] (~(B 'invoke) [~'_7__ ~(F 'x)] true))) (def ~(>D__B 'some?|__8) - (reify* [D__B] (~(B 'invoke) [~'_8__ ~(D 'x)] true))) + (reify* [~(csym `D__B)] (~(B 'invoke) [~'_8__ ~(D 'x)] true))) (def ~(>O__B 'some?|__9) - (reify* [O__B] (~(B 'invoke) [~'_9__ ~(O 'x)] true))) + (reify* [~(csym `O__B)] (~(B 'invoke) [~'_9__ ~(O 'x)] true))) [{:id 0 :index 0 :arg-types [(t/value nil)] :output-type (t/isa? Boolean)} {:id 1 :index 1 :arg-types [(t/isa? Boolean)] :output-type (t/isa? Boolean)} @@ -327,14 +326,14 @@ ($ (do ;; [x (t/isa? Reduced)] (def ~'reduced?|test|__0|0 - (reify* [O__B] + (reify* [~(csym `O__B)] (~(B 'invoke) [~'_0__ ~(O 'x)] (let* [~(tag "clojure.lang.Reduced" 'x) ~'x] true)))) ;; [x t/any?] (def ~'reduced?|test|__1|0 - (reify* [O__B B__B Y__B S__B C__B I__B L__B F__B D__B] + (reify* [~@(map csym `[O__B B__B Y__B S__B C__B I__B L__B F__B D__B])] (~(B 'invoke) [~'_1__ ~(O 'x)] false) (~(B 'invoke) [~'_2__ ~(B 'x)] false) (~(B 'invoke) [~'_3__ ~(Y 'x)] false) @@ -388,7 +387,7 @@ (def ~(O<> '>boolean|__0|input0|types) (*<> (t/isa? Boolean))) (def ~'>boolean|__0|0 - (reify* [B__B] + (reify* [~(csym `B__B)] (~(B 'invoke) [~'_0__ ~(B 'x)] ~'x))) ;; [x t/nil? -> (- t/nil? tt/boolean?)] @@ -396,7 +395,7 @@ (def ~(O<> '>boolean|__1|input0|types) (*<> (t/value nil))) (def ~'>boolean|__1|0 - (reify* [O__B] + (reify* [~(csym `O__B)] (~(B 'invoke) [~'_1__ ~(O 'x)] false))) ;; [x t/any? -> (- t/any? t/nil? tt/boolean?)] @@ -404,7 +403,7 @@ (def ~(O<> '>boolean|__2|input0|types) (*<> t/any?)) (def ~'>boolean|__2|0 - (reify* [O__B B__B Y__B S__B C__B I__B L__B F__B D__B] + (reify* [~@(map csym `[O__B B__B Y__B S__B C__B I__B L__B F__B D__B])] (~(B 'invoke) [~'_2__ ~(O 'x)] true) (~(B 'invoke) [~'_3__ ~(B 'x)] true) (~(B 'invoke) [~'_4__ ~(Y 'x)] true) @@ -445,7 +444,7 @@ (is= (>boolean 123) (boolean 123))))))) ;; Let's say you have (t/| t/string? t/number?) in one `fnt` overload. -;; This means that you *can't* have a reify with two Object>Object overloads and expect it to work +;; This means that you *can't* have a reify with two O__O overloads and expect it to work ;; at all. ;; Therefore, each `fnt` overload necessarily has a one-to-many relationship with `reify`s. ;; Only the primitivized overloads belong grouped together in one `reify`. @@ -473,25 +472,25 @@ (t/isa? java.lang.Float) (t/isa? java.lang.Double))) (def ~'>int*|__0|0 - (reify* [byte>int] + (reify* [~(csym `Y__I)] (~(I 'invoke) [~'_0__ ~(Y 'x)] ~'(. Primitive uncheckedIntCast x)))) (def ~'>int*|__0|1 - (reify* [short>int] + (reify* [~(csym `S__I)] (~(I 'invoke) [~'_1__ ~(S 'x)] ~'(. Primitive uncheckedIntCast x)))) (def ~'>int*|__0|2 - (reify* [char>int] + (reify* [~(csym `C__I)] (~(I 'invoke) [~'_2__ ~(C 'x)] ~'(. Primitive uncheckedIntCast x)))) (def ~'>int*|__0|3 - (reify* [int>int] + (reify* [~(csym `I__I)] (~(I 'invoke) [~'_3__ ~(I 'x)] ~'(. Primitive uncheckedIntCast x)))) (def ~'>int*|__0|4 - (reify* [long>int] + (reify* [~(csym `L__I)] (~(I 'invoke) [~'_4__ ~(L 'x)] ~'(. Primitive uncheckedIntCast x)))) (def ~'>int*|__0|5 - (reify* [float>int] + (reify* [~(csym `F__I)] (~(I 'invoke) [~'_5__ ~(F 'x)] ~'(. Primitive uncheckedIntCast x)))) (def ~'>int*|__0|6 - (reify* [double>int] + (reify* [~(csym `D__I)] (~(I 'invoke) [~'_6__ ~(D 'x)] ~'(. Primitive uncheckedIntCast x)))) ;; [x (t/ref (t/isa? Number)) @@ -500,7 +499,7 @@ (def ~(O<> '>int*|__1|input0|types) (*<> (t/ref (t/isa? Number)))) (def ~'>int*|__1|0 - (reify* [Object>int] + (reify* [~(csym `O__I)] (~(I 'invoke) [~'_7__ ~(O 'x)] (let* [~(tag "java.lang.Number" 'x) ~'x] ~'(. x intValue))))) @@ -511,21 +510,21 @@ ~'[(t/ref (t/isa? Number))])} ([~'x00__] (ifs ((Array/get ~'>int*|__0|input0|types 0) ~'x00__) - (.invoke ~(tag (cstr `byte>int) '>int*|__0|0) ~'x00__) + (.invoke ~(tag (cstr `Y__I) '>int*|__0|0) ~'x00__) ((Array/get ~'>int*|__0|input0|types 1) ~'x00__) - (.invoke ~(tag (cstr `short>int) '>int*|__0|1) ~'x00__) + (.invoke ~(tag (cstr `S__I) '>int*|__0|1) ~'x00__) ((Array/get ~'>int*|__0|input0|types 2) ~'x00__) - (.invoke ~(tag (cstr `char>int) '>int*|__0|2) ~'x00__) + (.invoke ~(tag (cstr `C__I) '>int*|__0|2) ~'x00__) ((Array/get ~'>int*|__0|input0|types 3) ~'x00__) - (.invoke ~(tag (cstr `int>int) '>int*|__0|3) ~'x00__) + (.invoke ~(tag (cstr `I__I) '>int*|__0|3) ~'x00__) ((Array/get ~'>int*|__0|input0|types 4) ~'x00__) - (.invoke ~(tag (cstr `long>int) '>int*|__0|4) ~'x00__) + (.invoke ~(tag (cstr `L__I) '>int*|__0|4) ~'x00__) ((Array/get ~'>int*|__0|input0|types 5) ~'x00__) - (.invoke ~(tag (cstr `float>int) '>int*|__0|5) ~'x00__) + (.invoke ~(tag (cstr `F__I) '>int*|__0|5) ~'x00__) ((Array/get ~'>int*|__0|input0|types 6) ~'x00__) - (.invoke ~(tag (cstr `double>int) '>int*|__0|6) ~'x00__) + (.invoke ~(tag (cstr `D__I) '>int*|__0|6) ~'x00__) ((Array/get ~'>int*|__1|input0|types 0) ~'x00__) - (.invoke ~(tag (cstr `Object>int) '>int*|__1|0) ~'x00__) + (.invoke ~(tag (cstr `O__I) '>int*|__1|0) ~'x00__) (unsupported! `>int* [~'x00__] 0)))))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" @@ -784,152 +783,152 @@ ;; [a t/comparable-primitive? b t/comparable-primitive? > tt/boolean?] - (def ~(tag (cstr `byte+Y__B) '>|__0) - (reify* [byte+Y__B] + (def ~(tag (cstr `YY__B) '>|__0) + (reify* [~(csym ~YY__B)] (~(B 'invoke) [~'_0__ ~(Y 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `byte+S__B) '>|__1) - (reify* [byte+S__B] + (def ~(tag (cstr `YS__B) '>|__1) + (reify* [~(csym ~YS__B)] (~(B 'invoke) [~'_1__ ~(Y 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `byte+C__B) '>|__2) - (reify* [byte+C__B] + (def ~(tag (cstr `YC__B) '>|__2) + (reify* [~(csym ~YC__B)] (~(B 'invoke) [~'_2__ ~(Y 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `byte+I__B) '>|__3) - (reify* [byte+I__B] + (def ~(tag (cstr `YI__B) '>|__3) + (reify* [~(csym ~YI__B)] (~(B 'invoke) [~'_3__ ~(Y 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `byte+L__B) '>|__4) - (reify* [byte+L__B] + (def ~(tag (cstr `YL__B) '>|__4) + (reify* [~(csym ~YL__B)] (~(B 'invoke) [~'_4__ ~(Y 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `byte+F__B) '>|__5) - (reify* [byte+F__B] + (def ~(tag (cstr `YF__B) '>|__5) + (reify* [~(csym ~YF__B)] (~(B 'invoke) [~'_5__ ~(Y 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `byte+D__B) '>|__6) - (reify* [byte+D__B] + (def ~(tag (cstr `YD__B) '>|__6) + (reify* [~(csym ~YD__B)] (~(B 'invoke) [~'_6__ ~(Y 'a) ~(D 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `short+Y__B) '>|__7) - (reify* [short+Y__B] + (def ~(tag (cstr `SY__B) '>|__7) + (reify* [~(csym `SY__B)] (~(B 'invoke) [~'_7__ ~(S 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `short+S__B) '>|__8) - (reify* [short+S__B] + (def ~(tag (cstr `SS__B) '>|__8) + (reify* [~(csym `SS__B)] (~(B 'invoke) [~'_8__ ~(S 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `short+C__B) '>|__9) - (reify* [short+C__B] + (def ~(tag (cstr `SC__B) '>|__9) + (reify* [~(csym `SC__B)] (~(B 'invoke) [~'_9__ ~(S 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `short+I__B) '>|__10) - (reify* [short+I__B] + (def ~(tag (cstr `SI__B) '>|__10) + (reify* [~(csym `SI__B)] (~(B 'invoke) [~'_10__ ~(S 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `short+L__B) '>|__11) - (reify* [short+L__B] + (def ~(tag (cstr `SL__B) '>|__11) + (reify* [~(csym `SL__B)] (~(B 'invoke) [~'_11__ ~(S 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `short+F__B) '>|__12) - (reify* [short+F__B] + (def ~(tag (cstr `SF__B) '>|__12) + (reify* [~(csym `SF__B)] (~(B 'invoke) [~'_12__ ~(S 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `short+D__B) '>|__13) - (reify* [short+D__B] + (def ~(tag (cstr `SD__B) '>|__13) + (reify* [~(csym `SD__B)] (~(B 'invoke) [~'_13__ ~(S 'a) ~(D 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `char+Y__B) '>|__14) - (reify* [char+Y__B] + (def ~(tag (cstr `CY__B) '>|__14) + (reify* [~(csym `CY__B)] (~(B 'invoke) [~'_14__ ~(C 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `char+S__B) '>|__15) - (reify* [char+S__B] + (def ~(tag (cstr `CS__B) '>|__15) + (reify* [~(csym `CS__B)] (~(B 'invoke) [~'_15__ ~(C 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `char+C__B) '>|__16) - (reify* [char+C__B] + (def ~(tag (cstr `CC__B) '>|__16) + (reify* [~(csym `CC__B)] (~(B 'invoke) [~'_16__ ~(C 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `char+I__B) '>|__17) - (reify* [char+I__B] + (def ~(tag (cstr `CI__B) '>|__17) + (reify* [~(csym `CI__B)] (~(B 'invoke) [~'_17__ ~(C 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `char+L__B) '>|__18) - (reify* [char+L__B] + (def ~(tag (cstr `CL__B) '>|__18) + (reify* [~(csym `CL__B)] (~(B 'invoke) [~'_18__ ~(C 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `char+F__B) '>|__19) - (reify* [char+F__B] + (def ~(tag (cstr `CF__B) '>|__19) + (reify* [~(csym `CF__B)] (~(B 'invoke) [~'_19__ ~(C 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `char+D__B) '>|__20) - (reify* [char+D__B] + (def ~(tag (cstr `CD__B) '>|__20) + (reify* [~(csym `CD__B)] (~(B 'invoke) [~'_20__ ~(C 'a) ~(D 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `int+Y__B) '>|__21) - (reify* [int+Y__B] + (def ~(tag (cstr `IY__B) '>|__21) + (reify* [~(csym `IY__B)] (~(B 'invoke) [~'_21__ ~(I 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `int+S__B) '>|__22) - (reify* [int+S__B] + (def ~(tag (cstr `IS__B) '>|__22) + (reify* [~(csym `IS__B)] (~(B 'invoke) [~'_22__ ~(I 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `int+C__B) '>|__23) - (reify* [int+C__B] + (def ~(tag (cstr `IC__B) '>|__23) + (reify* [~(csym `IC__B)] (~(B 'invoke) [~'_23__ ~(I 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `int+I__B) '>|__24) - (reify* [int+I__B] + (def ~(tag (cstr `II__B) '>|__24) + (reify* [~(csym `II__B)] (~(B 'invoke) [~'_24__ ~(I 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `int+L__B) '>|__25) - (reify* [int+L__B] + (def ~(tag (cstr `IL__B) '>|__25) + (reify* [~(csym `IL__B)] (~(B 'invoke) [~'_25__ ~(I 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `int+F__B) '>|__26) - (reify* [int+F__B] + (def ~(tag (cstr `IF__B) '>|__26) + (reify* [~(csym `IF__B)] (~(B 'invoke) [~'_26__ ~(I 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `int+D__B) '>|__27) - (reify* [int+D__B] + (def ~(tag (cstr `ID__B) '>|__27) + (reify* [~(csym `ID__B)] (~(B 'invoke) [~'_27__ ~(I 'a) ~(D 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `long+Y__B) '>|__28) - (reify* [long+Y__B] + (def ~(tag (cstr `LY__B) '>|__28) + (reify* [~(csym `LY__B)] (~(B 'invoke) [~'_28__ ~(L 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `long+S__B) '>|__29) - (reify* [long+S__B] + (def ~(tag (cstr `LS__B) '>|__29) + (reify* [~(csym `LS__B)] (~(B 'invoke) [~'_29__ ~(L 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `long+C__B) '>|__30) - (reify* [long+C__B] + (def ~(tag (cstr `LC__B) '>|__30) + (reify* [~(csym `LC__B)] (~(B 'invoke) [~'_30__ ~(L 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `long+I__B) '>|__31) - (reify* [long+I__B] + (def ~(tag (cstr `LI__B) '>|__31) + (reify* [~(csym `LI__B)] (~(B 'invoke) [~'_31__ ~(L 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `long+L__B) '>|__32) - (reify* [long+L__B] + (def ~(tag (cstr `LL__B) '>|__32) + (reify* [~(csym `LL__B)] (~(B 'invoke) [~'_32__ ~(L 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `long+F__B) '>|__33) - (reify* [long+F__B] + (def ~(tag (cstr `LF__B) '>|__33) + (reify* [~(csym `LF__B)] (~(B 'invoke) [~'_33__ ~(L 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `long+D__B) '>|__34) - (reify* [long+D__B] + (def ~(tag (cstr `LD__B) '>|__34) + (reify* [~(csym `LD__B)] (~(B 'invoke) [~'_34__ ~(L 'a) ~(D 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `float+Y__B) '>|__35) - (reify* [float+Y__B] + (def ~(tag (cstr `FY__B) '>|__35) + (reify* [~(csym `FY__B)] (~(B 'invoke) [~'_35__ ~(F 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `float+S__B) '>|__36) - (reify* [float+S__B] + (def ~(tag (cstr `FS__B) '>|__36) + (reify* [~(csym `FS__B)] (~(B 'invoke) [~'_36__ ~(F 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `float+C__B) '>|__37) - (reify* [float+C__B] + (def ~(tag (cstr `FC__B) '>|__37) + (reify* [~(csym `FC__B)] (~(B 'invoke) [~'_37__ ~(F 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `float+I__B) '>|__38) - (reify* [float+I__B] + (def ~(tag (cstr `FI__B) '>|__38) + (reify* [~(csym `FI__B)] (~(B 'invoke) [~'_38__ ~(F 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `float+L__B) '>|__39) - (reify* [float+L__B] + (def ~(tag (cstr `FL__B) '>|__39) + (reify* [~(csym `FL__B)] (~(B 'invoke) [~'_39__ ~(F 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `float+F__B) '>|__40) - (reify* [float+F__B] + (def ~(tag (cstr `FF__B) '>|__40) + (reify* [~(csym `FF__B)] (~(B 'invoke) [~'_40__ ~(F 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `float+D__B) '>|__41) - (reify* [float+D__B] + (def ~(tag (cstr `FD__B) '>|__41) + (reify* [~(csym `FD__B)] (~(B 'invoke) [~'_41__ ~(F 'a) ~(D 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `double+Y__B) '>|__42) - (reify* [double+Y__B] + (def ~(tag (cstr `DY__B) '>|__42) + (reify* [~(csym `DY__B)] (~(B 'invoke) [~'_42__ ~(D 'a) ~(Y 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `double+S__B) '>|__43) - (reify* [double+S__B] + (def ~(tag (cstr `DS__B) '>|__43) + (reify* [~(csym `DS__B)] (~(B 'invoke) [~'_43__ ~(D 'a) ~(S 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `double+C__B) '>|__44) - (reify* [double+C__B] + (def ~(tag (cstr `DC__B) '>|__44) + (reify* [~(csym `DC__B)] (~(B 'invoke) [~'_44__ ~(D 'a) ~(C 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `double+I__B) '>|__45) - (reify* [double+I__B] + (def ~(tag (cstr `DI__B) '>|__45) + (reify* [~(csym `DI__B)] (~(B 'invoke) [~'_45__ ~(D 'a) ~(I 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `double+L__B) '>|__46) - (reify* [double+L__B] + (def ~(tag (cstr `DL__B) '>|__46) + (reify* [~(csym `DL__B)] (~(B 'invoke) [~'_46__ ~(D 'a) ~(L 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `double+F__B) '>|__47) - (reify* [double+F__B] + (def ~(tag (cstr `DF__B) '>|__47) + (reify* [~(csym `DF__B)] (~(B 'invoke) [~'_47__ ~(D 'a) ~(F 'b)] ~'(. Numeric gt a b)))) - (def ~(tag (cstr `double+D__B) '>|__48) - (reify* [double+D__B] + (def ~(tag (cstr `DD__B) '>|__48) + (reify* [~(csym `DD__B)] (~(B 'invoke) [~'_48__ ~(D 'a) ~(D 'b)] ~'(. Numeric gt a b)))) ~>|types-form @@ -964,39 +963,39 @@ ;; [x (t/- tt/primitive? tt/boolean?)] - (def ~(tag (cstr `byte>long) '>long*|__0) - (reify* [byte>long] + (def ~(tag (cstr `Y__L) '>long*|__0) + (reify* [~(csym `Y__L)] (~(L 'invoke) [~'_0__ ~(Y 'x)] ~'(. Primitive uncheckedLongCast x)))) - (def ~(tag (cstr `short>long) '>long*|__1) - (reify* [short>long] + (def ~(tag (cstr `S__L) '>long*|__1) + (reify* [~(csym `S__L)] (~(L 'invoke) [~'_1__ ~(S 'x)] ~'(. Primitive uncheckedLongCast x)))) - (def ~(tag (cstr `char>long) '>long*|__2) - (reify* [char>long] + (def ~(tag (cstr `C__L) '>long*|__2) + (reify* [~(csym `C__L)] (~(L 'invoke) [~'_2__ ~(C 'x)] ~'(. Primitive uncheckedLongCast x)))) - (def ~(tag (cstr `int>long) '>long*|__3) - (reify* [int>long] + (def ~(tag (cstr `I__L) '>long*|__3) + (reify* [~(csym `I__L)] (~(L 'invoke) [~'_3__ ~(I 'x)] ~'(. Primitive uncheckedLongCast x)))) - (def ~(tag (cstr `long>long) '>long*|__4) - (reify* [long>long] + (def ~(tag (cstr `L__L) '>long*|__4) + (reify* [~(csym `L__L)] (~(L 'invoke) [~'_4__ ~(L 'x)] ~'(. Primitive uncheckedLongCast x)))) - (def ~(tag (cstr `float>long) '>long*|__5) - (reify* [float>long] + (def ~(tag (cstr `F__L) '>long*|__5) + (reify* [~(csym `F__L)] (~(L 'invoke) [~'_5__ ~(F 'x)] ~'(. Primitive uncheckedLongCast x)))) - (def ~(tag (cstr `double>long) '>long*|__6) - (reify* [double>long] + (def ~(tag (cstr `D__L) '>long*|__6) + (reify* [~(csym `D__L)] (~(L 'invoke) [~'_6__ ~(D 'x)] ~'(. Primitive uncheckedLongCast x)))) ;; [x (t/ref (t/isa? Number))] - (def ~(tag (cstr `Object>long) '>long*|__7) - (reify* [Object>long] + (def ~(tag (cstr `O__L) '>long*|__7) + (reify* [~(csym `O__L)] (~(L 'invoke) [~'_7__ ~(O 'x)] (. ~(tag "java.lang.Number" 'x) ~'longValue)))) @@ -1061,12 +1060,12 @@ ;; [x tt/boolean? > (t/ref tt/boolean?)] (def ~(tag (cstr `B__O) 'ref-output-type|__0) - (reify* [B__O] (~(O 'invoke) [~'_0__ ~(B 'x)] (new ~'Boolean ~'x)))) + (reify* [~(csym `B__O)] (~(O 'invoke) [~'_0__ ~(B 'x)] (new ~'Boolean ~'x)))) ;; [x tt/byte? > (t/ref tt/byte?)] (def ~(tag (cstr `Y__O) 'ref-output-type|__1) - (reify* [Y__O] (~(O 'invoke) [~'_1__ ~(Y 'x)] (new ~'Byte ~'x)))) + (reify* [~(csym `Y__O)] (~(O 'invoke) [~'_1__ ~(Y 'x)] (new ~'Byte ~'x)))) [[0 0 nil [(t/isa? Boolean)] (t/ref (t/isa? Boolean))] [1 1 nil [(t/isa? Byte)] (t/ref (t/isa? Byte))]] @@ -1121,35 +1120,35 @@ #_(def ~'>long|__0|input-types (*<> byte?)) (def ~'>long|__0 - (reify byte>long + (reify Y__L (~(L 'invoke) [_## ~(Y 'x)] ;; Resolved from `(>long* x)` (. >long*|__0 invoke ~'x)))) #_(def ~'>long|__1|input-types (*<> short?)) (def ~'>long|__1 - (reify short>long + (reify S__L (~(L 'invoke) [_## ~(C 'x)] ;; Resolved from `(>long* x)` (. >long*|__1 invoke ~'x)))) #_(def ~'>long|__2|input-types (*<> char?)) (def ~'>long|__2 - (reify char>long + (reify C__L (~(L 'invoke) [_## ~(S 'x)] ;; Resolved from `(>long* x)` (. >long*|__2 invoke ~'x)))) #_(def ~'>long|__3|input-types (*<> tt/int?)) (def ~'>long|__3 - (reify int>long + (reify I__L (~(L 'invoke) [_## ~(I 'x)] ;; Resolved from `(>long* x)` (. >long*|__3 invoke ~'x)))) #_(def ~'>long|__4|input-types (*<> tt/long?)) (def ~'>long|__4 - (reify long>long + (reify L__L (~(L 'invoke) [_## ~(L 'x)] ;; Resolved from `(>long* x)` (. >long*|__4 invoke ~'x)))) @@ -1163,7 +1162,7 @@ (t/fn [x (t/or double? float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE)))))) (def ~'>long|__5 - (reify double>long + (reify D__L (~(L 'invoke) [_## ~(D 'x)] ;; Resolved from `(>long* x)` (. >long*|__6 invoke ~'x)))) @@ -1173,7 +1172,7 @@ (t/fn [x (t/or double? float?)] (and (>= x Long/MIN_VALUE) (<= x Long/MAX_VALUE)))))) (def ~'>long|__6 - (reify float>long + (reify F__L (~(L 'invoke) [_## ~(F 'x)] ;; Resolved from `(>long* x)` (. >long*|__6 invoke ~'x)))) @@ -1185,7 +1184,7 @@ (*<> (t/and (t/isa? clojure.lang.BigInt) (t/fn [x (t/isa? clojure.lang.BigInt)] (t/nil? (.bipart x)))))) (def ~'>long|__7 - (reify Object>long + (reify O__L (~(L 'invoke) [_## ~(O 'x)] (let* [~(tag "clojure.lang.BigInt" 'x) ~'x] ~'(.lpart x))))) @@ -1196,7 +1195,7 @@ (*<> (t/and (t/isa? java.math.BigInteger) (t/fn [x (t/isa? java.math.BigInteger)] (< (.bitLength x) 64))))) (def ~'>long|__8 - (reify Object>long + (reify O__L (~(L 'invoke) [_## ~(O 'x)] (let* [~(tag "java.math.BigInteger" 'x) ~'x] ~'(.longValue x))))) @@ -1207,7 +1206,7 @@ #_(def ~'>long|__9|conditions (*<> (-> long|__8|input-types (core/get 0) utr/and-type>args (core/get 1)))) (def ~'>long|__9 - (reify Object>long + (reify O__L (~(L 'invoke) [_## ~(O 'x)] (let* [~(tag "clojure.lang.Ratio" 'x) ~'x] ;; Resolved from `(>long (.bigIntegerValue x))` @@ -1252,7 +1251,7 @@ #_(def ~'>long|__12|input-types (*<> t/string?)) (def ~'>long|__12 - (reify Object>long + (reify O__L (~(L 'invoke) [_## ~(O 'x)] ~'(Long/parseLong x)))) @@ -1261,7 +1260,7 @@ #_(def ~'>long|__13|input-types (*<> t/string? tt/int?)) (def ~'>long|__13 - (reify Object+int>long + (reify OI__L (~(L 'invoke) [_## ~(O 'x) ~(I 'radix)] ~'(Long/parseLong x radix)))) @@ -1320,14 +1319,14 @@ expected (case (env-lang) :clj ($ (do (def ~'!str|__0|0 - (reify* [>Object] + (reify* [~(csym `__O)] (~(O 'invoke) [~'_0__] ~(tag "java.lang.StringBuilder" '(new StringBuilder))))) (def ~(O<> '!str|__1|input0|types) (*<> (t/isa? java.lang.String))) (def ~'!str|__1|0 - (reify* [Object>Object] + (reify* [~(csym `O__O)] (~(O 'invoke) [~'_1__ ~(O 'x)] (let* [~(ST 'x) ~'x] ~(tag "java.lang.StringBuilder" @@ -1337,14 +1336,14 @@ (*<> (t/isa? java.lang.CharSequence) (t/isa? java.lang.Integer))) (def ~'!str|__2|0 - (reify* [Object>Object] + (reify* [~(csym `O__O)] (~(O 'invoke) [~'_2__ ~(O 'x)] (let* [~(tag "java.lang.CharSequence" 'x) ~'x] ~(tag "java.lang.StringBuilder" (list 'new 'StringBuilder (tag "java.lang.CharSequence" 'x))))))) (def ~'!str|__2|1 - (reify* [int>Object] + (reify* [~(csym `I__O)] (~(O 'invoke) [~'_3__ ~(I 'x)] ~(tag "java.lang.StringBuilder" '(new StringBuilder x))))) @@ -1354,18 +1353,18 @@ ~'[] ~'[t/string?] ~'[(t/or tt/char-seq? tt/int?)])} - ([] (.invoke ~(tag "quantum.core.test.defnt_equivalences.>Object" + ([] (.invoke ~(tag "quantum.core.test.defnt_equivalences.__O" '!str|__0|0))) ([~'x00__] (ifs ((Array/get ~'!str|__1|input0|types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" + (.invoke ~(tag "quantum.core.test.defnt_equivalences.O__O" '!str|__1|0) ~'x00__) ((Array/get ~'!str|__2|input0|types 0) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.Object>Object" + (.invoke ~(tag "quantum.core.test.defnt_equivalences.O__O" '!str|__2|0) ~'x00__) ((Array/get ~'!str|__2|input0|types 1) ~'x00__) - (.invoke ~(tag "quantum.core.test.defnt_equivalences.int>Object" + (.invoke ~(tag "quantum.core.test.defnt_equivalences.I__O" '!str|__2|1) ~'x00__) (unsupported! `!str [~'x00__] 0)))))))] (testing "code equivalence" (is-code= actual expected)) @@ -1392,13 +1391,13 @@ ;; [> tt/double?] (def ~'defn-self-reference|__0 - (reify* [>double] + (reify* [~(csym `__D)] (~(O 'invoke) [~'_0__] 2.0))) ;; [x tt/long? > tt/double?] (def ~'defn-self-reference|__1 - (reify* [long>double] + (reify* [~(csym `L__D)] (~(O 'invoke) [~'_1__ ~'x] (~'defn-self-reference)))) [{:id 0 :index 0 :arg-types [] :output-type (t/isa? Double)} @@ -1426,7 +1425,7 @@ (case (env-lang) :clj ($ (do (declare ~'defn-reference) (def ~(tag (cstr `>long) 'defn-reference|__0) - (reify* [>long] (~(L 'invoke) [~'_0__] ~'(>long* 1)))) + ( [>long] (~(L 'invoke) [~'_0__] ~'(>long* 1)))) [{:id 0 :index 0 :arg-types [] :output-type (t/isa? Long)}] @@ -1474,22 +1473,22 @@ :cljs t/val?)])) ~(case-env - :clj `(do (def ^>Object !str|__0 - (reify >Object + :clj `(do (def ^__O !str|__0 + (reify __O (^java.lang.Object invoke [_#] (StringBuilder.)))) ;; `t/string?` - (def ^Object>Object !str|__1 ; `t/string?` - (reify Object>Object + (def ^O__O !str|__1 ; `t/string?` + (reify O__O (^java.lang.Object invoke [_# ^java.lang.Object ~'x] (let* [^String x x] (StringBuilder. x))))) ;; `(t/or t/char-seq? tt/int?)` - (def ^Object>Object !str|__2 ; `t/char-seq?` - (reify Object>Object + (def ^O__O !str|__2 ; `t/char-seq?` + (reify O__O (^java.lang.Object invoke [_# ^java.lang.Object ~'x] (let* [^CharSequence x x] (StringBuilder. x))))) - (def ^int>Object !str|__3 ; `tt/int?` - (reify int>Object (^java.lang.Object invoke [_# ^int ~'x] + (def ^I__O !str|__3 ; `tt/int?` + (reify I__O (^java.lang.Object invoke [_# ^int ~'x] (StringBuilder. x)))) (defn !str ([ ] (.invoke !str|__0)) @@ -1527,11 +1526,11 @@ `(do ~(case-env :clj `(do (def str|__0 - (reify >Object (^java.lang.Object invoke [_# ] ""))) + (reify __O (^java.lang.Object invoke [_# ] ""))) (def str|__1 ; `nil?` - (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'x] ""))) + (reify O__O (^java.lang.Object invoke [_# ^java.lang.Object ~'x] ""))) (def str|__2 ; `Object` - (reify Object>Object (^java.lang.Object invoke [_# ^java.lang.Object ~'x] (.toString x)))) + (reify O__O (^java.lang.Object invoke [_# ^java.lang.Object ~'x] (.toString x)))) (defn str {:quantum.core.type/type @@ -1578,7 +1577,7 @@ ~(case-env :clj `(do ;; `array?` - (def count|__0__1 (reify Object>int (^int invoke [_# ^java.lang.Object ~'xs] (Array/count ^"[B" xs)))) + (def count|__0__1 (reify O__I (^int invoke [_# ^java.lang.Object ~'xs] (Array/count ^"[B" xs)))) ...) :cljs `(do ...))) @@ -1633,8 +1632,8 @@ `(do ;; [t/nil?] (def seq|__0|input-types (*<> t/nil?)) - (def ^Object>Object seq|__0 - (reify Object>Object + (def ^O__O seq|__0 + (reify O__O (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] ;; Notice, no casting for nil input nil))) @@ -1642,46 +1641,46 @@ ;; [(t/isa? ASeq)] (def seq|__2|input-types (*<> (t/isa? ASeq))) - (def ^Object>Object seq|__2 - (reify Object>Object + (def ^O__O seq|__2 + (reify O__O (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (let* [^ASeq xs xs] xs)))) ;; [(t/or (t/isa? LazySeq) (t/isa? Seqable))] (def seq|__3|input-types (*<> (t/isa? LazySeq))) - (def ^Object>Object seq|__3 - (reify Object>Object + (def ^O__O seq|__3 + (reify O__O (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (let* [^LazySeq xs xs] (.seq xs))))) (def seq|__4|input-types (*<> (t/isa? Seqable))) - (def ^Object>Object seq|__4 - (reify Object>Object + (def ^O__O seq|__4 + (reify O__O (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (let* [^Seqable xs xs] (.seq xs))))) ;; [t/iterable?] (def seq|__5|input-types (*<> t/iterable?)) - (def ^Object>Object seq|__5 - (reify Object>Object + (def ^O__O seq|__5 + (reify O__O (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (let* [^Iterable xs xs] (clojure.lang.RT/chunkIteratorSeq (.iterator xs)))))) ;; [t/char-seq?] (def seq|__6|input-types (*<> t/iterable?)) - (def ^Object>Object seq|__6 - (reify Object>Object + (def ^O__O seq|__6 + (reify O__O (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (let* [^CharSequence xs xs] (StringSeq/create xs))))) ;; [(t/isa? Map)] (def seq|__7|input-types (*<> (t/isa? Map))) - (def ^Object>Object seq|__7 - (reify Object>Object + (def ^O__O seq|__7 + (reify O__O (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] ;; This is after expansion; it's the first one that matches the overload ;; If no overload is found it'll have to be dispatched at runtime (protocol or @@ -1693,14 +1692,14 @@ ;; TODO perhaps at some point figure out that it doesn't need to create any more ;; overloads here than just one? (def seq|__8|input-types (*<> (t/isa? (Class/forName "[Z")))) - (def ^Object>Object seq|__8 - (reify Object>Object + (def ^O__O seq|__8 + (reify O__O (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (let* [^"[Z" xs xs] (ArraySeq/createFromObject xs))))) (def seq|__9|input-types (*<> (t/isa? (Class/forName "[B")))) - (def ^Object>Object seq|__9 - (reify Object>Object + (def ^O__O seq|__9 + (reify O__O (^java.lang.Object invoke [_# ^java.lang.Object ~'xs] (let* [^"[B" xs xs] (ArraySeq/createFromObject xs))))) ... @@ -1799,77 +1798,77 @@ ;; ===== `extend-defn!` tests ===== ;; (def dependent-extensible|direct-dispatch|codelist - `[(def ~(tag (cstr `boolean+byte+short+S__O) 'dependent-extensible|__0) - (reify* [boolean+byte+short+S__O] - (~(O 'invoke) [~'_0__ ~(B 'a) ~(Y 'b) ~(S 'c) ~(S 'd)] 1))) - (def ~(tag (cstr `boolean+byte+short+C__O) 'dependent-extensible|__1) - (reify* [boolean+byte+short+C__O] + `[(def ~(tag (cstr `BYSS__O) 'dependent-extensible|__0) + (reify* [~(csym `BYSS__O)] + (~(O 'invoke) [~'_0__ ~(B 'a) ~(Y 'b) ~(S 'c) ~(S 'd)] 1))) + (def ~(tag (cstr `BYSC__O) 'dependent-extensible|__1) + (reify* [~(csym `BYSC__O)] (~(O 'invoke) [~'_1__ ~(B 'a) ~(Y 'b) ~(S 'c) ~(C 'd)] 1))) - (def ~(tag (cstr `boolean+byte+short+Object>Object) 'dependent-extensible|__2) - (reify* [boolean+byte+short+Object>Object] + (def ~(tag (cstr `BYSO__O) 'dependent-extensible|__2) + (reify* [~(csym `BYSO__O)] (~(O 'invoke) [~'_2__ ~(B 'a) ~(Y 'b) ~(S 'c) ~(O 'd)] 1))) - (def ~(tag (cstr `boolean+byte+Object+C__O) 'dependent-extensible|__3) - (reify* [boolean+byte+Object+C__O] + (def ~(tag (cstr `BYOC__O) 'dependent-extensible|__3) + (reify* [~(csym `BYOC__O)] (~(O 'invoke) [~'_3__ ~(B 'a) ~(Y 'b) ~(O 'c) ~(C 'd)] 1))) - (def ~(tag (cstr `boolean+byte+Object+Object>Object) 'dependent-extensible|__4) - (reify* [boolean+byte+Object+Object>Object] + (def ~(tag (cstr `BYOO__O) 'dependent-extensible|__4) + (reify* [~(csym `BYOO__O)] (~(O 'invoke) [~'_4__ ~(B 'a) ~(Y 'b) ~(O 'c) ~(O 'd)] 1))) - (def ~(tag (cstr `boolean+byte+Object+Object>Object) 'dependent-extensible|__5) - (reify* [boolean+byte+Object+Object>Object] + (def ~(tag (cstr `BYOO__O) 'dependent-extensible|__5) + (reify* [~(csym `BYOO__O)] (~(O 'invoke) [~'_5__ ~(B 'a) ~(Y 'b) ~(O 'c) ~(O 'd)] 1))) - (def ~(tag (cstr `boolean+short+short+S__O) 'dependent-extensible|__6) - (reify* [boolean+short+short+S__O] + (def ~(tag (cstr `BSSS__O) 'dependent-extensible|__6) + (reify* [~(csym `BSSS__O)] (~(O 'invoke) [~'_6__ ~(B 'a) ~(S 'b) ~(S 'c) ~(S 'd)] 1))) - (def ~(tag (cstr `boolean+char+short+C__O) 'dependent-extensible|__7) - (reify* [boolean+char+short+C__O] + (def ~(tag (cstr `BCSC__O) 'dependent-extensible|__7) + (reify* [~(csym `BCSC__O)] (~(O 'invoke) [~'_7__ ~(B 'a) ~(C 'b) ~(S 'c) ~(C 'd)] 1))) - (def ~(tag (cstr `boolean+char+Object+C__O) 'dependent-extensible|__8) - (reify* [boolean+char+Object+C__O] + (def ~(tag (cstr `BCOC__O) 'dependent-extensible|__8) + (reify* [~(csym `BCOC__O)] (~(O 'invoke) [~'_8__ ~(B 'a) ~(C 'b) ~(O 'c) ~(C 'd)] 1))) - (def ~(tag (cstr `boolean+Object+short+Object>Object) 'dependent-extensible|__9) - (reify* [boolean+Object+short+Object>Object] + (def ~(tag (cstr `BOSO__O) 'dependent-extensible|__9) + (reify* [~(csym `BOSO__O)] (~(O 'invoke) [~'_9__ ~(B 'a) ~(O 'b) ~(S 'c) ~(O 'd)] 1))) - (def ~(tag (cstr `boolean+Object+Object+Object>Object) 'dependent-extensible|__10) - (reify* [boolean+Object+Object+Object>Object] + (def ~(tag (cstr `BOOO__O) 'dependent-extensible|__10) + (reify* [~(csym `BOOO__O)] (~(O 'invoke) [~'_10__ ~(B 'a) ~(O 'b) ~(O 'c) ~(O 'd)] 1))) - (def ~(tag (cstr `boolean+Object+Object+Object>Object) 'dependent-extensible|__11) - (reify* [boolean+Object+Object+Object>Object] + (def ~(tag (cstr `BOOO__O) 'dependent-extensible|__11) + (reify* [~(csym `BOOO__O)] (~(O 'invoke) [~'_11__ ~(B 'a) ~(O 'b) ~(O 'c) ~(O 'd)] 1))) - (def ~(tag (cstr `byte+byte+short+S__O) 'dependent-extensible|__12) - (reify* [byte+byte+short+S__O] + (def ~(tag (cstr `YYSS__O) 'dependent-extensible|__12) + (reify* [~(csym `YYSS__O)] (~(O 'invoke) [~'_12__ ~(Y 'a) ~(Y 'b) ~(S 'c) ~(S 'd)] 1))) - (def ~(tag (cstr `byte+byte+short+C__O) 'dependent-extensible|__13) - (reify* [byte+byte+short+C__O] + (def ~(tag (cstr `YYSC__O) 'dependent-extensible|__13) + (reify* [~(csym `YYSC__O)] (~(O 'invoke) [~'_13__ ~(Y 'a) ~(Y 'b) ~(S 'c) ~(C 'd)] 1))) - (def ~(tag (cstr `byte+byte+short+Object>Object) 'dependent-extensible|__14) - (reify* [byte+byte+short+Object>Object] + (def ~(tag (cstr `YYSO__O) 'dependent-extensible|__14) + (reify* [~(csym `YYSO__O)] (~(O 'invoke) [~'_14__ ~(Y 'a) ~(Y 'b) ~(S 'c) ~(O 'd)] 1))) - (def ~(tag (cstr `byte+byte+Object+C__O) 'dependent-extensible|__15) - (reify* [byte+byte+Object+C__O] + (def ~(tag (cstr `YYOC__O) 'dependent-extensible|__15) + (reify* [~(csym `YYOC__O)] (~(O 'invoke) [~'_15__ ~(Y 'a) ~(Y 'b) ~(O 'c) ~(C 'd)] 1))) - (def ~(tag (cstr `byte+byte+Object+Object>Object) 'dependent-extensible|__16) - (reify* [byte+byte+Object+Object>Object] + (def ~(tag (cstr `YYOO__O) 'dependent-extensible|__16) + (reify* [~(csym `YYOO__O)] (~(O 'invoke) [~'_16__ ~(Y 'a) ~(Y 'b) ~(O 'c) ~(O 'd)] 1))) - (def ~(tag (cstr `byte+byte+Object+Object>Object) 'dependent-extensible|__17) - (reify* [byte+byte+Object+Object>Object] + (def ~(tag (cstr `YYOO__O) 'dependent-extensible|__17) + (reify* [~(csym `YYOO__O)] (~(O 'invoke) [~'_17__ ~(Y 'a) ~(Y 'b) ~(O 'c) ~(O 'd)] 1))) - (def ~(tag (cstr `short+short+short+S__O) 'dependent-extensible|__18) - (reify* [short+short+short+S__O] + (def ~(tag (cstr `SSSS__O) 'dependent-extensible|__18) + (reify* [~(csym `SSSS__O)] (~(O 'invoke) [~'_18__ ~(S 'a) ~(S 'b) ~(S 'c) ~(S 'd)] 1))) - (def ~(tag (cstr `char+char+short+C__O) 'dependent-extensible|__19) - (reify* [char+char+short+C__O] + (def ~(tag (cstr `CCSC__O) 'dependent-extensible|__19) + (reify* [~(csym `CCSC__O)] (~(O 'invoke) [~'_19__ ~(C 'a) ~(C 'b) ~(S 'c) ~(C 'd)] 1))) - (def ~(tag (cstr `char+char+Object+C__O) 'dependent-extensible|__20) - (reify* [char+char+Object+C__O] + (def ~(tag (cstr `CCOC__O) 'dependent-extensible|__20) + (reify* [~(csym `CCOC__O)] (~(O 'invoke) [~'_20__ ~(C 'a) ~(C 'b) ~(O 'c) ~(C 'd)] 1))) - (def ~(tag (cstr `Object+Object+short+Object>Object) 'dependent-extensible|__21) - (reify* [Object+Object+short+Object>Object] + (def ~(tag (cstr `OOSO__O) 'dependent-extensible|__21) + (reify* [~(csym `OOSO__O)] (~(O 'invoke) [~'_21__ ~(O 'a) ~(O 'b) ~(S 'c) ~(O 'd)] 1))) - (def ~(tag (cstr `Object+Object+Object+Object>Object) 'dependent-extensible|__22) - (reify* [Object+Object+Object+Object>Object] + (def ~(tag (cstr `OOOO__O) 'dependent-extensible|__22) + (reify* [~(csym `OOOO__O)] (~(O 'invoke) [~'_22__ ~(O 'a) ~(O 'b) ~(O 'c) ~(O 'd)] 1))) - (def ~(tag (cstr `Object+Object+Object+Object>Object) 'dependent-extensible|__23) - (reify* [Object+Object+Object+Object>Object] + (def ~(tag (cstr `OOOO__O) 'dependent-extensible|__23) + (reify* [~(csym `OOOO__O)] (~(O 'invoke) [~'_23__ ~(O 'a) ~(O 'b) ~(O 'c) ~(O 'd)] 1)))]) (def dependent-extensible|fn|form @@ -2000,7 +1999,7 @@ (case (env-lang) :clj ($ (do (declare ~'extensible) (def ~(tag (cstr `D__O) 'extensible|__0) - (reify* [D__O] (~(O 'invoke) [~'_0__ ~(D 'a)] nil))) + ( [D__O] (~(O 'invoke) [~'_0__ ~(D 'a)] nil))) [{:id 0 :index 0 :arg-types [(t/isa? Double)] :output-type t/any?}] @@ -2021,7 +2020,7 @@ expected (case (env-lang) :clj ($ (do (def ~(tag (cstr `B__O) 'extensible|__1) - (reify* [B__O] + (reify* [~(csym `B__O)] (~(O 'invoke) [~'_0__ ~(B 'a)] nil))) [{:id 1 :index 0 :arg-types [(t/isa? Boolean)] :output-type t/any?} @@ -2185,7 +2184,7 @@ (case (env-lang) :clj ($ [(do (declare ~'simple-reactive-dependee) (def ~(tag (cstr `C__O) 'simple-reactive-dependee|__0) - (reify* [C__O] (~(O 'invoke) [~'_0__ ~(C 'a)] 1))) + (reify* [~(csym `C__O)] (~(O 'invoke) [~'_0__ ~(C 'a)] 1))) [{:id 0 :index 0 :arg-types [(t/isa? Character)] :output-type t/any?}] (defmeta ~'simple-reactive-dependee {:quantum.core.type/type simple-reactive-dependee|__type} @@ -2195,7 +2194,7 @@ (unsupported! `simple-reactive-dependee [~'x00__] 0)))))) (do (declare ~'simple-reactive-dependent) (def ~(tag (cstr `C__O) 'simple-reactive-dependent|__0) - (reify* [C__O] (~(O 'invoke) [~'_0__ ~(C 'a)] "abc"))) + (reify* [~(csym `C__O)] (~(O 'invoke) [~'_0__ ~(C 'a)] "abc"))) [{:id 0 :index 0 :arg-types [(t/isa? Character)] :output-type t/any?}] (defmeta ~'simple-reactive-dependent {:quantum.core.type/type simple-reactive-dependent|__type} @@ -2310,7 +2309,7 @@ (intern 'ns0 'abcde|__types|0 (overload-types>arg-types (rx/norx-deref ns0/abcde|__types) 0)))) - Resulting in `abcde`'s runtime-emission code in CLJ as: - - (do (def abcde|__0 (reify* [int>long] (invoke ([x00__ a] ...)))) + - (do (def abcde|__0 (reify* [~(csym `I__L)] (invoke ([x00__ a] ...)))) (defn abcde [x00__] (ifs ((Array/get ns0/abcde|__types|0 0) x00__) ... (unsupported! ...)))) @@ -2365,8 +2364,8 @@ (intern 'ns1 'fghij|__types|0 (overload-types>arg-types (rx/norx-deref ns1/fghij|__types) 0)))) - Resulting in `fghij`'s runtime-emission code in CLJ as: - - (do (def fghij|__0 (reify* [int>long] (invoke ([x00__ b] ...)))) - (def fghij|__1 (reify* [Object>Object] (invoke ([x00__ c] ...)))) + - (do (def fghij|__0 (reify* [~(csym `I__L)] (invoke ([x00__ b] ...)))) + (def fghij|__1 (reify* [~(csym `O__O)] (invoke ([x00__ c] ...)))) (defn fghij [x00__] (ifs ((Array/get ns0/fghij|__types|0 0) x00__) (. ns0/fghij|__0 invoke x00__) (unsupported! ...)))) @@ -2536,7 +2535,7 @@ (. ~(aget* ts 1) ~'invoke ~'x00__) (unsupported! `f0|test [~'x00__] 0)))))] ~(aset* fs 0 - `(reify* [B__O] + `(reify* [~(csym `B__O)] (~'invoke [~'_0__ ~(B 'a)] ;; From `(self/fn [b ...])` (let* [~fs (*<>|sized|macro 2) @@ -2553,7 +2552,7 @@ (. ~(>C__O (aget* fs 1)) ~'invoke ~'x00__) (unsupported! [~'x00__] 0)))))] ~(aset* fs 0 - `(reify* [Y__O] + `(reify* [~(csym `Y__O)] (~'invoke [~'_0__ ~(Y 'b)] ;; From `(self/fn [c ...])` (let* [~fs (*<>|sized|macro 2) @@ -2567,56 +2566,93 @@ (. ~(>S__O (aget* fs 1)) ~'invoke ~'x00__) (unsupported! [~'x00__] 0))))))] ~(aset* fs 0 - `(reify* [B__O] + `(reify* [~(csym `B__O)] (~'invoke [~'_0__ (B 'c)] ~'b (. ~(>B__O (aget* fs 0)) ~'invoke ~'a) (. ~(>B__O (aget* fs 0)) ~'invoke ~'c)))) ~(aset* fs 1 - `(reify* [S__O] + `(reify* [~(csym `S__O)] (~'invoke [~'_0__ (S 'c)] ~'b (. ~(>B__O (aget* fs 0)) ~'invoke ~'a) (. ~(>S__O (aget* fs 1)) ~'invoke ~'c)))) ~'f__2))) ~(aset* fs 1 - (reify* [C__O] + (reify* [~(csym `C__O)] (~'invoke [~'_0__ ~(C 'a)] ...))) ~'f__1)))) ~(aset* fs 1 - `(reify* [D__O] + `(reify* [~(csym `D__O)] (~'invoke [~'_0__ ~(D 'a)] ...))) ~'f__0)))))]) (let [actual (binding [self/*compilation-mode* :test] (macroexpand ' - (self/defn g|test [f0 (t/ftype [tt/long? :> tt/float?]) - f1 (t/ftype [tt/byte? :> tt/boolean?] - [tt/string? :> tt/char?]) - > tt/char?] - (f0 7) - (f1 "11")))) + (do (self/defn g|test [f0 (t/ftype [tt/long? :> tt/float?]) > tt/float?] + (f0 5)) + (self/defn h|test [f0 (t/ftype [tt/long? :> tt/float?] + [tt/string? :> tt/char?]) + f1 (t/ftype [tt/byte? :> tt/boolean?] + [tt/long? :> tt/char?] + [tt/string? :> tt/char?]) + > tt/char?] + (f0 7) + (g|test f0) + (h|test f1 f0) + (f1 "11"))))) expected (case (env-lang) :clj ($ (do (declare ~'g|test) + (defmeta-from ~'g|test + (let* [~fs (*<>|sized|macro 1) + ~'f__0 (new TypedFn + {:quantum.core.type/type ~'g|__type} + (fn* ([~ts ~fs ~'x00] + (ifs (~(aget* (aget* ts 0) 0) ~'x00__) + (. ~(aget* fs 0) ~'invoke ~'x00__) + (unsupported! `g|test [~'x00__] 0)))))] + ~(aset* fs 0 + `(reify [OI__F] + (~'invoke [~'_0__ ~(O 'f0) + ~(I 'i__0)] ; overload ID of `f0` : `[tt/long?]` + (. ~(>L__F (aget* `(.-fs ~'f0) 'i__0)) ~'invoke 5)))) + ~'f__0)) + (declare ~'h|test) [[0 0 false [] (t/ftype [tt/long? :> tt/char?])]] - (defmeta-from ~'g|test - (let* [~fs (*<>|sized|macro 2) - ~'f__0 (new TypedFn - {:quantum.core.type/type ~'g|__type} - (fn* ([~ts ~fs ~'x00__ ~'x01__] - (ifs (~(aget* (aget* ts 0) 0) ~'x00__) - (ifs (~(aget* (aget* ts 0) 1) ~'x00__) - (. ~(aget* fs 0) ~'invoke ~'x00__ ~'x01__) - (unsupported! `g|test [~'x00__ ~'x01__] 1)) - (unsupported! `g|test [~'x00__ ~'x01__] 0)))))] - ~(aset* fs 0 - `(reify* [O__C] - (~'invoke [~'_0__ ~(O 'f0) ~(O 'f1)] - (. ~(aget* `(.-fs ~'f0) ...) ~'invoke 7) - (. ~(aget* `(.-fs ~'f1) ...) ~'invoke "11")))) - ~'f__0)))))] - ...)) + (let* [~'g|test|__ (deref ~(list 'var `g|test))] ; to avoid var indirection + (defmeta-from ~'h|test + (let* [~'h|test|__fs (*<>|sized|macro 1) + ~'h|test|__f + (new TypedFn + {:quantum.core.type/type ~'g|__type} + ... + ~fs + (fn* ([~ts ~fs ~'x00__ ~'x01__] + (ifs (~(aget* (aget* ts 0) 0) ~'x00__) + (ifs (~(aget* (aget* ts 0) 1) ~'x00__) + (. ~(aget* fs 0) ~'invoke ~'x00__ ~'x01__) + (unsupported! `h|test [~'x00__ ~'x01__] 1)) + (unsupported! `h|test [~'x00__ ~'x01__] 0)))))] + ~(aset* h|test|__fs 0 + `(reify* [~(csym `OOII__C)] + (~'invoke [~'_0__ ~(O 'f0) ~(O 'f1) + ~(I 'i__0) ; overload ID of `f0` : `[tt/long?]` + ~(I 'i__1) ; overload ID of `f0` : `` + ~(I 'i__2)] ; overload ID of `f1` : `` + (. ~(aget* `(.-fs ~'f0) 'i__0) ~'invoke 7) + ;; It doesn't just refer to `g|test|__fs` or whatever because the + ;; fn in question (`g|test`) is extensible. Otherwise it would skip + ;; the ceremony of `(aget* `(.-fs ~'g|test|__) 0)` and just do e.g. + ;; `g|test|__0`. + (. ~(aget* `(.-fs ~'g|test|__) 0) ~'invoke ~'f0 i__1) + ;; It doesn't just refer to `h|test|__fs` because the fn in question + ;; (`h|test`) is extensible. Otherwise it would skip the ceremony of + ;; `(aget* `(.-fs ~'h|test|__f) 0)` and just do e.g. `h|test|__0`. + (. ~(aget* `(.-fs ~'h|test|__f) 0) ~'invoke ~'f0 ~'f1 ~'i__0 ~'i__2) + (. ~(aget* `(.-fs ~'f1) 'i__1) ~'invoke "11")))) + ~'f__0))))))] + ...)) " @@ -2626,7 +2662,7 @@ We could do: may allow for more than what the declared type requires, in which case it may have more and/or different overloads. So do something like this: (t/defn a [f (t/ftype [t/long?])] (f 1)) - -> (def a|__0 (reify [_ ^TypedFn f ^int f|__i] (.invoke ^long>Object (RT/aget (.-overloads f) f|__i) 1))) + -> (def a|__0 (reify [_ ^TypedFn f ^int f|__i] (.invoke ^L__O (RT/aget (.-overloads f) f|__i) 1))) (t/defn b [x (t/or t/boolean? t/long?)] x) (t/dotyped (a b)) -> (.invoke a|__0 b|__f 1) ; meaning, use the overload at index 1. If -1 then From 5cf1a288c551f09d730cd97e17738877c809f119 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 21 Nov 2018 16:59:27 -0700 Subject: [PATCH 764/810] Finish up this part of fn test --- resources-dev/defnt.cljc | 4 +- .../untyped/core/type/reifications.cljc | 1 + .../quantum/test/untyped/core/type/defnt.cljc | 321 +++++++++--------- 3 files changed, 172 insertions(+), 154 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index d069a856..56e31d64 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -61,7 +61,9 @@ Legend: [-] t/fn [ ] look at fn comparisons; really there's just <|=|> with <|=|> so 9 combos [ ] add `t/fn` as a special form so we don't need to re-analyze its constituents - [ ] t/ftype should automatically split types, while perhaps t/ftype* should just assume they're split (for use by e.g. `t/fn` and `t/defn`) + [ ] t/ftype should automatically split types, while perhaps t/ftype* should just assume + they're split (for use by e.g. `t/fn` and `t/defn`) + [ ] test t/fn to make sure meta 'sticks' : `(t/fn {...} [] ...)` [ ] make local vars sanitary/safe by using more of the gensym feature [2] t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 3f3518ba..41d7f1d5 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -504,6 +504,7 @@ (setFs [this fs']) (setTs [this ts'])) +;; TODO should we provide one with no `^:!` metadata, for optimization purposes? (udt/deftype TypedFn [meta ;; The types for direct dispatch overloads diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 515c3a61..2728ee3c 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -69,8 +69,9 @@ (defn >O__F [form] (tag (cstr `O__F) form)) (defn >O__O [form] (tag (cstr `O__O) form)) -(def ts (O<> 'ts__)) -(def fs (O<> 'fs__)) +(def &ts (O<> 'ts__)) +(def &fs (O<> 'fs__)) +(def &this '&this) (defn aget* [x i] (list '. 'clojure.lang.RT 'aget x i)) (defn aset* [x i v] (list '. 'clojure.lang.RT 'aset x i v)) @@ -86,15 +87,15 @@ expected ($ (do [[0 0 false [] (t/or t/nil? t/string?)]] (defmeta-from ~'pid - (let* [~fs (*<>|sized|macro 0) - ~'f__0 (new TypedFn - {:quantum.core.type/type pid|__type} - pid|__!types ; defined/created within `t/defn` - fs - (fn* ([~ts ~fs] (. ~(aget* fs 0) ~'invoke))))] - ~(aset* fs 0 + (let* [~pid|__fs (*<>|sized|macro 0) + ~'pid (new TypedFn + {:quantum.core.type/type pid|__type} + pid|__!types ; defined/created within `t/defn` + pid|__fs + (fn* ([~&ts ~&fs] (. ~(aget* &fs 0) ~'invoke))))] + ~(aset* pid|__fs 0 `(reify* [~(csym `__O)] - (~(O 'invoke) [~'_0__] + (~(O 'invoke) [~&this] ~(ST (list '. (tag "java.lang.management.RuntimeMXBean" '(. java.lang.management.ManagementFactory getRuntimeMXBean)) @@ -2506,153 +2507,167 @@ [(t/value nil) (t/not (t/value nil))]])) (deftest test|fn - (let [actual (binding [self/*compilation-mode* :test] - (macroexpand ' - ;: FIXME this contract is not being held up when returning nil - (self/defn f0|test [a (t/or tt/boolean? tt/double?) - > (t/ftype [tt/byte? :> (t/ftype [tt/char?])])] - ;; TODO this fits into a larger scheme of, should we have output types be - ;; `(t/and actual declared)` or should we just have them be `declared`? The - ;; latter is easier but it seems like the `t/fn` dispatch forces our hand - ;; towards the former. We need to think about this more. - (self/fn [b (t/or tt/byte? tt/char?) - > (t/ftype [(t/or (t/type a) tt/short?)])] - (self/fn f1|test [c (t/or (t/type a) tt/short?)] - b (f1|test a) (f1|test c)))))) - expected - (case (env-lang) - :clj - ($ (do (declare ~'f0|test) - [[0 0 false [] (t/ftype tt/boolean? [tt/byte? :> (t/ftype [tt/char?])])]] - (defmeta-from ~'f0|test - (let* [~fs (*<>|sized|macro 2) - ~'f__0 (new TypedFn - {:quantum.core.type/type ~'f0|test|__type} - (fn* ([~ts ~fs ~'x00__] - (ifs (~(aget* (aget* ts 0) 0) ~'x00__) - (. ~(aget* ts 0) ~'invoke ~'x00__) - (~(aget* (aget* ts 1) 0) ~'x00__) - (. ~(aget* ts 1) ~'invoke ~'x00__) - (unsupported! `f0|test [~'x00__] 0)))))] - ~(aset* fs 0 - `(reify* [~(csym `B__O)] - (~'invoke [~'_0__ ~(B 'a)] - ;; From `(self/fn [b ...])` - (let* [~fs (*<>|sized|macro 2) - ~'f__1 (new TypedFn nil - ;; TODO perhaps extern this (and parts thereof) whenever - ;; possible in `let*` statement on the very outside of the fn - ;; (so around the outer `reify*`) ? - (*<>|macro (*<>|macro t/byte?) (*<>|macro t/char?)) - ~fs - (fn* ([~ts ~fs ~'x00__] - (ifs (~(aget* (aget* ~ts 0) 0) ~'x00__) - (. ~(>Y__O (aget* fs 0)) ~'invoke ~'x00__) - (~(aget* (aget* ~ts 1) 0) ~'x00__) - (. ~(>C__O (aget* fs 1)) ~'invoke ~'x00__) - (unsupported! [~'x00__] 0)))))] - ~(aset* fs 0 - `(reify* [~(csym `Y__O)] - (~'invoke [~'_0__ ~(Y 'b)] - ;; From `(self/fn [c ...])` - (let* [~fs (*<>|sized|macro 2) - ~'f__2 (new TypedFn nil - (*<>|macro (*<>|macro t/boolean?) (*<>|macro t/short?)) - ~fs - (fn* ([~ts ~fs ~'x00] - (ifs (~(aget* (aget* ts 0) 0) ~'x00__) - (. ~(>B__O (aget* fs 0)) ~'invoke ~'x00__) - (~(aget* (aget* ts 1) 0) ~'x00__) - (. ~(>S__O (aget* fs 1)) ~'invoke ~'x00__) - (unsupported! [~'x00__] 0))))))] - ~(aset* fs 0 - `(reify* [~(csym `B__O)] - (~'invoke [~'_0__ (B 'c)] - ~'b - (. ~(>B__O (aget* fs 0)) ~'invoke ~'a) - (. ~(>B__O (aget* fs 0)) ~'invoke ~'c)))) - ~(aset* fs 1 - `(reify* [~(csym `S__O)] - (~'invoke [~'_0__ (S 'c)] - ~'b - (. ~(>B__O (aget* fs 0)) ~'invoke ~'a) - (. ~(>S__O (aget* fs 1)) ~'invoke ~'c)))) - ~'f__2))) - ~(aset* fs 1 - (reify* [~(csym `C__O)] - (~'invoke [~'_0__ ~(C 'a)] ...))) - ~'f__1)))) - ~(aset* fs 1 - `(reify* [~(csym `D__O)] - (~'invoke [~'_0__ ~(D 'a)] ...))) - ~'f__0)))))]) - (let [actual (binding [self/*compilation-mode* :test] - (macroexpand ' - (do (self/defn g|test [f0 (t/ftype [tt/long? :> tt/float?]) > tt/float?] - (f0 5)) - (self/defn h|test [f0 (t/ftype [tt/long? :> tt/float?] - [tt/string? :> tt/char?]) - f1 (t/ftype [tt/byte? :> tt/boolean?] - [tt/long? :> tt/char?] - [tt/string? :> tt/char?]) - > tt/char?] - (f0 7) - (g|test f0) - (h|test f1 f0) - (f1 "11"))))) - expected - (case (env-lang) - :clj - ($ (do (declare ~'g|test) - (defmeta-from ~'g|test - (let* [~fs (*<>|sized|macro 1) - ~'f__0 (new TypedFn - {:quantum.core.type/type ~'g|__type} - (fn* ([~ts ~fs ~'x00] - (ifs (~(aget* (aget* ts 0) 0) ~'x00__) - (. ~(aget* fs 0) ~'invoke ~'x00__) - (unsupported! `g|test [~'x00__] 0)))))] - ~(aset* fs 0 - `(reify [OI__F] - (~'invoke [~'_0__ ~(O 'f0) - ~(I 'i__0)] ; overload ID of `f0` : `[tt/long?]` - (. ~(>L__F (aget* `(.-fs ~'f0) 'i__0)) ~'invoke 5)))) - ~'f__0)) - (declare ~'h|test) - [[0 0 false [] (t/ftype [tt/long? :> tt/char?])]] - (let* [~'g|test|__ (deref ~(list 'var `g|test))] ; to avoid var indirection - (defmeta-from ~'h|test - (let* [~'h|test|__fs (*<>|sized|macro 1) - ~'h|test|__f + (testing "Nested fns" + (let [actual (binding [self/*compilation-mode* :test] + (macroexpand ' + ;: FIXME this contract is not being held up when returning nil + (self/defn f0|test [a (t/or tt/boolean? tt/double?) + > (t/ftype [tt/byte? :> (t/ftype [tt/char?])])] + ;; TODO this fits into a larger scheme of, should we have output types be + ;; `(t/and actual declared)` or should we just have them be `declared`? The + ;; latter is easier but it seems like the `t/fn` dispatch forces our hand + ;; towards the former. We need to think about this more. + (self/fn [b (t/or tt/byte? tt/char?) + > (t/ftype [(t/or (t/type a) tt/short?)])] + (self/fn f1|test [c (t/or (t/type a) tt/short?)] + b (f1|test a) (f1|test c)))))) + expected + (case (env-lang) + :clj + ($ (do [[0 0 false [] (t/ftype tt/boolean? [tt/byte? :> (t/ftype [tt/char?])])]] + (defmeta-from ~'f0|test + (let* [~'f0|test|__fs (*<>|sized|macro 2) + ~'f0|test + (new TypedFn + {:quantum.core.type/type ~'f0|test|__type} + ... + ~'f0|test|__fs + (fn* ([~&ts ~&fs ~'x00__] + (ifs (~(aget* (aget* &ts 0) 0) ~'x00__) + (. ~(aget* &ts 0) ~'invoke ~'x00__) + (~(aget* (aget* &ts 1) 0) ~'x00__) + (. ~(aget* &ts 1) ~'invoke ~'x00__) + (unsupported! `f0|test [~'x00__] 0)))))] + ~(aset* f0|test|__fs 0 + `(reify* [~(csym `B__O)] + (~'invoke [~&this ~(B 'a)] + ;; From `(self/fn [b ...])` + (let* [~'f__0|__fs (*<>|sized|macro 2) + ~'f__0 + (new TypedFn nil + ;; TODO perhaps extern this (and parts thereof) whenever + ;; possible in `let*` statement on the very outside of the fn + ;; (so around the outer `reify*`) ? + (*<>|macro (*<>|macro t/byte?) (*<>|macro t/char?)) + ~'f__0|__fs + (fn* ([~&ts ~&fs ~'x00__] + (ifs (~(aget* (aget* ~&ts 0) 0) ~'x00__) + (. ~(>Y__O (aget* &fs 0)) ~'invoke ~'x00__) + (~(aget* (aget* ~&ts 1) 0) ~'x00__) + (. ~(>C__O (aget* &fs 1)) ~'invoke ~'x00__) + (unsupported! [~'x00__] 0)))))] + ~(aset* f__0|__fs 0 + `(reify* [~(csym `Y__O)] + (~'invoke [~'_0__ ~(Y 'b)] + ;; From `(self/fn [c ...])` + (let* [~'f1|test|__fs (*<>|sized|macro 2) + ~'f1|test + (new TypedFn nil + (*<>|macro (*<>|macro t/boolean?) (*<>|macro t/short?)) + ~'f1|test|__fs + (fn* ([~&ts ~&fs ~'x00] + (ifs (~(aget* (aget* &ts 0) 0) ~'x00__) + (. ~(>B__O (aget* &fs 0)) ~'invoke ~'x00__) + (~(aget* (aget* &ts 1) 0) ~'x00__) + (. ~(>S__O (aget* &fs 1)) ~'invoke ~'x00__) + (unsupported! [~'x00__] 0))))))] + ~(aset* f1|test|__fs 0 + `(reify* [~(csym `B__O)] + (~'invoke [~&this (B 'c)] + ~'b + (. ~(>B__O (aget* 'f1|test|__fs 0)) ~'invoke ~'a) + (. ~(>B__O (aget* 'f1|test|__fs 0)) ~'invoke ~'c)))) + ~(aset* f1|test|__fs 1 + `(reify* [~(csym `S__O)] + (~'invoke [~&this (S 'c)] + ~'b + (. ~(>B__O (aget* 'f1|test|__fs 0)) ~'invoke ~'a) + (. ~(>S__O (aget* 'f1|test|__fs 1)) ~'invoke ~'c)))) + ~'f1|test))) + ~(aset* f__0|__fs 1 + (reify* [~(csym `C__O)] + (~'invoke [~&this ~(C 'a)] ...))) + ~'f__0)))) + ~(aset* f0|test|__fs 1 + `(reify* [~(csym `D__O)] + (~'invoke [~&this ~(D 'a)] ...))) + ~'f0|test)))))])) + (testing "Calling fns" + (let [actual (binding [self/*compilation-mode* :test] + (macroexpand ' + (do (self/defn g|test [f0 (t/ftype [tt/long? :> tt/float?]) > tt/float?] + (f0 5)) + (self/defn h|test [f0 (t/ftype [tt/long? :> tt/float?] + [tt/string? :> tt/char?]) + f1 (t/ftype [tt/byte? :> tt/boolean?] + [tt/long? :> tt/char?] + [tt/string? :> tt/char?]) + > tt/char?] + (f0 7) + (g|test f0) + (h|test f1 f0) + (f1 "11"))))) + expected + (case (env-lang) + :clj + ($ (do (defmeta-from ~'g|test + (let* [~'g|test|__fs (*<>|sized|macro 1) + ~'g|test (new TypedFn {:quantum.core.type/type ~'g|__type} - ... - ~fs - (fn* ([~ts ~fs ~'x00__ ~'x01__] - (ifs (~(aget* (aget* ts 0) 0) ~'x00__) - (ifs (~(aget* (aget* ts 0) 1) ~'x00__) - (. ~(aget* fs 0) ~'invoke ~'x00__ ~'x01__) - (unsupported! `h|test [~'x00__ ~'x01__] 1)) - (unsupported! `h|test [~'x00__ ~'x01__] 0)))))] - ~(aset* h|test|__fs 0 + (fn* ([~&ts ~&fs ~'x00] + (ifs (~(aget* (aget* &ts 0) 0) ~'x00__) + (. ~(aget* &fs 0) ~'invoke ~'x00__) + (unsupported! `g|test [~'x00__] 0)))))] + ~(aset* g|test|__fs 0 + `(reify [OI__F] + (~'invoke [~&this ~(O 'f0) + ~(I 'i__0)] ; overload ID of `f0` : `[tt/long?]` + (. ~(>L__F (aget* `(. ~'f0 ~'fs) 'i__0)) ~'invoke 5)))) + ~'g|test)) + (let* [~'g|test|__ (deref ~(list 'var `g|test))] ; to avoid var indirection + (defmeta-from ~'h|test + (let* [~'h|test|__fs (*<>|sized|macro 1) + ~'h|test|__f + (new TypedFn + {:quantum.core.type/type ~'g|__type} + ... + ~'h|test|__fs + (fn* ([~&ts ~&fs ~'x00__ ~'x01__] + (ifs (~(aget* (aget* &ts 0) 0) ~'x00__) + (ifs (~(aget* (aget* &ts 0) 1) ~'x00__) + (. ~(aget* &fs 0) ~'invoke ~'x00__ ~'x01__) + (unsupported! `h|test [~'x00__ ~'x01__] 1)) + (unsupported! `h|test [~'x00__ ~'x01__] 0)))))] + ;; TODO if a reify overload ever gets redefined (same ID) then the + ;; interface might be different... ugh... + ~(aset* h|test|__fs 0 `(reify* [~(csym `OOII__C)] - (~'invoke [~'_0__ ~(O 'f0) ~(O 'f1) + (~'invoke [~&this ~(O 'f0) ~(O 'f1) ~(I 'i__0) ; overload ID of `f0` : `[tt/long?]` - ~(I 'i__1) ; overload ID of `f0` : `` - ~(I 'i__2)] ; overload ID of `f1` : `` - (. ~(aget* `(.-fs ~'f0) 'i__0) ~'invoke 7) - ;; It doesn't just refer to `g|test|__fs` or whatever because the - ;; fn in question (`g|test`) is extensible. Otherwise it would skip - ;; the ceremony of `(aget* `(.-fs ~'g|test|__) 0)` and just do e.g. - ;; `g|test|__0`. - (. ~(aget* `(.-fs ~'g|test|__) 0) ~'invoke ~'f0 i__1) - ;; It doesn't just refer to `h|test|__fs` because the fn in question - ;; (`h|test`) is extensible. Otherwise it would skip the ceremony of - ;; `(aget* `(.-fs ~'h|test|__f) 0)` and just do e.g. `h|test|__0`. - (. ~(aget* `(.-fs ~'h|test|__f) 0) ~'invoke ~'f0 ~'f1 ~'i__0 ~'i__2) - (. ~(aget* `(.-fs ~'f1) 'i__1) ~'invoke "11")))) - ~'f__0))))))] - ...)) + ~(I 'i__1) ; overload ID of `f1` : `[tt/long?]` + ~(I 'i__2)] ; overload ID of `f1` : `[tt/string?]` + ;; This `let*` is here to save on how many arguments need to be + ;; allocated to the stack, and to avoid having to rewrite these + ;; bindings in the body. Hopefully the bindings will be optimized + ;; away by the JVM. + (let* [~'i__2 ~'i__1 + ~'i__3 ~'i__0 + ~'i__4 ~'i__2] + (. ~(aget* `(. ~'f0 ~'fs) 'i__0) ~'invoke 7) + ;; It doesn't just refer to `g|test|__fs` or whatever because the + ;; fn in question (`g|test`) is extensible. Otherwise it would + ;; skip the ceremony of `(aget* `(. ~'g|test|__ ~'fs) 0)` and just + ;; do e.g. `g|test|__0`. + (. ~(aget* `(. ~'g|test|__ ~'fs) 0) ~'invoke ~'f0 ~'i__1) + ;; It doesn't just refer to `h|test|__fs` because the fn in + ;; question (`h|test`) is extensible. Otherwise it would skip the + ;; ceremony of `(aget* `(. ~'h|test|__f ~'fs) 0)` and just do e.g. + ;; `h|test|__0`. + (. ~(aget* `(. ~'h|test|__f ~'fs) 0) ~'invoke ~'f1 ~'f0 ~'i__2 ~'i__3) + (. ~(aget* `(. ~'f1 ~'fs) 'i__4) ~'invoke "11"))))) + ~'h|test|__f))))))] + ...))) " From b076df7eea247470022e31fff391a0cf2106eb3b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 21 Nov 2018 17:02:13 -0700 Subject: [PATCH 765/810] Better spacing --- .../quantum/test/untyped/core/type/defnt.cljc | 114 +++++++++--------- 1 file changed, 56 insertions(+), 58 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 2728ee3c..b9b69143 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -2610,64 +2610,62 @@ expected (case (env-lang) :clj - ($ (do (defmeta-from ~'g|test - (let* [~'g|test|__fs (*<>|sized|macro 1) - ~'g|test - (new TypedFn - {:quantum.core.type/type ~'g|__type} - (fn* ([~&ts ~&fs ~'x00] - (ifs (~(aget* (aget* &ts 0) 0) ~'x00__) - (. ~(aget* &fs 0) ~'invoke ~'x00__) - (unsupported! `g|test [~'x00__] 0)))))] - ~(aset* g|test|__fs 0 - `(reify [OI__F] - (~'invoke [~&this ~(O 'f0) - ~(I 'i__0)] ; overload ID of `f0` : `[tt/long?]` - (. ~(>L__F (aget* `(. ~'f0 ~'fs) 'i__0)) ~'invoke 5)))) - ~'g|test)) - (let* [~'g|test|__ (deref ~(list 'var `g|test))] ; to avoid var indirection - (defmeta-from ~'h|test - (let* [~'h|test|__fs (*<>|sized|macro 1) - ~'h|test|__f - (new TypedFn - {:quantum.core.type/type ~'g|__type} - ... - ~'h|test|__fs - (fn* ([~&ts ~&fs ~'x00__ ~'x01__] - (ifs (~(aget* (aget* &ts 0) 0) ~'x00__) - (ifs (~(aget* (aget* &ts 0) 1) ~'x00__) - (. ~(aget* &fs 0) ~'invoke ~'x00__ ~'x01__) - (unsupported! `h|test [~'x00__ ~'x01__] 1)) - (unsupported! `h|test [~'x00__ ~'x01__] 0)))))] - ;; TODO if a reify overload ever gets redefined (same ID) then the - ;; interface might be different... ugh... - ~(aset* h|test|__fs 0 - `(reify* [~(csym `OOII__C)] - (~'invoke [~&this ~(O 'f0) ~(O 'f1) - ~(I 'i__0) ; overload ID of `f0` : `[tt/long?]` - ~(I 'i__1) ; overload ID of `f1` : `[tt/long?]` - ~(I 'i__2)] ; overload ID of `f1` : `[tt/string?]` - ;; This `let*` is here to save on how many arguments need to be - ;; allocated to the stack, and to avoid having to rewrite these - ;; bindings in the body. Hopefully the bindings will be optimized - ;; away by the JVM. - (let* [~'i__2 ~'i__1 - ~'i__3 ~'i__0 - ~'i__4 ~'i__2] - (. ~(aget* `(. ~'f0 ~'fs) 'i__0) ~'invoke 7) - ;; It doesn't just refer to `g|test|__fs` or whatever because the - ;; fn in question (`g|test`) is extensible. Otherwise it would - ;; skip the ceremony of `(aget* `(. ~'g|test|__ ~'fs) 0)` and just - ;; do e.g. `g|test|__0`. - (. ~(aget* `(. ~'g|test|__ ~'fs) 0) ~'invoke ~'f0 ~'i__1) - ;; It doesn't just refer to `h|test|__fs` because the fn in - ;; question (`h|test`) is extensible. Otherwise it would skip the - ;; ceremony of `(aget* `(. ~'h|test|__f ~'fs) 0)` and just do e.g. - ;; `h|test|__0`. - (. ~(aget* `(. ~'h|test|__f ~'fs) 0) ~'invoke ~'f1 ~'f0 ~'i__2 ~'i__3) - (. ~(aget* `(. ~'f1 ~'fs) 'i__4) ~'invoke "11"))))) - ~'h|test|__f))))))] - ...))) + ($ (do (defmeta-from ~'g|test + (let* [~'g|test|__fs (*<>|sized|macro 1) + ~'g|test + (new TypedFn + {:quantum.core.type/type ~'g|__type} + (fn* ([~&ts ~&fs ~'x00] + (ifs (~(aget* (aget* &ts 0) 0) ~'x00__) + (. ~(aget* &fs 0) ~'invoke ~'x00__) + (unsupported! `g|test [~'x00__] 0)))))] + ~(aset* g|test|__fs 0 + `(reify [OI__F] + (~'invoke [~&this ~(O 'f0) + ~(I 'i__0)] ; overload ID of `f0` : `[tt/long?]` + (. ~(>L__F (aget* `(. ~'f0 ~'fs) 'i__0)) ~'invoke 5)))) + ~'g|test)) + (let* [~'g|test|__ (deref ~(list 'var `g|test))] ; to avoid var indirection + (defmeta-from ~'h|test + (let* [~'h|test|__fs (*<>|sized|macro 1) + ~'h|test|__f + (new TypedFn + {:quantum.core.type/type ~'g|__type} + ... + ~'h|test|__fs + (fn* ([~&ts ~&fs ~'x00__ ~'x01__] + (ifs (~(aget* (aget* &ts 0) 0) ~'x00__) + (ifs (~(aget* (aget* &ts 0) 1) ~'x00__) + (. ~(aget* &fs 0) ~'invoke ~'x00__ ~'x01__) + (unsupported! `h|test [~'x00__ ~'x01__] 1)) + (unsupported! `h|test [~'x00__ ~'x01__] 0)))))] + ;; TODO if a reify overload ever gets redefined (same ID) then the interface + ;; might be different... ugh... + ~(aset* h|test|__fs 0 + `(reify* [~(csym `OOII__C)] + (~'invoke [~&this ~(O 'f0) ~(O 'f1) + ~(I 'i__0) ; overload ID of `f0` : `[tt/long?]` + ~(I 'i__1) ; overload ID of `f1` : `[tt/long?]` + ~(I 'i__2)] ; overload ID of `f1` : `[tt/string?]` + ;; This `let*` is here to save on how many arguments need to be + ;; allocated to the stack, and to avoid having to rewrite these bindings + ;; in the body. Hopefully the bindings will be optimized away by the JVM + (let* [~'i__2 ~'i__1 + ~'i__3 ~'i__0 + ~'i__4 ~'i__2] + (. ~(aget* `(. ~'f0 ~'fs) 'i__0) ~'invoke 7) + ;; It doesn't just refer to `g|test|__fs` or whatever because the fn + ;; in question (`g|test`) is extensible. Otherwise it would skip the + ;; ceremony of `(aget* `(. ~'g|test|__ ~'fs) 0)` and just do e.g. + ;; `g|test|__0`. + (. ~(aget* `(. ~'g|test|__ ~'fs) 0) ~'invoke ~'f0 ~'i__1) + ;; It doesn't just refer to `h|test|__fs` because the fn in question + ;; (`h|test`) is extensible. Otherwise it would skip the ceremony of + ;; `(aget* `(. ~'h|test|__f ~'fs) 0)` and just do e.g. `h|test|__0`. + (. ~(aget* `(. ~'h|test|__f ~'fs) 0) ~'invoke ~'f1 ~'f0 ~'i__2 ~'i__3) + (. ~(aget* `(. ~'f1 ~'fs) 'i__4) ~'invoke "11"))))) + ~'h|test|__f))))))] + ...))) " From e627631ccdea4127d448cfa2ce520004686c7304 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 21 Nov 2018 17:55:32 -0700 Subject: [PATCH 766/810] Remove `declare` --- .../quantum/untyped/core/type/defnt.cljc | 21 ++++++------------- .../quantum/test/untyped/core/type/defnt.cljc | 2 +- 2 files changed, 7 insertions(+), 16 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 82b93aef..4d388871 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -847,18 +847,11 @@ {:overload-types-decl (>overload-types-decl opts fn|globals type-decl-datum fn|types) :reify (overload>reify overload opts fn|globals id)}))) - declare-form-seq - (when-let [hinted-names - (->> direct-dispatch-data-seq - (uc/lmap (fn-> :reify :hinted-name)) - seq)] - [(list* `declare hinted-names)]) - form (concat declare-form-seq - (->> direct-dispatch-data-seq - (uc/mapcat - (c/fn [{:as direct-dispatch-data :keys [overload-types-decl]}] - [(:form overload-types-decl) - (-> direct-dispatch-data :reify :form)]))))] + form (->> direct-dispatch-data-seq + (uc/mapcat + (c/fn [{:as direct-dispatch-data :keys [overload-types-decl]}] + [(:form overload-types-decl) + (-> direct-dispatch-data :reify :form)])))] (kw-map form direct-dispatch-data-seq)) :cljs (TODO))) @@ -1229,9 +1222,7 @@ (let [direct-dispatch (>direct-dispatch opts fn|globals fn|types) dynamic-dispatch (>dynamic-dispatch-fn|codelist opts fn|globals fn|types) fn-codelist - (->> `[;; For recursion - ~@(when (= kind :defn) [`(declare ~(:fn|name fn|globals))]) - ~@(:form direct-dispatch) + (->> `[~@(:form direct-dispatch) ~@dynamic-dispatch] (remove nil?))] (case kind diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index b9b69143..ac14c8c8 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -2620,7 +2620,7 @@ (. ~(aget* &fs 0) ~'invoke ~'x00__) (unsupported! `g|test [~'x00__] 0)))))] ~(aset* g|test|__fs 0 - `(reify [OI__F] + `(reify* [~(csym `OI__F)] (~'invoke [~&this ~(O 'f0) ~(I 'i__0)] ; overload ID of `f0` : `[tt/long?]` (. ~(>L__F (aget* `(. ~'f0 ~'fs) 'i__0)) ~'invoke 5)))) From 9923134c028da2e45acfe619506256363f0091f6 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 27 Nov 2018 23:06:07 -0700 Subject: [PATCH 767/810] input-type -> input; output-type -> output --- resources-dev/defnt.cljc | 6 +- src-untyped/quantum/untyped/core/analyze.cljc | 8 +-- src-untyped/quantum/untyped/core/type.cljc | 48 ++++++++-------- .../quantum/untyped/core/type/compare.cljc | 2 +- .../untyped/core/type/reifications.cljc | 2 +- src/quantum/core/collections_typed.cljc | 10 ++-- src/quantum/core/data/identifiers.cljc | 4 +- src/quantum/core/data/numeric.cljc | 56 +++++++++---------- src/quantum/core/data/primitive.cljc | 18 +++--- test/quantum/test/untyped/core/analyze.cljc | 30 +++++----- test/quantum/test/untyped/core/type.cljc | 18 +++--- 11 files changed, 101 insertions(+), 101 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 56e31d64..3784ed61 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -74,7 +74,7 @@ Legend: - numeric ranges - numeric characteristics [ ] Probably should disallow recursive type references, including: - `(t/defn f [x (t/input-type f ...)])` + `(t/defn f [x (t/input f ...)])` [ ] Perhaps it's the case that we can't actually have type bases but rather reactive splits. In the case of `narrowest`, it expects a split and fails without it: `[a (t/- integer? int?), b integer? > (narrowest (t/type a) (t/type b))]` @@ -181,7 +181,7 @@ Legend: (t/defn empty? > p/boolean? ([x p/nil?] true) ([xs dc/counted?] (-> xs count num/zero?)) - ([xs (t/input-type educe :_ :_ :?)] (educe empty?|rf x))) + ([xs (t/input educe :_ :_ :?)] (educe empty?|rf x))) - Should we allow something like `^:analyze-impl` or something to mimic inline optimizations but avoid actual inlining? - maybe redefine `untyped.core.type` in a typed way? `t/def` doesn't realize certain things are `t/type?` @@ -265,7 +265,7 @@ Legend: [ ] t/deftype [-] t/extend-defn! [ ] Ability to add output type restriction after the fact? - [ ] lazy compilation especially around `t/input-type` + [ ] lazy compilation especially around `t/input` [ ] equivalence of typed predicates (i.e. that which is t/<= `(t/ftype [x t/any? :> p/boolean?])`) to types: - [xs (t/fn [x (t/isa? clojure.lang.Range)] ...)] diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 7fa62f94..9bad9959 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -806,11 +806,11 @@ _ (uref/set! !!dependent? true) t (case (name caller|form) "input-type" (if (-> env :opts :split-types?) - (t/input-type|meta-or caller|t unvalued-arg-types) - (t/input-type|or caller|t unvalued-arg-types)) + (t/input|meta-or caller|t unvalued-arg-types) + (t/input|or caller|t unvalued-arg-types)) "output-type" (if (-> env :opts :split-types?) - (t/output-type|meta-or caller|t unvalued-arg-types) - (t/output-type|or caller|t unvalued-arg-types)) + (t/output|meta-or caller|t unvalued-arg-types) + (t/output|or caller|t unvalued-arg-types)) "type" caller|t)] (uast/call-node {:env env diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 3ee1915d..21ef7b7a 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -620,7 +620,7 @@ seq) (reduced nil))))))))) -(defn- input-or-output-type-handle-reactive [f t args] +(defn- input-or-output-handle-reactive [f t args] (if (utr/rx-type? t) (if (seq-or utr/rx-type? args) (rx (f @t (map utr/deref-when-reactive args))) @@ -629,7 +629,7 @@ (rx (f t (map utr/deref-when-reactive args))) (f t args)))) -(defn- input-type|meta-or|norx [t match-spec #_::match-spec] +(defn- input|meta-or|norx [t match-spec #_::match-spec] (let [i|? (->> match-spec (reducei (c/fn [_ t i] (when (find-spec? t) (reduced i))) nil)) type-args (->> match-spec @@ -637,62 +637,62 @@ (uc/map (c/fn [{:keys [input-types]}] (get input-types i|?))))] (with-expand-meta-ors type-args meta-or))) -(defns input-type|meta-or +(defns input|meta-or [t (us/or* utr/fn-type? utr/rx-type?), match-spec _ #_::match-spec | (->> match-spec (filter find-spec?) count (c/= 1)) > type?] - (input-or-output-type-handle-reactive input-type|meta-or|norx t match-spec)) + (input-or-output-handle-reactive input|meta-or|norx t match-spec)) -(defn- input-type|or|norx [t match-spec] - (let [t' (input-type|meta-or|norx t match-spec)] +(defn- input|or|norx [t match-spec] + (let [t' (input|meta-or|norx t match-spec)] (cond-> t' (utr/meta-or-type? t') (->> utr/meta-or-type>types (apply or))))) -(defns input-type|or +(defns input|or "Outputs the type of a specified input to a typed fn." [t (us/or* utr/fn-type? utr/rx-type?), match-spec _ #_::match-spec | (->> match-spec (filter find-spec?) count (c/= 1)) > type?] - (input-or-output-type-handle-reactive input-type|or|norx t match-spec)) + (input-or-output-handle-reactive input|or|norx t match-spec)) -(defn input-type +(defn input "Usage in arglist contexts: - - `(t/input-type >namespace :?)` + - `(t/input >namespace :?)` - Outputs a reactive type embodying the union of the possible types of the first input to `>namespace`. - - `(t/input-type reduce :_ :_ :?)` + - `(t/input reduce :_ :_ :?)` - Outputs a reactive type embodying the union of the possible types of the third input to `reduce`. - - `(t/input-type reduce :? :_ string?)` + - `(t/input reduce :? :_ string?)` - Outputs a reactive type embodying the union of the possible types of the first input to `reduce` when the third input satisfies `string?`." - ([t & args] (err! "Can't use `input-type` outside of arglist contexts"))) + ([t & args] (err! "Can't use `input` outside of arglist contexts"))) -(defn- output-type|meta-or|norx [t match-spec] +(defn- output|meta-or|norx [t match-spec] (let [type-args (->> match-spec (match-spec>type-data-seq t) (uc/map :output-type))] (with-expand-meta-ors type-args meta-or))) -(defns output-type|meta-or +(defns output|meta-or [t (us/or* utr/fn-type? utr/rx-type?) args (us/seq-of (us/or* #{:_} type?)) > type?] - (input-or-output-type-handle-reactive output-type|meta-or|norx t args)) + (input-or-output-handle-reactive output|meta-or|norx t args)) -(defn- output-type|or|norx [t args] - (let [t' (output-type|meta-or|norx t args)] +(defn- output|or|norx [t args] + (let [t' (output|meta-or|norx t args)] (cond-> t' (utr/meta-or-type? t') (->> utr/meta-or-type>types (apply or))))) -(defns output-type|or +(defns output|or "Outputs the output type of a typed fn." [t (us/or* utr/fn-type? utr/rx-type?) args (us/seq-of (us/or* #{:_} type?)) > type?] - (input-or-output-type-handle-reactive output-type|or|norx t args)) + (input-or-output-handle-reactive output|or|norx t args)) -(defn output-type +(defn output "Usage in arglist contexts: - - `(t/output-type >namespace :any)` + - `(t/output >namespace :any)` - (TODO) Outputs a reactive type embodying the union of the possible output types of `>namespace` given any valid inputs at all - - `(t/output-type reduce [:_ :_ string?])` + - `(t/output reduce [:_ :_ string?])` - Outputs a reactive type embodying the union of the possible output types of `reduce` when the third input satisfies `string?`." - ([t & args] (err! "Can't use `output-type` outside of arglist contexts"))) + ([t & args] (err! "Can't use `output` outside of arglist contexts"))) ;; ===== Dependent types ===== ;; diff --git a/src-untyped/quantum/untyped/core/type/compare.cljc b/src-untyped/quantum/untyped/core/type/compare.cljc index e41257ac..748b2778 100644 --- a/src-untyped/quantum/untyped/core/type/compare.cljc +++ b/src-untyped/quantum/untyped/core/type/compare.cljc @@ -448,7 +448,7 @@ :cljs (TODO))) ;; This is used to make comparisons work with `UnorderedType` and `OrderedType`. -;; TODO we should not be using `seqable?` but rather `(t/input-type reduce :_ :_ :?)`. See also the +;; TODO we should not be using `seqable?` but rather `(t/input reduce :_ :_ :?)`. See also the ;; implementations of `UnorderedType` and `OrderedType`. (def- seqable-except-array? (OrType. diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index 41d7f1d5..be6076c2 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -328,7 +328,7 @@ ;; ----- UnorderedType ----- ;; (defn- satisfies-unordered-type? [xs data] - (and (seqable? xs) ; TODO we should rather use `(t/input-type reduce :_ :_ :?)` + (and (seqable? xs) ; TODO we should rather use `(t/input reduce :_ :_ :?)` (let [!frequencies (! {}) each-input-matches-one-type-not-exceeding-frequency? (->> xs diff --git a/src/quantum/core/collections_typed.cljc b/src/quantum/core/collections_typed.cljc index fcc32836..ad54c978 100644 --- a/src/quantum/core/collections_typed.cljc +++ b/src/quantum/core/collections_typed.cljc @@ -367,9 +367,9 @@ Like `reduce`, does not have a notion of a transforming function (unlike `transduce`). Like `transduce`, uses the seed (0-arity) and completing (1-arity) arities of the reducing function `rf` when performing a reduction (unlike `reduce`)." - ([rf rf?, xs (t/input-type reduce [:_ :_ :?])] (educe rf (rf) xs)) + ([rf rf?, xs (t/input reduce [:_ :_ :?])] (educe rf (rf) xs)) ([rf rf?, init t/any?, x dasync/read-chan?] (async/go (rf (async/ p/int?] (.size xs))) #?(:clj ([xs dc/java-map? > p/int?] (.size xs))) ;; Not counted - ([xs (t/input-type educe [:_ :_ :?])] (educe count|rf xs))) + ([xs (t/input educe [:_ :_ :?])] (educe count|rf xs))) (t/defn ^:inline gen-bounded-count|rf [n dn/std-integer?] (t/fn {:inline true} @@ -416,7 +416,7 @@ (t/defn ^:inline bounded-count > dn/std-integer? ([n dn/std-integer?, xs dc/counted?] (count xs)) - ([n dn/std-integer?, xs (t/input-type educe [:_ :_ :?])] (educe (gen-bounded-count|rf n) xs))) + ([n dn/std-integer?, xs (t/input educe [:_ :_ :?])] (educe (gen-bounded-count|rf n) xs))) (t/def ^:inline empty?|rf (fn/aritoid @@ -428,4 +428,4 @@ (t/defn ^:inline empty? > p/boolean? ([x p/nil?] true) ([xs dc/counted?] (-> xs count num/zero?)) - ([xs (t/input-type educe [:_ :_ :?])] (educe empty?|rf x))) + ([xs (t/input educe [:_ :_ :?])] (educe empty?|rf x))) diff --git a/src/quantum/core/data/identifiers.cljc b/src/quantum/core/data/identifiers.cljc index 53b40e7f..25658f8e 100644 --- a/src/quantum/core/data/identifiers.cljc +++ b/src/quantum/core/data/identifiers.cljc @@ -71,8 +71,8 @@ (t/defn unqualify > symbol? [sym symbol?] (-> sym >name >symbol)) -(t/defn unqualified? [x (t/input-type >namespace [:?])] (-> x >namespace t/nil?)) -(t/defn qualified? [x (t/input-type >namespace [:?])] (-> x >namespace t/val?)) +(t/defn unqualified? [x (t/input >namespace [:?])] (-> x >namespace t/nil?)) +(t/defn qualified? [x (t/input >namespace [:?])] (-> x >namespace t/val?)) (def unqualified-keyword? (t/and keyword? unqualified?)) (def qualified-keyword? (t/and keyword? qualified?)) diff --git a/src/quantum/core/data/numeric.cljc b/src/quantum/core/data/numeric.cljc index b4a9cf92..d4cdc9aa 100644 --- a/src/quantum/core/data/numeric.cljc +++ b/src/quantum/core/data/numeric.cljc @@ -191,29 +191,29 @@ #?(:clj ([a bigdec? b bigdec?] (c?/comp= a b))) #?(:clj ([a bigdec? - b (t/- (t/input-type >bigdec :?) bigdec? java-bigint? clj-bigint? ratio?)] + b (t/- (t/input >bigdec :?) bigdec? java-bigint? clj-bigint? ratio?)] (c?/= a (>bigdec b)))) -#?(:clj ([a (t/- (t/input-type >bigdec :?) bigdec? java-bigint? clj-bigint? ratio?) +#?(:clj ([a (t/- (t/input >bigdec :?) bigdec? java-bigint? clj-bigint? ratio?) b bigdec?] (c?/= (>bigdec a) b))) #?(:clj ([a java-bigint? b java-bigint?] (.equals a b))) #?(:clj ([a java-bigint? - b (t/- (t/input-type >java-bigint :?) java-bigint? clj-bigint? ratio?)] + b (t/- (t/input >java-bigint :?) java-bigint? clj-bigint? ratio?)] (c?/= a (>java-bigint b)))) -#?(:clj ([a (t/- (t/input-type >java-bigint :?) java-bigint? clj-bigint? ratio?) +#?(:clj ([a (t/- (t/input >java-bigint :?) java-bigint? clj-bigint? ratio?) b java-bigint?] (c?/= (>java-bigint a) b))) #?(:clj ([a clj-bigint? b clj-bigint?] (.equals a b))) #?(:clj ([a clj-bigint? - b (t/- (t/input-type >clj-bigint :?) clj-bigint? ratio?)] (c?/= a (>clj-bigint b)))) -#?(:clj ([a (t/- (t/input-type >clj-bigint :?) clj-bigint? ratio?) + b (t/- (t/input >clj-bigint :?) clj-bigint? ratio?)] (c?/= a (>clj-bigint b)))) +#?(:clj ([a (t/- (t/input >clj-bigint :?) clj-bigint? ratio?) b clj-bigint?] (c?/= (>clj-bigint a) b))) #?(:clj ([a ratio? b ratio?] (and (c?/= ^:val (.numerator a) ^:val (.numerator b)) (c?/= ^:val (.denominator a) ^:val (.denominator b))))) #?(:clj ([a ratio? - b (t/- (t/input-type >ratio :?) ratio?)] (c?/= a (>ratio b)))) -#?(:clj ([a (t/- (t/input-type >ratio :?) ratio?) + b (t/- (t/input >ratio :?) ratio?)] (c?/= a (>ratio b)))) +#?(:clj ([a (t/- (t/input >ratio :?) ratio?) b ratio?] (c?/= (>ratio a) b)))) (t/def numeric-comparator? (t/ftype p/boolean? [numeric? numeric?])) @@ -225,20 +225,20 @@ b bigdec?] (compf a b))) #?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? a bigdec? - b (t/- (t/input-type >bigdec :?) bigdec? java-bigint? clj-bigint? ratio?)] + b (t/- (t/input >bigdec :?) bigdec? java-bigint? clj-bigint? ratio?)] (numeric-compf a (>bigdec b)))) #?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? - a (t/- (t/input-type >bigdec :?) bigdec? java-bigint? clj-bigint? ratio?) + a (t/- (t/input >bigdec :?) bigdec? java-bigint? clj-bigint? ratio?) b bigdec?] (numeric-compf (>bigdec a) b))) #?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? a java-bigint? b java-bigint?] (compf a b))) #?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? a java-bigint? - b (t/- (t/input-type >java-bigint :?) java-bigint? clj-bigint? ratio?)] + b (t/- (t/input >java-bigint :?) java-bigint? clj-bigint? ratio?)] (numeric-compf a (>java-bigint b)))) #?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? - a (t/- (t/input-type >java-bigint :?) java-bigint? clj-bigint? ratio?) + a (t/- (t/input >java-bigint :?) java-bigint? clj-bigint? ratio?) b java-bigint?] (numeric-compf (>java-bigint a) b))) #?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? a clj-bigint? @@ -247,10 +247,10 @@ (compf (>java-bigint a) (>java-bigint b))))) #?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? a clj-bigint? - b (t/- (t/input-type >clj-bigint :?) clj-bigint? ratio?)] + b (t/- (t/input >clj-bigint :?) clj-bigint? ratio?)] (numeric-compf a (>clj-bigint b)))) #?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? - a (t/- (t/input-type >clj-bigint :?) clj-bigint? ratio?) + a (t/- (t/input >clj-bigint :?) clj-bigint? ratio?) b clj-bigint?] (numeric-compf (>clj-bigint a) b))) #?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? a ratio? @@ -259,33 +259,33 @@ ^:val (.multiply ^:val (.denominator a) ^:val (.denominator b))))) #?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? a ratio? - b (t/- (t/input-type >ratio :?) ratio?)] (numeric-compf a (>ratio b)))) + b (t/- (t/input >ratio :?) ratio?)] (numeric-compf a (>ratio b)))) #?(:clj ([numeric-compf numeric-comparator?, compf c?/boolean-comparator? - a (t/- (t/input-type >ratio :?) ratio?) + a (t/- (t/input >ratio :?) ratio?) b ratio?] (numeric-compf (>ratio a) b)))) (t/extend-defn! c?/< - ([x (t/input-type numeric-compare :?)] (numeric-compare x)) - ([a (t/input-type numeric-compare :_ :_ :? :_) - b (t/input-type numeric-compare :_ :_ [= (t/type a)] :?)] + ([x (t/input numeric-compare :?)] (numeric-compare x)) + ([a (t/input numeric-compare :_ :_ :? :_) + b (t/input numeric-compare :_ :_ [= (t/type a)] :?)] (numeric-compare c?/< c?/comp< a b))) (t/extend-defn! c?/<= - ([x (t/input-type numeric-compare :?)] (numeric-compare x)) - ([a (t/input-type numeric-compare :_ :_ :? :_) - b (t/input-type numeric-compare :_ :_ [= (t/type a)] :?)] + ([x (t/input numeric-compare :?)] (numeric-compare x)) + ([a (t/input numeric-compare :_ :_ :? :_) + b (t/input numeric-compare :_ :_ [= (t/type a)] :?)] (numeric-compare c?/<= c?/comp<= a b))) (t/extend-defn! c?/> - ([x (t/input-type numeric-compare :?)] (numeric-compae x)) - ([a (t/input-type numeric-compare :_ :_ :? :_) - b (t/input-type numeric-compare :_ :_ [= (t/type a)] :?)] + ([x (t/input numeric-compare :?)] (numeric-compae x)) + ([a (t/input numeric-compare :_ :_ :? :_) + b (t/input numeric-compare :_ :_ [= (t/type a)] :?)] (numeric-compare c?/> c?/comp> a b))) (t/extend-defn! c?/>= - ([x (t/input-type numeric-compare :?)] (numeric-compare x)) - ([a (t/input-type numeric-compare :_ :_ :? :_) - b (t/input-type numeric-compare :_ :_ [= (t/type a)] :?)] + ([x (t/input numeric-compare :?)] (numeric-compare x)) + ([a (t/input numeric-compare :_ :_ :? :_) + b (t/input numeric-compare :_ :_ [= (t/type a)] :?)] (numeric-compare c?/>= c?/comp>= a b))) ;; TODO `c?/compare` diff --git a/src/quantum/core/data/primitive.cljc b/src/quantum/core/data/primitive.cljc index e906468b..5cfaef8d 100644 --- a/src/quantum/core/data/primitive.cljc +++ b/src/quantum/core/data/primitive.cljc @@ -324,23 +324,23 @@ #?(:clj ([a numeric? , b (t/ref c?/icomparable?)] (.compareTo (box a) b)))) (t/extend-defn! c?/comp< - ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare [= (t/type a)] :?)] + ([a (t/input c?/compare :? :_), b (t/input c?/compare [= (t/type a)] :?)] (c?/< (c?/compare a b) 0))) (t/extend-defn! c?/comp<= - ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare [= (t/type a)] :?)] + ([a (t/input c?/compare :? :_), b (t/input c?/compare [= (t/type a)] :?)] (c?/<= (c?/compare a b) 0))) (t/extend-defn! c?/comp= - ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare [= (t/type a)] :?)] + ([a (t/input c?/compare :? :_), b (t/input c?/compare [= (t/type a)] :?)] (c?/= (c?/compare a b) 0))) (t/extend-defn! c?/comp>= - ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare [= (t/type a)] :?)] + ([a (t/input c?/compare :? :_), b (t/input c?/compare [= (t/type a)] :?)] (c?/>= (c?/compare a b) 0))) (t/extend-defn! c?/comp> - ([a (t/input-type c?/compare :? :_), b (t/input-type c?/compare [= (t/type a)] :?)] + ([a (t/input c?/compare :? :_), b (t/input c?/compare [= (t/type a)] :?)] (c?/> (c?/compare a b) 0))) ;; TODO come back to this @@ -360,10 +360,10 @@ #_(t/defn narrowest "Based on max/min safe integer value." > t/type? - ([t0 (t/and (t/input-type >min-safe-integer-value [:? t/>= t/type?]) - (t/input-type >max-safe-integer-value [:? t/>= t/type?])) - t1 (t/and (t/input-type >min-safe-integer-value [:? t/>= t/type?]) - (t/input-type >max-safe-integer-value [:? t/>= t/type?]))] + ([t0 (t/and (t/input >min-safe-integer-value [:? t/>= t/type?]) + (t/input >max-safe-integer-value [:? t/>= t/type?])) + t1 (t/and (t/input >min-safe-integer-value [:? t/>= t/type?]) + (t/input >max-safe-integer-value [:? t/>= t/type?]))] (let [t0-min (>min-safe-integer-value t0) t1-min (>min-safe-integer-value t1) t0-max (>max-safe-integer-value t0) diff --git a/test/quantum/test/untyped/core/analyze.cljc b/test/quantum/test/untyped/core/analyze.cljc index 3014fd2a..e8ee20e7 100644 --- a/test/quantum/test/untyped/core/analyze.cljc +++ b/test/quantum/test/untyped/core/analyze.cljc @@ -190,7 +190,7 @@ -> ERROR `a` not in environment and `a` already in queue; circular dependency detected" (throws (self/analyze-arg-syms '{a (t/type b) b (t/type c) c (t/type a)} 't/any?))) - (testing "Complex test for `t/type` and simple test for `t/input-type`" + (testing "Complex test for `t/type` and simple test for `t/input`" ;; This test overview was put up in ~30 minutes on 9/30/2018 during a seemingly random walk of ;; thoughts without any testing or research whatsoever that happened to actually coalesce ;; into a working, clear, simple algorithm for handling dependent types. Not sure if @@ -426,17 +426,17 @@ (is= (-> (self/analyze-arg-syms '{a (t/or tt/boolean? (t/type b)) b (t/or tt/byte? (t/type d)) - c (t/input-type dummy :?) + c (t/input dummy :?) d (let [b (t/- tt/char? tt/long?)] (t/or tt/char? (t/type b) (t/type c)))} '(t/or (t/type b) (t/type d))) transform-ana) ret))) ;; TODO add multiple tests for this (`input-types-combine`) - (testing "`t/input-type` + `t/type`" + (testing "`t/input` + `t/type`" (is= (-> (self/analyze-arg-syms - '{a (t/or (t/input-type input-types-combine :? (t/type c)) tt/string?) - b (t/and (t/input-type input-types-combine :? (t/type c)) tt/long?) + '{a (t/or (t/input input-types-combine :? (t/type c)) tt/string?) + b (t/and (t/input input-types-combine :? (t/type c)) tt/long?) c (t/or tt/byte? tt/char?)} 'tt/int?) transform-ana) @@ -472,12 +472,12 @@ 'b t/none? 'c (t/isa? Character)} (t/isa? Integer)]])) - (testing "input to `t/input-type` depends on another `t/input-type`; `t/output-type` depends on - other `t/input-type`s" + (testing "input to `t/input` depends on another `t/input`; `t/output` depends on + other `t/input`s" (is= (-> (self/analyze-arg-syms - '{a (t/input-type tt/fake-compare :? :_) - b (t/input-type tt/fake-compare (t/type a) :?)} - '(t/output-type tt/fake-compare (t/type a) (t/type b))) + '{a (t/input tt/fake-compare :? :_) + b (t/input tt/fake-compare (t/type a) :?)} + '(t/output tt/fake-compare (t/type a) (t/type b))) transform-ana) [;; Directly from `[t/long? t/long?]` [{'a (t/isa? Long) 'b (t/isa? Long)} (t/isa? Integer)] @@ -491,9 +491,9 @@ ;; Directly from `[(t/ref t/val?) t/nil?]` [{'a (t/ref (t/not (t/value nil))) 'b (t/value nil)} (t/isa? Integer)]]) (is= (-> (self/analyze-arg-syms - '{a (t/input-type tt/fake-compare :? :_) - b (t/input-type tt/fake-compare [= (t/type a)] :?)} - '(t/output-type tt/fake-compare (t/type a) (t/type b))) + '{a (t/input tt/fake-compare :? :_) + b (t/input tt/fake-compare [= (t/type a)] :?)} + '(t/output tt/fake-compare (t/type a) (t/type b))) transform-ana) [;; Directly from `[t/long? t/long?]` [{'a (t/isa? Long) 'b (t/isa? Long)} (t/isa? Integer)] @@ -538,14 +538,14 @@ b (t/or tt/byte? (t/type d)) c (t/or tt/short? tt/char?) d (let [b (t/- tt/char? tt/long?)] - (t/or tt/char? (t/type b) (t/input-type >long-checked :?) (t/type c)))} + (t/or tt/char? (t/type b) (t/input >long-checked :?) (t/type c)))} '(t/or (t/type b) (t/type d)) false) transform-ana) (let [c (t/or tt/short? tt/char?) d (t/or tt/char? (t/value (t/- tt/char? tt/long?)) - (t/rx (t/input-type* + (t/rx (t/input* (-> #'>long-checked meta :quantum.core.type/type deref) [:?])) c) b (t/or tt/byte? d) diff --git a/test/quantum/test/untyped/core/type.cljc b/test/quantum/test/untyped/core/type.cljc index e9a65a87..c2777b36 100644 --- a/test/quantum/test/untyped/core/type.cljc +++ b/test/quantum/test/untyped/core/type.cljc @@ -548,12 +548,12 @@ [ifn? t/any? java-set? :> comparable?])) (deftest test|input-type|meta-or - (is= (t/input-type|meta-or + (is= (t/input|meta-or (-> #'fake-compare meta :quantum.core.type/type deref) [(t/not (t/value nil)) :?]) ;; i.e., not `long?` (t/meta-or [(t/value nil)])) - (is= (t/input-type|meta-or + (is= (t/input|meta-or (-> #'fake-compare meta :quantum.core.type/type deref) [long? :?]) (t/meta-or @@ -561,20 +561,20 @@ ;; `[(t/ref t/val?) t/nil?]` [(t/value nil) long?])) - (is= (t/input-type|meta-or + (is= (t/input|meta-or (-> #'fake-compare meta :quantum.core.type/type deref) [[= long?] :?]) (t/meta-or [long?]))) (deftest test|input-type|or - (is= (t/or string? symbol?) (t/input-type|or >namespace|type [:?])) - (is= (t/or string? java-set?) (t/input-type|or reduce|type [:_ :_ :?]))) - (is= fn? (t/input-type|or reduce|type [:? :_ string?])) + (is= (t/or string? symbol?) (t/input|or >namespace|type [:?])) + (is= (t/or string? java-set?) (t/input|or reduce|type [:_ :_ :?]))) + (is= fn? (t/input|or reduce|type [:? :_ string?])) (deftest test|output-type|or - (is= string? (t/output-type|or >namespace|type)) - (is= (t/or char-seq? comparable?) (t/output-type|or reduce|type)) - (is= char-seq? (t/output-type|or reduce|type [:_ :_ string?]))) + (is= string? (t/output|or >namespace|type)) + (is= (t/or char-seq? comparable?) (t/output|or reduce|type)) + (is= char-seq? (t/output|or reduce|type [:_ :_ string?]))) (deftest test|rx (testing "=" From 1943e7e3d53b1924a9fe939dae0230ab59e0cbb1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 27 Nov 2018 23:07:01 -0700 Subject: [PATCH 768/810] Try to set up the outlines of `comp` and `aritoid`... phew --- .../quantum/test/untyped/core/type/defnt.cljc | 237 +++++++++++++----- 1 file changed, 178 insertions(+), 59 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index ac14c8c8..7045d963 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -87,7 +87,7 @@ expected ($ (do [[0 0 false [] (t/or t/nil? t/string?)]] (defmeta-from ~'pid - (let* [~pid|__fs (*<>|sized|macro 0) + (let* [~pid|__fs (*<>|sized|macro 1) ~'pid (new TypedFn {:quantum.core.type/type pid|__type} pid|__!types ; defined/created within `t/defn` @@ -1449,11 +1449,11 @@ (deftest dependent-type-test (testing "t/type") ;; tested in `extend-defn!` test - (testing "t/input-type" + (testing "t/input" (let [actual (macroexpand ' (self/defn input-type-test - [> (t/output-type >long-checked [t/string?])] 1)) + [> (t/output >long-checked [t/string?])] 1)) expected (case (env-lang) :clj @@ -2179,7 +2179,7 @@ (self/defn simple-reactive-dependee ([a tt/char?] 1))) (macroexpand ' (self/defn simple-reactive-dependent - ([a (t/input-type simple-reactive-dependee :?)] "abc")))]) + ([a (t/input simple-reactive-dependee :?)] "abc")))]) eval) expected (case (env-lang) @@ -2209,7 +2209,7 @@ (binding [self/*compilation-mode* :test] (macroexpand ' (self/defn reactive-extensible - ([a (t/input-type dependent-extensible :?)]))))]))) + ([a (t/input dependent-extensible :?)]))))]))) ;; TODO make this into an actual test (doto (macroexpand '(self/extend-defn! dependent-extensible ([] 5))) eval)) @@ -2233,25 +2233,25 @@ (t/or tt/byte? (t/arglist-type (t/or tt/char? - (t/- @(t/input-type* abcde :?) tt/long?) + (t/- @(t/input* abcde :?) tt/long?) (t/arglist-type (t/or tt/short? tt/string?)))))))) b (t/rx (t/or tt/byte? (t/arglist-type (t/or tt/char? - (t/- @(t/input-type* abcde :?) tt/long?) + (t/- @(t/input* abcde :?) tt/long?) (t/arglist-type (t/or tt/short? tt/string?)))))) c (t/or tt/short? tt/string?) d (t/rx (t/or tt/char? - (t/- @(t/input-type* abcde :?) tt/long?) + (t/- @(t/input* abcde :?) tt/long?) (t/arglist-type (t/or tt/short? tt/string?)))) > (t/rx (t/or (t/arglist-type (t/or tt/byte? (t/arglist-type (t/or tt/char? - (t/- @(t/input-type* abcde :?) tt/long?) + (t/- @(t/input* abcde :?) tt/long?) (t/arglist-type (t/or tt/short? tt/string?)))))) (t/or tt/char? - (t/- @(t/input-type* abcde :?) tt/long?) + (t/- @(t/input* abcde :?) tt/long?) (t/arglist-type (t/or tt/short? tt/string?)))))])) - Suppose you have: @@ -2324,7 +2324,7 @@ (unsupported! ...)))) - (t/defn fghij ; in `ns1` ([b t/string? > (t/type b)] ...) - ([c (t/input-type ns0/abcde :?) > (t/output-type ns0/abcde (t/type c))] ...)) + ([c (t/input ns0/abcde :?) > (t/output ns0/abcde (t/type c))] ...)) - Resulting in `fghij`'s compile-time-emission code (assuming no :test mode) as: - (do (intern 'ns1 'fghij|__bases (rx/! {:norx-prev nil @@ -2340,16 +2340,16 @@ :body-codelist [...] :dependent? true :reactive? false}) - (let [t0 (t/rx (t/input-type* @ns0/abcde|__type :?))] + (let [t0 (t/rx (t/input* @ns0/abcde|__type :?))] {:ns 'ns1 ;; This is only present when there is at least one dependent type in the ;; arglist / output - :args-form (om 'c '(t/input-type ns0/abcde :?)) + :args-form (om 'c '(t/input ns0/abcde :?)) :arg-types-basis [t0] ;; This is only present when there is at least one dependent type in the ;; arglist / output - :output-type|form '(t/output-type ns0/abcde (t/type c)) - :output-type|basis (t/rx (t/output-type* @ns0/abcde|__type @t0)) + :output-type|form '(t/output ns0/abcde (t/type c)) + :output-type|basis (t/rx (t/output* @ns0/abcde|__type @t0)) :body-codelist [...] :dependent? true :reactive? true})]})) @@ -2597,15 +2597,33 @@ (macroexpand ' (do (self/defn g|test [f0 (t/ftype [tt/long? :> tt/float?]) > tt/float?] (f0 5)) - (self/defn h|test [f0 (t/ftype [tt/long? :> tt/float?] - [tt/string? :> tt/char?]) - f1 (t/ftype [tt/byte? :> tt/boolean?] - [tt/long? :> tt/char?] - [tt/string? :> tt/char?]) - > tt/char?] + (self/defn h|test [f0 (t/ftype [tt/string? :> tt/char?]) > (t/type f0)] + f0) + ;; This won't compile + #_(self/defn i|test [f0 (t/ftype [tt/string? :> tt/char?]) + > (t/ftype' [tt/string? :> tt/char?])] + f0) + (self/defn i|test [f0 (t/ftype' [tt/string? :> tt/char?]) > (t/type f0)] + f0) + (self/defn j|test [f0 (t/ftype [tt/long? :> tt/float?] + [tt/string? :> tt/char?]) + f1 (t/ftype [tt/byte? :> tt/boolean?] + [tt/long? :> tt/char?] + [tt/string? :> tt/char?]) + f2 (t/ftype' [tt/long? :> tt/float?]) + > tt/char?] (f0 7) + (f1 21) (g|test f0) - (h|test f1 f0) + ((h|test f0) "63") + ;; This won't compile + #_((i|test f0) "98") + ((i|test ^:wrap f0) "98") + (j|test f1 f0) + ;; FIXME for `t/ftype` comparison: what if `f1` also has the overload + ;; `[(t/and tt/string? (fn-> count (= 2))) :> tt/double?]`? + ;; Then yes `f1` accepts at least `tt/string?`, which outputs no more + ;; than `tt/boolean?`, but it's not clear whether `tt/double?` or `tt/char?` gets output (f1 "11"))))) expected (case (env-lang) @@ -2615,58 +2633,159 @@ ~'g|test (new TypedFn {:quantum.core.type/type ~'g|__type} + ... + ~'g|test|__fs (fn* ([~&ts ~&fs ~'x00] (ifs (~(aget* (aget* &ts 0) 0) ~'x00__) (. ~(aget* &fs 0) ~'invoke ~'x00__) (unsupported! `g|test [~'x00__] 0)))))] ~(aset* g|test|__fs 0 `(reify* [~(csym `OI__F)] - (~'invoke [~&this ~(O 'f0) - ~(I 'i__0)] ; overload ID of `f0` : `[tt/long?]` - (. ~(>L__F (aget* `(. ~'f0 ~'fs) 'i__0)) ~'invoke 5)))) + (~'invoke [~&this ~(O 'f0)] (~'f0 5)))) ~'g|test)) - (let* [~'g|test|__ (deref ~(list 'var `g|test))] ; to avoid var indirection - (defmeta-from ~'h|test - (let* [~'h|test|__fs (*<>|sized|macro 1) - ~'h|test|__f + (defmeta-from ~'h|test + (let* [~'h|test|__fs (*<>|sized|macro 1) + ~'h|test + (new TypedFn + {:quantum.core.type/type ~'h|__type} + ... + ~'h|test|__fs + (fn* ([~&ts ~&fs ~'x00] + (ifs (~(aget* (aget* &ts 0) 0) ~'x00__) + (. ~(aget* &fs 0) ~'invoke ~'x00__) + (unsupported! `h|test [~'x00__] 0)))))] + ~(aset* h|test|__fs 0 + `(reify* [~(csym `O__O)] + (~'invoke [~&this ~(O 'f0)] f0))) + ~'h|test)) + (defmeta-from ~'i|test + (let* [~'i|test|__fs (*<>|sized|macro 1) + ~'i|test + (new TypedFn + {:quantum.core.type/type ~'i|__type} + ... + ~'i|test|__fs + (fn* ([~&ts ~&fs ~'x00] + (ifs (~(aget* (aget* &ts 0) 0) ~'x00__) + (. ~(aget* &fs 0) ~'invoke ~'x00__) + (unsupported! `i|test [~'x00__] 0)))))] + ~(aset* i|test|__fs 0 + `(reify* [~(csym `O__O)] + (~'invoke [~&this ~(O 'f0)] f0))) + ~'i|test)) + ;; to avoid var indirection + (let* [~'g|test|__ (deref ~(list 'var `g|test)) + ~'h|test|__ (deref ~(list 'var `h|test)) + ~'i|test|__ (deref ~(list 'var `i|test))] + (defmeta-from ~'j|test + (let* [~'j|test|__fs (*<>|sized|macro 1) + ~'j|test (new TypedFn - {:quantum.core.type/type ~'g|__type} + {:quantum.core.type/type ~'j|__type} ... - ~'h|test|__fs + ~'j|test|__fs (fn* ([~&ts ~&fs ~'x00__ ~'x01__] (ifs (~(aget* (aget* &ts 0) 0) ~'x00__) (ifs (~(aget* (aget* &ts 0) 1) ~'x00__) (. ~(aget* &fs 0) ~'invoke ~'x00__ ~'x01__) - (unsupported! `h|test [~'x00__ ~'x01__] 1)) - (unsupported! `h|test [~'x00__ ~'x01__] 0)))))] - ;; TODO if a reify overload ever gets redefined (same ID) then the interface - ;; might be different... ugh... - ~(aset* h|test|__fs 0 - `(reify* [~(csym `OOII__C)] - (~'invoke [~&this ~(O 'f0) ~(O 'f1) - ~(I 'i__0) ; overload ID of `f0` : `[tt/long?]` - ~(I 'i__1) ; overload ID of `f1` : `[tt/long?]` - ~(I 'i__2)] ; overload ID of `f1` : `[tt/string?]` - ;; This `let*` is here to save on how many arguments need to be - ;; allocated to the stack, and to avoid having to rewrite these bindings - ;; in the body. Hopefully the bindings will be optimized away by the JVM - (let* [~'i__2 ~'i__1 - ~'i__3 ~'i__0 - ~'i__4 ~'i__2] - (. ~(aget* `(. ~'f0 ~'fs) 'i__0) ~'invoke 7) - ;; It doesn't just refer to `g|test|__fs` or whatever because the fn - ;; in question (`g|test`) is extensible. Otherwise it would skip the - ;; ceremony of `(aget* `(. ~'g|test|__ ~'fs) 0)` and just do e.g. - ;; `g|test|__0`. - (. ~(aget* `(. ~'g|test|__ ~'fs) 0) ~'invoke ~'f0 ~'i__1) - ;; It doesn't just refer to `h|test|__fs` because the fn in question - ;; (`h|test`) is extensible. Otherwise it would skip the ceremony of - ;; `(aget* `(. ~'h|test|__f ~'fs) 0)` and just do e.g. `h|test|__0`. - (. ~(aget* `(. ~'h|test|__f ~'fs) 0) ~'invoke ~'f1 ~'f0 ~'i__2 ~'i__3) - (. ~(aget* `(. ~'f1 ~'fs) 'i__4) ~'invoke "11"))))) - ~'h|test|__f))))))] + (unsupported! `j|test [~'x00__ ~'x01__] 1)) + (unsupported! `j|test [~'x00__ ~'x01__] 0)))))] + ;; NOTE we could accommodate for the situation in which a reify overload gets + ;; redefined (same ID): to ensure the interface stays the same, we could + ;; ensure that each interface has (arbitrarily) up to 10 extra params, with an + ;; int array as the last extra param which is then unpacked. However, this + ;; would not accommodate for the facts that 1) the meaning of each int param + ;; could change, and even if this were able to be controlled, 2) existing call + ;; sites using that overload would either have too many or few params. Of + ;; course, we could add a default interface implementation for every supported + ;; arity, each one of which would curry in the params to the actually + ;; implemented arity (there are other ways too probably). But it just seems + ;; like a lot of overhead with not too much gain. + ;; (reify* [~(csym `OOIII__C)] + ;; (~'invoke [~&this ~(O 'f0) ~(O 'f1) + ;; ~(I 'i__0) ; overload ID of `f0` : `[tt/long?]` + ;; ~(I 'i__2) ; overload ID of `f1` : `[tt/long?]` + ;; ~(I 'i__5)] ; overload ID of `f1` : `[tt/string?]` + ;; ...)) + ~(aset* j|test|__fs 0 + `(reify* [~(csym `OO__C)] + (~'invoke [~&this ~(O 'f0) ~(O 'f1)] + (~'f0 7) + (. ~(aget* `(. ~'f2 ~'fs) 0) ~'invoke 21) + ;; - It doesn't just refer to `g|test|__fs` or whatever because the fn + ;; in question (`g|test`) is extensible. Otherwise it would skip the + ;; ceremony of `(aget* `(. ~'g|test|__ ~'fs) 0)` and just do e.g. + ;; `g|test|__0`. + (. ~(aget* `(. ~'g|test|__ ~'fs) 0) ~'invoke ~'f0) + ;; We need to know how to call the resulting fn and the callee can't + ;; provide that information to all callers. So we have to make this call + ;; dynamic, sadly. + ((. ~(aget* `(. ~'h|test|__ ~'fs) 0) ~'invoke ~'f0) "63") + (. ~(aget* `(. ~(aget* `(. ~'i|test|__ ~'fs) 0) ~'invoke + ;; Two arrays (`ts` — two arrays, `fs` — two `reify`s), + ;; one `TypedFunction` object. Not super cheap + (self/fn ([~'x0__ tt/long? ~'> tt/float?] (f0 x0__)) + ([~'x0__ tt/string? ~'> tt/char?] (f0 x0__)))) + 1) + ~'invoke "98") + ;; - It doesn't just refer to `j|test|__fs` because the fn in question + ;; (`j|test`) is extensible. Otherwise it would skip the ceremony of + ;; `(aget* `(. ~'j|test|__f ~'fs) 0)` and just do e.g. `j|test|__0`. + (. ~(aget* `(. ~'j|test ~'fs) 0) ~'invoke ~'f1 ~'f0) + ;; - Knows that calling `f1` with `["11"]` means: + ;; - We need to know overload ID of `f1` with input types + ;; `[tt/string?]` + (f1 "11")))) + ~'j|test))))))] ...))) +;; Now *this* is where type inference would come in handy... +(self/defn comp + (^:inline [...] identity) + (^:inline [f0 t/tfn? > (t/type f0)] f0) + ([f0 (t/ftype [(t/output f1 :any)]), f1 t/tfn?] + (self/fn + ([] + (f0 (f1))) + ([x0 (t/input f1 :?)] + (f0 (f1 x0))) + ([x0 (t/input f1 :? :_), x1 (t/input g (t/type x0) :?)] + (f0 (f1 x0 x1))) + ([x0 (t/input f1 :? :_ :_) + x1 (t/input f1 (t/type x0) :? :_) + x2 (t/input f1 (t/type x0) (t/type x1) :?)] + (f0 (f1 x0 x1 x2))) + ([x0 (t/input f1 :? :&) + x1 (t/input f1 (t/type x0) :? :&) + x2 (t/input f1 (t/type x0) (t/type x1) :? :&) + & xs (t/input f1 (t/type x0) (t/type x1) (t/type x2) :?&)] + (f0 (apply f1 x0 x1 x2 xs))))) + ([f0 f1 & fs] (reduce1 comp (list* f0 f1 fs)))) + +;; TODO this works better as a macro I think +(self/defn aritoid + ([f0 (t/ftype []) + > (t/ftype [:> (t/output f0)])] + (self/fn ([> (t/output f0)] (f0)))) + ([f0 (t/ftype []) + f1 (t/ftype [t/any?]) + > (t/ftype [:> (t/output f0)] + [:> (t/output f1 :_)])] + (self/fn ([> (t/output f0)] (f0)) + ([x0 (t/input f1 :?) + > (t/output f1 (t/type x0))] (f1 x0)))) + ([f0 (t/ftype []) + f1 (t/ftype [t/any?]) + f2 (t/ftype [t/any? t/any?]) + > (t/ftype [:> (t/output f0)] + [:> (t/output f1 :_)] + [:> (t/output f2 :_ :_)])] + (self/fn ([> (t/output f0)] (f0)) + ([x0 (t/input f1 :?) + > (t/output f1 (t/type x0))] (f1 x0)) + ([x0 (t/input f2 :? :_) + x1 (t/input f2 (t/type x0) :?) + > (t/output f1 (t/type x0) (t/type x1))] (f2 x0 x1))))) " We could do: From eb1496acc12e427776b7e1d47d8b6f4cd85fbc38 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 28 Nov 2018 12:43:50 -0700 Subject: [PATCH 769/810] Clear up contract satisfaction / growth+breakage notes --- .../test/untyped/core/type/compare.cljc | 90 ++++++++++++------- 1 file changed, 57 insertions(+), 33 deletions(-) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index ca4ced89..d4deb2d3 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -1350,42 +1350,66 @@ to behave. " ;; [0 1 2] means t/compare|input is 0, t/compare|output is 1, and t/compare is 2 - "Liskov’s Substitution Principle - Contract satisfaction ('Growth') is `t/<=|input` (you cannot require more) and `t/>=|output` - (you cannot guarantee less) - - Inputs - - I require an animal and you give me a sheep: - - `(t/<= sheep? animal?)` - - If I require an animal and you give me a sheep and some wheat, it has to be in an - acceptable open container of some sort (generally a map) because the caller is not - guaranteed to know how to handle it otherwise: - - `(t/<> (t/tuple sheep? wheat?) animal?) - - `(t/<> (t/map :requirement sheep? :extra0 wheat?) animal?) - - `(t/<= (t/closed-map :requirement sheep? :extra0 wheat?) - (t/merge (t/closed-map :requirement animal?) (t/map-of id/keyword? t/any?))) - - `(t/<= (t/map :requirement sheep? :extra0 wheat?) - (t/map :requirement animal?)) - - Outputs - - I guarantee an animal and I provide a sheep: - - `(t/<= sheep? animal?)` - - If I guarantee an animal and I provide a sheep and some wheat, it has to be in an - acceptable open container of some sort (generally a map) because the caller is not - guaranteed to know how to handle it otherwise: - - `(t/<> (t/tuple sheep? wheat?) animal?) - - `(t/<> (t/map :guarantee sheep? :extra0 wheat?) animal?) - - `(t/<= (t/closed-map :guarantee sheep? :extra0 wheat?) - (t/merge (t/closed-map :requirement animal?) (t/map-of id/keyword? t/any?))) - Contract non-satisfaction ('Breakage') is `>=|input` (input covariance) and `t/<=|output` - (output contravariance) - - Inputs - - I require an animal but you give me any old organism - - Outputs - - I guarantee an animal but I provide any old organism - - I guarantee a sheep and some wheat but I provide only a sheep - - (t/?? (t/map :guarantee))" + "Contract satisfaction / 'Growth' (which is the opposite of contract non-satisfaction / + 'Breakage') is: + - For inputs: + - In the language of the type system: + - `t/<=` for inputs w.r.t. declared input type + - `t/>=|input` for fns w.r.t. declared type of an fn-input + - In the language of Liskov’s Substitution Principle: + - preconditions cannot be strengthened + - contravariance of input types + - In the language of 'Growth vs. Breakage': + - you cannot require more, but you can accept more + - Examples + - Comparing inputs directly + - We require a grain and we are provided a wheat (<) : good + - We require a grain and we are provided any edible thing (> / ><) : bad + - We require a grain and we are provided a sheep (<>) : bad + - Comparing inputs of contracts / fns (note that 'old contract' also works for 'declared + type of fn-input' and 'new contract' also works for 'actual type of fn-input') + - Old contract requires grain; new contract requires wheat (<) : bad + - Old contract requires grain; new contract requires any edible thing (>) : good + - Old contract requires grain; new contract requires a sheep (<>) : bad + - For outputs: + - In the language of the type system: + - `t/<=` for outputs w.r.t. declared output type + - `t/<=|output` for fns w.r.t. declared type of an fn-input + - In the language of Liskov’s Substitution Principle: + - postconditions cannot be weakened + - covariance of output types + - In the language of 'Growth vs. Breakage': + - you cannot guarantee less, but you can provide more + - Examples + - Comparing outputs directly + - We guarantee a grain and we provide a wheat (<) : good + - We guarantee a grain and we provide any edible thing (> / ><) : bad + - We guarantee a grain and we provide a sheep (<>) : bad + - Intuitively, if the contract says, output a grain, and it outputs a wheat and a sheep, + that seems good but is it? What does it mean to 'output a wheat and a sheep'? + - Is it `(t/unordered wheat? sheep?)`? If so, `(t/unordered wheat? sheep?)` is not `t/<` + `(t/unordered grain?)` and so that's bad. + - Is it `(t/map :grain wheat? :sheep sheep?)` (an 'open container')? If so, then *that* + is `t/<` `(t/map :grain wheat?)` and so that's good. + - This 'open container' is partially what the Growth vs. Breakage talk is referring to. + If I require a grain and you provide a wheat and a sheep, it has to be in an + acceptable open container of some sort (generally a map) because the consumer is not + guaranteed to know how to handle it otherwise. + - If we don't deal in open containers, that's like if you require a grain (and only + have space for a grain, and no availability/means to acquire more space or make it + someone else's problem) but someone leaves a wheat and 200 sheep on your doorstep, + that's not great. Yes, you got what you asked for, but you have nowhere to put the + sheep and no time to deal with the problem. + - Comparing outputs of contracts / fns (note that 'old contract' also works for 'declared + type of fn-input' and 'new contract' also works for 'actual type of fn-input') + - Old contract guarantees grain; new contract guarantees wheat (<) : good + - Old contract guarantees grain; new contract guarantees any edible thing (>) : bad + - Old contract guarantees grain; new contract guarantees a sheep (<>) : bad" (testing "input arities <" (testing "same-arity input types <" (testing "output <" + ;; it accepts fewer (<) things than it is required (>=) to accept — bad + ;; it provides fewer (<) things than it is allowed (<=) to provide — good (test-comparison|fn [ t/boolean?]) (t/ftype [] [t/any? :> t/long?]))) From 286405b78649750e4f6cb079b96f87b7532bc07c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 28 Nov 2018 12:48:28 -0700 Subject: [PATCH 770/810] Some more notes --- test/quantum/test/untyped/core/type/compare.cljc | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index d4deb2d3..2b45ee38 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -1405,6 +1405,9 @@ - Old contract guarantees grain; new contract guarantees wheat (<) : good - Old contract guarantees grain; new contract guarantees any edible thing (>) : bad - Old contract guarantees grain; new contract guarantees a sheep (<>) : bad" + ;; We can think of the first `ftype` input to `test-comparison|fn` as the "new contract" or + ;; actual type of fn-input", and the second `ftype` input as the "old contract" or "declared type + ;; of fn-input". (testing "input arities <" (testing "same-arity input types <" (testing "output <" @@ -1415,6 +1418,8 @@ (t/ftype [] [t/any? :> t/long?]))) (testing "output =") (testing "output >" + ;; it accepts fewer (<) things than it is required (>=) to accept — bad + ;; it provides more (>) things than it is allowed (<=) to provide — bad (test-comparison|fn [ ident] (t/ftype [t/boolean?]) (t/ftype [:> t/boolean?] [t/any? :> t/boolean?]))) @@ -1426,6 +1431,8 @@ (t/ftype [:> t/boolean?]) (t/ftype [] [t/any?]))) (testing "output =" + ;; it accepts fewer (<) things than it is required (>=) to accept — bad + ;; it provides the same (=) things as it is allowed (<=) to provide — good (test-comparison|fn [ Date: Wed, 28 Nov 2018 12:50:50 -0700 Subject: [PATCH 771/810] Add one case of a contract-satisfactory fn --- test/quantum/test/untyped/core/type/compare.cljc | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 2b45ee38..869bd4ad 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -1501,7 +1501,12 @@ (testing "output ><") (testing "output <>")) (testing "same-arity input types >" - (testing "output <") + (testing "output <" + ;; it accepts more (>) things than it is required (>=) to accept — good + ;; it provides fewer (<) things than it is allowed (<=) to provide — good + (test-comparison|fn [ >ident t/boolean?]) + (t/ftype [t/boolean?]))) (testing "output =") (testing "output >") (testing "output ><") From c9b065f74fcb9005a278f8881feaacbd0eb24a88 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 28 Nov 2018 12:52:30 -0700 Subject: [PATCH 772/810] Trying to fix input-fn specificity problem --- .../quantum/test/untyped/core/type/defnt.cljc | 51 +++++++++++++++++-- 1 file changed, 48 insertions(+), 3 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 7045d963..aee53bce 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -2768,15 +2768,15 @@ > (t/ftype [:> (t/output f0)])] (self/fn ([> (t/output f0)] (f0)))) ([f0 (t/ftype []) - f1 (t/ftype [t/any?]) + f1 (t/ftype [t/none?]) > (t/ftype [:> (t/output f0)] [:> (t/output f1 :_)])] (self/fn ([> (t/output f0)] (f0)) ([x0 (t/input f1 :?) > (t/output f1 (t/type x0))] (f1 x0)))) ([f0 (t/ftype []) - f1 (t/ftype [t/any?]) - f2 (t/ftype [t/any? t/any?]) + f1 (t/ftype [t/none?]) + f2 (t/ftype [t/none? t/none?]) > (t/ftype [:> (t/output f0)] [:> (t/output f1 :_)] [:> (t/output f2 :_ :_)])] @@ -2787,6 +2787,29 @@ x1 (t/input f2 (t/type x0) :?) > (t/output f1 (t/type x0) (t/type x1))] (f2 x0 x1))))) +" +So `f1`'s declared type is `(t/ftype [t/any?])`, meaning, it has to at least accept one arg which is +`t/<=` `t/any?`. +Then really we're just doing arity checking here. Input and output type checks become kind of +meaningless unless you know the actual input type. + + + + +To fix this passed fn specificity problem, we could leverage a global map of the comparison of all +types to all types (`O(n^2)` worst case space, but I think we can do it in less). + +Let's say fimpl is (t/ftype [p/byte? (t/and p/string? whatever)] + [p/byte? p/string?]) +How do we get `(f a)` to recognize that it needs to go to overload 0, not 1? +We could have some sort of interval tree, or perhaps a map sorted by comparisons, in which we can +have log-time access to the right thing — like if you hand it the hash of `p/byte?` `p/string?` then +it goes to the first thing matching that. That way we don't have to rely on dynamism absolutely +everywhere. + +This still doesn't get around other issues seen in `aritoid` and `comp`. TODO +" + " We could do: `(. ^TheReifyType (aget (.-ts f) ) invoke <~@args>)` @@ -2819,3 +2842,25 @@ TODO let's see what we can do with the expansion/inlining of `compf`. It may pro (quantum.untyped.core.type/isa? java.lang.Character))]), :form numeric-compf}} + +;; ===== Failed approaches ===== ;; +" +To fix this passed fn specificity problem, we could leverage either inheritance or a global map of +the comparison of all types to all types (`O(n^2)` worst case space, but I think we can do it in +less). + +For instance, +(t/defn a [f (t/ftype [p/byte? p/string?])] + (f a)) + +F = (t/ftype [p/byte? (t/and p/string? (fn-> count (= 5)))]) +- `p/byte?`'s hash is -627458773 and `(t/and p/string? (fn-> count (= 5))`'s hash is -123456 +So FClass implements _-627458773_-123456 + +G = (t/ftype [p/byte? p/string?]) +- `p/byte?`'s hash is -627458773 and `p/string?`'s hash is -1854681952 +So GClass implements _-627458773_-1854681952 + +But now _-627458773_-123456 needs to extend _-627458773_-1854681952, which requires a rewrite of all +things that use it... so I don't think inheritance is our answer. +" From 962d9fd3cb2414d22c0b1685fd75e05d84eaede2 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 28 Nov 2018 18:45:39 -0700 Subject: [PATCH 773/810] Maybe inner expansion is the secret --- src-untyped/quantum/untyped/core/type.cljc | 4 +- .../quantum/test/untyped/core/type/defnt.cljc | 158 +++++++++++++++++- 2 files changed, 152 insertions(+), 10 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 21ef7b7a..2c229ba3 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -1008,7 +1008,7 @@ (isa?|direct #?(:clj clojure.lang.IFn :cljs cljs.core/IFn))) ;; Used by `quantum.untyped.core.analyze` via `t/callable?` -(def* fnt? (and fn? (>expr (fn-> c/meta :quantum.core.type/type type?)))) +(def* tfn? (and fn? (>expr (fn-> c/meta :quantum.core.type/type type?)))) ;; TODO should we allow java.lang.Runnable, java.util.concurrent.Callable, and other ;; functional interfaces to be `callable?`? @@ -1016,7 +1016,7 @@ (uvar/def callable? "The set of all objects that are able to called/invoked by being in functor position (first element of an unquoted list) within a typed context." - (or fn? ifn? fnt?)) + (or fn? ifn? tfn?)) ;; ===== Metadata ===== ;; diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index aee53bce..84fcd435 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -2739,9 +2739,87 @@ ~'j|test))))))] ...))) +;; Automatically analyzes the body of `tfn?`s which have at least one input of `t/fn?` +;; Meaning, the body is analyzed as if inline, but if not marked `inline`, will intern a separate fn +;; for the purpose +(t/defn- apply* [f (t/meta-or t/tfn? t/fn?), !xs !alist?] + (case (count !xs) + 0 (f !xs) + 1 (f (get !xs 0)) + 2 (f (get !xs 0) (get !xs 1)) + 3 (f (get !xs 0) (get !xs 1) (get !xs 2)) + 4 (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3)) + 5 (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4)) + 6 (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4) + (get !xs 5)) + 7 (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4) + (get !xs 5) (get !xs 6)) + 8 (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4) + (get !xs 5) (get !xs 6) (get !xs 7)) + 9 (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4) + (get !xs 5) (get !xs 6) (get !xs 7) (get !xs 8)) + 10 (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4) + (get !xs 5) (get !xs 6) (get !xs 7) (get !xs 8) (get !xs 9)) + 11 (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4) + (get !xs 5) (get !xs 6) (get !xs 7) (get !xs 8) (get !xs 9) + (get !xs 10)) + 12 (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4) + (get !xs 5) (get !xs 6) (get !xs 7) (get !xs 8) (get !xs 9) + (get !xs 10) (get !xs 11)) + 13 (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4) + (get !xs 5) (get !xs 6) (get !xs 7) (get !xs 9) (get !xs 10) + (get !xs 10) (get !xs 11) (get !xs 12)) + 14 (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4) + (get !xs 5) (get !xs 6) (get !xs 7) (get !xs 9) (get !xs 10) + (get !xs 10) (get !xs 11) (get !xs 12) (get !xs 13)) + 15 (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4) + (get !xs 5) (get !xs 6) (get !xs 7) (get !xs 9) (get !xs 10) + (get !xs 10) (get !xs 11) (get !xs 12) (get !xs 13) (get !xs 14)) + 16 (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4) + (get !xs 5) (get !xs 6) (get !xs 7) (get !xs 9) (get !xs 10) + (get !xs 10) (get !xs 11) (get !xs 12) (get !xs 13) (get !xs 14) + (get !xs 15)) + 17 (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4) + (get !xs 5) (get !xs 6) (get !xs 7) (get !xs 9) (get !xs 10) + (get !xs 10) (get !xs 11) (get !xs 12) (get !xs 13) (get !xs 14) + (get !xs 15) (get !xs 16)) + 18 (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4) + (get !xs 5) (get !xs 6) (get !xs 7) (get !xs 9) (get !xs 10) + (get !xs 10) (get !xs 11) (get !xs 12) (get !xs 13) (get !xs 14) + (get !xs 15) (get !xs 16) (get !xs 17)) + 19 (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4) + (get !xs 5) (get !xs 6) (get !xs 7) (get !xs 9) (get !xs 10) + (get !xs 10) (get !xs 11) (get !xs 12) (get !xs 13) (get !xs 14) + (get !xs 15) (get !xs 16) (get !xs 17) (get !xs 18)) + 20 (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4) + (get !xs 5) (get !xs 6) (get !xs 7) (get !xs 8) (get !xs 9) + (get !xs 10) (get !xs 11) (get !xs 12) (get !xs 13) (get !xs 14) + (get !xs 15) (get !xs 16) (get !xs 17) (get !xs 18) (get !xs 19)) + (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4) + (get !xs 5) (get !xs 6) (get !xs 7) (get !xs 8) (get !xs 9) + (get !xs 10) (get !xs 11) (get !xs 12) (get !xs 13) (get !xs 14) + (get !xs 15) (get !xs 16) (get !xs 17) (get !xs 18) (get !xs 19) + (let [variadic-ct (-> !xs count (- 20)) + !variadics (<>*|ct variadic-ct)] + (loops/dotimes [i variadic-ct] + (assoc! !variadics i (get !xs i))))))) + +;; Assuming collections.core is available +(t/defn ^:inline apply + ([f fn?, xs reducible?] + (apply* f (>!alist xs))) + ([f fn?, x0 ?, xs reducible?] + (apply* f (join! (!alist x0) xs))) + ([f fn?, x0 ?, x1 ?, xs reducible?] + (apply* f (join! (!alist x0 x1) xs))) + ([f fn?, x0 ?, x1 ?, x2 ?, xs reducible?] + (apply* f (join! (!alist x0 x1 x2) xs))) + ([f fn?, x0 ?, x1 ?, x2 ?, x3 ? & xs reducible?] + (apply* f (join! (!alist x0 x1 x2 x3) xs)))) + ;; Now *this* is where type inference would come in handy... (self/defn comp - (^:inline [...] identity) + (^:inline [> (t/value identity)] identity) (^:inline [f0 t/tfn? > (t/type f0)] f0) ([f0 (t/ftype [(t/output f1 :any)]), f1 t/tfn?] (self/fn @@ -2762,18 +2840,29 @@ (f0 (apply f1 x0 x1 x2 xs))))) ([f0 f1 & fs] (reduce1 comp (list* f0 f1 fs)))) -;; TODO this works better as a macro I think +(self/defn comp + ;; `> ?` is everywhere implied + (^:inline [] identity) + (^:inline [f0 t/tfn?] f0) + ([f0 ?, f1 ?] + (self/fn + ([] (f0 (f1))) + ([x0 ?] (f0 (f1 x0))) + ([x0 ?, x1 ?] (f0 (f1 x0 x1))) + ([x0 ?, x1 ?, x2 ?] (f0 (f1 x0 x1 x2))) + ([x0 ?, x1 ?, x2 ?, xs ?] (f0 (apply f1 x0 x1 x2 xs)))))) + (self/defn aritoid ([f0 (t/ftype []) > (t/ftype [:> (t/output f0)])] - (self/fn ([> (t/output f0)] (f0)))) + (self/fn ([> (t/output f0)] (f0)))) ([f0 (t/ftype []) - f1 (t/ftype [t/none?]) + f1 (t/ftype [t/eps?]) ; needs to be `t/eps?` meaning just an 'epsilon' above `t/none?` in order to be a valid input, but still `t/<` w.r.t. everything else > (t/ftype [:> (t/output f0)] [:> (t/output f1 :_)])] - (self/fn ([> (t/output f0)] (f0)) + (self/fn ([> (t/output f0)] (f0)) ([x0 (t/input f1 :?) - > (t/output f1 (t/type x0))] (f1 x0)))) + > (t/output f1 (t/type x0))] (f1 x0)))) ([f0 (t/ftype []) f1 (t/ftype [t/none?]) f2 (t/ftype [t/none? t/none?]) @@ -2787,9 +2876,62 @@ x1 (t/input f2 (t/type x0) :?) > (t/output f1 (t/type x0) (t/type x1))] (f2 x0 x1))))) +(self/defn aritoid + ;; `> ?` is everywhere implied + ([f0 ?] + (self/fn ([] (f0)))) + ([f0 ?, f1 ?] + (self/fn ([] (f0)) + ([x0 ?] (f1 x0)))) + ([f0 ?, f1 ?, f2 ?] + (self/fn ([] (f0)) + ([x0 ?] (f1 x0)) + ([x0 ?, x1 ?] (f2 x0 x1))))) + +;; ========================= + +(t/dotyped (apply inc [1])) +-> (let* [f inc, xs [1]] + (apply* f (>!alist xs))) +-> (let* [f inc, xs [1]] + (apply* f (>!alist xs))) +-> (let* [f inc, xs [1]] + (let* [!xs (>!alist xs)] + ;; This part isn't really analyzed; just `(count !xs)` first + (case (count !xs) ; figures out that the count is 1 + 0 (f !xs) + 1 (f (get !xs 0)) + ...))) +-> (let* [f inc, xs [1]] + (let* [f f, !xs (>!alist xs)] + (f (get !xs 0)))) ; maybe it could figure out that `(get !xs 0)` yields `1`? +A -> (let* [f inc, xs [1]] + (let* [f f, !xs (>!alist xs)] + (f (.get !xs 0)))) +B -> (let* [f inc, xs [1]] + (let* [f f, !xs (>!alist xs)] ; eliminate unused, non-side-effecting (since fn `>!alist` not marked with `:!`) param (`!xs`). Don't warn about unused param since this is only in an "inner expansion" + (f 1))) + -> (let* [f inc, xs [1]] + (let* [f f] ; eliminate iso-binding + (f 1))) + -> (let* [f inc, xs [1]] (f 1)) ; eliminate unused, non-side-effecting (since fn `>!alist` not marked with `:!`) binding (`xs`). Don't warn about unused param since this is only in an "inner expansion" + -> (inc 1) + -> 2 + +(t/defn test|apply [xs reducible?] + (apply inc xs)) +-> (t/defn test|apply [xs reducible?] + (let* [f inc, xs xs] + (apply* inc (>!alist xs)))) +-> Not analyzed because `reducible?` (type of `xs`) is not `t/<` `reducible?` (type of `apply*.xs`) +Maybe we should always analyze in this case? That's a lot of analyzing code paths but still... maybe it'll be nice for "advanced compilation" and we can do dynamic dispatch otherwise? +- Lazy compilation? Maybe just before the typed context when it gets used is when it can be compiled + +;; ========================= + " -So `f1`'s declared type is `(t/ftype [t/any?])`, meaning, it has to at least accept one arg which is -`t/<=` `t/any?`. +So `f1`'s declared type is `(t/ftype [t/eps?])`, meaning, it has to at least accept 1 input, whose +type is `t/>=` `t/eps?`. Then really we're just doing arity checking here. Input and output type checks become kind of meaningless unless you know the actual input type. From 8933f34609839d0dd4e0c852f3673c0212d31d64 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 28 Nov 2018 19:40:19 -0700 Subject: [PATCH 774/810] More notes on inner expansion --- .../quantum/test/untyped/core/type/defnt.cljc | 105 +++++++++++++++++- 1 file changed, 99 insertions(+), 6 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 84fcd435..0515b20a 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -2888,16 +2888,14 @@ ([x0 ?] (f1 x0)) ([x0 ?, x1 ?] (f2 x0 x1))))) -;; ========================= +;; ===== Inner expansion ===== ;; (t/dotyped (apply inc [1])) --> (let* [f inc, xs [1]] - (apply* f (>!alist xs))) -> (let* [f inc, xs [1]] (apply* f (>!alist xs))) -> (let* [f inc, xs [1]] (let* [!xs (>!alist xs)] - ;; This part isn't really analyzed; just `(count !xs)` first + ;; This part isn't really analyzed in whole; just `(count !xs)` first (case (count !xs) ; figures out that the count is 1 0 (f !xs) 1 (f (get !xs 0)) @@ -2918,14 +2916,109 @@ B -> (let* [f inc, xs [1]] -> (inc 1) -> 2 +(t/dotyped (apply + (range 25))) +-> (apply + (clojure.lang.LongRange/create 25)) ; retains metadata about count, etc. +-> (let* [f +, xs (clojure.lang.LongRange/create 25)] + (apply* f (>!alist xs))) ; expanded because `(t/type f)` `t/<` `(t/type apply.f)` +-> (let* [f +, xs (clojure.lang.LongRange/create 25)] + (let* [!xs (>!alist xs)] + ;; This part isn't really analyzed in whole; just `(count !xs)` first + (case (count !xs) ; figures out that the count is 25 + ... + ;; This is not supposed to be inlined, just held out + (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4) + (get !xs 5) (get !xs 6) (get !xs 7) (get !xs 8) (get !xs 9) + (get !xs 10) (get !xs 11) (get !xs 12) (get !xs 13) (get !xs 14) + (get !xs 15) (get !xs 16) (get !xs 17) (get !xs 18) (get !xs 19) + (let [variadic-ct (-> !xs count (- 20)) + !variadics (<>*|ct variadic-ct)] + (loops/dotimes [i variadic-ct] + (assoc! !variadics i (get !xs i)))))))) +-> (let* [f +, xs (clojure.lang.LongRange/create 25)] + (let* [!xs (>!alist xs)] ; knows the count is 25 + ;; This is not supposed to be inlined, just held out + (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4) + (get !xs 5) (get !xs 6) (get !xs 7) (get !xs 8) (get !xs 9) + (get !xs 10) (get !xs 11) (get !xs 12) (get !xs 13) (get !xs 14) + (get !xs 15) (get !xs 16) (get !xs 17) (get !xs 18) (get !xs 19) + (let [variadic-ct (-> 25 (- 20)) + !variadics (<>*|ct variadic-ct)] + (loops/dotimes [i variadic-ct] + (assoc! !variadics i (get !xs i))))))) +-> (let* [f +, xs (clojure.lang.LongRange/create 25)] + (let* [!xs (>!alist xs)] ; knows the count is 25 + ;; This is not supposed to be inlined, just held out + (f (get !xs 0) (get !xs 1) (get !xs 2) (get !xs 3) (get !xs 4) + (get !xs 5) (get !xs 6) (get !xs 7) (get !xs 8) (get !xs 9) + (get !xs 10) (get !xs 11) (get !xs 12) (get !xs 13) (get !xs 14) + (get !xs 15) (get !xs 16) (get !xs 17) (get !xs 18) (get !xs 19) + (let [variadic-ct 5 + !variadics (<>*|ct variadic-ct)] + (loops/dotimes [i variadic-ct] + (assoc! !variadics i (get !xs i))))))) +-> (let* [f +, xs (clojure.lang.LongRange/create 25)] + (let* [!xs (>!alist xs)] ; knows the count is 25 + ;; - This is not supposed to be inlined, just held out + ;; - Splices in the inlined fns here + (f (. !xs get 0) (. !xs get 1) (. !xs get 2) (. !xs get 3) (. !xs get 4) + (. !xs get 5) (. !xs get 6) (. !xs get 7) (. !xs get 8) (. !xs get 9) + (. !xs get 10) (. !xs get 11) (. !xs get 12) (. !xs get 13) (. !xs get 14) + (. !xs get 15) (. !xs get 16) (. !xs get 17) (. !xs get 18) (. !xs get 19) + (let [variadic-ct 5 + !variadics (<>*|ct variadic-ct)] + (loops/dotimes [i variadic-ct] ; this will of course be expanded too + (let* [!xs !variadics] + (do (. RT aset !xs i (. !xs get i)) + !xs))))))) +;; Assumes it's at a top-level place in the ns since `dotyped` was invoked in an untyped context +-> (let* [apply*|expansion|__0 + (reify* [OO__O] + (invoke [&this f !xs] + (let* [^ArrayList !xs !xs] + (f (. !xs get 0) (. !xs get 1) (. !xs get 2) (. !xs get 3) (. !xs get 4) + (. !xs get 5) (. !xs get 6) (. !xs get 7) (. !xs get 8) (. !xs get 9) + (. !xs get 10) (. !xs get 11) (. !xs get 12) (. !xs get 13) (. !xs get 14) + (. !xs get 15) (. !xs get 16) (. !xs get 17) (. !xs get 18) (. !xs get 19) + (let [variadic-ct 5 + !variadics (<>*|ct variadic-ct)] + (loops/dotimes [i variadic-ct] ; this will of course be expanded too + (let* [!xs !variadics] + (do (. RT aset !xs i (. !xs get i)) + !xs))))))))] + (let* [f +, xs (clojure.lang.LongRange/create 25)] + (let* [!xs (>!alist xs)] + (. apply*|expansion|__0 invoke f !xs)))) + +(t/fn [] (apply + (range 25))) +-> ;; because nothing is "higher" than the `t/fn` + ;; TODO what if it's defined in an untyped context not in the ns? + (let* [apply*|expansion|__0 ...] + (reify* [...] + (invoke [...] + (let* [f +, xs (clojure.lang.LongRange/create 25)] + (let* [!xs (>!alist xs)] + (. apply*|expansion|__0 invoke f !xs)))))) + +(t/defn abc [] (t/fn [] (apply + (range 25)))) +-> ;; derives from a queue-like collection of expansions found while analyzing `abc` + (let* [apply*|expansion|__0 ...] + ... + (reify* [...] + (invoke [...] + (t/fn [] + (let* [f +, xs (clojure.lang.LongRange/create 25)] + (let* [!xs (>!alist xs)] + (. apply*|expansion|__0 invoke f !xs))))))) + + (t/defn test|apply [xs reducible?] (apply inc xs)) -> (t/defn test|apply [xs reducible?] (let* [f inc, xs xs] (apply* inc (>!alist xs)))) -> Not analyzed because `reducible?` (type of `xs`) is not `t/<` `reducible?` (type of `apply*.xs`) -Maybe we should always analyze in this case? That's a lot of analyzing code paths but still... maybe it'll be nice for "advanced compilation" and we can do dynamic dispatch otherwise? -- Lazy compilation? Maybe just before the typed context when it gets used is when it can be compiled + +;; TODO Lazy compilation? Maybe just before the typed context when it gets used is when it can be compiled ;; ========================= From 9239c9e2abd702ed718a4ec160e966879a9d25ed Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 28 Nov 2018 19:45:12 -0700 Subject: [PATCH 775/810] Provide next example --- test/quantum/test/untyped/core/type/defnt.cljc | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 0515b20a..2db0e168 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -3020,6 +3020,20 @@ B -> (let* [f inc, xs [1]] ;; TODO Lazy compilation? Maybe just before the typed context when it gets used is when it can be compiled +;; TODO let's see how this is able to be unrolled +(t/defn map+ [f t/tfn?] + (t/fn [rf ?] + (t/fn + ([] (rf)) + ([result ?] (rf result)) + ([result ?, input ?] + (rf result (f input)))))) + +(t/defn reduce ...) + +(t/dotyped (->> [1 2] (map+ inc) (reduce conj))) +-> ... + ;; ========================= " From 113b53692e082a3aae610b6e7e660dd0ceb0a454 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 29 Nov 2018 09:23:22 -0700 Subject: [PATCH 776/810] Demo of how to inner-expand `(transduce (map|transducer inc) conj [1 2])` --- .../quantum/test/untyped/core/type/defnt.cljc | 218 +++++++++++++++++- 1 file changed, 208 insertions(+), 10 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 2db0e168..c76724ea 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -3021,18 +3021,216 @@ B -> (let* [f inc, xs [1]] ;; TODO Lazy compilation? Maybe just before the typed context when it gets used is when it can be compiled ;; TODO let's see how this is able to be unrolled -(t/defn map+ [f t/tfn?] +(t/defn map|transducer [f t/tfn?] (t/fn [rf ?] - (t/fn + (^:inline t/fn ([] (rf)) - ([result ?] (rf result)) - ([result ?, input ?] - (rf result (f input)))))) - -(t/defn reduce ...) - -(t/dotyped (->> [1 2] (map+ inc) (reduce conj))) --> ... + ([ret ?] (rf ret)) + ([ret ?, input ?] + (rf ret (f input)))))) + +(t/defn reduce + (^:inline [rf rf?, init t/ref?, xs (t/isa? IReduce)] + (.reduce xs rf init))) ; .reduce on IReduce will be handled specially + +(t/defn transduce [xf ?, rf ?, init ?, xs ?] + (let [f (xf rf) + ret (reduce f init xs)] + (f ret))) + +(t/dotyped (transduce (map|transducer inc) conj [1 2])) +-> (transduce + ;; inner expansion + (let* [f inc] + ;; `?` are resolved + (t/fn [rf (t/ftype [] [t/any?] [t/any? (t/input f :?)])] + (^:inline t/fn + ;; We avoid resolving `?` return types since the body may change + ([] (rf)) + ([ret (t/input rf :?)] (rf ret)) + ([ret (t/input rf :? (t/output f (t/type x))), x (t/input f :?)] + (rf ret (f x)))))) + conj + [] + [1 2]) +-> ;; inner expansion + (let* [xf (let* [f inc] + (t/fn [rf (t/ftype [] [t/any?] [t/any? (t/input f :?)])] + (^:inline t/fn + ([] (rf)) + ([ret (t/input rf :?)] (rf ret)) + ([ret (t/input rf :? (t/output f (t/type x))), x (t/input f :?)] + (rf ret (f x)))))) + rf conj + init [] + xs [1 2]] + (let* [f (xf rf) + ret (reduce f init xs)] + (f ret))) +-> (let* [xf (let* [f inc] + (t/fn [rf (t/ftype [] [t/any?] [t/any? (t/input f :?)])] + (^:inline t/fn + ([] (rf)) + ([ret (t/input rf :?)] (rf ret)) + ([ret (t/input rf :? (t/output f (t/type x))), x (t/input f :?)] + (rf ret (f x)))))) + rf conj + init [] + xs [1 2]] + (let* [f ;; inner expansion + (let* [f inc] + ;; elides isobindings so no additional `let*` + (^:inline t/fn + ([] (rf)) + ([ret (t/input rf :?)] (rf ret)) + ([ret (t/input rf :? (t/output f (t/type x))), x (t/input f :?)] + (rf ret (f x))))) + ret (reduce f init xs)] + (f ret))) +-> (let* [xf (let* [f inc] + (t/fn [rf (t/ftype [] [t/any?] [t/any? (t/input f :?)])] + (^:inline t/fn + ([] (rf)) + ([ret (t/input rf :?)] (rf ret)) + ([ret (t/input rf :? (t/output f (t/type x))), x (t/input f :?)] + (rf ret (f x)))))) + rf conj + init [] + xs [1 2]] + (let* [f (let* [f inc] + (^:inline t/fn + ([] []) ; expanded from `(conj)` + ([ret (t/input rf :?)] ret) ; expanded from `(conj ret)` + ([ret (t/input rf :? (t/output f (t/type x))), x (t/input f :?)] + (rf ret (f x))))) + ret (.reduce xs f init)] ; inlined; elides isobindings so no `let*` + (f ret))) +-> (let* [xf (let* [f inc] + (t/fn [rf (t/ftype [] [t/any?] [t/any? (t/input f :?)])] + (^:inline t/fn + ([] (rf)) + ([ret (t/input rf :?)] (rf ret)) + ([ret (t/input rf :? (t/output f (t/type x))), x (t/input f :?)] + (rf ret (f x)))))) + rf conj + init [] + xs [1 2]] + (let* [f (let* [f inc] + (^:inline t/fn + ([] []) + ([ret (t/input rf :?)] ret) + ([ret (t/input rf :? (t/output f (t/type x))) + x (t/and (t/input f :?) (t/element xs))] ; throw if `t/none?` results + ;; because the class of `x` was determined + (let* [x (. Numbers uncheckedLongCast x)] + (rf ret (. Numbers inc x)))))) + ;; `.reduce` is handled specially and does type checking ahead of time on `f` to avoid + ;; runtime checks as much as possible + ret (.reduce xs + (c/fn [ret x] + (let* [x (. Numbers uncheckedLongCast x)] + (rf ret (. Numbers inc x)))) + init)] + (f ret))) +-> (let* [xf (let* [f inc] + (t/fn [rf (t/ftype [] [t/any?] [t/any? (t/input f :?)])] + (^:inline t/fn + ([] (rf)) + ([ret (t/input rf :?)] (rf ret)) + ([ret (t/input rf :? (t/output f (t/type x))), x (t/input f :?)] + (rf ret (f x)))))) + rf conj + init [] + xs [1 2]] + (let* [f (let* [f inc] + (^:inline t/fn + ([] []) + ([ret (t/input rf :?)] ret) + ([ret (t/input rf :? (t/output f (t/type x))) + x (t/and (t/input f :?) (t/element xs))] ; throw if `t/none?` results + ;; because the class of `x` was determined + (let* [x (. Numbers uncheckedLongCast x)] + (rf ret (. Numbers inc x)))))) + ;; `.reduce` is handled specially and does type checking ahead of time on `f` to avoid + ;; runtime checks as much as possible + ret (.reduce xs + (c/fn [ret x] + (let* [x (. Numbers uncheckedLongCast x)] + (rf ret (. Numbers inc x)))) + init)] + ret)) +-> (let* [xf (let* [f inc] + (t/fn [rf (t/ftype [] [t/any?] [t/any? (t/input f :?)])] + (^:inline t/fn + ([] (rf)) + ([ret (t/input rf :?)] (rf ret)) + ([ret (t/input rf :? (t/output f (t/type x))), x (t/input f :?)] + (rf ret (f x)))))) + rf conj + init [] + xs [1 2]] + (let* [f (let* [f inc] + ;; TODO need to analyze this as if we're doing: + ;; (loop [i 0, ret init] + ;; (if (>= i (count xs)) + ;; ret + ;; (let* [x (nth xs)] (recur (below-fn ret x))))) + (^:inline t/fn + ([] []) + ([;; throws if `t/none?` results + ret (t/and (t/input rf :?) + ...)] ret) + ([;; throws if `t/none?` results + ret (t/and (t/input rf :? (t/output f (t/type x))) + (t/or (t/type init) + ...)) + ;; throws if `t/none?` results + x (t/and (t/input f :?) (t/element xs))] + ;; because the class of `x` was determined + (let* [x (. Numbers uncheckedLongCast x)] + (rf ret (. Numbers inc x))))))] + (.reduce xs + (c/fn [ret x] + (let* [x (. Numbers uncheckedLongCast x)] + (. conj|__0 invoke ret (. Numbers inc x)))) + init))) +-> (let* [xf (let* [f inc] + (t/fn [rf (t/ftype [] [t/any?] [t/any? (t/input f :?)])] + (^:inline t/fn + ([] (rf)) + ([ret (t/input rf :?)] (rf ret)) + ([ret (t/input rf :? (t/output f (t/type x))), x (t/input f :?)] + (rf ret (f x)))))) + rf conj + init [] + xs [1 2]] + (.reduce xs + (c/fn [ret x] + (let* [x (. Numbers uncheckedLongCast x)] + (rf ret (. Numbers inc x)))) + init)) +-> (let* [init [] + xs [1 2]] + (.reduce xs + (c/fn [ret x] + (let* [x (. Numbers uncheckedLongCast x)] + (. conj|__0 invoke ret (. Numbers inc x)))) + init)) +-> (let* [transduce|expanded__0 + (reify* [O__O] + (invoke [&this init xs] + (.reduce xs + (c/fn [ret x] + (let* [x (. Numbers uncheckedLongCast x)] + (. conj|__0 invoke ret (. Numbers inc x)))) + init)))] + (. transduce|expanded__0 invoke [] [1 2])) +;; So, did this actually help? Yes; we were able to elide a lot of checks/dynamism/overhead. Should +;; we use it in all occasions? Unclear. It's a lot of work to implement and the compilation might be +;; slow. It may be best to leave for an "advanced compilation" enhancement later. We can afford +;; dynamism as long as it's 'fast enough' — e.g. instead of `(t/boolean? x)` we expand to +;; `(instance? Boolean x)`. Clojure has this kind of dynamism with pretty much everything anyway. +;; The real issue is when we dynamically invoke an fn that does some more complex checks. ;; ========================= From 0bc819a346186e92230014f350ebcfa319c90bee Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 29 Nov 2018 09:25:24 -0700 Subject: [PATCH 777/810] Add note on dynamism --- test/quantum/test/untyped/core/type/defnt.cljc | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index c76724ea..09eca5d4 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -3231,6 +3231,10 @@ B -> (let* [f inc, xs [1]] ;; dynamism as long as it's 'fast enough' — e.g. instead of `(t/boolean? x)` we expand to ;; `(instance? Boolean x)`. Clojure has this kind of dynamism with pretty much everything anyway. ;; The real issue is when we dynamically invoke an fn that does some more complex checks. +;; We should be able to have configurable levels of dynamism: +;; 1) advanced : eliminate as much dynamism as possible +;; 2) normal : eliminate as much dynamism as possible for global fns only +;; 3) dynamic : make everything dynamic, for faster compilation and thought processes ;; ========================= From 09af8cd8025e6eed391690ff8e0c724e1144ab6a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 29 Nov 2018 17:48:16 -0700 Subject: [PATCH 778/810] Start in on `t/fn` analysis --- resources-dev/defnt.cljc | 18 +++++++++--------- src-untyped/quantum/untyped/core/analyze.cljc | 16 ++++++++++++++-- test/quantum/test/untyped/core/type/defnt.cljc | 2 +- 3 files changed, 24 insertions(+), 12 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 3784ed61..7d880059 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -59,13 +59,19 @@ Legend: - TODO implement the following: [-] t/fn - [ ] look at fn comparisons; really there's just <|=|> with <|=|> so 9 combos [ ] add `t/fn` as a special form so we don't need to re-analyze its constituents [ ] t/ftype should automatically split types, while perhaps t/ftype* should just assume they're split (for use by e.g. `t/fn` and `t/defn`) [ ] test t/fn to make sure meta 'sticks' : `(t/fn {...} [] ...)` - [ ] make local vars sanitary/safe by using more of the gensym feature - [2] t/numerically : e.g. a double representing exactly what a float is able to represent + [2] `?` : type inference + - use logic programming and variable unification e.g. `?1` `?2` ? + - For this situation: `?` is `(t/- dc/counted?)` + ([n dn/std-integer?, xs dc/counted?] (count xs)) + ([n dn/std-integer?, xs ?] ...) + - [ ] No trailing `>` means `> ?` + [3] inner expansion (see tests to see how this could work) + [4] make local vars sanitary/safe by making better use of the gensym feature + [5] t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. - t/numerically-integer? - Primitive conversions not requiring checks can go in data.primitive @@ -87,12 +93,6 @@ Legend: - `[x with-metable?, meta' meta? > (t/run with-metable?) #_(TODO TYPED (t/value-of x))]` [ ] (comp/t== x) - dependent type such that the passed input must be identical to x - [ ] `?` : type inference - - use logic programming and variable unification e.g. `?1` `?2` ? - - For this situation: `?` is `(t/- dc/counted?)` - ([n dn/std-integer?, xs dc/counted?] (count xs)) - ([n dn/std-integer?, xs ?] ...) - - [ ] No trailing `>` means `> ?`f [ ] Non-boxed (primitive) `t/def`s: `(var/def- min-float (Numeric/negate Float/MAX_VALUE))` - direct linking doesn't help with this; the way around this is seems to be to do `let` bindings for all captured non-dynamic vars, and unbox the var-values that are primitive [ ] `(t/validate x (t/run t/string?))` for `(t/run t/string?)` needs to be more performant diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 9bad9959..18a94383 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -164,6 +164,8 @@ ;; ----- End reflection support ----- ;; +(def ^:dynamic *analyzing?* false) + (defonce !!analyze-arg-syms|iter (>!thread-local 0)) ; `nneg-fixint?` (defonce !!analyze-depth (>!thread-local 0)) @@ -610,6 +612,10 @@ (err! "Expected var, but found" {:form form :resolved resolved}) (uast/var* env (list 'var (uid/>symbol resolved)) resolved (t/value resolved)))))) +(defns- analyze-seq|tfn + [env ::env form ...] + ) + (defn- filter-dynamic-dispatchable-overload-types "An example of dynamic dispatch: - When we call `seq` on an input of type `(t/? (t/isa? java.util.Set))`, direct dispatch will @@ -940,6 +946,8 @@ (quantum.untyped.core.type.defnt/dotyped quantum.core.type/dotyped) (analyze-seq|do env (list* 'do (rest form))) fn* (TODO "fn*" {:form form}) + (quantum.core.type.defnt/fn + quantum.untyped.core.type.defnt/fn) (analyze-seq|tfn env form) if (analyze-seq|if env form) let* (analyze-seq|let* env form) new (analyze-seq|new env form) @@ -968,7 +976,11 @@ (analyze-seq|call env form)))) (defns- analyze-seq [env ::env, form _] - (let [expanded-form (binding [*ns* (or (-> env :opts :ns) *ns*)] (ufeval/macroexpand form))] + (let [expanded-form (case (first form) + (quantum.core.type.defnt/fn + quantum.untyped.core.type.defnt/fn) + form ; will be analyzed in `analyze-seq*` + (binding [*ns* (or (-> env :opts :ns) *ns*)] (ufeval/macroexpand form)))] (if-let [no-expansion? (ucomp/== form expanded-form)] (analyze-seq* env expanded-form) (let [expanded-form' (cond-> expanded-form @@ -1079,7 +1091,7 @@ ([form _] (analyze {} form)) ([env ::env, form _] (uref/set! !!analyze-depth 0) - (analyze* env form))) + (binding [*analyzing?* true] (analyze* env form)))) ;; ===== Arglist analysis ===== ;; diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 09eca5d4..89a804a8 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -2852,6 +2852,7 @@ ([x0 ?, x1 ?, x2 ?] (f0 (f1 x0 x1 x2))) ([x0 ?, x1 ?, x2 ?, xs ?] (f0 (apply f1 x0 x1 x2 xs)))))) +;; Type inference would come in handy here too (self/defn aritoid ([f0 (t/ftype []) > (t/ftype [:> (t/output f0)])] @@ -3020,7 +3021,6 @@ B -> (let* [f inc, xs [1]] ;; TODO Lazy compilation? Maybe just before the typed context when it gets used is when it can be compiled -;; TODO let's see how this is able to be unrolled (t/defn map|transducer [f t/tfn?] (t/fn [rf ?] (^:inline t/fn From ded2c2ddac3d43c7ea0bda0ee89094a55c4f0d73 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Dec 2018 00:37:15 -0700 Subject: [PATCH 779/810] Add `TypedDefnNode` and `ExtendTypedDefnNode` --- .../quantum/untyped/core/analyze/ast.cljc | 43 ++++++++++++++++++- 1 file changed, 42 insertions(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index dfb9685c..31f08cef 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -361,7 +361,7 @@ unanalyzed-form #_::t/form form #_::t/form arg #_::node - type #_t/nil?] + type #_(t/value t/none?)] INode fipp.ednize/IOverride fipp.ednize/IEdn @@ -371,3 +371,44 @@ (defn throw-node [m] (map->ThrowNode m)) (defn throw-node? [x] (instance? ThrowNode x)) + +(defrecord TypedDefnNode + [env #_::env + unanalyzed-form #_::t/form + name #_simple-symbol? + meta #_meta? + overloads #_(t/vec-of (t/kv {:arg-types (t/vec-of t/type?) + :type t/type? + :body node?})) + form #_::t/form + type #_t/type?] + INode + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (list `defnt-node (std-print-structure this)))) + +;; Not type hinted because it's inferred +(defn defnt-node [m] (map->TypedDefnNode m)) + +(defn defnt-node? [x] (instance? TypedDefnNode x)) + +(defrecord ExtendTypedDefnNode + [env #_::env + unanalyzed-form #_::t/form + name #_simple-symbol? + meta #_meta? + ;; The extensions, not the original overloads (which data will have been lost) + overloads #_(t/vec-of (t/kv {:arg-types (t/vec-of t/type?) + :type t/type? + :body node?})) + form #_::t/form + type #_t/type?] ; of the extended fn + INode + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (list `defnt-node (std-print-structure this)))) + +;; Not type hinted because it's inferred +(defn extend-defnt-node [m] (map->ExtendTypedDefnNode m)) + +(defn extend-defnt-node? [x] (instance? ExtendTypedDefnNode x)) From 7738b88fa7e440e86803f15ec78872ea78f80c9d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Dec 2018 00:37:28 -0700 Subject: [PATCH 780/810] t/tfn? -> t/fnt? --- src-untyped/quantum/untyped/core/type.cljc | 4 ++-- test/quantum/test/untyped/core/type/defnt.cljc | 12 ++++++------ 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type.cljc b/src-untyped/quantum/untyped/core/type.cljc index 2c229ba3..21ef7b7a 100644 --- a/src-untyped/quantum/untyped/core/type.cljc +++ b/src-untyped/quantum/untyped/core/type.cljc @@ -1008,7 +1008,7 @@ (isa?|direct #?(:clj clojure.lang.IFn :cljs cljs.core/IFn))) ;; Used by `quantum.untyped.core.analyze` via `t/callable?` -(def* tfn? (and fn? (>expr (fn-> c/meta :quantum.core.type/type type?)))) +(def* fnt? (and fn? (>expr (fn-> c/meta :quantum.core.type/type type?)))) ;; TODO should we allow java.lang.Runnable, java.util.concurrent.Callable, and other ;; functional interfaces to be `callable?`? @@ -1016,7 +1016,7 @@ (uvar/def callable? "The set of all objects that are able to called/invoked by being in functor position (first element of an unquoted list) within a typed context." - (or fn? ifn? tfn?)) + (or fn? ifn? fnt?)) ;; ===== Metadata ===== ;; diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 89a804a8..3653b432 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -2739,10 +2739,10 @@ ~'j|test))))))] ...))) -;; Automatically analyzes the body of `tfn?`s which have at least one input of `t/fn?` +;; Automatically analyzes the body of `fnt?`s which have at least one input of `t/fn?` ;; Meaning, the body is analyzed as if inline, but if not marked `inline`, will intern a separate fn ;; for the purpose -(t/defn- apply* [f (t/meta-or t/tfn? t/fn?), !xs !alist?] +(t/defn- apply* [f (t/meta-or t/fnt? t/fn?), !xs !alist?] (case (count !xs) 0 (f !xs) 1 (f (get !xs 0)) @@ -2820,8 +2820,8 @@ ;; Now *this* is where type inference would come in handy... (self/defn comp (^:inline [> (t/value identity)] identity) - (^:inline [f0 t/tfn? > (t/type f0)] f0) - ([f0 (t/ftype [(t/output f1 :any)]), f1 t/tfn?] + (^:inline [f0 t/fnt? > (t/type f0)] f0) + ([f0 (t/ftype [(t/output f1 :any)]), f1 t/fnt?] (self/fn ([] (f0 (f1))) @@ -2843,7 +2843,7 @@ (self/defn comp ;; `> ?` is everywhere implied (^:inline [] identity) - (^:inline [f0 t/tfn?] f0) + (^:inline [f0 t/fnt?] f0) ([f0 ?, f1 ?] (self/fn ([] (f0 (f1))) @@ -3021,7 +3021,7 @@ B -> (let* [f inc, xs [1]] ;; TODO Lazy compilation? Maybe just before the typed context when it gets used is when it can be compiled -(t/defn map|transducer [f t/tfn?] +(t/defn map|transducer [f t/fnt?] (t/fn [rf ?] (^:inline t/fn ([] (rf)) From ffb0394fef4129624e695a27397dff5330ac765b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Dec 2018 00:39:41 -0700 Subject: [PATCH 781/810] analyzer now hooks in to analying typed macros --- src-untyped/quantum/untyped/core/analyze.cljc | 32 +++++++++++++------ 1 file changed, 22 insertions(+), 10 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 18a94383..17df4b65 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -164,7 +164,17 @@ ;; ----- End reflection support ----- ;; -(def ^:dynamic *analyzing?* false) +(def ^:dynamic *analyzing?* false) + +;; Will define later in `quantum.untyped.core.type.defnt` +(defonce !!analyze-fnt + (atom (fn [env form] (throw (ex-info "`analyze-fnt` has not been defined yet" {}))))) + +(defonce !!analyze-defnt + (atom (fn [env form] (throw (ex-info "`analyze-defnt` has not been defined yet" {}))))) + +(defonce !!analyze-extend-defnt + (atom (fn [env form] (throw (ex-info "`analyze-extend-defnt!` has not been defined yet" {}))))) (defonce !!analyze-arg-syms|iter (>!thread-local 0)) ; `nneg-fixint?` @@ -612,10 +622,6 @@ (err! "Expected var, but found" {:form form :resolved resolved}) (uast/var* env (list 'var (uid/>symbol resolved)) resolved (t/value resolved)))))) -(defns- analyze-seq|tfn - [env ::env form ...] - ) - (defn- filter-dynamic-dispatchable-overload-types "An example of dynamic dispatch: - When we call `seq` on an input of type `(t/? (t/isa? java.util.Set))`, direct dispatch will @@ -939,15 +945,19 @@ [env ::env, [caller|form _ & body _ :as form] _ > uast/node?] (case caller|form . (analyze-seq|dot env form) + (quantum.core.type/def quantum.untyped.core.type.defnt/def) + (TODO "t/def" {:form form}) def (TODO "def" {:form form}) deftype* (TODO "deftype*" {:form form}) do (analyze-seq|do env form) ;; To avoid having to re-analyze - (quantum.untyped.core.type.defnt/dotyped quantum.core.type/dotyped) - (analyze-seq|do env (list* 'do (rest form))) + (quantum.core.type/dotyped quantum.untyped.core.type.defnt/dotyped) + (analyze-seq|do env (list* 'do (rest form))) fn* (TODO "fn*" {:form form}) - (quantum.core.type.defnt/fn - quantum.untyped.core.type.defnt/fn) (analyze-seq|tfn env form) + (quantum.core.type.defnt/fn quantum.untyped.core.type.defnt/fn) + (@!!analyze-fnt env form) + (quantum.core.type.defnt/defn quantum.untyped.core.type.defnt/defn) + (@!!analyze-defnt env form) if (analyze-seq|if env form) let* (analyze-seq|let* env form) new (analyze-seq|new env form) @@ -978,7 +988,9 @@ (defns- analyze-seq [env ::env, form _] (let [expanded-form (case (first form) (quantum.core.type.defnt/fn - quantum.untyped.core.type.defnt/fn) + quantum.untyped.core.type.defnt/fn + quantum.core.type.defnt/defn + quantum.untyped.core.type.defnt/defn) form ; will be analyzed in `analyze-seq*` (binding [*ns* (or (-> env :opts :ns) *ns*)] (ufeval/macroexpand form)))] (if-let [no-expansion? (ucomp/== form expanded-form)] From 2609bffcb2a5994fc360e38922766aceac90835e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Dec 2018 00:49:22 -0700 Subject: [PATCH 782/810] Restruture typed macro impls to use `uana/analyze` --- .../quantum/untyped/core/type/defnt.cljc | 522 ++++++++++-------- 1 file changed, 288 insertions(+), 234 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 4d388871..68b6c6ad 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -11,7 +11,7 @@ [quantum.core.type.defs :as tdef] [quantum.untyped.core.analyze :as uana] [quantum.untyped.core.analyze.ast :as uast] - [quantum.untyped.core.core + [quantum.untyped.core.core :as ucore :refer [istr sentinel]] ; TODO use quantum.untyped.core.string/istr instead [quantum.untyped.core.defnt :refer [defns defns- fns]] @@ -64,11 +64,66 @@ [quantum.core Numeric] [quantum.core.data Array]))) +;; TODO move +(def index? #(and (integer? %) (>= % 0))) +(def count? index?) + +(defonce *fn->type (atom {})) + +(defonce *interfaces (atom {})) + +;; ===== Effects management ===== ;; + +(defonce !global-overload-queue (uvec/alist)) ; (t/!seq-of ::types-decl-datum-with-overload) + +(uvar/defonce !global-rollback-queue + "To ensure that side-effects are as atomic as possible in the case of a failure in `defn` or + `extend-defn!`." + (uvec/alist)) ; (t/!seq-of (t/ftype [])) + +(defns- intern-with-rollback! [!rollback-queue _, ns-sym simple-symbol?, sym simple-symbol?, v _] + (let [var-val (resolve (uid/qualify ns-sym sym)) + !value (atom nil)] + (when var-val (reset! !value (var-get var-val))) + (intern ns-sym sym v) + (alist-conj! !rollback-queue + #(if var-val + (intern ns-sym sym @!value) + (uvar/unintern! ns-sym sym))))) + +(defn- drain-rollback-queue! + "Rolls back already-executed effects in reverse order." + [!rollback-queue] + (->> !rollback-queue + reverse + (uc/run! + (c/fn [rollback-fn] + (uerr/catch-all (rollback-fn) + rollback-err + (err! nil "Unable to roll back all effects" {:failed-rollback-fn rollback-fn} + nil rollback-err)))))) + +(defns- with-rollback! [!overload-queue _, !rollback-queue _, f fn?] + (uerr/catch-all + (f) + e + (do (ulog/ppr :error e) + (drain-rollback-queue! !rollback-queue) + (err! nil "Exception; rolled back successfully" nil nil e)) + (do (uvec/alist-empty! !rollback-queue) + (uvec/alist-empty! !overload-queue)))) + +(defns- analyze-with-rollback! [unanalyzed-form _] + (with-rollback! !global-overload-queue !global-rollback-queue + #(-> % unanalyzed-form uana/analyze :form))) + +;; ===== Macros ===== ;; + ;; TODO move #?(:clj (defmacro dotyped "Like `do`, but evaluates `args` in a typed context." - [& args] (-> `(do ~@args) uana/analyze :form))) + [& args] (analyze-with-rollback! `(dotyped ~@args)))) ;; TODO move #?(:clj @@ -84,16 +139,18 @@ (list 'quantum.untyped.core.type.defnt/def sym doc-or-meta nil v) (list 'quantum.untyped.core.type.defnt/def sym nil doc-or-meta v))) ([sym doc meta-val v] - (list 'def - (if (or doc meta-val) - (update-meta sym merge - (-> meta-val (cond-> doc (assoc :doc doc)) uana/analyze :form)) - sym) - (let [node (uana/analyze v)] - (if (and (-> node :type utr/value-type?) - (-> node :type t/unvalue t/type?)) - `(utr/with-name ~(:form node) '~(uid/qualify *ns* sym)) - (:form node))))))) + (with-rollback! !global-overload-queue !global-rollback-queue + (c/fn [] + (list 'def + (if (or doc meta-val) + (update-meta sym merge + (-> meta-val (cond-> doc (assoc :doc doc)) uana/analyze :form)) + sym) + (let [node (uana/analyze v)] + (if (and (-> node :type utr/value-type?) + (-> node :type t/unvalue t/type?)) + `(utr/with-name ~(:form node) '~(uid/qualify *ns* sym)) + (:form node))))))))) #?(:clj (defmacro def- @@ -105,61 +162,101 @@ ([sym doc meta-val v] (list 'quantum.untyped.core.type.defnt/def (update-meta sym merge {:private true}) doc meta-val v)))) -;; TODO move -(def index? #(and (integer? %) (>= % 0))) -(def count? index?) -;; ===== `t/extend-defn!` specs ===== ;; +#?(:clj +(defmacro fn + "With `t/fn`, protocols, interfaces, and multimethods become unnecessary. The preferred method of + dispatch becomes the function alone. -(us/def :quantum.core.defnt/fn|extended-name symbol?) + `t/fn` is intended to catch many runtime errors at compile time, but cannot catch all of them. -(us/def :quantum.core.defnt/extend-defn! - (us/and (us/spec - (us/cat :quantum.core.defnt/fn|extended-name :quantum.core.defnt/fn|extended-name - :quantum.core.defnt/overloads :quantum.core.defnt/overloads)) - (uss/fn-like|postchecks|gen :quantum.core.defnt/overloads) - :quantum.core.defnt/postchecks)) + `t/fn`, along with `t/defn`, `t/dotyped`, and others, creates a typed context in which its + internal forms are analyzed, type-consistency is checked, and type-dispatch is resolved at + compile time inasmuch as possible, and at runtime only when necessary. -;; ===== End `t/extend-defn!` specs ===== ;; + Recommendations for the type system: + - Primitives are always preferred to boxed values. All values that can be primitives (i.e. ones + that are `t/<=` w.r.t. a `(t/isa? )`) are treated as primitives unless + specifically marked otherwise with the `t/ref` metadata-adding directive. + - One could imagine a dynamic set of types corresponding to a given predicate, e.g. `decimal?`. + Say someone comes up with a new `decimal?`-like class and wants to redefine `decimal?` to + accommodate. One could define `decimal?` as a reactive/extensible type to do this. However, it + is preferable to instead define a marker protocol called `PDecimal` or some such and put that + on the defined `deftype` itself, and incorporate `PDecimal` into `decimal?` from the start. In + this way fewer reactive changes have to happen and less compilation occurs. -(defonce *fn->type (atom {})) + Compile-Time (Direct) Dispatch characteristics + - Any input, if its type is `t/<=` a non-nil primitive (boxed or not) class, it will be marked + as a primitive in the corresponding `reify`. + - If an input is a nilable primitive, its nilability will not result in only one `reify` + overload with a boxed input, but rather will result in two `reify` overloads — one + corresponding to a nil input and another for the primitive input. -(defonce defnt-cache (atom {})) ; TODO For now — but maybe lock-free concurrent hash map to come + Runtime (Dynamic) Dispatch characteristics + - Compile-Time Dispatch is preferred to Runtime Dispatch in all but the following situations, in + which Compile-Time Dispatch is not possible: + - When a typed function (or a typed object with function-like characteristics such as a + `t/deftype`) is referenced outside of a typed context. -(defonce *interfaces (atom {})) + Metadata directives special to all typed contexts include: + - `:val` : If `true` and attached as metadata to a form, it will cause that form's type to be + `t/and`ed with `t/val?`. + - `:dyn` : If `true` and attached as metadata to a form corresponding with a typed fn in functor + position, it will cause that typed fn to be called dynamically if no direct dispatch + is found at compile time. + - For instance, `(name (read ...))` fails at compile-time; we want it to at least try + at runtime. So we annotate like `(^:dyn name (read ...))`, which tells the compiler + to figure out at runtime whether a call to `name` will succeed. -(defonce !overload-queue (uvec/alist)) ; (t/!seq-of ::types-decl-datum-with-overload) + Metadata directives special to `t/fn`/`t/defn` include: + - `:inline` : If `true` and attached as metadata to the arglist of an overload, will cause that + overload to be inlined if possible: + - `(t/defn abc (^:inline [] ...))` + If `true` and attached as metadata to the whole `t/defn` or `t/fn`, will cause + every one of its overloads to be inlined if possible. Overloads added to a `t/defn` + with `:inline` `true` will inherit this inline directive unless `:inline` is false + for the overload or `:unline` is true: + - `(t/defn ^:inline abc ([] ...) ([...] ...))` + - `(t/defn ^:inline abc (^{:inline false} [] ...) ([...] ...))` + - `(t/defn ^:inline abc ([] ...) (^:unline [...] ...))` + Note: + - Inlining is possible only in typed contexts. + - If the metadata for an overload changes via `extend-defn!` from designating it as + inline to designating it as non-inline, or vice versa, unexpected behavior may + occur. -(uvar/defonce !rollback-queue - "To ensure that side-effects are as atomic as possible in the case of a failure in `defn` or - `extend-defn!`." - (uvec/alist)) ; (t/!seq-of (t/ftype [])) + `t/fn` only works fully in contexts in which the metalanguage (compiler language) is the same as + the object language. Otherwise, while the compiler could still analyze types symbolically to an + extent, it could not actually run evaluated type-predicates on inputs to determine type-satisfaction. + - Consumers wishing to use the full-featured `t/fn` in ClojureScript must either use + bootstrapped ClojureScript or transpile ClojureScript via the JavaScript implementation of + the Google Closure Compiler. Consumers for whom the version of `t/fn` with purely symbolic + analysis is acceptable may use the standard approach of transpiling ClojureScript via the Java + implementation of the Google Closure Compiler." + [& args] (analyze-with-rollback! `(fn ~@args)))) -(defns- intern-with-rollback! [ns-sym simple-symbol?, sym simple-symbol?, v _] - (let [var-val (resolve (uid/qualify ns-sym sym)) - !value (atom nil)] - (when var-val (reset! !value (var-get var-val))) - (intern ns-sym sym v) - (alist-conj! !rollback-queue - #(if var-val - (intern ns-sym sym @!value) - (uvar/unintern! ns-sym sym))))) +#?(:clj +(defmacro defn + "A `defn` with an empty body is like using `declare`." + [& args] (analyze-with-rollback! `(defn ~@args)))) -(defn- drain-rollback-queue! - "Rolls back already-executed effects in reverse order." - [] - (->> !rollback-queue - reverse - (uc/run! - (c/fn [rollback-fn] - (uerr/catch-all (rollback-fn) - rollback-err - (err! nil "Unable to roll back all effects" {:failed-rollback-fn rollback-fn} - nil rollback-err)))))) +#?(:clj +(defmacro extend-defn! + "Currently undefining overloads is not possible." + [& args] (analyze-with-rollback! `(extend-defn! ~@args)))) -;; ==== Internal specs ===== ;; +;; ===== `t/extend-defn!` specs ===== ;; + +(us/def :quantum.core.defnt/fn|extended-name symbol?) + +(us/def :quantum.core.defnt/extend-defn! + (us/and (us/spec + (us/cat :quantum.core.defnt/fn|extended-name :quantum.core.defnt/fn|extended-name + :quantum.core.defnt/overloads :quantum.core.defnt/overloads)) + (uss/fn-like|postchecks|gen :quantum.core.defnt/overloads) + :quantum.core.defnt/postchecks)) -(us/def ::lang #{:clj :cljs}) +;; ==== Internal specs ===== ;; (def ^:dynamic *compilation-mode* :normal) @@ -170,7 +267,6 @@ (us/def ::opts (us/kv {:compilation-mode ::compilation-mode :gen-gensym t/fn? - :lang ::lang :kind ::kind})) ;; "global" because they apply to the whole `t/fn` @@ -215,6 +311,7 @@ :reactive? boolean? :inline? boolean?})) +;; Interned as `!overload-bases` (us/def ::overload-bases-data (us/kv {:prev-norx (us/nilable (us/vec-of ::overload-basis|norx)) :current (us/vec-of ::overload-basis)})) @@ -247,7 +344,7 @@ :arglist-code|fn|hinted (us/vec-of simple-symbol?) :arglist-code|hinted (us/vec-of simple-symbol?) :arglist-code|reify|unhinted (us/vec-of simple-symbol?) - :body-form t/any? + :body-node uast/node? :output-class (us/nilable class?) :output-type t/type? :positional-args-ct count? @@ -291,16 +388,12 @@ :body-codelist (us/vec-of t/any?) :inline? boolean?})) +;; Interned as `!fn|types` (us/def ::fn|types (us/kv {:fn|output-type-norx t/type? :fn|type-norx t/type? :overload-types (us/vec-of ::types-decl-datum)})) -#_(:clj -(c/defn fnt|arg->class [lang {:as arg [k spec] ::fnt|arg-spec :keys [arg-binding]}] - (cond (not= k :spec) java.lang.Object; default class - (symbol? spec) (pred->class lang spec)))) - (c/defn >with-runtime-output-type [body output-type|form] `(t/validate ~body ~output-type|form)) ;; TODO simplify this class computation @@ -366,6 +459,8 @@ (defonce thing (atom nil)) +(uvar/def- ^:const min-int-value -2147483648) + (c/defn sort-overload-types "A naïve implementation would do an aggregate compare on the arg-types vectors, but the resulting comparator would not be transitive due to the behavior of `<>` and `><`, and the arg-types @@ -395,9 +490,8 @@ (uc/group-deep-by-into max-arity (c/fn [i x] (let [t (-> x kf (get i))] (if-let [c (uana/sort-guide t)] - ;; Min int value to ensure sort-guide ones always - ;; come first - (+ -2147483648 c) + ;; To ensure sort-guide ones always come first + (+ min-int-value c) (hash t)))) (c/fn ([] (umap/>!sorted-map)) ([ret] (->> ret uc/vals+ uc/cat+ (educe alist-conj!))) @@ -437,9 +531,10 @@ (defns- unanalyzed-overload>overload "Given an `::unanalyzed-overload`, performs type analysis on the body and computes a resulting `t/fn` overload, which is the foundation for one `reify`." - [{:as opts :keys [lang _, kind _]} ::opts + [{:as opts :keys [kind _]} ::opts {:as fn|globals :keys [fn|globals-name _, fn|name _, fn|ns-name _, fn|output-type _ fn|overload-types-name _]} ::fn|globals + env ::uana/env {:as unanalyzed-overload :keys [arg-classes _, arg-types _, arglist-code|hinted _, arglist-code|reify|unhinted _, arglist-form|unanalyzed _, args-form _, body-codelist _ output-type|form _ @@ -452,7 +547,7 @@ (let [;; Not sure if `nil` is the right approach for the value recursive-ast-node-reference (when (= kind :defn) (uast/symbol {} fn|name nil fn|type)) - env (->> (zipmap (keys args-form) arg-types) + local-env (->> (zipmap (keys args-form) arg-types) (uc/map' (c/fn [[arg-binding arg-type]] [arg-binding (uast/unbound nil arg-binding arg-type)])) ;; To support recursion @@ -461,34 +556,35 @@ recursive-ast-node-reference (uid/qualify fn|ns-name fn|overload-types-name) fn|overload-types)))) - body-node (uana/analyze - (assoc env :opts {:ns (-> unanalyzed-overload :ns-name the-ns)}) - (ufgen/?wrap-do body-codelist)) - hint-arg|fn (c/fn [i arg-binding] - (ufth/with-type-hint arg-binding - (ufth/>fn-arglist-tag - (uc/get arg-classes i) - lang - (uc/count args-form) - variadic?))) + env' (-> env + (merge local-env) + (assoc-in [:opts :ns] (-> unanalyzed-overload :ns-name the-ns))) + body-node (uana/analyze env' (ufgen/?wrap-do body-codelist)) output-type (with-validate-output-type declared-output-type body-node) output-class (type>class output-type) - body-form - (-> (:form body-node) + body-node + (-> body-node (cond-> (t/run? output-type) ;; TODO here the output type is being re-created each time (unless the fn's overall ;; output type is being preferred) because it could reference inputs, but we ;; should probably analyze to determine whether it references inputs so we can, ;; in the 90% case, extern the output type - (>with-runtime-output-type + (update :form >with-runtime-output-type (or output-type|form `(?norx-deref (:fn|output-type ~(uid/qualify fn|ns-name fn|globals-name))))))) positional-args-ct (count args-form) + hint-arg|fn (c/fn [i arg-binding] + (ufth/with-type-hint arg-binding + (ufth/>fn-arglist-tag + (uc/get arg-classes i) + ucore/lang + (uc/count args-form) + variadic?))) arglist-code|fn|hinted (cond-> (->> args-form keys (uc/map-indexed hint-arg|fn)) variadic? (conj '& (-> varargs-form keys first)))] (kw-map arglist-form|unanalyzed arg-classes arg-types arglist-code|fn|hinted - arglist-code|reify|unhinted arglist-code|hinted body-form positional-args-ct + arglist-code|reify|unhinted arglist-code|hinted body-node positional-args-ct output-type output-class variadic?)))) (defns- class>interface-part-name [c class? > string?] @@ -527,7 +623,7 @@ #?(:clj (defns overload>reify [{:as overload - :keys [arg-classes _, arglist-code|reify|unhinted _, body-form _, output-class _]} ::overload + :keys [arg-classes _, arglist-code|reify|unhinted _, body-node _, output-class _]} ::overload {:as opts :keys [gen-gensym _]} ::opts {:keys [fn|name _]} ::fn|globals overload|id ::overload|id @@ -554,7 +650,7 @@ (reify* [~(-> interface >name >symbol)] (~(ufth/with-type-hint uana/direct-dispatch-method-sym (ufth/>arglist-embeddable-tag output-class|reify)) - ~arglist-code ~body-form)))] + ~arglist-code ~(:form body-node))))] {:form form :hinted-name reify|name :interface interface @@ -604,16 +700,17 @@ (defns- >overload-types-decl "The evaluated `form` of each overload-types-decl is an array of non-primitivized types that the dynamic dispatch uses to dispatch off input types." - [{:as opts :keys [compilation-mode _, lang _]} ::opts + [{:as opts :keys [compilation-mode _]} ::opts {:as fn|globals :keys [fn|ns-name _, fn|name _, fn|overload-types-name _]} ::fn|globals {:as types-decl-datum :keys [id _, index _] ns-name- [:ns-name _]} ::types-decl-datum fn|types ::fn|types > ::overload-types-decl] (let [decl-name (-> (>overload-types-decl|name fn|name id) (ufth/with-type-hint "[Ljava.lang.Object;")) - form (if (or (not= compilation-mode :test) (= lang :clj)) + form (if (or (not= compilation-mode :test) (= ucore/lang :clj)) (let [arg-types (overload-types>arg-types fn|types index)] - (do (intern-with-rollback! ns-name- decl-name arg-types) + (do (intern-with-rollback! + !global-rollback-queue ns-name- decl-name arg-types) nil)) `(def ~decl-name (overload-types>arg-types @@ -747,10 +844,10 @@ (err! "Duplicate input types for overload" (umap/om :arglist-form-0 (:arglist-form|unanalyzed prev-overload) :arg-types-0 (:arg-types prev-overload) - :body-0 (:body-form prev-overload) + :body-0 (-> prev-overload :body-node :form) :arglist-form-1 (:arglist-form|unanalyzed overload) :arg-types-1 (:arg-types overload) - :body-1 (:body-form overload))))))) + :body-1 (-> overload :body-node :form))))))) (defns- overload-bases-data>fn|types "Each overload type is structurally (`=`) unique and if an overload is introduced which is `t/=` @@ -760,6 +857,8 @@ opts ::opts {:as fn|globals :keys [fn|name _, fn|ns-name _, fn|output-type _, fn|overload-types-name _]} ::fn|globals + env _ + !overload-queue _ > ::fn|types] (establish-dependency-relations-on-new-overload-bases! fn|output-type overload-bases-data) (let [fn|output-type-norx|prev (:fn|output-type-norx existing-fn-types) @@ -817,7 +916,7 @@ (uc/map-indexed (c/fn [i x] (let [id (+ i first-current-overload-id)] - (unanalyzed-overload>overload opts fn|globals x id + (unanalyzed-overload>overload opts fn|globals env x id overload-types-with-replacing-ids fn|type-norx))))) overload-types (->> overload-types-with-replacing-ids @@ -835,11 +934,12 @@ ;; ----- Direct dispatch ----- ;; (defns- >direct-dispatch - [{:as opts :keys [gen-gensym _, lang _, kind _]} ::opts - fn|globals ::fn|globals - fn|types ::fn|types + [{:as opts :keys [gen-gensym _, kind _]} ::opts + fn|globals ::fn|globals + fn|types ::fn|types + !overload-queue _ > ::direct-dispatch] - (case lang + (case ucore/lang :clj (let [direct-dispatch-data-seq (->> !overload-queue (uc/map @@ -914,7 +1014,7 @@ (>combinatoric-seq+ fn|globals overload-types-for-arity arglist))))) (defns- >dynamic-dispatch-fn|codelist - [{:as opts :keys [compilation-mode _, gen-gensym _, lang _, kind _]} ::opts + [{:as opts :keys [compilation-mode _, gen-gensym _, kind _]} ::opts {:as fn|globals :keys [fn|meta _, fn|ns-name _, fn|name _, fn|output-type _ fn|overload-types-name _, fn|type-name _]} ::fn|globals fn|types ::fn|types] @@ -1117,11 +1217,12 @@ :current (incorporate-overload-bases current new-overload-bases)}] (with-optional-validate-overload-bases overload-bases') (let [prev-overload-bases (norx-deref !overload-bases)] - (alist-conj! !rollback-queue + (alist-conj! !global-rollback-queue #(uref/set! !overload-bases prev-overload-bases)) (uref/set! !overload-bases overload-bases')))) (with-do-let [!overload-bases (urx/! {:prev-norx nil :current new-overload-bases})] - (intern-with-rollback! fn|ns-name fn|overload-bases-name !overload-bases))))) + (intern-with-rollback! + !global-rollback-queue fn|ns-name fn|overload-bases-name !overload-bases))))) (defns- >!fn|types "`!fn|types` is a reaction which depends on the `!overload-bases` atom and all reactive types @@ -1132,17 +1233,20 @@ what they'll be for the lifetime of the function." [{:as opts :keys [kind _]} ::opts {:as fn|globals :keys [fn|ns-name _, fn|overload-types-name _, fn|type-name _]} ::fn|globals - !overload-bases urx/reactive?] + env ::uana/env + !overload-bases urx/reactive? + !overload-queue _] (if (= kind :extend-defn!) (-> (uid/qualify fn|ns-name fn|overload-types-name) resolve var-get) (with-do-let [!fn|types (doto (urx/!rx @!overload-bases) (uref/add-interceptor! :the-interceptor (c/fn [_ _ old-overload-types overload-bases-data] ;; `opts` and `fn|globals` are closed over - (overload-bases-data>fn|types - overload-bases-data old-overload-types opts fn|globals))) + (overload-bases-data>fn|types overload-bases-data + old-overload-types opts fn|globals env !overload-queue))) norx-deref)] - (intern-with-rollback! fn|ns-name fn|overload-types-name !fn|types)))) + (intern-with-rollback! + !global-rollback-queue fn|ns-name fn|overload-types-name !fn|types)))) (defns- >!fn|type [{:as opts :keys [kind _]} ::opts @@ -1151,31 +1255,31 @@ (if (= kind :extend-defn!) (-> (uid/qualify fn|ns-name fn|type-name) resolve var-get) (with-do-let [!fn|type (t/rx* (urx/>!rx #(:fn|type-norx @!fn|types) {:eq-fn t/=}) nil)] - (intern-with-rollback! fn|ns-name fn|type-name !fn|type)))) + (intern-with-rollback! !global-rollback-queue fn|ns-name fn|type-name !fn|type)))) ;; ===== `opts` + `fn|globals` ===== ;; (defns- >fn|opts "`opts` are per invocation of `t/defn` and/or `extend-defn!`, while `globals` persist for as long as the `t/defn` does." - [kind ::kind, lang ::lang, compilation-mode ::compilation-mode > ::opts] + [kind ::kind, compilation-mode ::compilation-mode > ::opts] (let [gen-gensym-base (ufgen/>reproducible-gensym|generator) gen-gensym (c/fn [x] (symbol (str (gen-gensym-base x) "__")))] - (kw-map compilation-mode gen-gensym kind lang))) + (kw-map compilation-mode gen-gensym kind))) (defns- >fn|globals+?overload-bases-form "`opts` are per invocation of `t/defn` and/or `extend-defn!`, while `globals` persist for as long as the `t/defn` does." - [kind ::kind, args _ > (us/kv {:fn|globals ::fn|globals :overload-bases-form t/any?})] - (let [{:as args' - :keys [:quantum.core.specs/fn|name + [kind ::kind, unanalyzed-form _ > (us/kv {:fn|globals ::fn|globals :overload-bases-form t/any?})] + (let [{:keys [:quantum.core.specs/fn|name :quantum.core.defnt/fn|extended-name :quantum.core.defnt/output-spec] overload-bases-form :quantum.core.defnt/overloads fn|meta :quantum.core.specs/meta} - (us/validate args (case kind :defn :quantum.core.defnt/defnt - :fn :quantum.core.defnt/fnt - :extend-defn! :quantum.core.defnt/extend-defn!)) + (us/validate (rest unanalyzed-form) + (case kind :defn :quantum.core.defnt/defnt + :fn :quantum.core.defnt/fnt + :extend-defn! :quantum.core.defnt/extend-defn!)) fn|var (when (= kind :extend-defn!) (or (uvar/resolve *ns* fn|extended-name) (err! "Could not resolve fn name to extend" @@ -1187,132 +1291,82 @@ (-> fn|extended-name >name symbol) fn|name) fn|globals-name (symbol (str fn|name "|__globals"))] - (if (= kind :extend-defn!) - {:fn|globals (-> (uid/qualify fn|ns-name fn|globals-name) resolve var-get) - :overload-bases-form overload-bases-form} - (let [fn|inline? (if (nil? (:inline fn|meta)) - false - (us/validate (:inline fn|meta) t/boolean?)) - fn|meta (dissoc fn|meta :inline) - fn|output-type|form (or (second output-spec) `t/any?) - ;; TODO this needs to be analyzed for dependent types referring to local vars - fn|output-type (eval fn|output-type|form) - fn|overload-bases-name (symbol (str fn|name "|__bases")) - fn|overload-types-name (symbol (str fn|name "|__types")) - fn|type-name (symbol (str fn|name "|__type")) - fn|globals - (kw-map fn|globals-name fn|inline? fn|meta fn|name fn|ns-name fn|output-type|form - fn|output-type fn|overload-bases-name fn|overload-types-name - fn|type-name)] - (intern-with-rollback! fn|ns-name fn|globals-name fn|globals) - (kw-map fn|globals overload-bases-form))))) + (if (= kind :extend-defn!) + {:fn|globals (-> (uid/qualify fn|ns-name fn|globals-name) resolve var-get) + :overload-bases-form overload-bases-form} + (let [fn|inline? (if (nil? (:inline fn|meta)) + false + (us/validate (:inline fn|meta) t/boolean?)) + fn|meta (dissoc fn|meta :inline) + fn|output-type|form (or (second output-spec) `t/any?) + ;; TODO this needs to be analyzed for dependent types referring to local vars + fn|output-type (eval fn|output-type|form) + fn|overload-bases-name (symbol (str fn|name "|__bases")) + fn|overload-types-name (symbol (str fn|name "|__types")) + fn|type-name (symbol (str fn|name "|__type")) + fn|globals + (kw-map fn|globals-name fn|inline? fn|meta fn|name fn|ns-name fn|output-type|form + fn|output-type fn|overload-bases-name fn|overload-types-name + fn|type-name)] + (intern-with-rollback! !global-rollback-queue fn|ns-name fn|globals-name fn|globals) + (kw-map fn|globals overload-bases-form))))) ;; ===== Whole `t/(de)fn` creation ===== ;; -(defns fn|code [kind ::kind, lang ::lang, compilation-mode ::compilation-mode, args _] - (uerr/catch-all - (let [opts (>fn|opts kind lang compilation-mode) - {:keys [fn|globals overload-bases-form]} (>fn|globals+?overload-bases-form kind args) - !overload-bases (>!overload-bases opts fn|globals overload-bases-form) - !fn|types (>!fn|types opts fn|globals !overload-bases) - fn|types (norx-deref !fn|types) - !fn|type (>!fn|type opts fn|globals !fn|types)] - (if (empty? (norx-deref !overload-bases)) - `(declare ~(:fn|name fn|globals)) - (let [direct-dispatch (>direct-dispatch opts fn|globals fn|types) - dynamic-dispatch (>dynamic-dispatch-fn|codelist opts fn|globals fn|types) - fn-codelist - (->> `[~@(:form direct-dispatch) - ~@dynamic-dispatch] - (remove nil?))] - (case kind - :fn (TODO "Haven't done t/fn yet") - (:defn :extend-defn!) `(do ~@fn-codelist))))) - e - (do (ulog/ppr :error e) - (drain-rollback-queue!) - (err! nil "Exception; rolled back successfully" nil nil e)) - (do (uvec/alist-empty! !rollback-queue) - (uvec/alist-empty! !overload-queue)))) - -#?(:clj -(defmacro fn - "With `t/fn`, protocols, interfaces, and multimethods become unnecessary. The preferred method of - dispatch becomes the function alone. - - `t/fn` is intended to catch many runtime errors at compile time, but cannot catch all of them. - - `t/fn`, along with `t/defn`, `t/dotyped`, and others, creates a typed context in which its - internal forms are analyzed, type-consistency is checked, and type-dispatch is resolved at - compile time inasmuch as possible, and at runtime only when necessary. - - Recommendations for the type system: - - Primitives are always preferred to boxed values. All values that can be primitives (i.e. ones - that are `t/<=` w.r.t. a `(t/isa? )`) are treated as primitives unless - specifically marked otherwise with the `t/ref` metadata-adding directive. - - One could imagine a dynamic set of types corresponding to a given predicate, e.g. `decimal?`. - Say someone comes up with a new `decimal?`-like class and wants to redefine `decimal?` to - accommodate. One could define `decimal?` as a reactive/extensible type to do this. However, it - is preferable to instead define a marker protocol called `PDecimal` or some such and put that - on the defined `deftype` itself, and incorporate `PDecimal` into `decimal?` from the start. In - this way fewer reactive changes have to happen and less compilation occurs. - - Compile-Time (Direct) Dispatch characteristics - - Any input, if its type is `t/<=` a non-nil primitive (boxed or not) class, it will be marked - as a primitive in the corresponding `reify`. - - If an input is a nilable primitive, its nilability will not result in only one `reify` - overload with a boxed input, but rather will result in two `reify` overloads — one - corresponding to a nil input and another for the primitive input. - - Runtime (Dynamic) Dispatch characteristics - - Compile-Time Dispatch is preferred to Runtime Dispatch in all but the following situations, in - which Compile-Time Dispatch is not possible: - - When a typed function (or a typed object with function-like characteristics such as a - `t/deftype`) is referenced outside of a typed context. - - Metadata directives special to all typed contexts include: - - `:val` : If `true` and attached as metadata to a form, it will cause that form's type to be - `t/and`ed with `t/val?`. - - `:dyn` : If `true` and attached as metadata to a form corresponding with a typed fn in functor - position, it will cause that typed fn to be called dynamically if no direct dispatch - is found at compile time. - - For instance, `(name (read ...))` fails at compile-time; we want it to at least try - at runtime. So we annotate like `(^:dyn name (read ...))`, which tells the compiler - to figure out at runtime whether a call to `name` will succeed. - - Metadata directives special to `t/fn`/`t/defn` include: - - `:inline` : If `true` and attached as metadata to the arglist of an overload, will cause that - overload to be inlined if possible: - - `(t/defn abc (^:inline [] ...))` - If `true` and attached as metadata to the whole `t/defn` or `t/fn`, will cause - every one of its overloads to be inlined if possible. Overloads added to a `t/defn` - with `:inline` `true` will inherit this inline directive unless `:inline` is false - for the overload or `:unline` is true: - - `(t/defn ^:inline abc ([] ...) ([...] ...))` - - `(t/defn ^:inline abc (^{:inline false} [] ...) ([...] ...))` - - `(t/defn ^:inline abc ([] ...) (^:unline [...] ...))` - Note: - - Inlining is possible only in typed contexts. - - If the metadata for an overload changes via `extend-defn!` from designating it as - inline to designating it as non-inline, or vice versa, unexpected behavior may - occur. - - `t/fn` only works fully in contexts in which the metalanguage (compiler language) is the same as - the object language. Otherwise, while the compiler could still analyze types symbolically to an - extent, it could not actually run evaluated type-predicates on inputs to determine type-satisfaction. - - Consumers wishing to use the full-featured `t/fn` in ClojureScript must either use - bootstrapped ClojureScript or transpile ClojureScript via the JavaScript implementation of - the Google Closure Compiler. Consumers for whom the version of `t/fn` with purely symbolic - analysis is acceptable may use the standard approach of transpiling ClojureScript via the Java - implementation of the Google Closure Compiler." - [& args] (fn|code :fn (ufeval/env-lang) *compilation-mode* args))) - -#?(:clj -(defmacro defn - "A `defn` with an empty body is like using `declare`." - [& args] (fn|code :defn (ufeval/env-lang) *compilation-mode* args))) - -#?(:clj -(defmacro extend-defn! - "Currently undefining overloads is not possible." - [& args] (fn|code :extend-defn! (ufeval/env-lang) *compilation-mode* args))) +(defns analyze-fn [env ::uana/env, form _] + (TODO)) + +(reset! uana/!!analyze-fnt analyze-fn) + +;; TODO lazily and incrementally analyze this; maybe we want to do code transformations which don't +;; require analysis, as shown in tests +(defns- analyze-defn* [kind #{:defn :extend-defn!}, env ::uana/env, unanalyzed-form _ > uast/node?] + (let [opts (>fn|opts kind *compilation-mode*) + !overload-queue !global-overload-queue + {:keys [fn|globals overload-bases-form] + {:keys [fn|ns-name fn|name fn|meta fn|globals-name]} :fn|globals} + (>fn|globals+?overload-bases-form kind unanalyzed-form) + !overload-bases (>!overload-bases opts fn|globals overload-bases-form) + !fn|types (>!fn|types opts fn|globals env !overload-bases !overload-queue) + fn|types (norx-deref !fn|types) + !fn|type (>!fn|type opts fn|globals !fn|types) + {:keys [form overloads]} + (if (empty? (norx-deref !overload-bases)) + {:form `(declare ~(:fn|name fn|globals)) + :overloads []} + (let [direct-dispatch + (>direct-dispatch opts fn|globals fn|types !overload-queue) + dynamic-dispatch (>dynamic-dispatch-fn|codelist opts fn|globals fn|types) + fn-codelist + (->> `[~@(:form direct-dispatch) + ~@dynamic-dispatch] + (remove nil?))] + {:form `(do ~@fn-codelist) + :overloads (->> direct-dispatch + :direct-dispatch-data-seq + (uc/map+ (fn-> :reify :overload)) + (uc/map + (c/fn [overload] + {:type (:output-type overload) + :arg-types (:arg-types overload) + :body (:body-node overload)})))})) + ast-basis + {:env env + :unanalyzed-form unanalyzed-form + :name fn|name + :meta fn|meta + :overloads overloads + :form form + ;; TODO is `norx-deref` the right approach? + :type (norx-deref !fn|type)}] + (case kind + :defn (uast/defnt-node ast-basis) + :extend-defn! (uast/extend-defnt-node ast-basis)))) + +(defns analyze-defn [env ::uana/env, form _ > uast/node?] (analyze-defn* :defn env form)) + +(reset! uana/!!analyze-defnt analyze-defn) + +(defns analyze-extend-defn [env ::uana/env, form _] (analyze-defn* :extend-defn! env form)) + +(reset! uana/!!analyze-extend-defnt analyze-extend-defn) From c5665dd1862134e3500d4c573f23fd5ff63fc132 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Dec 2018 00:54:15 -0700 Subject: [PATCH 783/810] Fix bug and log a different bug --- resources-dev/defnt.cljc | 2 ++ src-untyped/quantum/untyped/core/type/defnt.cljc | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 7d880059..346491ee 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -166,6 +166,8 @@ Legend: - (t/seq vector? [ [0 (t/value :a)] [1 (t/value :b)] [2 (t/value :c)]]) - (t/kv vector? { 0 [0 (t/value :a)] 1 [1 (t/value :b)] 2 [2 (t/value :c)]}) - and so on ad infinitum. Therefore we reserve `t/kv` for `(t/and t/lookup? (t/not indexed?))`. + - TODO why are there two overloads in this case?? + (uana/pr! (uana/analyze `(defn ~'abcde []))) - Probably comparing a protocol with something else should be a matter for reactivity since protocols can be extended - TODO CLJS needs to implement it better diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 68b6c6ad..63f1c562 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -115,7 +115,7 @@ (defns- analyze-with-rollback! [unanalyzed-form _] (with-rollback! !global-overload-queue !global-rollback-queue - #(-> % unanalyzed-form uana/analyze :form))) + (c/fn [] (-> unanalyzed-form uana/analyze :form)))) ;; ===== Macros ===== ;; From f33deb451401d17293dc7fce97a30519f492ef55 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Dec 2018 14:15:12 -0700 Subject: [PATCH 784/810] `>array` --- src-untyped/quantum/untyped/core/collections.cljc | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/collections.cljc b/src-untyped/quantum/untyped/core/collections.cljc index aa968697..db8a2f12 100644 --- a/src-untyped/quantum/untyped/core/collections.cljc +++ b/src-untyped/quantum/untyped/core/collections.cljc @@ -14,7 +14,7 @@ :refer [transient?]] [quantum.untyped.core.data :refer [val?]] - [quantum.untyped.core.data.array + [quantum.untyped.core.data.array :as uarr :refer [array?]] [quantum.untyped.core.data.map :as umap] [quantum.untyped.core.data.vector :as uvec] @@ -321,6 +321,18 @@ (defn >set [xs] (if (set? xs) xs (ur/join #{} xs))) +(def >array|rf + (aritoid uvec/alist + (fn [!xs] #?(:clj (.toArray ^java.util.ArrayList !xs) :cljs !xs)) + uvec/alist-conj!)) + +(defn >array [xs] + (ifs (nil? xs) (uarr/*<>) + (instance? java.util.Collection xs) (.toArray ^java.util.Collection xs) + (ur/transformer? xs) (educe >array|rf xs) + (array? xs) xs + (uerr/not-supported! `>array xs))) + (def ensure-set (condf1 nil? (fn' #{}) From f7caea80632b44347730291a9a15f46dbccdc061 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Dec 2018 14:15:33 -0700 Subject: [PATCH 785/810] Add a few more notes --- resources-dev/defnt.cljc | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 346491ee..785cc09d 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -1,3 +1,8 @@ +;; TODO look at this for type-checked Spec implementation: https://github.com/arohner/spectrum/blob/master/src/spectrum/conform.clj +;; TODO look at this thread for useful discussion on potential type systems in Clojure: https://groups.google.com/forum/#!topic/clojure/Dxk-rCVL5Ss +;; - Reach out to mikera and let him know about the type system when it's done since he was working on something vaguely similar +;; TODO look at HM impl : https://github.com/ericnormand/hindley-milner + Note that for anything built-in js/, the `t/isa?` predicates might need some special help ;; TO MOVE @@ -59,7 +64,8 @@ Legend: - TODO implement the following: [-] t/fn - [ ] add `t/fn` as a special form so we don't need to re-analyze its constituents + [-] Get `t/defn` working with `let*` + TypedFn way of doing things + [ ] Sketch out `defnt/analyze-fn` using tests as a guide [ ] t/ftype should automatically split types, while perhaps t/ftype* should just assume they're split (for use by e.g. `t/fn` and `t/defn`) [ ] test t/fn to make sure meta 'sticks' : `(t/fn {...} [] ...)` @@ -268,6 +274,8 @@ Legend: [-] t/extend-defn! [ ] Ability to add output type restriction after the fact? [ ] lazy compilation especially around `t/input` + - Let's say you write a `t/defn` with a signature of [t/indexed? t/indexed? t/indexed?]. This + would generate thousands of possibilities if eagerly loaded, but instead it is lazily loaded. [ ] equivalence of typed predicates (i.e. that which is t/<= `(t/ftype [x t/any? :> p/boolean?])`) to types: - [xs (t/fn [x (t/isa? clojure.lang.Range)] ...)] @@ -1804,6 +1812,7 @@ Legend: - :todo #{} - :attribution - :doc + - :performance - :incorporated (t/or (t/set-of (t/or )) (t/map-of (t/or ) date)) From 2449cd327e8e33f84a37511f7d15169068d856ae Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Dec 2018 15:43:41 -0700 Subject: [PATCH 786/810] Clean up untyped.core.data.array --- .../quantum/untyped/core/data/array.cljc | 37 ++++++++++--------- .../quantum/test/untyped/core/type/defnt.cljc | 37 +++++++++---------- 2 files changed, 38 insertions(+), 36 deletions(-) diff --git a/src-untyped/quantum/untyped/core/data/array.cljc b/src-untyped/quantum/untyped/core/data/array.cljc index 00487459..64c770b0 100644 --- a/src-untyped/quantum/untyped/core/data/array.cljc +++ b/src-untyped/quantum/untyped/core/data/array.cljc @@ -15,14 +15,15 @@ :cljs (core/array? x))) #?(:clj -(defmacro *<>|sized|macro [n] +(defmacro *<>|sized [n] (case-env :clj `(Array/newUninitialized1dObjectArray ~n) :cljs `(let [arr# (cljs.core/array)] (set! (.-length arr#) ~n) arr#)))) -#?(:clj -(defmacro *<>|macro +(defn *<>|sized|fn [#?(:clj ^long n :cljs ^number n)] (*<>|sized n)) + +(defn *<>|code ([] #?(:clj `(Array/newUninitialized1dObjectArray 0) :cljs `(core/array))) @@ -65,21 +66,23 @@ ~@(for [[i x] (->> (concat [x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10] xs) (map-indexed vector))] `(Array/set ~arr-sym (Primitive/box ~x) ~i)))) - :cljs `(core/array ~x0 ~x1 ~x2 ~x3 ~x4 ~x5 ~x6 ~x7 ~x8 ~x9 ~x10 ~@xs))))) + :cljs `(core/array ~x0 ~x1 ~x2 ~x3 ~x4 ~x5 ~x6 ~x7 ~x8 ~x9 ~x10 ~@xs)))) + +#?(:clj (defmacro *<> [& xs] (apply *<>|code xs))) -(defn ^"[Ljava.lang.Object;" *<> - ([] (*<>|macro)) - ([x0] (*<>|macro x0)) - ([x0 x1] (*<>|macro x0 x1)) - ([x0 x1 x2] (*<>|macro x0 x1 x2)) - ([x0 x1 x2 x3] (*<>|macro x0 x1 x2 x3)) - ([x0 x1 x2 x3 x4] (*<>|macro x0 x1 x2 x3 x4)) - ([x0 x1 x2 x3 x4 x5] (*<>|macro x0 x1 x2 x3 x4 x5)) - ([x0 x1 x2 x3 x4 x5 x6] (*<>|macro x0 x1 x2 x3 x4 x5 x6)) - ([x0 x1 x2 x3 x4 x5 x6 x7] (*<>|macro x0 x1 x2 x3 x4 x5 x6 x7)) - ([x0 x1 x2 x3 x4 x5 x6 x7 x8] (*<>|macro x0 x1 x2 x3 x4 x5 x6 x7 x8)) - ([x0 x1 x2 x3 x4 x5 x6 x7 x8 x9] (*<>|macro x0 x1 x2 x3 x4 x5 x6 x7 x8 x9)) - ([x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10] (*<>|macro x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)) +(defn ^"[Ljava.lang.Object;" *<>|fn + ([] (*<>)) + ([x0] (*<> x0)) + ([x0 x1] (*<> x0 x1)) + ([x0 x1 x2] (*<> x0 x1 x2)) + ([x0 x1 x2 x3] (*<> x0 x1 x2 x3)) + ([x0 x1 x2 x3 x4] (*<> x0 x1 x2 x3 x4)) + ([x0 x1 x2 x3 x4 x5] (*<> x0 x1 x2 x3 x4 x5)) + ([x0 x1 x2 x3 x4 x5 x6] (*<> x0 x1 x2 x3 x4 x5 x6)) + ([x0 x1 x2 x3 x4 x5 x6 x7] (*<> x0 x1 x2 x3 x4 x5 x6 x7)) + ([x0 x1 x2 x3 x4 x5 x6 x7 x8] (*<> x0 x1 x2 x3 x4 x5 x6 x7 x8)) + ([x0 x1 x2 x3 x4 x5 x6 x7 x8 x9] (*<> x0 x1 x2 x3 x4 x5 x6 x7 x8 x9)) + ([x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10] (*<> x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10)) ([x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 & xs] #?(:clj (let [arr (Array/newUninitialized1dObjectArray (+ 11 (count xs)))] (Array/set arr x0 0) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 3653b432..2daf9136 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -7,9 +7,9 @@ :refer [dotyped]] [quantum.test.untyped.core.type :as tt] [quantum.untyped.core.type.defnt :as self - :refer [unsupported!]] + :refer [aget* aset* unsupported!]] [quantum.untyped.core.data.array - :refer [*<> *<>|macro]] + :refer [*<>]] [quantum.untyped.core.form :refer [$ code=]] [quantum.untyped.core.form.evaluate @@ -73,9 +73,6 @@ (def &fs (O<> 'fs__)) (def &this '&this) -(defn aget* [x i] (list '. 'clojure.lang.RT 'aget x i)) -(defn aset* [x i v] (list '. 'clojure.lang.RT 'aset x i v)) - #?(:clj (deftest test|pid (let [actual @@ -87,20 +84,20 @@ expected ($ (do [[0 0 false [] (t/or t/nil? t/string?)]] (defmeta-from ~'pid - (let* [~pid|__fs (*<>|sized|macro 1) + (let* [~'pid|__fs (*<>|sized 1) ~'pid (new TypedFn {:quantum.core.type/type pid|__type} - pid|__!types ; defined/created within `t/defn` - pid|__fs + pid|__types ; defined/created within `t/defn` + ~'pid|__fs (fn* ([~&ts ~&fs] (. ~(aget* &fs 0) ~'invoke))))] - ~(aset* pid|__fs 0 + ~(aset* 'pid|__fs 0 `(reify* [~(csym `__O)] (~(O 'invoke) [~&this] ~(ST (list '. (tag "java.lang.management.RuntimeMXBean" '(. java.lang.management.ManagementFactory getRuntimeMXBean)) 'getName))))) - f))))] + ~'pid))))] (testing "code equivalence" (is-code= actual expected)) (testing "functionality" (eval actual) @@ -2526,7 +2523,7 @@ :clj ($ (do [[0 0 false [] (t/ftype tt/boolean? [tt/byte? :> (t/ftype [tt/char?])])]] (defmeta-from ~'f0|test - (let* [~'f0|test|__fs (*<>|sized|macro 2) + (let* [~'f0|test|__fs (*<>|sized 2) ~'f0|test (new TypedFn {:quantum.core.type/type ~'f0|test|__type} @@ -2542,13 +2539,13 @@ `(reify* [~(csym `B__O)] (~'invoke [~&this ~(B 'a)] ;; From `(self/fn [b ...])` - (let* [~'f__0|__fs (*<>|sized|macro 2) + (let* [~'f__0|__fs (*<>|sized 2) ~'f__0 (new TypedFn nil ;; TODO perhaps extern this (and parts thereof) whenever ;; possible in `let*` statement on the very outside of the fn ;; (so around the outer `reify*`) ? - (*<>|macro (*<>|macro t/byte?) (*<>|macro t/char?)) + (*<> (*<> t/byte?) (*<> t/char?)) ~'f__0|__fs (fn* ([~&ts ~&fs ~'x00__] (ifs (~(aget* (aget* ~&ts 0) 0) ~'x00__) @@ -2560,10 +2557,10 @@ `(reify* [~(csym `Y__O)] (~'invoke [~'_0__ ~(Y 'b)] ;; From `(self/fn [c ...])` - (let* [~'f1|test|__fs (*<>|sized|macro 2) + (let* [~'f1|test|__fs (*<>|sized 2) ~'f1|test (new TypedFn nil - (*<>|macro (*<>|macro t/boolean?) (*<>|macro t/short?)) + (*<> (*<> t/boolean?) (*<> t/short?)) ~'f1|test|__fs (fn* ([~&ts ~&fs ~'x00] (ifs (~(aget* (aget* &ts 0) 0) ~'x00__) @@ -2629,7 +2626,7 @@ (case (env-lang) :clj ($ (do (defmeta-from ~'g|test - (let* [~'g|test|__fs (*<>|sized|macro 1) + (let* [~'g|test|__fs (*<>|sized 1) ~'g|test (new TypedFn {:quantum.core.type/type ~'g|__type} @@ -2644,7 +2641,7 @@ (~'invoke [~&this ~(O 'f0)] (~'f0 5)))) ~'g|test)) (defmeta-from ~'h|test - (let* [~'h|test|__fs (*<>|sized|macro 1) + (let* [~'h|test|__fs (*<>|sized 1) ~'h|test (new TypedFn {:quantum.core.type/type ~'h|__type} @@ -2659,7 +2656,7 @@ (~'invoke [~&this ~(O 'f0)] f0))) ~'h|test)) (defmeta-from ~'i|test - (let* [~'i|test|__fs (*<>|sized|macro 1) + (let* [~'i|test|__fs (*<>|sized 1) ~'i|test (new TypedFn {:quantum.core.type/type ~'i|__type} @@ -2678,7 +2675,7 @@ ~'h|test|__ (deref ~(list 'var `h|test)) ~'i|test|__ (deref ~(list 'var `i|test))] (defmeta-from ~'j|test - (let* [~'j|test|__fs (*<>|sized|macro 1) + (let* [~'j|test|__fs (*<>|sized 1) ~'j|test (new TypedFn {:quantum.core.type/type ~'j|__type} @@ -3315,3 +3312,5 @@ So GClass implements _-627458773_-1854681952 But now _-627458773_-123456 needs to extend _-627458773_-1854681952, which requires a rewrite of all things that use it... so I don't think inheritance is our answer. " + +;; TODO quantum.test.untyped.core.defnt should be incorporated here — includes some destructuring From f4d448be442748100e6d4cf71b11fee7babd9b35 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Dec 2018 15:43:49 -0700 Subject: [PATCH 787/810] Remove `quantum.test.core.macros.defnt` --- test/quantum/test/core/macros/defnt.cljc | 620 ----------------------- 1 file changed, 620 deletions(-) delete mode 100644 test/quantum/test/core/macros/defnt.cljc diff --git a/test/quantum/test/core/macros/defnt.cljc b/test/quantum/test/core/macros/defnt.cljc deleted file mode 100644 index 0c7a8747..00000000 --- a/test/quantum/test/core/macros/defnt.cljc +++ /dev/null @@ -1,620 +0,0 @@ -(ns quantum.test.core.macros.defnt - (:require - [quantum.core.macros.defnt :as ns] - [quantum.core.log :as log - :refer [prl]] - [quantum.core.error :as err] - [quantum.core.macros.protocol :as proto] - [quantum.core.macros.reify :as reify] - [quantum.core.macros.transform :as trans] - [quantum.core.analyze.clojure.core :as ana] - [quantum.core.macros - :refer [macroexpand-all]] - [quantum.core.test - :refer [deftest is testing]] - [quantum.untyped.core.form.evaluate :as ufeval - :refer [case-env]]) - #?(:cljs - (:require-macros - [quantum.test.core.macros.defnt - :refer [with-merge-test]])) - #?(:clj (:import java.util.concurrent.atomic.AtomicInteger))) - -; TODO look at this for type-checked Spec implementation: https://github.com/arohner/spectrum/blob/master/src/spectrum/conform.clj -; TODO look at this thread for useful discussion on potential type systems in Clojure: https://groups.google.com/forum/#!topic/clojure/Dxk-rCVL5Ss -; TODO look at HM impl : https://github.com/ericnormand/hindley-milner - -(defn quantum.test.core.macros.defnt/simple:a a0)))))))) - (testing "CLJS" - (is (meta= (expand-all-arities-for-defnt+ simple {:lang :cljs}) - '(do (def simple:__overloads (js-obj)) - (aset simple:__overloads "fn0" - (fn [a] (+ (.deref a) 5))) - (aset simple:__overloads "fn1" - (fn [a] (. simple:__overloads fn0 (->quantum.test.core.macros.defnt/simple:a a)))) - ))))) - (testing "Macro-expansion" - (testing "Definition" - (is (= expanded - '(do (defn simple - ([a] - (validate a even?) - (+ a 5))))))) - (testing "Valid types" - (testing "Type check (compile-time check)" - (is (= '(. ^Fn__number__even simple:__reify invoke 2) - (macroexpand-all '(typed (simple 2)))))) - (testing "No type check (runtime check)" - (is (= '(simple 2) - (macroexpand-all '(simple 2)))))) - (testing "Invalid types" - (testing "Type check (compile-time check)" - (is (error? (macroexpand-all '(typed (simple "asd"))))) - (is (error? (macroexpand-all '(typed (simple 3)))))) - (testing "No type check (runtime check)" - (is (= '(simple "asd") - (macroexpand-all '(simple "asd")))) - (is (= '(simple 3) - (macroexpand-all '(simple 3))))))) - (testing "Evaluation" - (testing "Valid types" - (testing "Type check (compile-time check)" - (is (= 6 (eval '(typed (simple 2)))))) - (testing "No type check (runtime check)" - (is (= 6 (eval '(simple 2)))))) - (testing "Invalid types" - (testing "Type check (compile-time check)" - (is (compile-error? (eval '(typed (simple "asd"))))) - (is (compile-error? (eval '(typed (simple 3)))))) - (testing "No type check (runtime check)" - (is (runtime-error? (eval '(simple "asd")))) - (is (runtime-error? (eval '(simple 3))))))) - - - - (un-defnt+ simple)) - (let [simple:opts '(defnt+ simple:opts - ([a {:spec even? :opts #{:compile-time?}}]))])) - -(def defnt+:example - '(defnt+ example - ([a (s/and even? #(< 5 % 100)) - b t/any - c ::number-between-6-and-20 - {:as d :keys [e g]} (s/keys* :req-un [[:e t/boolean? true] - [:f t/number?] - [:g (s/or* t/number? t/sequential?) - 0]])] - {:pre (< a @c) - :post (s/and (s/coll-of odd? :kind t/array?) - #(= (first %) c))} - ...) - ([a string? - b (s/coll-of bigdec? :kind vector?) - c t/any - d t/any] - ...))) - -(def data - {:ns- *ns* - :lang :clj - :class-sym 'AtomicInteger - :expanded 'java.util.concurrent.atomic.AtomicInteger}) - -#?(:clj -(deftest test:get-qualified-class-name ; TODO :clj only for now - (let [{:keys [ns- lang class-sym]} data] - (is (= (ns/get-qualified-class-name - lang ns- class-sym) - (:expanded data)))))) - -(defn test:classes-for-type-predicate - ([pred lang]) - ([pred lang type-arglist])) - -(deftest test:defnt-keyword->positional-profundal ; TODO derepeat - (is (thrown? Throwable (ns/defnt-keyword->positional-profundal :else))) - (is (thrown? Throwable (ns/defnt-keyword->positional-profundal :nope<>))) - (is (= nil (ns/defnt-keyword->positional-profundal "<0>"))) - (testing "Positional" - (is (= [0 nil] (ns/defnt-keyword->positional-profundal :<0>))) - (is (= [0 nil] (ns/defnt-keyword->positional-profundal '<0>))) - (is (thrown? Throwable (ns/defnt-keyword->positional-profundal :<01>))) - (is (= nil (ns/defnt-keyword->positional-profundal '<01>))) ; Assumes it's an actual type - (is (= [1 nil] (ns/defnt-keyword->positional-profundal '<1>))) - (is (= [89 nil] (ns/defnt-keyword->positional-profundal '<89>)))) - (testing "Elemental" - (is (= [0 1] (ns/defnt-keyword->positional-profundal :<0>:1))) - (is (= [0 0] (ns/defnt-keyword->positional-profundal :<0>:0))) - (is (= [93 27] (ns/defnt-keyword->positional-profundal :<93>:27))) - (is (thrown? Throwable (ns/defnt-keyword->positional-profundal :<93>:07))))) - -(deftest test:positional-profundal->hint - (is (= 'String (ns/positional-profundal->hint - :clj 0 nil '[a b c d] '[String :<0> "[D" :<2>:1]))) - (is (= 'double (ns/positional-profundal->hint - :clj 2 1 '[a b c d] '[String :<0> "[D" :<2>:1]))) - (is (= :<2>:1 (ns/positional-profundal->hint - :clj 3 nil '[a b c d] '[String :<0> "[D" :<2>:1])))) - -(deftest test:hints->with-replace-special-kws - (testing "Position+depth spec" - (is (= '[String String "[D" double] - (ns/hints->with-replace-special-kws - {:lang :clj - :arglist '[a b c d] - :hints '[String :<0> "[D" :<2>:1]})))) - (testing "CLJS throws on depth spec" - (is (thrown? Throwable - (ns/hints->with-replace-special-kws - {:lang :cljs - :arglist '[a b c d] - :hints '[String :<0> "[D" :<2>:1]})))) - (testing "Refs" - (testing "No cycles" - (is (= '["[D" "[D" "[D" double] - (ns/hints->with-replace-special-kws - {:lang :clj - :arglist '[a b c d] - :hints '["[D" :<0> :<1> :<2>:1]})))) - (testing "Self-reference" - (is (thrown? Throwable - (ns/hints->with-replace-special-kws - {:lang :clj - :arglist '[a b c d] - :hints '[:<0> :<0> "[D" :<2>:1]})))) - (testing "Currently doesn't handle forward references" - (is (thrown? Throwable - (ns/hints->with-replace-special-kws - {:lang :clj - :arglist '[a b c d] - :hints '[:<1> String "[D" :<2>:1]})))))) - -#?(:clj -(ns/defnt dummy-defnt - ([^objects? x ^int k v] 0) - ([^clojure.lang.PersistentVector x k v] 1) - ([^default x k v] 2) - ([ x k ] 3) - ([^clojure.lang.PersistentVector x k ] 4) - ([ x ] 5))) - -(defn interface-call? [code] (-> code first (= '.))) -(defn protocol-call? [code] (-> code first (= 'quantum.test.core.macros.defnt/dummy-defnt-protocol))) - -#?(:clj -(deftest test:defnt:0 - (testing "Specific match -> interface" - (let [code (macroexpand-all '(dummy-defnt (object-array 2) 4 (Object.)))] - (is (interface-call? code)) - (is (= 0 (eval code))))) - (testing "Matches only a default method (not in interface) -> protocol" - (let [code (macroexpand-all '(dummy-defnt (Object.) 4 (Object.)))] - (is (protocol-call? code)) - (is (= 2 (eval code))))) - (testing "Non-default `Object` method -> interface" - (let [code (macroexpand-all '(dummy-defnt (Object.)))] - (is (= '. (first code))) - (is (= nil #_"java.lang.Object" (-> code (nth 3) ana/type-hint))) - (is (= 5 (eval code))))) - (testing "Downcast on related" - (let [code (macroexpand-all '(dummy-defnt ^clojure.lang.IPersistentVector (vector) (long 4)))] - (is (= '. (first code))) - (is (= "clojure.lang.PersistentVector" (-> code (nth 3) ana/type-hint))) - (is (= 4 (eval code))))) - (testing "No downcast on Object" - (let [code (macroexpand-all '(dummy-defnt (vector) (long 4)))] - (is (= '. (first code))) - (is (= "java.lang.Object" (-> code (nth 3) ana/type-hint))) - (is (= 3 (eval code))))))) - -#?(:clj -(deftest test:expand-classes-for-type-hint ; TODO :clj only for now - (let [{:keys [ns- lang class-sym]} data] - (is (= (ns/expand-classes-for-type-hint - class-sym lang ns- [class-sym]) - #{(:expanded data)}))))) - -(deftest - ^{:todo ["Add failure tests"]} - test:protocol-verify-unique-first-hint - (is (= nil - (ns/protocol-verify-unique-first-hint - '([Test_COLON_defnt_COLON_nsEval - [#{java.util.concurrent.atomic.AtomicInteger}] - Object] - [Test_COLON_defnt_COLON_nsEval - [#{java.lang.Short java.lang.Integer java.math.BigInteger long short - int java.lang.Long clojure.lang.BigInt}] - Object]))))) - -; Non |deftest| tests - -#_(log/enable! :macro-expand) -#_(log/enable! :macro-expand-protocol) - -#?(:clj (def test-boxed-long (Long. 1))) -#?(:clj (def test-boxed-int (Integer. 1))) -(def test-string "abcde") - -#_(ns/defnt test:defnt-def** - ([^integer? a b] (+ a b))) - -#_(ns/defnt test:defnt-def - #?(:clj ([^AtomicInteger a] (.get a))) ; namespace-resolved class - ([^integer? a] (inc a)) ; predicate class - #_([^integer? a ^integer? b] [a b]) - ([#{String StringBuilder} a #{boolean char} b] [a b]) - ([#{byte short} a #{int long} b #{float double} c] [a b c])) - -#_(ns/defnt test:defnt-def-generic - ([^string? x] (first x)) ; predicate class - ([x] x)) ; Generic - -#?(:clj -(defmacro with-merge-test [env sym expected] - `(quantum.core.collections.base/merge-call ~env - (fn [env#] - (testing '~sym - (let [ret# (~sym env#)] - (log/ppr-hints :user ~(str "<< TESTING " (name sym) " >>") ret#) - (is (= ret# ~expected)) - ret#)))))) - -#_(deftest integration:defnt - (let [sym 'test-defnt - env {:sym sym ; TODO test the defnt before it gets to this point - :strict? false - :relaxed? false - :sym-with-meta sym - :lang :clj - :ns- *ns* - :body '(([a] (.get a)) - ([a] (inc a)) - ([#{String StringBuilder} a #{boolean char} b] [a b]) - ([#{short byte} a #{long int} b #{double float} c] [a b c])) - :externs (atom [])} - reify-body (fn [env] {:reify-body (reify/gen-reify-body env)}) - reify-def (fn [{:keys [lang] :as env}] - (when (= lang :clj) - (reify/gen-reify-def env))) - defprotocol-from-interface - (fn [{:keys [strict?] :as env}] - (when-not strict? - (proto/gen-defprotocol-from-interface env))) - reify-body-result - '(reify user.TestDefntInterface - (^Object TestDefnt [this ^java.lang.Object a ] (inc ^java.lang.Object a )) - (^Object TestDefnt [this ^java.lang.StringBuilder a ^boolean b ] [^java.lang.StringBuilder a b ]) - (^Object TestDefnt [this ^java.lang.StringBuilder a ^char b ] [^java.lang.StringBuilder a b ]) - (^Object TestDefnt [this ^java.lang.String a ^boolean b ] [^java.lang.String a b ]) - (^Object TestDefnt [this ^java.lang.String a ^char b ] [^java.lang.String a b ]) - (^Object TestDefnt [this ^short a ^long b ^double c] [ a b c]) - (^Object TestDefnt [this ^short a ^long b ^float c] [ a b c]) - (^Object TestDefnt [this ^short a ^int b ^double c] [ a b c]) - (^Object TestDefnt [this ^short a ^int b ^float c] [ a b c]) - (^Object TestDefnt [this ^byte a ^long b ^double c] [ a b c]) - (^Object TestDefnt [this ^byte a ^long b ^float c] [ a b c]) - (^Object TestDefnt [this ^byte a ^int b ^double c] [ a b c]) - (^Object TestDefnt [this ^byte a ^int b ^float c] [ a b c])) - env (-> env - (with-merge-test ns/defnt-arities - '{:arities - [[[a] (.get a)] - [[a] (inc a)] - [[a b] [a b]] - [[a b c] [a b c]]]}) - (with-merge-test ns/defnt-arglists - '{:arglists - [[a] - [a] - [#{StringBuilder String} a - #{boolean char} b] - [#{short byte} a - #{long int} b - #{double float} c]]}) - (with-merge-test ns/defnt-gen-protocol-names - '{:genned-protocol-name TestDefntProtocol, - :genned-protocol-method-name test-defnt-protocol, - :genned-protocol-method-name-qualified user/test-defnt-protocol}) - (with-merge-test ns/defnt-arglists-types - '{:arglists-types - ([[Object] Object] - [[Object] Object] - [[#{StringBuilder String} - #{boolean char}] - Object] - [[#{short byte} - #{long int} - #{double float}] - Object])}) - (with-merge-test ns/defnt-gen-interface-unexpanded - '{:genned-method-name TestDefnt, - :genned-interface-name TestDefntInterface, - :ns-qualified-interface-name user.TestDefntInterface, - :gen-interface-code-header - (gen-interface :name user.TestDefntInterface :methods), - :gen-interface-code-body-unexpanded - {[TestDefnt [#{java.lang.Object}] Object] [[a] (inc a)], - [TestDefnt - [#{java.lang.StringBuilder java.lang.String} #{boolean char}] - Object] - [[a b] [a b]], - [TestDefnt [#{short byte} #{long int} #{double float}] Object] - [[a b c] [a b c]]}}) - (with-merge-test ns/defnt-types-for-arg-positions - {:types-for-arg-positions - '{0 {java.lang.Object #{1}, - java.lang.String #{2}, - java.lang.StringBuilder #{2}, - short #{3}, - byte #{3}}, - 1 {boolean #{2}, char #{2}, long #{3}, int #{3}}, - 2 {double #{3}, float #{3}}}, - :first-types - '{java.lang.Object #{1}, - java.lang.String #{2}, - java.lang.StringBuilder #{2}, - short #{3}, - byte #{3}}}) - (with-merge-test ns/defnt-available-default-types - '{:available-default-types - {0 #{Object boolean char long double int float}, - 1 #{Object double short float byte}, - 2 #{Object boolean char long short int byte}}}) - (with-merge-test ns/defnt-gen-interface-expanded - '{:gen-interface-code-body-expanded - [[[TestDefnt [java.lang.Object ] Object] ([^java.lang.Object a ] (inc a))] - [[TestDefnt [java.lang.StringBuilder boolean ] Object] ([^java.lang.StringBuilder a ^boolean b ] [a b ])] - [[TestDefnt [java.lang.StringBuilder char ] Object] ([^java.lang.StringBuilder a ^char b ] [a b ])] - [[TestDefnt [java.lang.String boolean ] Object] ([^java.lang.String a ^boolean b ] [a b ])] - [[TestDefnt [java.lang.String char ] Object] ([^java.lang.String a ^char b ] [a b ])] - [[TestDefnt [short long double] Object] ([^short a ^long b ^double c] [a b c])] - [[TestDefnt [short long float ] Object] ([^short a ^long b ^float c] [a b c])] - [[TestDefnt [short int double] Object] ([^short a ^int b ^double c] [a b c])] - [[TestDefnt [short int float ] Object] ([^short a ^int b ^float c] [a b c])] - [[TestDefnt [byte long double] Object] ([^byte a ^long b ^double c] [a b c])] - [[TestDefnt [byte long float ] Object] ([^byte a ^long b ^float c] [a b c])] - [[TestDefnt [byte int double] Object] ([^byte a ^int b ^double c] [a b c])] - [[TestDefnt [byte int float ] Object] ([^byte a ^int b ^float c] [a b c])]]}) - (with-merge-test ns/defnt-gen-interface-def - '{:gen-interface-def - (gen-interface - :name user.TestDefntInterface - :methods - [[TestDefnt [java.lang.Object ] Object] - [TestDefnt [java.lang.StringBuilder boolean ] Object] - [TestDefnt [java.lang.StringBuilder char ] Object] - [TestDefnt [java.lang.String boolean ] Object] - [TestDefnt [java.lang.String char ] Object] - [TestDefnt [short long double] Object] - [TestDefnt [short long float ] Object] - [TestDefnt [short int double] Object] - [TestDefnt [short int float ] Object] - [TestDefnt [byte long double] Object] - [TestDefnt [byte long float ] Object] - [TestDefnt [byte int double] Object] - [TestDefnt [byte int float ] Object]])}) - (with-merge-test reify-body - {:reify-body reify-body-result}) - (with-merge-test reify-def - {:reified-sym - 'test-defnt-reified, - :reified-sym-qualified - ^user.TestDefntInterface 'user/test-defnt-reified, - :reify-def - (list 'def 'test-defnt-reified reify-body-result)}) - (with-merge-test defprotocol-from-interface - '{:protocol-def - (defprotocol TestDefntProtocol - (test-defnt-protocol__3 [a0 a1 a2]) - (test-defnt-protocol__2 [a0 a1] [a0 a1 a2]) - (test-defnt-protocol [a0] [a0 a1] [a0 a1 a2])), - :genned-protocol-method-names - (test-defnt-protocol__3 - test-defnt-protocol__2 - test-defnt-protocol)}) - (with-merge-test ns/defnt-extend-protocol-def - '{:extend-protocol-def - (extend-protocol - TestDefntProtocol - nil - (test-defnt-protocol - ([#_(tag nil) a] (let [] (inc ^java.lang.Object a)))) - java.lang.StringBuilder - (test-defnt-protocol - ([^java.lang.StringBuilder a b] (let [b (boolean b)] [^java.lang.StringBuilder a b])) - ([^java.lang.StringBuilder a b] (let [b (char b)] [^java.lang.StringBuilder a b]))) - java.lang.String - (test-defnt-protocol - ([^java.lang.String a b] (let [b (boolean b)] [^java.lang.String a b])) - ([^java.lang.String a b] (let [b (char b)] [^java.lang.String a b]))) - java.lang.Short - (test-defnt-protocol - ([a ^long b ^double c] (let [a (short a) b (long b) c (double c)] [a b c])) - ([a ^long b c] (let [a (short a) b (long b) c (float c)] [a b c])) - ([a b ^double c] (let [a (short a) b (int b) c (double c)] [a b c])) - ([a b c] (let [a (short a) b (int b) c (float c)] [a b c]))) - java.lang.Byte - (test-defnt-protocol - ([a ^long b ^double c] (let [a (byte a) b (long b) c (double c)] [a b c])) - ([a ^long b c] (let [a (byte a) b (long b) c (float c)] [a b c])) - ([a b ^double c] (let [a (byte a) b (int b) c (double c)] [a b c])) - ([a b c] (let [a (byte a) b (int b) c (float c)] [a b c]))))}) - #_(with-merge-test ns/defnt-gen-helper-macro - '{}))])) - -#_(deftest test:defnt - #?(:clj (is (= 300 (test:defnt-def (AtomicInteger. 300))))) ; reify - (is (= 2 (test:defnt-def test-boxed-long))) ; protocol - (is (= 2 (test:defnt-def test-boxed-int ))) - (is (= 2 (test:defnt-def 1))) ; reify - #?(:clj (is (instance? IllegalArgumentException - (err/suppress (test:defnt-def 1.0))))) ; reify, 'No matching method found' - (is (= \a (test:defnt-def-generic test-string))) - (is (= 1 (test:defnt-def-generic 1))) - (is (= [1 2] (test:defnt-def 1 2))) ; reify - (is (= [1 "abcde"] (test:defnt-def test-boxed-int test-string))) ; reify - ) - -(log/disable! :macro-expand) - - -#_(:clj - (defnt' div*-bin- - "Lax |/|; continues on overflow/underflow. - TODO Doesn't preserve ratios." - (^double ; is it actually always double? - [#{byte char short int long float double} n - #{byte char short int long float double} d] - (quantum.core.Numeric/divide n d)) - (^Number [^java.math.BigInteger n ^java.math.BigInteger d] - (when (.equals d BigInteger/ZERO) - (throw (ArithmeticException. "Divide by zero"))) - (let [^BigInteger gcd (.gcd n d)] - (if (.equals gcd BigInteger/ZERO) - BigInt/ZERO - (let [n-f (.divide n gcd) - d-f (.divide d gcd)] - (cond - (.equals d BigInteger/ONE) - (BigInt/fromBigInteger n-f) - (.equals d (.negate BigInteger/ONE)) - (BigInt/fromBigInteger (.negate n-f)) - :else (clojure.lang.Ratio. (if (neg? d-f) (.negate n-f) n-f) - (if (neg? d-f) (.negate d-f) d-f))))))) - ([^clojure.lang.BigInt n ^clojure.lang.BigInt d] - (div*-bin- (->big-integer n) (->big-integer d))) - ([^java.math.BigDecimal n ^java.math.BigDecimal d] - (if (nil? *math-context*) - (.divide n d) - (.divide n d *math-context*))))) - -; TODO you lose the |defnt'| power with this - -; (:clj (defnt div*-bin-denom-byte -; ([#{byte char short int long float double} d ^byte n] (div*-bin- n d)))) -; (:clj (defnt div*-bin-denom-char -; ([#{byte char short int long float double} d ^char n] (div*-bin- n d)))) -; (:clj (defnt div*-bin-denom-short -; ([#{byte char short int long float double} d ^short n] (div*-bin- n d)))) -; (:clj (defnt div*-bin-denom-int -; ([#{byte char short int long float double} d ^int n] (div*-bin- n d)))) -; (:clj (defnt div*-bin-denom-long -; ([#{byte char short int long float double} d ^long n] (div*-bin- n d)))) -; (:clj (defnt div*-bin-denom-float -; ([#{byte char short int long float double} d ^float n] (div*-bin- n d)))) -; (:clj (defnt div*-bin-denom-double -; ([#{byte char short int long float double} d ^double n] (div*-bin- n d)))) From 17a0281774da8672d6abedcefc8fc86cc0b60c0e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Dec 2018 15:44:05 -0700 Subject: [PATCH 788/810] Now `t/defn` uses `TypedFn` format --- .../quantum/untyped/core/type/defnt.cljc | 365 +++++++++--------- 1 file changed, 185 insertions(+), 180 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 63f1c562..9eccd6ca 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -23,8 +23,7 @@ :refer [not==]] [quantum.untyped.core.data :refer [kw-map]] - [quantum.untyped.core.data.array :as uarr - :refer [*<>]] + [quantum.untyped.core.data.array :as uarr] [quantum.untyped.core.data.map :as umap] [quantum.untyped.core.data.reactive :as urx :refer [?norx-deref norx-deref]] @@ -48,7 +47,7 @@ [quantum.untyped.core.loops :refer [reduce-2]] [quantum.untyped.core.reducers :as ur - :refer [educe educei reducei]] + :refer [educe educei join reducei]] [quantum.untyped.core.refs :as uref :refer [?deref]] [quantum.untyped.core.spec :as us] @@ -56,13 +55,15 @@ [quantum.untyped.core.type :as t :refer [?]] [quantum.untyped.core.type.compare :as utcomp] - [quantum.untyped.core.type.reifications :as utr] + [quantum.untyped.core.type.reifications :as utr + #?@(:cljs [:refer [TypedFn]])] [quantum.untyped.core.vars :as uvar :refer [update-meta]]) #?(:clj (:import [java.util ArrayList HashMap TreeMap] [quantum.core Numeric] - [quantum.core.data Array]))) + [quantum.core.data Array] + [quantum.untyped.core.type.reifications TypedFn]))) ;; TODO move (def index? #(and (integer? %) (>= % 0))) @@ -344,6 +345,7 @@ :arglist-code|fn|hinted (us/vec-of simple-symbol?) :arglist-code|hinted (us/vec-of simple-symbol?) :arglist-code|reify|unhinted (us/vec-of simple-symbol?) + :interface class? :body-node uast/node? :output-class (us/nilable class?) :output-type t/type? @@ -351,7 +353,8 @@ ;; When present, varargs are considered to be of class Object :variadic? t/boolean?})) -(us/def ::overload|id index?) +(us/def ::overload|id index?) +(us/def ::overload|index index?) (us/def ::overload-types-decl (us/kv {:form t/any? @@ -360,18 +363,12 @@ (us/def ::reify|name simple-symbol?) ; hinted with the interface name (us/def ::reify - (us/kv {:form t/any? - :hinted-name ::reify|name - :interface class? - :overload ::overload})) + (us/kv {:form t/any? + :id ::overload|id + :index ::overload|index + :overload ::overload})) -(us/def ::direct-dispatch-data - (us/kv {:overload-types-decl ::overload-types-decl - :reify ::reify})) - -(us/def ::direct-dispatch - (us/kv {:form t/any? - :direct-dispatch-data-seq (us/vec-of ::direct-dispatch-data)})) +(us/def ::direct-dispatch-seq (us/vec-of ::reify)) ; sorted by ID (us/def ::type-datum (us/kv {:arg-types (us/vec-of t/type?) @@ -382,6 +379,7 @@ (us/kv {:id ::overload|id :index index? ; overload-index (position in the overall types-decl) :ns-name simple-symbol? + :interface class? :arglist-code|hinted (us/vec-of simple-symbol?) :arg-types (us/vec-of t/type?) :output-type t/type? @@ -396,6 +394,9 @@ (c/defn >with-runtime-output-type [body output-type|form] `(t/validate ~body ~output-type|form)) +(c/defn with-array-type-hint [x] + (ufth/with-type-hint x #?(:clj "[Ljava.lang.Object;" :cljs "array"))) + ;; TODO simplify this class computation ;; ===== Arg type/class extraction/comparison ===== ;; @@ -525,13 +526,35 @@ [] type-data)) -;; ===== Unanalyzed overloads ===== ;; +;; ===== `unanalyzed-overload>overload` ===== ;; + +(defns- class>interface-part-name [c class? > string?] + (if (= c java.lang.Object) + "Object" + (let [illegal-pattern #"\|\+"] + (if (->> c >name (re-find illegal-pattern)) + (err! "Class cannot contain pattern" {:class c :pattern illegal-pattern}) + (-> c >name (str/replace "." "|")))))) + +(defns- overload-classes>interface-sym [args-classes (us/seq-of class?), out-class class? > symbol?] + (>symbol (str (->> args-classes (uc/lmap class>interface-part-name) (str/join "+")) + ">" (class>interface-part-name out-class)))) + +(defns- overload-classes>interface + [args-classes (us/vec-of class?), out-class class?, gen-gensym fn?] + (let [interface-sym (overload-classes>interface-sym args-classes out-class) + hinted-method-sym (ufth/with-type-hint uana/direct-dispatch-method-sym + (ufth/>interface-method-tag out-class)) + hinted-args (ufth/hint-arglist-with + (ufgen/gen-args 0 (count args-classes) "x" gen-gensym) + (map ufth/>interface-method-tag args-classes))] + `(~'definterface ~interface-sym (~hinted-method-sym ~hinted-args)))) #?(:clj (defns- unanalyzed-overload>overload "Given an `::unanalyzed-overload`, performs type analysis on the body and computes a resulting `t/fn` overload, which is the foundation for one `reify`." - [{:as opts :keys [kind _]} ::opts + [{:as opts :keys [gen-gensym _, kind _]} ::opts {:as fn|globals :keys [fn|globals-name _, fn|name _, fn|ns-name _, fn|output-type _ fn|overload-types-name _]} ::fn|globals env ::uana/env @@ -582,37 +605,24 @@ variadic?))) arglist-code|fn|hinted (cond-> (->> args-form keys (uc/map-indexed hint-arg|fn)) - variadic? (conj '& (-> varargs-form keys first)))] - (kw-map arglist-form|unanalyzed arg-classes arg-types arglist-code|fn|hinted - arglist-code|reify|unhinted arglist-code|hinted body-node positional-args-ct - output-type output-class variadic?)))) - -(defns- class>interface-part-name [c class? > string?] - (if (= c java.lang.Object) - "Object" - (let [illegal-pattern #"\|\+"] - (if (->> c >name (re-find illegal-pattern)) - (err! "Class cannot contain pattern" {:class c :pattern illegal-pattern}) - (-> c >name (str/replace "." "|")))))) + variadic? (conj '& (-> varargs-form keys first))) + arg-classes|reify (->> arg-classes (uc/map class>simplest-class)) + output-class|reify (class>simplest-class output-class) + interface-k [output-class|reify arg-classes|reify] + interface + (-> *interfaces + (swap! update interface-k + #(or % (eval (overload-classes>interface arg-classes|reify output-class|reify + gen-gensym)))) + (uc/get interface-k))] + (kw-map arg-classes arg-classes|reify arg-types arglist-code|fn|hinted arglist-code|hinted + arglist-code|reify|unhinted arglist-form|unanalyzed body-node output-class + output-class|reify output-type positional-args-ct variadic?)))) ;; ===== Direct dispatch ===== ;; ;; ----- Direct dispatch: `reify` ---- ;; -(defns- overload-classes>interface-sym [args-classes (us/seq-of class?), out-class class? > symbol?] - (>symbol (str (->> args-classes (uc/lmap class>interface-part-name) (str/join "+")) - ">" (class>interface-part-name out-class)))) - -(defns- overload-classes>interface - [args-classes (us/vec-of class?), out-class class?, gen-gensym fn?] - (let [interface-sym (overload-classes>interface-sym args-classes out-class) - hinted-method-sym (ufth/with-type-hint uana/direct-dispatch-method-sym - (ufth/>interface-method-tag out-class)) - hinted-args (ufth/hint-arglist-with - (ufgen/gen-args 0 (count args-classes) "x" gen-gensym) - (map ufth/>interface-method-tag args-classes))] - `(~'definterface ~interface-sym (~hinted-method-sym ~hinted-args)))) - (defns- >reify-name-unhinted ([fn|name simple-symbol?, overload|id ::overload|id > simple-symbol?] (symbol (str fn|name "|__" overload|id))) @@ -622,46 +632,35 @@ #?(:clj (defns overload>reify - [{:as overload - :keys [arg-classes _, arglist-code|reify|unhinted _, body-node _, output-class _]} ::overload - {:as opts :keys [gen-gensym _]} ::opts + [{:as opts :keys [gen-gensym _]} ::opts {:keys [fn|name _]} ::fn|globals - overload|id ::overload|id + {:as overload + :keys [arg-classes|reify _, arglist-code|reify|unhinted _, body-node _, interface _ + output-class|reify _]} ::overload + overload|id ::overload|id + overload|index ::overload|index > ::reify] - (let [arg-classes|reify (->> arg-classes (uc/map class>simplest-class)) - output-class|reify (class>simplest-class output-class) - interface-k {:out output-class|reify :in arg-classes|reify} - interface - (-> *interfaces - (swap! update interface-k - #(or % (eval (overload-classes>interface arg-classes|reify output-class|reify - gen-gensym)))) - (uc/get interface-k)) - arglist-code - (ur/join [(gen-gensym '_)] + (let [arglist-code + (join [(gen-gensym '_)] (->> arglist-code|reify|unhinted (uc/map-indexed (c/fn [i|arg arg|form] (ufth/with-type-hint arg|form (-> arg-classes|reify (uc/get i|arg) ufth/>arglist-embeddable-tag)))))) - reify|name (-> (>reify-name-unhinted fn|name overload|id) - (ufth/with-type-hint (>name interface))) - form `(~'def ~reify|name - (reify* [~(-> interface >name >symbol)] - (~(ufth/with-type-hint uana/direct-dispatch-method-sym - (ufth/>arglist-embeddable-tag output-class|reify)) - ~arglist-code ~(:form body-node))))] - {:form form - :hinted-name reify|name - :interface interface - :overload overload}))) + form `(reify* [~(-> interface >name >symbol)] + (~(ufth/with-type-hint uana/direct-dispatch-method-sym + (ufth/>arglist-embeddable-tag output-class|reify)) + ~arglist-code ~(:form body-node))) + id overload|id + index overload|index] + (kw-map form id index overload)))) ;; ----- Type declarations ----- ;; (c/defn overload-types>arg-types [?!fn|types #_(t/or ::fn|types (t/of urx/reactive? ::fn|types)), overload-index #_index? #_> #_(objects-of type?)] - (apply *<> (-> ?!fn|types ?norx-deref :overload-types (get overload-index) :arg-types))) + (apply uarr/*<>|fn (-> ?!fn|types ?norx-deref :overload-types (get overload-index) :arg-types))) (c/defn overload-types>ftype [fn|ns-name #_simple-symbol? @@ -690,33 +689,6 @@ :output-type (:output-type prev-datum) :replacing-id (:id datum)))))))) -(defns- >overload-types-decl|name - ([fn|name simple-symbol?, overload|id ::overload|id > simple-symbol?] - (symbol (str fn|name "|__" overload|id "|types"))) - ([fn|ns-name simple-symbol?, fn|name simple-symbol?, overload|id ::overload|id - > qualified-symbol?] - (symbol (name fn|ns-name) (str fn|name "|__" overload|id "|types")))) - -(defns- >overload-types-decl - "The evaluated `form` of each overload-types-decl is an array of non-primitivized types that the - dynamic dispatch uses to dispatch off input types." - [{:as opts :keys [compilation-mode _]} ::opts - {:as fn|globals :keys [fn|ns-name _, fn|name _, fn|overload-types-name _]} ::fn|globals - {:as types-decl-datum :keys [id _, index _] ns-name- [:ns-name _]} ::types-decl-datum - fn|types ::fn|types - > ::overload-types-decl] - (let [decl-name (-> (>overload-types-decl|name fn|name id) - (ufth/with-type-hint "[Ljava.lang.Object;")) - form (if (or (not= compilation-mode :test) (= ucore/lang :clj)) - (let [arg-types (overload-types>arg-types fn|types index)] - (do (intern-with-rollback! - !global-rollback-queue ns-name- decl-name arg-types) - nil)) - `(def ~decl-name - (overload-types>arg-types - ~(uid/qualify fn|ns-name fn|overload-types-name) ~index)))] - {:form form :name decl-name})) - (defns- overload-basis-data>types+ "Split and primitivized; not yet sorted." [{:keys [fn|output-type _]} ::fn|globals, ns-name-val _, args-form _, output-type|form _ @@ -900,7 +872,7 @@ (->> ;; We `join` in this order because if two overloads are of equal sorting ;; priority, the ones with earlier IDs should appear in ;; `dedupe-overload-types-data` - (ur/join existing-overload-types sorted-changed-overload-types) + (join existing-overload-types sorted-changed-overload-types) (sort-overload-types :arg-types) (dedupe-overload-types-data fn|ns-name fn|name) (uc/map-indexed (c/fn [i datum] (assoc datum :index i))))) @@ -922,43 +894,54 @@ (->> overload-types-with-replacing-ids (uc/map (c/fn [datum] - (let [id (or (:replacing-id datum) (:id datum))] - (when (>= id first-current-overload-id) - (let [overload (get sorted-changed-overloads - (- id first-current-overload-id))] - ;; So that direct dispatch can use them later on in the pipeline - (alist-conj! !overload-queue (assoc datum :overload overload)))) - (dissoc datum :replacing-id)))))] + (let [id (or (:replacing-id datum) (:id datum)) + datum' + (if (>= id first-current-overload-id) + (let [overload (get sorted-changed-overloads + (- id first-current-overload-id)) + datum' (assoc datum :interface (:interface overload))] + ;; So that direct dispatch can use `overload` later on + (alist-conj! !overload-queue (assoc datum :overload overload)) + datum') + datum)] + + (dissoc datum' :replacing-id)))))] + ;; TODO use records here and other memory-friendly things (kw-map fn|output-type-norx fn|type-norx overload-types))))) ;; ----- Direct dispatch ----- ;; -(defns- >direct-dispatch +(defns- >direct-dispatch-seq + "Generates a seq of unevaluated direct-dispatch `reify`s sorted by index." [{:as opts :keys [gen-gensym _, kind _]} ::opts fn|globals ::fn|globals fn|types ::fn|types !overload-queue _ - > ::direct-dispatch] + > ::direct-dispatch-seq] (case ucore/lang - :clj (let [direct-dispatch-data-seq - (->> !overload-queue - (uc/map - (c/fn [{:as type-decl-datum :keys [arg-types id index overload]}] - {:overload-types-decl - (>overload-types-decl opts fn|globals type-decl-datum fn|types) - :reify (overload>reify overload opts fn|globals id)}))) - form (->> direct-dispatch-data-seq - (uc/mapcat - (c/fn [{:as direct-dispatch-data :keys [overload-types-decl]}] - [(:form overload-types-decl) - (-> direct-dispatch-data :reify :form)])))] - (kw-map form direct-dispatch-data-seq)) + :clj (->> !overload-queue + (uc/map + (c/fn [{:as type-decl-datum :keys [arg-types id index overload]}] + (overload>reify opts fn|globals overload id index))) + (sort-by :index) + >vec) :cljs (TODO))) ;; ===== Dynamic dispatch ===== ;; -(defns >direct-dispatch|reify-call [reify-name symbol?, args-codelist (us/seq-of t/any?)] - `(. ~reify-name ~uana/direct-dispatch-method-sym ~@args-codelist)) +(c/defn aget* [x i] + #?(:clj (list '. 'clojure.lang.RT 'aget x i) + :cljs (list 'cljs.core/aget x i))) + +(c/defn aset* [x i v] + #?(:clj (list '. 'clojure.lang.RT 'aset x i v) + :cljs (list 'cljs.core/aset x i v))) + +(defns >direct-dispatch|reify-call + [overload|id ::overload|id, reify|interface class? + [ts|sym simple-symbol? :as args-codelist] (us/seq-of t/any?)] + `(. ~(ufth/with-type-hint (aget* ts|sym overload|id) (>name reify|interface)) + ~uana/direct-dispatch-method-sym ~@args-codelist)) ;; TODO spec (defns unsupported! @@ -972,28 +955,27 @@ (defns- >combinatoric-seq+ [{:as fn|globals :keys [fn|ns-name _ fn|name _]} ::fn|globals overload-types-for-arity (us/vec-of ::types-decl-datum) - arglist (us/vec-of simple-symbol?)] - (->> overload-types-for-arity - (uc/map+ - (c/fn [{:as types-decl-datum :keys [arg-types] overload|id :id ns-name- :ns-name}] - (let [overload-types-decl|name (>overload-types-decl|name ns-name- fn|name overload|id) - reify-name-unhinted (>reify-name-unhinted ns-name- fn|name overload|id)] - [(>direct-dispatch|reify-call reify-name-unhinted arglist) - (->> arg-types - (uc/map-indexed - (c/fn [i|arg arg-type] - {:i i|arg - :t arg-type - :getf `((Array/get ~overload-types-decl|name ~i|arg) - ~(get arglist i|arg))})))]))))) + arglist (us/vec-of simple-symbol?)] ; exclusively the non `ts`/`fs` args + (let [[ts|name fs|name & _] arglist] + (->> overload-types-for-arity + (uc/map+ + (c/fn [{:as types-decl-datum :keys [arg-types id interface] ns-name- :ns-name}] + [(>direct-dispatch|reify-call id interface arglist) + (->> arg-types + (uc/map-indexed + (c/fn [i|arg arg-type] + {:i i|arg + :t arg-type + :getf `(~(aget* (with-array-type-hint (aget* ts|name id)) i|arg) + ~(get arglist i|arg))})))]))))) (defns- >dynamic-dispatch|body-for-arity [{:as fn|globals :keys [fn|ns-name _, fn|name _]} ::fn|globals overload-types-for-arity (us/vec-of ::types-decl-datum) arglist (us/vec-of simple-symbol?)] (if (empty? arglist) - (let [overload|id (-> overload-types-for-arity first :id)] - (>direct-dispatch|reify-call (>reify-name-unhinted fn|ns-name fn|name overload|id) arglist)) + (let [{:as types-decl-datum :keys [id interface]} (first overload-types-for-arity)] + (>direct-dispatch|reify-call id interface arglist)) (let [!!i|arg (atom 0) combinef (c/fn @@ -1013,7 +995,7 @@ (aritoid combinef combinef (c/fn [x [k [{:keys [getf i]}]]] (combinef x getf k i))) (>combinatoric-seq+ fn|globals overload-types-for-arity arglist))))) -(defns- >dynamic-dispatch-fn|codelist +(defns- >dynamic-dispatch [{:as opts :keys [compilation-mode _, gen-gensym _, kind _]} ::opts {:as fn|globals :keys [fn|meta _, fn|ns-name _, fn|name _, fn|output-type _ fn|overload-types-name _, fn|type-name _]} ::fn|globals @@ -1024,28 +1006,13 @@ (group-by (fn-> :arg-types count)) (sort-by key) ; for purposes of reproducibility and organization (map (c/fn [[arg-ct overload-types-for-arity]] - (let [arglist (ufgen/gen-args 0 arg-ct "x" gen-gensym) + (let [ts|name (with-array-type-hint (gen-gensym "ts")) + fs|name (with-array-type-hint (gen-gensym "fs")) + arglist (join [ts|name fs|name] (ufgen/gen-args 0 arg-ct "x" gen-gensym)) body (>dynamic-dispatch|body-for-arity fn|globals overload-types-for-arity arglist)] - (list arglist body))))) - fn|meta' (merge fn|meta {:quantum.core.type/type (uid/qualify fn|ns-name fn|type-name)}) - overload-types|form - (when (= compilation-mode :test) - (->> fn|types :overload-types - (uc/map (c/fn [{:keys [id index inline? arg-types output-type]}] - [id index inline? arg-types output-type])) - fedn/-edn))] - ;; TODO determine whether CLJS needs (update-in m [:jsdoc] conj "@param {...*} var_args") - (if (= kind :extend-defn!) - [overload-types|form - `(doto (intern (quote ~fn|ns-name) (quote ~fn|name) - ~(with-meta `(fn* ~@overload-forms) fn|meta')) - (alter-meta! merge ~fn|meta'))] - (let [dispatch-form `(uvar/defmeta ~fn|name ~fn|meta' - ~(when-not (empty? overload-forms) `(fn* ~@overload-forms)))] - (if (= compilation-mode :test) - [overload-types|form dispatch-form] - [dispatch-form]))))) + (list arglist body)))))] + {:form (when-not (empty? overload-forms) `(fn* ~@overload-forms))})) ;; ===== End dynamic dispatch ===== ;; @@ -1110,7 +1077,7 @@ :types|split (when dependent? (->> (overload-basis-data>types+ fn|globals ns-name-val args-form output-type|form body-codelist|unanalyzed) - ur/join)) + join)) ;; TODO Only needed if `inline? or `reactive?`, or if new :body-codelist body-codelist|unanalyzed :dependent? dependent? @@ -1207,6 +1174,7 @@ (->> current (uc/map (c/fn [basis] + ;; TODO use record here {:arg-types|basis (->> basis :arg-types|basis (uc/map ?norx-deref)) :output-type|basis (-> basis :output-type|basis ?norx-deref) :types|split (:types|split basis) @@ -1304,10 +1272,12 @@ fn|overload-bases-name (symbol (str fn|name "|__bases")) fn|overload-types-name (symbol (str fn|name "|__types")) fn|type-name (symbol (str fn|name "|__type")) - fn|globals - (kw-map fn|globals-name fn|inline? fn|meta fn|name fn|ns-name fn|output-type|form - fn|output-type fn|overload-bases-name fn|overload-types-name - fn|type-name)] + fn|ts-name (symbol (str fn|name "|__ts")) + fn|fs-name (symbol (str fn|name "|__fs")) + fn|globals ; TODO use record here + (kw-map fn|fs-name fn|globals-name fn|inline? fn|meta fn|name fn|ns-name + fn|output-type|form fn|output-type fn|overload-bases-name + fn|overload-types-name fn|ts-name fn|type-name)] (intern-with-rollback! !global-rollback-queue fn|ns-name fn|globals-name fn|globals) (kw-map fn|globals overload-bases-form))))) @@ -1318,35 +1288,69 @@ (reset! uana/!!analyze-fnt analyze-fn) +(defns- >fn|ts + "Creates the array-of-arrays containing the type input data, for consumption by dynamic dispatch. + Interns the result as `fn|ts-name`." + ;; TODO but maybe can use a 2D array to avoid having to double cast with `(aget* (aget* &ts 1) 0)` + {:performance "Can't flatten this array because the param sizes are variable."} + [{:as fn|globals :keys [fn|ns-name _, fn|ts-name _]} ::fn|globals + fn|types ::fn|types + #_> #_(t/of oarray? (t/of oarray? t/type?))] + (let [ts (->> fn|types + :overload-types + (uc/map+ (fn-> :arg-types uc/>array)) + uc/>array)] + (intern-with-rollback! !global-rollback-queue fn|ns-name fn|ts-name ts) + ts)) + +(defns- >overload-types|form [{:as fn|opts :keys [compilation-mode _]} ::opts, fn|types ::fn|types] + (when (= compilation-mode :test) + (->> fn|types :overload-types + (uc/map (c/fn [{:keys [id index inline? arg-types output-type]}] + [id index inline? arg-types output-type])) + fedn/-edn))) + ;; TODO lazily and incrementally analyze this; maybe we want to do code transformations which don't ;; require analysis, as shown in tests (defns- analyze-defn* [kind #{:defn :extend-defn!}, env ::uana/env, unanalyzed-form _ > uast/node?] (let [opts (>fn|opts kind *compilation-mode*) !overload-queue !global-overload-queue {:keys [fn|globals overload-bases-form] - {:keys [fn|ns-name fn|name fn|meta fn|globals-name]} :fn|globals} + {:keys [fn|fs-name fn|globals-name fn|meta fn|name fn|ns-name fn|ts-name fn|type-name]} + :fn|globals} (>fn|globals+?overload-bases-form kind unanalyzed-form) !overload-bases (>!overload-bases opts fn|globals overload-bases-form) !fn|types (>!fn|types opts fn|globals env !overload-bases !overload-queue) fn|types (norx-deref !fn|types) + fn|ts (>fn|ts fn|globals fn|types) !fn|type (>!fn|type opts fn|globals !fn|types) {:keys [form overloads]} (if (empty? (norx-deref !overload-bases)) {:form `(declare ~(:fn|name fn|globals)) :overloads []} - (let [direct-dispatch - (>direct-dispatch opts fn|globals fn|types !overload-queue) - dynamic-dispatch (>dynamic-dispatch-fn|codelist opts fn|globals fn|types) - fn-codelist - (->> `[~@(:form direct-dispatch) - ~@dynamic-dispatch] - (remove nil?))] - {:form `(do ~@fn-codelist) - :overloads (->> direct-dispatch - :direct-dispatch-data-seq - (uc/map+ (fn-> :reify :overload)) + (let [fn|meta (merge fn|meta + {:quantum.core.type/type (uid/qualify fn|ns-name fn|type-name)}) + direct-dispatch-seq + (>direct-dispatch-seq opts fn|globals fn|types !overload-queue) + dynamic-dispatch + (>dynamic-dispatch opts fn|globals fn|types) + defmeta-form + `(uvar/defmeta-from ~fn|name + (let* [~fn|fs-name (uarr/*<>|sized 1) + ~fn|name (new TypedFn ~fn|meta ~fn|ts-name ~fn|fs-name + ~(:form dynamic-dispatch))] + ~@(->> direct-dispatch-seq + (map (c/fn [{:as reify-data :keys [id form]}] + (aset* fn|fs-name id form)))) + ~fn|name)) + overload-types|form (>overload-types|form opts fn|types)] + {:form (if overload-types|form + `(do ~overload-types|form + ~defmeta-form) + defmeta-form) + :overloads (->> direct-dispatch-seq (uc/map - (c/fn [overload] + (c/fn [{:keys [overload]}] {:type (:output-type overload) :arg-types (:arg-types overload) :body (:body-node overload)})))})) @@ -1357,7 +1361,8 @@ :meta fn|meta :overloads overloads :form form - ;; TODO is `norx-deref` the right approach? + ;; TODO is `norx-deref` the right approach? What if something else refers + ;; to the defn that then is extended? Will that not happen correctly? :type (norx-deref !fn|type)}] (case kind :defn (uast/defnt-node ast-basis) From d508bb733257b31a78d84aa00161ff7a5562474a Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Dec 2018 16:17:42 -0700 Subject: [PATCH 789/810] First test passes with new `TypedFn`-based impl! --- .../quantum/untyped/core/type/defnt.cljc | 114 ++++++++++-------- src-untyped/quantum/untyped/core/vars.cljc | 7 ++ src/quantum/core/type.cljc | 4 +- .../quantum/test/untyped/core/type/defnt.cljc | 23 ++-- 4 files changed, 88 insertions(+), 60 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 9eccd6ca..5db0aaf3 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -375,16 +375,22 @@ :pre-type (us/nilable t/type?) :output-type t/type?})) +(def types-decl-datum-kv-basis + {:id ::overload|id + :index index? ; overload-index (position in the overall types-decl) + :ns-name simple-symbol? + :interface class? + :arglist-code|hinted (us/vec-of simple-symbol?) + :arg-types (us/vec-of t/type?) + :output-type t/type? + :body-codelist (us/vec-of t/any?) + :inline? boolean?}) + +(us/def ::types-decl-datum-without-interface + (us/kv (dissoc types-decl-datum-kv-basis :interface))) + (us/def ::types-decl-datum - (us/kv {:id ::overload|id - :index index? ; overload-index (position in the overall types-decl) - :ns-name simple-symbol? - :interface class? - :arglist-code|hinted (us/vec-of simple-symbol?) - :arg-types (us/vec-of t/type?) - :output-type t/type? - :body-codelist (us/vec-of t/any?) - :inline? boolean?})) + (us/kv types-decl-datum-kv-basis)) ;; Interned as `!fn|types` (us/def ::fn|types @@ -529,16 +535,20 @@ ;; ===== `unanalyzed-overload>overload` ===== ;; (defns- class>interface-part-name [c class? > string?] - (if (= c java.lang.Object) - "Object" - (let [illegal-pattern #"\|\+"] - (if (->> c >name (re-find illegal-pattern)) - (err! "Class cannot contain pattern" {:class c :pattern illegal-pattern}) - (-> c >name (str/replace "." "|")))))) + (case (>name c) + "java.lang.Object" "O" + "boolean" "B" + "byte" "Y" + "short" "S" + "char" "C" + "int" "I" + "long" "L" + "float" "F" + "double" "D")) (defns- overload-classes>interface-sym [args-classes (us/seq-of class?), out-class class? > symbol?] - (>symbol (str (->> args-classes (uc/lmap class>interface-part-name) (str/join "+")) - ">" (class>interface-part-name out-class)))) + (>symbol (str (->> args-classes (uc/lmap class>interface-part-name) (apply str)) + "__" (class>interface-part-name out-class)))) (defns- overload-classes>interface [args-classes (us/vec-of class?), out-class class?, gen-gensym fn?] @@ -564,7 +574,7 @@ varargs-form _, variadic? _] declared-output-type [:output-type _]} ::unanalyzed-overload overload|id index? - fn|overload-types (us/vec-of ::types-decl-datum) + fn|overload-types (us/vec-of ::types-decl-datum-without-interface) fn|type (us/nilable t/type?) > ::overload] (let [;; Not sure if `nil` is the right approach for the value @@ -616,7 +626,7 @@ gen-gensym)))) (uc/get interface-k))] (kw-map arg-classes arg-classes|reify arg-types arglist-code|fn|hinted arglist-code|hinted - arglist-code|reify|unhinted arglist-form|unanalyzed body-node output-class + arglist-code|reify|unhinted arglist-form|unanalyzed body-node interface output-class output-class|reify output-type positional-args-ct variadic?)))) ;; ===== Direct dispatch ===== ;; @@ -938,10 +948,10 @@ :cljs (list 'cljs.core/aset x i v))) (defns >direct-dispatch|reify-call - [overload|id ::overload|id, reify|interface class? - [ts|sym simple-symbol? :as args-codelist] (us/seq-of t/any?)] - `(. ~(ufth/with-type-hint (aget* ts|sym overload|id) (>name reify|interface)) - ~uana/direct-dispatch-method-sym ~@args-codelist)) + [overload|id ::overload|id, reify|interface class?, fs|name simple-symbol? + relevant-arglist (us/vec-of simple-symbol?)] + `(. ~(ufth/with-type-hint (aget* fs|name overload|id) (>name reify|interface)) + ~uana/direct-dispatch-method-sym ~@relevant-arglist)) ;; TODO spec (defns unsupported! @@ -955,45 +965,50 @@ (defns- >combinatoric-seq+ [{:as fn|globals :keys [fn|ns-name _ fn|name _]} ::fn|globals overload-types-for-arity (us/vec-of ::types-decl-datum) - arglist (us/vec-of simple-symbol?)] ; exclusively the non `ts`/`fs` args - (let [[ts|name fs|name & _] arglist] + ts|name simple-symbol? + fs|name simple-symbol? + relevant-arglist (us/vec-of simple-symbol?)] + (let [] (->> overload-types-for-arity (uc/map+ (c/fn [{:as types-decl-datum :keys [arg-types id interface] ns-name- :ns-name}] - [(>direct-dispatch|reify-call id interface arglist) + [(>direct-dispatch|reify-call id interface fs|name relevant-arglist) (->> arg-types (uc/map-indexed (c/fn [i|arg arg-type] {:i i|arg :t arg-type :getf `(~(aget* (with-array-type-hint (aget* ts|name id)) i|arg) - ~(get arglist i|arg))})))]))))) + ~(get relevant-arglist i|arg))})))]))))) (defns- >dynamic-dispatch|body-for-arity [{:as fn|globals :keys [fn|ns-name _, fn|name _]} ::fn|globals overload-types-for-arity (us/vec-of ::types-decl-datum) arglist (us/vec-of simple-symbol?)] - (if (empty? arglist) - (let [{:as types-decl-datum :keys [id interface]} (first overload-types-for-arity)] - (>direct-dispatch|reify-call id interface arglist)) - (let [!!i|arg (atom 0) - combinef - (c/fn - ([] (transient [`ifs])) - ([ret] - (-> ret (conj! `(unsupported! '~(uid/qualify fn|ns-name fn|name) - ~arglist ~(deref !!i|arg))) - persistent! - seq)) - ([ret getf x i] - (reset! !!i|arg i) - (uc/conj! ret getf x)))] - (uc/>combinatoric-tree (count arglist) - (c/fn [a b] (t/= (:t a) (:t b))) - (aritoid combinef combinef (c/fn [x [{:keys [getf i]} group]] (combinef x getf group i))) - uc/conj!|rf - (aritoid combinef combinef (c/fn [x [k [{:keys [getf i]}]]] (combinef x getf k i))) - (>combinatoric-seq+ fn|globals overload-types-for-arity arglist))))) + (let [[ts|name fs|name & relevant-arglist] arglist + relevant-arglist (>vec relevant-arglist)] + (if (empty? relevant-arglist) + (let [{:as types-decl-datum :keys [id interface]} (first overload-types-for-arity)] + (>direct-dispatch|reify-call id interface fs|name relevant-arglist)) + (let [!!i|arg (atom 0) + combinef + (c/fn + ([] (transient [`ifs])) + ([ret] + (-> ret (conj! `(unsupported! '~(uid/qualify fn|ns-name fn|name) + ~relevant-arglist ~(deref !!i|arg))) + persistent! + seq)) + ([ret getf x i] + (reset! !!i|arg i) + (uc/conj! ret getf x)))] + (uc/>combinatoric-tree (count relevant-arglist) + (c/fn [a b] (t/= (:t a) (:t b))) + (aritoid combinef combinef (c/fn [x [{:keys [getf i]} group]] (combinef x getf group i))) + uc/conj!|rf + (aritoid combinef combinef (c/fn [x [k [{:keys [getf i]}]]] (combinef x getf k i))) + (>combinatoric-seq+ + fn|globals overload-types-for-arity ts|name fs|name relevant-arglist)))))) (defns- >dynamic-dispatch [{:as opts :keys [compilation-mode _, gen-gensym _, kind _]} ::opts @@ -1334,10 +1349,11 @@ (>direct-dispatch-seq opts fn|globals fn|types !overload-queue) dynamic-dispatch (>dynamic-dispatch opts fn|globals fn|types) + qualified-ts-name (uid/qualify fn|ns-name fn|ts-name) defmeta-form `(uvar/defmeta-from ~fn|name (let* [~fn|fs-name (uarr/*<>|sized 1) - ~fn|name (new TypedFn ~fn|meta ~fn|ts-name ~fn|fs-name + ~fn|name (new TypedFn ~fn|meta ~qualified-ts-name ~fn|fs-name ~(:form dynamic-dispatch))] ~@(->> direct-dispatch-seq (map (c/fn [{:as reify-data :keys [id form]}] diff --git a/src-untyped/quantum/untyped/core/vars.cljc b/src-untyped/quantum/untyped/core/vars.cljc index d8ed3255..88655c5c 100644 --- a/src-untyped/quantum/untyped/core/vars.cljc +++ b/src-untyped/quantum/untyped/core/vars.cljc @@ -74,6 +74,13 @@ (vary-meta x merge meta-val) x)))) +#?(:clj +(defmacro defmeta-from + "Like `defmeta-from`, but gets the metadata from the bound object." + [sym x] + `(do (def ~sym ~x) + (alter-meta! (var ~sym) merge (meta ~sym))))) + ;; ===== Aliases ===== ;; #?(:clj (ucore/defaliases ucore defalias defaliases defaliases')) diff --git a/src/quantum/core/type.cljc b/src/quantum/core/type.cljc index d138ad26..f71154a5 100644 --- a/src/quantum/core/type.cljc +++ b/src/quantum/core/type.cljc @@ -22,8 +22,8 @@ ? run, isa? isa?|direct ; fn ; TODO TYPED rename ftype - input-type input-type|meta-or input-type|or - output-type output-type|meta-or output-type|or + input input|meta-or input|or + output output|meta-or output|or unordered ordered value unvalue ;; Combinators diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 2daf9136..8f1f8f54 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -6,10 +6,8 @@ [quantum.core.type :refer [dotyped]] [quantum.test.untyped.core.type :as tt] - [quantum.untyped.core.type.defnt :as self - :refer [aget* aset* unsupported!]] [quantum.untyped.core.data.array - :refer [*<>]] + :refer [*<> *<>|sized]] [quantum.untyped.core.form :refer [$ code=]] [quantum.untyped.core.form.evaluate @@ -22,9 +20,11 @@ [quantum.untyped.core.test :as utest :refer [deftest is is= is-code= testing throws]] [quantum.untyped.core.type :as t] + [quantum.untyped.core.type.defnt :as self + :refer [aget* aset* unsupported!]] [quantum.untyped.core.type.reifications :as utr] [quantum.untyped.core.vars - :refer [defmeta]]) + :refer [defmeta defmeta-from]]) (:import [clojure.lang ASeq ISeq LazySeq Named Reduced RT Seqable] [quantum.core.data Array] @@ -39,6 +39,8 @@ (orchestra.spec.test/unstrument) (orchestra.spec.test/instrument)) +(do + (defn B [form] (tag "boolean" form)) (defn Y [form] (tag "byte" form)) (defn S [form] (tag "short" form)) @@ -58,6 +60,7 @@ (defn csym [x] (-> x cstr symbol)) +(defn >__O [form] (tag (cstr `__O) form)) (defn >B__B [form] (tag (cstr `B__B) form)) (defn >Y__Y [form] (tag (cstr `Y__Y) form)) (defn >S__S [form] (tag (cstr `S__S) form)) @@ -69,10 +72,12 @@ (defn >O__F [form] (tag (cstr `O__F) form)) (defn >O__O [form] (tag (cstr `O__O) form)) -(def &ts (O<> 'ts__)) -(def &fs (O<> 'fs__)) +(def &ts (O<> 'ts0__)) +(def &fs (O<> 'fs0__)) (def &this '&this) +) + #?(:clj (deftest test|pid (let [actual @@ -87,12 +92,12 @@ (let* [~'pid|__fs (*<>|sized 1) ~'pid (new TypedFn {:quantum.core.type/type pid|__type} - pid|__types ; defined/created within `t/defn` + pid|__ts ; defined/created within `t/defn` ~'pid|__fs - (fn* ([~&ts ~&fs] (. ~(aget* &fs 0) ~'invoke))))] + (fn* ([~&ts ~&fs] (. ~(>__O (aget* &fs 0)) ~'invoke))))] ~(aset* 'pid|__fs 0 `(reify* [~(csym `__O)] - (~(O 'invoke) [~&this] + (~(O 'invoke) [~'_0__] ~(ST (list '. (tag "java.lang.management.RuntimeMXBean" '(. java.lang.management.ManagementFactory getRuntimeMXBean)) From 56681d149c201ddb3086942101b427bda400d590 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Dec 2018 16:28:35 -0700 Subject: [PATCH 790/810] Begin to work on second test --- .../quantum/untyped/core/type/defnt.cljc | 2 +- .../quantum/test/untyped/core/type/defnt.cljc | 105 +++++++++--------- 2 files changed, 55 insertions(+), 52 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 5db0aaf3..a3135a28 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -1352,7 +1352,7 @@ qualified-ts-name (uid/qualify fn|ns-name fn|ts-name) defmeta-form `(uvar/defmeta-from ~fn|name - (let* [~fn|fs-name (uarr/*<>|sized 1) + (let* [~fn|fs-name (uarr/*<>|sized ~(-> fn|types :overload-types count)) ~fn|name (new TypedFn ~fn|meta ~qualified-ts-name ~fn|fs-name ~(:form dynamic-dispatch))] ~@(->> direct-dispatch-seq diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 8f1f8f54..d916e043 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -24,7 +24,7 @@ :refer [aget* aset* unsupported!]] [quantum.untyped.core.type.reifications :as utr] [quantum.untyped.core.vars - :refer [defmeta defmeta-from]]) + :refer [defmeta-from]]) (:import [clojure.lang ASeq ISeq LazySeq Named Reduced RT Seqable] [quantum.core.data Array] @@ -117,30 +117,7 @@ expected (case (env-lang) :clj - ($ (do (declare ~'identity) - - ;; [x t/any?] - - (def ~(>B__B 'identity|__0) - (reify* [~(csym `B__B)] (~(B 'invoke) [~'_0__ ~(B 'x)] ~'x))) - (def ~(>Y__Y 'identity|__1) - (reify* [~(csym `Y__Y)] (~(Y 'invoke) [~'_1__ ~(Y 'x)] ~'x))) - (def ~(>S__S 'identity|__2) - (reify* [~(csym `S__S)] (~(S 'invoke) [~'_2__ ~(S 'x)] ~'x))) - (def ~(>C__C 'identity|__3) - (reify* [~(csym `C__C)] (~(C 'invoke) [~'_3__ ~(C 'x)] ~'x))) - (def ~(>I__I 'identity|__4) - (reify* [~(csym `I__I)] (~(I 'invoke) [~'_4__ ~(I 'x)] ~'x))) - (def ~(>L__L 'identity|__5) - (reify* [~(csym `L__L)] (~(L 'invoke) [~'_5__ ~(L 'x)] ~'x))) - (def ~(>F__F 'identity|__6) - (reify* [~(csym `F__F)] (~(F 'invoke) [~'_6__ ~(F 'x)] ~'x))) - (def ~(>D__D 'identity|__7) - (reify* [~(csym `D__D)] (~(D 'invoke) [~'_7__ ~(D 'x)] ~'x))) - (def ~(>O__O 'identity|__8) - (reify* [~(csym `O__O)] (~(O 'invoke) [~'_8__ ~(O 'x)] ~(O 'x)))) - - [[0 0 true [t/boolean?] t/boolean?] + ($ (do [[0 0 true [t/boolean?] t/boolean?] [1 1 true [t/byte?] t/byte?] [2 2 true [t/short?] t/short?] [3 3 true [t/char?] t/char?] @@ -149,32 +126,58 @@ [6 6 true [t/float?] t/float?] [7 7 true [t/double?] t/double?] [8 8 true [t/any?] t/any?]] - - (defmeta ~'identity - {:quantum.core.type/type identity|__type} - (fn* ([~'x00__] - (ifs - ((Array/get identity|__0|types 0) ~'x00__) - (. identity|__0 ~'invoke ~'x00__) - ((Array/get identity|__1|types 0) ~'x00__) - (. identity|__1 ~'invoke ~'x00__) - ((Array/get identity|__2|types 0) ~'x00__) - (. identity|__2 ~'invoke ~'x00__) - ((Array/get identity|__3|types 0) ~'x00__) - (. identity|__3 ~'invoke ~'x00__) - ((Array/get identity|__4|types 0) ~'x00__) - (. identity|__4 ~'invoke ~'x00__) - ((Array/get identity|__5|types 0) ~'x00__) - (. identity|__5 ~'invoke ~'x00__) - ((Array/get identity|__6|types 0) ~'x00__) - (. identity|__6 ~'invoke ~'x00__) - ((Array/get identity|__7|types 0) ~'x00__) - (. identity|__7 ~'invoke ~'x00__) - ((Array/get identity|__8|types 0) ~'x00__) - (. identity|__8 ~'invoke ~'x00__) - ;; TODO no need for `unsupported!` because it will always get a valid - ;; branch - (unsupported! `identity [~'x00__] 0))))))) + (defmeta-from ~'identity + (let* [~'identity|__fs (*<>|sized 9) + ~'identity + (new TypedFn + {:quantum.core.type/type identity|__type} + identity|__ts + ~'identity|__fs + (fn* ([~&ts ~&fs ~'x00__] + (ifs (~(aget* (O<> (aget* &ts 0)) 0) ~'x00__) + (. ~(>B__B (aget* &fs 0)) ~'invoke ~'x00__) + (~(aget* (O<> (aget* &ts 1)) 0) ~'x00__) + (. ~(>Y__Y (aget* &fs 1)) ~'invoke ~'x00__) + (~(aget* (O<> (aget* &ts 2)) 0) ~'x00__) + (. ~(>S__S (aget* &fs 2)) ~'invoke ~'x00__) + (~(aget* (O<> (aget* &ts 3)) 0) ~'x00__) + (. ~(>C__C (aget* &fs 3)) ~'invoke ~'x00__) + (~(aget* (O<> (aget* &ts 4)) 0) ~'x00__) + (. ~(>I__I (aget* &fs 4)) ~'invoke ~'x00__) + (~(aget* (O<> (aget* &ts 5)) 0) ~'x00__) + (. ~(>L__L (aget* &fs 5)) ~'invoke ~'x00__) + (~(aget* (O<> (aget* &ts 6)) 0) ~'x00__) + (. ~(>F__F (aget* &fs 6)) ~'invoke ~'x00__) + (~(aget* (O<> (aget* &ts 7)) 0) ~'x00__) + (. ~(>D__D (aget* &fs 7)) ~'invoke ~'x00__) + (~(aget* (O<> (aget* &ts 8)) 0) ~'x00__) + (. ~(>O__O (aget* &fs 8)) ~'invoke ~'x00__) + ;; TODO no need for `unsupported!` because it will + ;; always get a valid branch + (unsupported! `identity [~'x00__] 0)))))] + ~(aset* 'identity|__fs 0 + `(reify* [])) + ;; [x t/any?] + + ~(aset* 'identity 0 + `(reify* [~(csym `B__B)] (~(B 'invoke) [~'_0__ ~(B 'x)] ~'x))) + ~(aset* 'identity 1 + `(reify* [~(csym `Y__Y)] (~(Y 'invoke) [~'_1__ ~(Y 'x)] ~'x))) + ~(aset* 'identity 2 + `(reify* [~(csym `S__S)] (~(S 'invoke) [~'_2__ ~(S 'x)] ~'x))) + ~(aset* 'identity 3 + `(reify* [~(csym `C__C)] (~(C 'invoke) [~'_3__ ~(C 'x)] ~'x))) + ~(aset* 'identity 4 + `(reify* [~(csym `I__I)] (~(I 'invoke) [~'_4__ ~(I 'x)] ~'x))) + ~(aset* 'identity 5 + `(reify* [~(csym `L__L)] (~(L 'invoke) [~'_5__ ~(L 'x)] ~'x))) + ~(aset* 'identity 6 + `(reify* [~(csym `F__F)] (~(F 'invoke) [~'_6__ ~(F 'x)] ~'x))) + ~(aset* 'identity 7 + `(reify* [~(csym `D__D)] (~(D 'invoke) [~'_7__ ~(D 'x)] ~'x))) + ~(aset* 'identity 8 + `(reify* [~(csym `O__O)] (~(O 'invoke) [~'_8__ ~(O 'x)] ~(O 'x)))) + ~'identity)))) :cljs ;; Direct dispatch will be simple functions, not `reify`s ($ (do (defn ~'identity [~'x] ~'x))))] From 6ec315618e099040ae73e5482a57fbf64500aa35 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Dec 2018 16:54:40 -0700 Subject: [PATCH 791/810] Prevent stack overflow with dotyped --- src-untyped/quantum/untyped/core/analyze.cljc | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 17df4b65..ae05a410 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -987,7 +987,9 @@ (defns- analyze-seq [env ::env, form _] (let [expanded-form (case (first form) - (quantum.core.type.defnt/fn + (quantum.core.type.defnt/dotyped + quantum.untyped.core.type.defnt/dotyped + quantum.core.type.defnt/fn quantum.untyped.core.type.defnt/fn quantum.core.type.defnt/defn quantum.untyped.core.type.defnt/defn) From 97b6445eb18be638dc5d9c64f807a0bca7fdf6d7 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sat, 1 Dec 2018 16:55:28 -0700 Subject: [PATCH 792/810] Better non-expansion --- src-untyped/quantum/untyped/core/type/defnt.cljc | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index a3135a28..697aad60 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -1363,7 +1363,7 @@ {:form (if overload-types|form `(do ~overload-types|form ~defmeta-form) - defmeta-form) + `(do ~defmeta-form)) :overloads (->> direct-dispatch-seq (uc/map (c/fn [{:keys [overload]}] From b4bec75a8548849c8bdd5ab2477b95cacb6e4798 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 2 Dec 2018 22:54:44 -0700 Subject: [PATCH 793/810] Another test passes! --- .../quantum/test/untyped/core/type/defnt.cljc | 20 +++++++++---------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index d916e043..0cfc5100 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -155,27 +155,25 @@ ;; TODO no need for `unsupported!` because it will ;; always get a valid branch (unsupported! `identity [~'x00__] 0)))))] - ~(aset* 'identity|__fs 0 - `(reify* [])) ;; [x t/any?] - ~(aset* 'identity 0 + ~(aset* 'identity|__fs 0 `(reify* [~(csym `B__B)] (~(B 'invoke) [~'_0__ ~(B 'x)] ~'x))) - ~(aset* 'identity 1 + ~(aset* 'identity|__fs 1 `(reify* [~(csym `Y__Y)] (~(Y 'invoke) [~'_1__ ~(Y 'x)] ~'x))) - ~(aset* 'identity 2 + ~(aset* 'identity|__fs 2 `(reify* [~(csym `S__S)] (~(S 'invoke) [~'_2__ ~(S 'x)] ~'x))) - ~(aset* 'identity 3 + ~(aset* 'identity|__fs 3 `(reify* [~(csym `C__C)] (~(C 'invoke) [~'_3__ ~(C 'x)] ~'x))) - ~(aset* 'identity 4 + ~(aset* 'identity|__fs 4 `(reify* [~(csym `I__I)] (~(I 'invoke) [~'_4__ ~(I 'x)] ~'x))) - ~(aset* 'identity 5 + ~(aset* 'identity|__fs 5 `(reify* [~(csym `L__L)] (~(L 'invoke) [~'_5__ ~(L 'x)] ~'x))) - ~(aset* 'identity 6 + ~(aset* 'identity|__fs 6 `(reify* [~(csym `F__F)] (~(F 'invoke) [~'_6__ ~(F 'x)] ~'x))) - ~(aset* 'identity 7 + ~(aset* 'identity|__fs 7 `(reify* [~(csym `D__D)] (~(D 'invoke) [~'_7__ ~(D 'x)] ~'x))) - ~(aset* 'identity 8 + ~(aset* 'identity|__fs 8 `(reify* [~(csym `O__O)] (~(O 'invoke) [~'_8__ ~(O 'x)] ~(O 'x)))) ~'identity)))) :cljs From 84a3658d886844ea0a9cae35a3255b9188dc134b Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Tue, 4 Dec 2018 22:55:39 -0700 Subject: [PATCH 794/810] Begin to analyze `t/fn`s --- src-untyped/quantum/untyped/core/analyze.cljc | 86 ++++++++++------- .../quantum/untyped/core/type/defnt.cljc | 95 +++++++++++-------- 2 files changed, 105 insertions(+), 76 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index ae05a410..8901feb1 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -215,7 +215,10 @@ (us/def ::opts (us/map-of keyword? t/any?)) -(us/def ::env (us/map-of (us/or* symbol? #(= % :opts)) t/any?)) +(us/def ::env + (us/map-of (us/or* symbol? #(= % :opts)) + ;; Technically this should change based on the key spec + (us/or* uast/node? map?))) (declare analyze* analyze-arg-syms*) @@ -326,7 +329,7 @@ ;; the others :type (-> body uc/last :type)})))) -(defns analyze-seq|let*|bindings [env ::env, bindings|form _] +(defns- analyze-seq|let*|bindings [env ::env, bindings|form _] (->> bindings|form (uc/partition-all+ 2) (reduce (fn [{env' :env !bindings :form :keys [bindings-map]} [sym form :as binding|form]] @@ -337,7 +340,7 @@ {:env env :form (transient []) :bindings-map {}}) (<- (update :form (fn-> persistent! (add-file-context-from bindings|form)))))) -(defns analyze-seq|let* +(defns- analyze-seq|let* [env ::env, [_ _, bindings|form _ & body|form _ :as form] _ > uast/let*?] (let [{env' :env bindings|form' :form :keys [bindings-map]} (analyze-seq|let*|bindings env bindings|form) @@ -689,8 +692,8 @@ [env ::env, caller|node uast/node?, caller|type _, inputs-ct _] (if-let [fn|name (utr/fn-type>fn-name caller|type)] (let [overload-types-name (symbol (namespace fn|name) (str (name fn|name) "|__types"))] - (if-let [fn|types (get env overload-types-name)] - (->> fn|types (uc/filter #(-> % :arg-types count (= inputs-ct)))) + (if-let [fn|types-node (get env overload-types-name)] + (->> fn|types-node :value (uc/filter #(-> % :arg-types count (= inputs-ct)))) (if-let [fn|types-var (uvar/resolve (or (-> env :opts :ns) *ns*) overload-types-name)] (->> fn|types-var var-get urx/norx-deref :overload-types (uc/filter #(-> % :arg-types count (= inputs-ct)))) @@ -942,8 +945,8 @@ (defns- analyze-seq* "Analyze a seq after it has been macro-expanded. The ->`form` is post- incremental macroexpansion." - [env ::env, [caller|form _ & body _ :as form] _ > uast/node?] - (case caller|form + [env ::env, [caller|form _ & body _ :as form] _, expanded-caller-sym symbol? > uast/node?] + (case expanded-caller-sym . (analyze-seq|dot env form) (quantum.core.type/def quantum.untyped.core.type.defnt/def) (TODO "t/def" {:form form}) @@ -969,34 +972,37 @@ var (analyze-seq|var env form) (if (-> env :opts :arglist-context?) (if-let [caller-form-dependent-type-call? - (and (symbol? caller|form) - (when-let [sym (some-> - (uvar/resolve (or (-> env :opts :ns) *ns*) caller|form) - uid/>symbol)] - (case sym - (quantum.core.type/type - quantum.untyped.core.type/type - quantum.core.type/input-type - quantum.untyped.core.type/input-type - quantum.core.type/output-type - quantum.untyped.core.type/output-type) true - false)))] + (case expanded-caller-sym + (quantum.core.type/type + quantum.untyped.core.type/type + quantum.core.type/input-type + quantum.untyped.core.type/input-type + quantum.core.type/output-type + quantum.untyped.core.type/output-type) true + false)] (analyze-seq|dependent-type-call env form) (analyze-seq|call env form)) (analyze-seq|call env form)))) (defns- analyze-seq [env ::env, form _] - (let [expanded-form (case (first form) + (let [ns-val (or (-> env :opts :ns) *ns*) + caller|form (first form) + expanded-caller-sym (if (symbol? caller|form) + (or (some->> caller|form (uvar/resolve ns-val) uid/>symbol) + caller|form) + caller|form) + expanded-form (case expanded-caller-sym (quantum.core.type.defnt/dotyped quantum.untyped.core.type.defnt/dotyped quantum.core.type.defnt/fn quantum.untyped.core.type.defnt/fn quantum.core.type.defnt/defn - quantum.untyped.core.type.defnt/defn) + quantum.untyped.core.type.defnt/defn) form ; will be analyzed in `analyze-seq*` - (binding [*ns* (or (-> env :opts :ns) *ns*)] (ufeval/macroexpand form)))] + (binding [*ns* ns-val] + (ufeval/macroexpand form)))] (if-let [no-expansion? (ucomp/== form expanded-form)] - (analyze-seq* env expanded-form) + (analyze-seq* env expanded-form expanded-caller-sym) (let [expanded-form' (cond-> expanded-form (uvar/with-metable? expanded-form) (update-meta merge (meta form))) expanded (analyze* env expanded-form')] @@ -1008,19 +1014,18 @@ :expanded expanded :type (:type expanded)}))))) -(defns- ?resolve [env ::env, sym symbol?] +(defns- ?resolve + [env ::env, sym symbol? > (us/nilable (us/kv {:resolved some? :resolved-via keyword?}))] (if-let [[_ local] (or (find env sym) (and (-> env :opts :arglist-context?) (-> env :opts :arg-env deref (find sym))))] {:resolved local :resolved-via :env} - (let [resolved (uvar/resolve (or (-> env :opts :ns) *ns*) sym)] - (ifs resolved - {:resolved resolved :resolved-via :resolve} - (some->> sym namespace symbol (uvar/resolve (or (-> env :opts :ns) *ns*)) class?) - {:resolved (analyze-seq|dot - env (list '. (-> sym namespace symbol) (-> sym name symbol))) - :resolved-via :dot} - nil)))) + (if-let [resolved (uvar/resolve (or (-> env :opts :ns) *ns*) sym)] + {:resolved resolved :resolved-via :resolve} + (when (some->> sym namespace symbol (uvar/resolve (or (-> env :opts :ns) *ns*)) class?) + {:resolved (analyze-seq|dot + env (list '. (-> sym namespace symbol) (-> sym name symbol))) + :resolved-via :dot})))) (defns- analyze-symbol|arglist-context "Handles forward dependent-type dependencies e.g. `[a (type b) b t/any?]`" @@ -1104,6 +1109,7 @@ > uast/node? ([form _] (analyze {} form)) ([env ::env, form _] + (when (and (-> env (dissoc :opts) empty?) (-> form first name (= "fn"))) (throw (Exception.))) (uref/set! !!analyze-depth 0) (binding [*analyzing?* true] (analyze* env form)))) @@ -1121,6 +1127,13 @@ *print-level* 10] (quantum.untyped.core.print/ppr x))) +(defn pr-no-meta! [x] + (binding [quantum.untyped.core.analyze.ast/*print-env?* false + quantum.untyped.core.print/*collapse-symbols?* true + *print-meta* false + *print-level* 10] + (quantum.untyped.core.print/ppr x))) + #?(:clj (uvar/def sort-guide "for use in arglist sorting, in increasing conceptual (and bit) size" {t/nil? 0 @@ -1233,10 +1246,11 @@ > (us/vec-of (us/kv {:env ::env :output-type-node uast/node?}))] (uref/set! !!analyze-arg-syms|iter 0) (uref/set! !!dependent? false) - (try (analyze-arg-syms* - {:opts (merge (:opts env) - (>analyze-arg-syms|opts env arg-sym->arg-type-form output-type-or-form - split-types?))}) + (try (binding [*analyzing?* true] + (analyze-arg-syms* + {:opts (merge (:opts env) + (>analyze-arg-syms|opts env arg-sym->arg-type-form output-type-or-form + split-types?))})) (catch Throwable t (if (and (uerr/error-map? t) (-> t :ident (= ::arg-syms-analyzed))) (-> t :data :result) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 697aad60..2560d5ef 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -276,7 +276,7 @@ :fn|inline? boolean? :fn|meta (us/nilable :quantum.core.specs/meta) :fn|ns-name simple-symbol? - :fn|name ::uss/fn|name + :fn|name (us/nilable ::uss/fn|name) :fn|output-type t/type? :fn|output-type|form t/any? :fn|overload-bases-name simple-symbol? @@ -579,16 +579,18 @@ > ::overload] (let [;; Not sure if `nil` is the right approach for the value recursive-ast-node-reference - (when (= kind :defn) (uast/symbol {} fn|name nil fn|type)) + (when (not= kind :extend-defn!) (uast/symbol {} fn|name nil fn|type)) local-env (->> (zipmap (keys args-form) arg-types) (uc/map' (c/fn [[arg-binding arg-type]] [arg-binding (uast/unbound nil arg-binding arg-type)])) ;; To support recursion - (<- (cond-> (not= kind :extend-defn!) - (assoc fn|name - recursive-ast-node-reference - (uid/qualify fn|ns-name fn|overload-types-name) - fn|overload-types)))) + (<- (cond-> + (and fn|name (not= kind :extend-defn!)) + (assoc fn|name recursive-ast-node-reference) + (= kind :defn) + (assoc (uid/qualify fn|ns-name fn|overload-types-name) + (uast/var-value fn|overload-types-name fn|overload-types + (t/value fn|overload-types)))))) env' (-> env (merge local-env) (assoc-in [:opts :ns] (-> unanalyzed-overload :ns-name the-ns))) @@ -701,9 +703,9 @@ (defns- overload-basis-data>types+ "Split and primitivized; not yet sorted." - [{:keys [fn|output-type _]} ::fn|globals, ns-name-val _, args-form _, output-type|form _ - body-codelist _] - (->> (uana/analyze-arg-syms {:opts {:ns (the-ns ns-name-val)}} + [{:keys [fn|output-type _]} ::fn|globals, env ::uana/env, ns-name-val _, args-form _ + output-type|form _, body-codelist _] + (->> (uana/analyze-arg-syms (assoc-in env [:opts :ns] (the-ns ns-name-val)) args-form (or output-type|form fn|output-type) true) (uc/map+ (c/fn [{:keys [env output-type-node]}] (let [arg-env (->> env :opts :arg-env deref) @@ -786,6 +788,7 @@ `n` is the size of the existing overload types. 'Cheap' because only a `=` check is performed `n` times for each `m`. All other computations are done only once for each `m`." [fn|globals ::fn|globals + env ::uana/env {:keys [prev-norx _, current _]} ::overload-bases-data existing-overload-types (us/nilable (us/vec-of ::types-decl-datum)) > (us/vec-of ::unanalyzed-overload)] @@ -804,9 +807,8 @@ (seq-or #(and (= output-type (:output-type %)) (= arg-types (:arg-types %))) existing-overload-types))] - (->> (or types|split (overload-basis-data>types+ - fn|globals (:ns-name basis) args-form output-type|form - body-codelist|unanalyzed)) + (->> (or types|split (overload-basis-data>types+ fn|globals env (:ns-name basis) + args-form output-type|form body-codelist|unanalyzed)) (cond->> (and (not new-overload-basis?) (= (:body-codelist basis) (:body-codelist prev-basis))) (uc/remove+ type-signature-equal-to-existing?)) @@ -839,7 +841,7 @@ opts ::opts {:as fn|globals :keys [fn|name _, fn|ns-name _, fn|output-type _, fn|overload-types-name _]} ::fn|globals - env _ + env ::uana/env !overload-queue _ > ::fn|types] (establish-dependency-relations-on-new-overload-bases! fn|output-type overload-bases-data) @@ -853,7 +855,7 @@ :fn|output-type|new fn|output-type-norx})) (if-not-let [changed-unanalyzed-overloads (seq (>changed-unanalyzed-overloads - fn|globals overload-bases-data existing-overload-types))] + fn|globals env overload-bases-data existing-overload-types))] (or existing-fn-types {:fn|output-type-norx fn|output-type-norx :fn|type-norx (t/ftype (uid/qualify fn|ns-name fn|name) fn|output-type-norx) @@ -1036,6 +1038,7 @@ [opts ::opts {:as fn|globals :keys [fn|inline? _, fn|output-type _, fn|output-type _, fn|output-type|form _]} ::fn|globals + env ::uana/env {:as overload-basis-form {:as arglist-form args [:args _] @@ -1062,7 +1065,8 @@ (assert (-> varargs :binding-form first (= :sym)))) args-form (reduce-2 assoc (umap/om) arg-bindings arg-types|form) ns-name-val (>symbol *ns*) - [arglist-basis] (uana/analyze-arg-syms {:opts {:ns (the-ns ns-name-val)}} args-form + [arglist-basis] (uana/analyze-arg-syms + (assoc-in env [:opts :ns] (the-ns ns-name-val)) args-form (or output-type|form fn|output-type) false) binding->arg-type|basis (->> arglist-basis :env :opts :arg-env deref (uc/map-vals' :type)) arg-types|basis (->> args-form keys (uc/map binding->arg-type|basis)) @@ -1090,8 +1094,8 @@ ;; previous split types. If non-reactive, then the split types of this overload basis can be ;; compared to existing overload bases. :types|split (when dependent? - (->> (overload-basis-data>types+ fn|globals ns-name-val args-form - output-type|form body-codelist|unanalyzed) + (->> (overload-basis-data>types+ fn|globals env ns-name-val + args-form output-type|form body-codelist|unanalyzed) join)) ;; TODO Only needed if `inline? or `reactive?`, or if new :body-codelist body-codelist|unanalyzed @@ -1176,10 +1180,11 @@ but which can be updated and appended to." [{:as opts :keys [kind _]} ::opts {:as fn|globals :keys [fn|ns-name _, fn|overload-bases-name _]} ::fn|globals + env ::uana/env overload-bases-form _] (let [new-overload-bases - (->> overload-bases-form - (uc/map (c/fn [x] (overload-basis-form>overload-basis opts fn|globals x))))] + (->> overload-bases-form + (uc/map (c/fn [x] (overload-basis-form>overload-basis opts fn|globals env x))))] (if (= kind :extend-defn!) (with-do-let [!overload-bases (-> (uid/qualify fn|ns-name fn|overload-bases-name) resolve var-get)] @@ -1204,8 +1209,9 @@ #(uref/set! !overload-bases prev-overload-bases)) (uref/set! !overload-bases overload-bases')))) (with-do-let [!overload-bases (urx/! {:prev-norx nil :current new-overload-bases})] - (intern-with-rollback! - !global-rollback-queue fn|ns-name fn|overload-bases-name !overload-bases))))) + (when-not (= kind :fn) + (intern-with-rollback! + !global-rollback-queue fn|ns-name fn|overload-bases-name !overload-bases)))))) (defns- >!fn|types "`!fn|types` is a reaction which depends on the `!overload-bases` atom and all reactive types @@ -1228,8 +1234,9 @@ (overload-bases-data>fn|types overload-bases-data old-overload-types opts fn|globals env !overload-queue))) norx-deref)] - (intern-with-rollback! - !global-rollback-queue fn|ns-name fn|overload-types-name !fn|types)))) + (when-not (= kind :fn) + (intern-with-rollback! + !global-rollback-queue fn|ns-name fn|overload-types-name !fn|types))))) (defns- >!fn|type [{:as opts :keys [kind _]} ::opts @@ -1293,16 +1300,12 @@ (kw-map fn|fs-name fn|globals-name fn|inline? fn|meta fn|name fn|ns-name fn|output-type|form fn|output-type fn|overload-bases-name fn|overload-types-name fn|ts-name fn|type-name)] - (intern-with-rollback! !global-rollback-queue fn|ns-name fn|globals-name fn|globals) + (when-not (= kind :fn) + (intern-with-rollback! !global-rollback-queue fn|ns-name fn|globals-name fn|globals)) (kw-map fn|globals overload-bases-form))))) ;; ===== Whole `t/(de)fn` creation ===== ;; -(defns analyze-fn [env ::uana/env, form _] - (TODO)) - -(reset! uana/!!analyze-fnt analyze-fn) - (defns- >fn|ts "Creates the array-of-arrays containing the type input data, for consumption by dynamic dispatch. Interns the result as `fn|ts-name`." @@ -1327,16 +1330,9 @@ ;; TODO lazily and incrementally analyze this; maybe we want to do code transformations which don't ;; require analysis, as shown in tests -(defns- analyze-defn* [kind #{:defn :extend-defn!}, env ::uana/env, unanalyzed-form _ > uast/node?] - (let [opts (>fn|opts kind *compilation-mode*) - !overload-queue !global-overload-queue - {:keys [fn|globals overload-bases-form] - {:keys [fn|fs-name fn|globals-name fn|meta fn|name fn|ns-name fn|ts-name fn|type-name]} - :fn|globals} - (>fn|globals+?overload-bases-form kind unanalyzed-form) - !overload-bases (>!overload-bases opts fn|globals overload-bases-form) - !fn|types (>!fn|types opts fn|globals env !overload-bases !overload-queue) - fn|types (norx-deref !fn|types) +#_(defns- analyze-defn* [kind #{:defn :extend-defn!}, env ::uana/env, unanalyzed-form _ > uast/node?] + (analyze-fn* kind env unanalyzed-form) + (let [ fn|ts (>fn|ts fn|globals fn|types) !fn|type (>!fn|type opts fn|globals !fn|types) {:keys [form overloads]} @@ -1384,6 +1380,25 @@ :defn (uast/defnt-node ast-basis) :extend-defn! (uast/extend-defnt-node ast-basis)))) +(defns- analyze-fn* + [kind #{:defn :extend-defn! :fn}, env ::uana/env, unanalyzed-form _ > uast/node?] + (let [!overload-queue !global-overload-queue + opts (>fn|opts kind *compilation-mode*) + {:keys [fn|globals overload-bases-form] + {:keys [fn|fs-name fn|globals-name fn|meta fn|name fn|ns-name fn|ts-name fn|type-name]} + :fn|globals} + (>fn|globals+?overload-bases-form kind unanalyzed-form) + !overload-bases (>!overload-bases opts fn|globals env overload-bases-form) + !fn|types (>!fn|types opts fn|globals env !overload-bases !overload-queue) + fn|types (norx-deref !fn|types)] + @!overload-bases + (println "DONEEE") + (TODO))) + +(defns analyze-fn [env ::uana/env, form _] (analyze-fn* :fn env form)) + +(reset! uana/!!analyze-fnt analyze-fn) + (defns analyze-defn [env ::uana/env, form _ > uast/node?] (analyze-defn* :defn env form)) (reset! uana/!!analyze-defnt analyze-defn) From 03dbc04ff6e324d4006892124ebea70de1d428ff Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 5 Dec 2018 10:04:23 -0700 Subject: [PATCH 795/810] t/fn analysis is well on its way --- resources-dev/defnt.cljc | 5 +- .../quantum/untyped/core/analyze/ast.cljc | 20 ++ .../quantum/untyped/core/type/defnt.cljc | 263 +++++++++--------- 3 files changed, 157 insertions(+), 131 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 785cc09d..79983bd7 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -69,6 +69,8 @@ Legend: [ ] t/ftype should automatically split types, while perhaps t/ftype* should just assume they're split (for use by e.g. `t/fn` and `t/defn`) [ ] test t/fn to make sure meta 'sticks' : `(t/fn {...} [] ...)` + [ ] support `ts` and `types` referring to closed-over local vars + - Should do e.g. `(OrType. ... [t/boolean? (AndType. ...)])` to have minimal overhead [2] `?` : type inference - use logic programming and variable unification e.g. `?1` `?2` ? - For this situation: `?` is `(t/- dc/counted?)` @@ -76,8 +78,7 @@ Legend: ([n dn/std-integer?, xs ?] ...) - [ ] No trailing `>` means `> ?` [3] inner expansion (see tests to see how this could work) - [4] make local vars sanitary/safe by making better use of the gensym feature - [5] t/numerically : e.g. a double representing exactly what a float is able to represent + [4] t/numerically : e.g. a double representing exactly what a float is able to represent - and variants thereof: `numerically-long?` etc. - t/numerically-integer? - Primitive conversions not requiring checks can go in data.primitive diff --git a/src-untyped/quantum/untyped/core/analyze/ast.cljc b/src-untyped/quantum/untyped/core/analyze/ast.cljc index 31f08cef..fe5cdfc2 100644 --- a/src-untyped/quantum/untyped/core/analyze/ast.cljc +++ b/src-untyped/quantum/untyped/core/analyze/ast.cljc @@ -372,6 +372,26 @@ (defn throw-node? [x] (instance? ThrowNode x)) +(defrecord TypedFnNode + [env #_::env + unanalyzed-form #_::t/form + name #_simple-symbol? + meta #_meta? + overloads #_(t/vec-of (t/kv {:arg-types (t/vec-of t/type?) + :type t/type? + :body node?})) + form #_::t/form + type #_t/type?] + INode + fipp.ednize/IOverride + fipp.ednize/IEdn + (-edn [this] (list `fnt-node (std-print-structure this)))) + +;; Not type hinted because it's inferred +(defn fnt-node [m] (map->TypedFnNode m)) + +(defn fnt-node? [x] (instance? TypedFnNode x)) + (defrecord TypedDefnNode [env #_::env unanalyzed-form #_::t/form diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 2560d5ef..e8e74e49 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -82,27 +82,31 @@ `extend-defn!`." (uvec/alist)) ; (t/!seq-of (t/ftype [])) -(defns- intern-with-rollback! [!rollback-queue _, ns-sym simple-symbol?, sym simple-symbol?, v _] - (let [var-val (resolve (uid/qualify ns-sym sym)) - !value (atom nil)] - (when var-val (reset! !value (var-get var-val))) - (intern ns-sym sym v) - (alist-conj! !rollback-queue - #(if var-val - (intern ns-sym sym @!value) - (uvar/unintern! ns-sym sym))))) +(defns- intern-with-rollback! + ([ns-sym simple-symbol?, sym simple-symbol?, v _] + (intern-with-rollback! !global-rollback-queue ns-sym sym v)) + ([!rollback-queue _, ns-sym simple-symbol?, sym simple-symbol?, v _] + (let [var-val (resolve (uid/qualify ns-sym sym)) + !value (atom nil)] + (when var-val (reset! !value (var-get var-val))) + (intern ns-sym sym v) + (alist-conj! !rollback-queue + #(if var-val + (intern ns-sym sym @!value) + (uvar/unintern! ns-sym sym)))))) (defn- drain-rollback-queue! "Rolls back already-executed effects in reverse order." - [!rollback-queue] - (->> !rollback-queue - reverse - (uc/run! - (c/fn [rollback-fn] - (uerr/catch-all (rollback-fn) - rollback-err - (err! nil "Unable to roll back all effects" {:failed-rollback-fn rollback-fn} - nil rollback-err)))))) + ([] (drain-rollback-queue! !global-rollback-queue)) + ([!rollback-queue] + (->> !rollback-queue + reverse + (uc/run! + (c/fn [rollback-fn] + (uerr/catch-all (rollback-fn) + rollback-err + (err! nil "Unable to roll back all effects" {:failed-rollback-fn rollback-fn} + nil rollback-err))))))) (defns- with-rollback! [!overload-queue _, !rollback-queue _, f fn?] (uerr/catch-all @@ -114,9 +118,12 @@ (do (uvec/alist-empty! !rollback-queue) (uvec/alist-empty! !overload-queue)))) -(defns- analyze-with-rollback! [unanalyzed-form _] - (with-rollback! !global-overload-queue !global-rollback-queue - (c/fn [] (-> unanalyzed-form uana/analyze :form)))) +(defns- analyze-with-rollback! + ([unanalyzed-form _] + (analyze-with-rollback! !global-overload-queue !global-rollback-queue unanalyzed-form)) + ([!overload-queue _, !rollback-queue _, unanalyzed-form _] + (with-rollback! !overload-queue !rollback-queue + (c/fn [] (-> unanalyzed-form uana/analyze :form))))) ;; ===== Macros ===== ;; @@ -140,7 +147,7 @@ (list 'quantum.untyped.core.type.defnt/def sym doc-or-meta nil v) (list 'quantum.untyped.core.type.defnt/def sym nil doc-or-meta v))) ([sym doc meta-val v] - (with-rollback! !global-overload-queue !global-rollback-queue + (with-rollback! (c/fn [] (list 'def (if (or doc meta-val) @@ -277,6 +284,7 @@ :fn|meta (us/nilable :quantum.core.specs/meta) :fn|ns-name simple-symbol? :fn|name (us/nilable ::uss/fn|name) + :fn|name|global ::uss/fn|name :fn|output-type t/type? :fn|output-type|form t/any? :fn|overload-bases-name simple-symbol? @@ -578,17 +586,18 @@ fn|type (us/nilable t/type?) > ::overload] (let [;; Not sure if `nil` is the right approach for the value - recursive-ast-node-reference - (when (not= kind :extend-defn!) (uast/symbol {} fn|name nil fn|type)) + ?recursive-ast-node-reference + (when (and fn|name (not= kind :extend-defn!)) (uast/symbol {} fn|name nil fn|type)) local-env (->> (zipmap (keys args-form) arg-types) (uc/map' (c/fn [[arg-binding arg-type]] [arg-binding (uast/unbound nil arg-binding arg-type)])) ;; To support recursion (<- (cond-> (and fn|name (not= kind :extend-defn!)) - (assoc fn|name recursive-ast-node-reference) - (= kind :defn) - (assoc (uid/qualify fn|ns-name fn|overload-types-name) + (assoc fn|name + ?recursive-ast-node-reference + ;; TODO maybe there's a better way for fns + (uid/qualify fn|ns-name fn|overload-types-name) (uast/var-value fn|overload-types-name fn|overload-types (t/value fn|overload-types)))))) env' (-> env @@ -635,13 +644,6 @@ ;; ----- Direct dispatch: `reify` ---- ;; -(defns- >reify-name-unhinted - ([fn|name simple-symbol?, overload|id ::overload|id > simple-symbol?] - (symbol (str fn|name "|__" overload|id))) - ([fn|ns-name simple-symbol?, fn|name simple-symbol?, overload|id ::overload|id - > qualified-symbol?] - (symbol (name fn|ns-name) (str fn|name "|__" overload|id)))) - #?(:clj (defns overload>reify [{:as opts :keys [gen-gensym _]} ::opts @@ -676,7 +678,7 @@ (c/defn overload-types>ftype [fn|ns-name #_simple-symbol? - ?fn|name #_(s/nilable simple-symbol?) + fn|name|global #_simple-symbol? overload-types #_(vec-of ::type-datum) fn|output-type #_t/type?] (let [overload-types' (->> overload-types @@ -684,16 +686,15 @@ (cond-> arg-types pre-type (conj :| pre-type) output-type (conj :> output-type)))))] - (if ?fn|name - (apply t/ftype (uid/qualify fn|ns-name ?fn|name) fn|output-type overload-types') - (apply t/ftype fn|output-type overload-types')))) + (apply t/ftype (uid/qualify fn|ns-name fn|name|global) fn|output-type overload-types'))) (c/defn- dedupe-overload-types-data [fn|ns-name fn|name types-decl-data] (->> types-decl-data (dedupe-type-data (c/fn [data prev-datum datum] (ulog/ppr :warn - (str "Overwriting type overload for `" (uid/qualify fn|ns-name fn|name) "`") + (str "Overwriting type overload for `" + (cond->> fn|name fn|name (uid/qualify fn|ns-name)) "`") {:arg-types-prev (:arg-types prev-datum) :arg-types (:arg-types datum)}) (-> data pop (conj (assoc datum :id (:id prev-datum) @@ -838,11 +839,11 @@ but not `=` then that overload will be rejected." [overload-bases-data ::overload-bases-data existing-fn-types (us/nilable ::fn|types) - opts ::opts + {:as opts :keys [kind _]} ::opts {:as fn|globals - :keys [fn|name _, fn|ns-name _, fn|output-type _, fn|overload-types-name _]} ::fn|globals - env ::uana/env - !overload-queue _ + :keys [fn|name _, fn|name|global _, fn|ns-name _, fn|output-type _, fn|overload-types-name _]} + ::fn|globals + env ::uana/env > ::fn|types] (establish-dependency-relations-on-new-overload-bases! fn|output-type overload-bases-data) (let [fn|output-type-norx|prev (:fn|output-type-norx existing-fn-types) @@ -858,8 +859,8 @@ fn|globals env overload-bases-data existing-overload-types))] (or existing-fn-types {:fn|output-type-norx fn|output-type-norx - :fn|type-norx (t/ftype (uid/qualify fn|ns-name fn|name) fn|output-type-norx) - :overload-types []}) + :fn|type-norx (t/ftype (uid/qualify fn|ns-name fn|name|global) fn|output-type-norx) + :overload-types []}) (let [sorted-changed-unanalyzed-overloads (->> changed-unanalyzed-overloads (sort-overload-types :arg-types) @@ -891,7 +892,7 @@ ;; Partially for recursive purposes fn|type-norx (overload-types>ftype - fn|ns-name fn|name overload-types-with-replacing-ids fn|output-type-norx) + fn|ns-name fn|name|global overload-types-with-replacing-ids fn|output-type-norx) ;; We should analyze everything first in order to figure out body-dependent input types ;; before we can compare them against each other, but we're ignoring body-dependent input ;; types for now @@ -913,7 +914,8 @@ (- id first-current-overload-id)) datum' (assoc datum :interface (:interface overload))] ;; So that direct dispatch can use `overload` later on - (alist-conj! !overload-queue (assoc datum :overload overload)) + (alist-conj! + !global-overload-queue (assoc datum :overload overload)) datum') datum)] @@ -926,12 +928,11 @@ (defns- >direct-dispatch-seq "Generates a seq of unevaluated direct-dispatch `reify`s sorted by index." [{:as opts :keys [gen-gensym _, kind _]} ::opts - fn|globals ::fn|globals - fn|types ::fn|types - !overload-queue _ + fn|globals ::fn|globals + fn|types ::fn|types > ::direct-dispatch-seq] (case ucore/lang - :clj (->> !overload-queue + :clj (->> !global-overload-queue (uc/map (c/fn [{:as type-decl-datum :keys [arg-types id index overload]}] (overload>reify opts fn|globals overload id index))) @@ -965,8 +966,7 @@ :arg-index i})))) (defns- >combinatoric-seq+ - [{:as fn|globals :keys [fn|ns-name _ fn|name _]} ::fn|globals - overload-types-for-arity (us/vec-of ::types-decl-datum) + [overload-types-for-arity (us/vec-of ::types-decl-datum) ts|name simple-symbol? fs|name simple-symbol? relevant-arglist (us/vec-of simple-symbol?)] @@ -984,11 +984,15 @@ ~(get relevant-arglist i|arg))})))]))))) (defns- >dynamic-dispatch|body-for-arity - [{:as fn|globals :keys [fn|ns-name _, fn|name _]} ::fn|globals + [{:as opts :keys [kind _]} ::opts + {:as fn|globals :keys [fn|ns-name _, fn|name _]} ::fn|globals overload-types-for-arity (us/vec-of ::types-decl-datum) arglist (us/vec-of simple-symbol?)] (let [[ts|name fs|name & relevant-arglist] arglist - relevant-arglist (>vec relevant-arglist)] + relevant-arglist (>vec relevant-arglist) + unsupported-name (if fn|name + (if (= kind :fn) fn|name (uid/qualify fn|ns-name fn|name)) + ')] (if (empty? relevant-arglist) (let [{:as types-decl-datum :keys [id interface]} (first overload-types-for-arity)] (>direct-dispatch|reify-call id interface fs|name relevant-arglist)) @@ -997,8 +1001,8 @@ (c/fn ([] (transient [`ifs])) ([ret] - (-> ret (conj! `(unsupported! '~(uid/qualify fn|ns-name fn|name) - ~relevant-arglist ~(deref !!i|arg))) + (-> ret (conj! `(unsupported! + '~unsupported-name ~relevant-arglist ~(deref !!i|arg))) persistent! seq)) ([ret getf x i] @@ -1009,12 +1013,11 @@ (aritoid combinef combinef (c/fn [x [{:keys [getf i]} group]] (combinef x getf group i))) uc/conj!|rf (aritoid combinef combinef (c/fn [x [k [{:keys [getf i]}]]] (combinef x getf k i))) - (>combinatoric-seq+ - fn|globals overload-types-for-arity ts|name fs|name relevant-arglist)))))) + (>combinatoric-seq+ overload-types-for-arity ts|name fs|name relevant-arglist)))))) (defns- >dynamic-dispatch [{:as opts :keys [compilation-mode _, gen-gensym _, kind _]} ::opts - {:as fn|globals :keys [fn|meta _, fn|ns-name _, fn|name _, fn|output-type _ + {:as fn|globals :keys [fn|meta _, fn|ns-name _, fn|output-type _ fn|overload-types-name _, fn|type-name _]} ::fn|globals fn|types ::fn|types] (let [overload-forms @@ -1027,7 +1030,7 @@ fs|name (with-array-type-hint (gen-gensym "fs")) arglist (join [ts|name fs|name] (ufgen/gen-args 0 arg-ct "x" gen-gensym)) body (>dynamic-dispatch|body-for-arity - fn|globals overload-types-for-arity arglist)] + opts fn|globals overload-types-for-arity arglist)] (list arglist body)))))] {:form (when-not (empty? overload-forms) `(fn* ~@overload-forms))})) @@ -1205,13 +1208,13 @@ :current (incorporate-overload-bases current new-overload-bases)}] (with-optional-validate-overload-bases overload-bases') (let [prev-overload-bases (norx-deref !overload-bases)] - (alist-conj! !global-rollback-queue - #(uref/set! !overload-bases prev-overload-bases)) + (when-not (= kind :fn) + (alist-conj! !global-rollback-queue + #(uref/set! !overload-bases prev-overload-bases))) (uref/set! !overload-bases overload-bases')))) (with-do-let [!overload-bases (urx/! {:prev-norx nil :current new-overload-bases})] (when-not (= kind :fn) - (intern-with-rollback! - !global-rollback-queue fn|ns-name fn|overload-bases-name !overload-bases)))))) + (intern-with-rollback! fn|ns-name fn|overload-bases-name !overload-bases)))))) (defns- >!fn|types "`!fn|types` is a reaction which depends on the `!overload-bases` atom and all reactive types @@ -1223,8 +1226,7 @@ [{:as opts :keys [kind _]} ::opts {:as fn|globals :keys [fn|ns-name _, fn|overload-types-name _, fn|type-name _]} ::fn|globals env ::uana/env - !overload-bases urx/reactive? - !overload-queue _] + !overload-bases urx/reactive?] (if (= kind :extend-defn!) (-> (uid/qualify fn|ns-name fn|overload-types-name) resolve var-get) (with-do-let [!fn|types (doto (urx/!rx @!overload-bases) @@ -1232,11 +1234,10 @@ (c/fn [_ _ old-overload-types overload-bases-data] ;; `opts` and `fn|globals` are closed over (overload-bases-data>fn|types overload-bases-data - old-overload-types opts fn|globals env !overload-queue))) + old-overload-types opts fn|globals env))) norx-deref)] (when-not (= kind :fn) - (intern-with-rollback! - !global-rollback-queue fn|ns-name fn|overload-types-name !fn|types))))) + (intern-with-rollback! fn|ns-name fn|overload-types-name !fn|types))))) (defns- >!fn|type [{:as opts :keys [kind _]} ::opts @@ -1245,7 +1246,7 @@ (if (= kind :extend-defn!) (-> (uid/qualify fn|ns-name fn|type-name) resolve var-get) (with-do-let [!fn|type (t/rx* (urx/>!rx #(:fn|type-norx @!fn|types) {:eq-fn t/=}) nil)] - (intern-with-rollback! !global-rollback-queue fn|ns-name fn|type-name !fn|type)))) + (when-not (= kind :fn) (intern-with-rollback! fn|ns-name fn|type-name !fn|type))))) ;; ===== `opts` + `fn|globals` ===== ;; @@ -1253,14 +1254,17 @@ "`opts` are per invocation of `t/defn` and/or `extend-defn!`, while `globals` persist for as long as the `t/defn` does." [kind ::kind, compilation-mode ::compilation-mode > ::opts] - (let [gen-gensym-base (ufgen/>reproducible-gensym|generator) + (let [gen-gensym-base (if (= compilation-mode :test) + (ufgen/>reproducible-gensym|generator) + gensym) gen-gensym (c/fn [x] (symbol (str (gen-gensym-base x) "__")))] (kw-map compilation-mode gen-gensym kind))) (defns- >fn|globals+?overload-bases-form "`opts` are per invocation of `t/defn` and/or `extend-defn!`, while `globals` persist for as long as the `t/defn` does." - [kind ::kind, unanalyzed-form _ > (us/kv {:fn|globals ::fn|globals :overload-bases-form t/any?})] + [{:as opts :keys [gen-gensym _, kind _]} ::opts, unanalyzed-form _ + > (us/kv {:fn|globals ::fn|globals :overload-bases-form t/any?})] (let [{:keys [:quantum.core.specs/fn|name :quantum.core.defnt/fn|extended-name :quantum.core.defnt/output-spec] @@ -1277,10 +1281,13 @@ fn|ns-name (if (= kind :extend-defn!) (-> fn|var >?namespace >symbol) (>symbol *ns*)) - fn|name (if (= kind :extend-defn!) - (-> fn|extended-name >name symbol) + fn|name (case kind + :extend-defn! (-> fn|extended-name >name symbol) + (:defn :fn) fn|name) + fn|name|global (if (= kind :fn) + (symbol (str fn|name (when fn|name "|") (gen-gensym "__anon"))) fn|name) - fn|globals-name (symbol (str fn|name "|__globals"))] + fn|globals-name (symbol (str fn|name|global "|__globals"))] (if (= kind :extend-defn!) {:fn|globals (-> (uid/qualify fn|ns-name fn|globals-name) resolve var-get) :overload-bases-form overload-bases-form} @@ -1291,17 +1298,16 @@ fn|output-type|form (or (second output-spec) `t/any?) ;; TODO this needs to be analyzed for dependent types referring to local vars fn|output-type (eval fn|output-type|form) - fn|overload-bases-name (symbol (str fn|name "|__bases")) - fn|overload-types-name (symbol (str fn|name "|__types")) - fn|type-name (symbol (str fn|name "|__type")) - fn|ts-name (symbol (str fn|name "|__ts")) - fn|fs-name (symbol (str fn|name "|__fs")) + fn|overload-bases-name (symbol (str fn|name|global "|__bases")) + fn|overload-types-name (symbol (str fn|name|global "|__types")) + fn|type-name (symbol (str fn|name|global "|__type")) + fn|ts-name (symbol (str fn|name|global "|__ts")) + fn|fs-name (symbol (str fn|name|global "|__fs")) fn|globals ; TODO use record here - (kw-map fn|fs-name fn|globals-name fn|inline? fn|meta fn|name fn|ns-name - fn|output-type|form fn|output-type fn|overload-bases-name + (kw-map fn|fs-name fn|globals-name fn|inline? fn|meta fn|name fn|name|global + fn|ns-name fn|output-type|form fn|output-type fn|overload-bases-name fn|overload-types-name fn|ts-name fn|type-name)] - (when-not (= kind :fn) - (intern-with-rollback! !global-rollback-queue fn|ns-name fn|globals-name fn|globals)) + (when-not (= kind :fn) (intern-with-rollback! fn|ns-name fn|globals-name fn|globals)) (kw-map fn|globals overload-bases-form))))) ;; ===== Whole `t/(de)fn` creation ===== ;; @@ -1311,14 +1317,16 @@ Interns the result as `fn|ts-name`." ;; TODO but maybe can use a 2D array to avoid having to double cast with `(aget* (aget* &ts 1) 0)` {:performance "Can't flatten this array because the param sizes are variable."} - [{:as fn|globals :keys [fn|ns-name _, fn|ts-name _]} ::fn|globals + [{:as opts :keys [kind _]} ::opts + {:as fn|globals :keys [fn|ns-name _, fn|ts-name _]} ::fn|globals fn|types ::fn|types #_> #_(t/of oarray? (t/of oarray? t/type?))] (let [ts (->> fn|types :overload-types (uc/map+ (fn-> :arg-types uc/>array)) uc/>array)] - (intern-with-rollback! !global-rollback-queue fn|ns-name fn|ts-name ts) + ;; TODO need to avoid this in CLJS and when there are closed over locals in the type + (intern-with-rollback! fn|ns-name fn|ts-name ts) ts)) (defns- >overload-types|form [{:as fn|opts :keys [compilation-mode _]} ::opts, fn|types ::fn|types] @@ -1330,36 +1338,47 @@ ;; TODO lazily and incrementally analyze this; maybe we want to do code transformations which don't ;; require analysis, as shown in tests -#_(defns- analyze-defn* [kind #{:defn :extend-defn!}, env ::uana/env, unanalyzed-form _ > uast/node?] - (analyze-fn* kind env unanalyzed-form) - (let [ - fn|ts (>fn|ts fn|globals fn|types) +(defns- analyze-fn* + [kind #{:defn :extend-defn! :fn}, env ::uana/env, unanalyzed-form _ > uast/node?] + (let [opts (>fn|opts kind *compilation-mode*) + {:keys [fn|globals overload-bases-form] + {:keys [fn|fs-name fn|globals-name fn|meta fn|name fn|name|global fn|ns-name fn|ts-name + fn|type-name]} + :fn|globals} + (>fn|globals+?overload-bases-form opts unanalyzed-form) + !overload-bases (>!overload-bases opts fn|globals env overload-bases-form) + !fn|types (>!fn|types opts fn|globals env !overload-bases) + fn|types (norx-deref !fn|types) + fn|ts (>fn|ts opts fn|globals fn|types) !fn|type (>!fn|type opts fn|globals !fn|types) {:keys [form overloads]} (if (empty? (norx-deref !overload-bases)) - {:form `(declare ~(:fn|name fn|globals)) - :overloads []} - (let [fn|meta (merge fn|meta - {:quantum.core.type/type (uid/qualify fn|ns-name fn|type-name)}) - direct-dispatch-seq - (>direct-dispatch-seq opts fn|globals fn|types !overload-queue) - dynamic-dispatch - (>dynamic-dispatch opts fn|globals fn|types) - qualified-ts-name (uid/qualify fn|ns-name fn|ts-name) - defmeta-form - `(uvar/defmeta-from ~fn|name - (let* [~fn|fs-name (uarr/*<>|sized ~(-> fn|types :overload-types count)) - ~fn|name (new TypedFn ~fn|meta ~qualified-ts-name ~fn|fs-name - ~(:form dynamic-dispatch))] - ~@(->> direct-dispatch-seq - (map (c/fn [{:as reify-data :keys [id form]}] - (aset* fn|fs-name id form)))) - ~fn|name)) + (if (= kind :defn) + {:form `(declare ~(:fn|name|global fn|globals)) + :overloads []} + (err! "Overloads cannot be empty for non-`t/defn`s." {:form unanalyzed-form})) + (let [fn|meta (cond-> fn|meta + (not= kind :fn) (merge {:quantum.core.type/type + (uid/qualify fn|ns-name fn|type-name)})) + direct-dispatch-seq (>direct-dispatch-seq opts fn|globals fn|types) + dynamic-dispatch (>dynamic-dispatch opts fn|globals fn|types) + qualified-ts-name (uid/qualify fn|ns-name fn|ts-name) + fn-form + `(let* [~fn|fs-name (uarr/*<>|sized ~(-> fn|types :overload-types count)) + ~fn|name|global (new TypedFn ~fn|meta ~qualified-ts-name ~fn|fs-name + ~(:form dynamic-dispatch))] + ~@(->> direct-dispatch-seq + (map (c/fn [{:as reify-data :keys [id form]}] + (aset* fn|fs-name id form)))) + ~fn|name|global) + overall-form (case kind + :fn fn-form + :defn `(uvar/defmeta-from ~fn|name|global ~fn-form) + ;; FIXME extend-defn should redefine the fs, ts, and dynamic dispatch of the existing TypedFn object + :extend-fn! (TODO)) overload-types|form (>overload-types|form opts fn|types)] - {:form (if overload-types|form - `(do ~overload-types|form - ~defmeta-form) - `(do ~defmeta-form)) + {:form `(do ~@(cond-> [] overload-types|form (conj overload-types|form)) + ~overall-form) :overloads (->> direct-dispatch-seq (uc/map (c/fn [{:keys [overload]}] @@ -1377,29 +1396,15 @@ ;; to the defn that then is extended? Will that not happen correctly? :type (norx-deref !fn|type)}] (case kind + :fn (uast/fnt-node ast-basis) :defn (uast/defnt-node ast-basis) :extend-defn! (uast/extend-defnt-node ast-basis)))) -(defns- analyze-fn* - [kind #{:defn :extend-defn! :fn}, env ::uana/env, unanalyzed-form _ > uast/node?] - (let [!overload-queue !global-overload-queue - opts (>fn|opts kind *compilation-mode*) - {:keys [fn|globals overload-bases-form] - {:keys [fn|fs-name fn|globals-name fn|meta fn|name fn|ns-name fn|ts-name fn|type-name]} - :fn|globals} - (>fn|globals+?overload-bases-form kind unanalyzed-form) - !overload-bases (>!overload-bases opts fn|globals env overload-bases-form) - !fn|types (>!fn|types opts fn|globals env !overload-bases !overload-queue) - fn|types (norx-deref !fn|types)] - @!overload-bases - (println "DONEEE") - (TODO))) - (defns analyze-fn [env ::uana/env, form _] (analyze-fn* :fn env form)) (reset! uana/!!analyze-fnt analyze-fn) -(defns analyze-defn [env ::uana/env, form _ > uast/node?] (analyze-defn* :defn env form)) +(defns analyze-defn [env ::uana/env, form _ > uast/node?] (analyze-fn* :defn env form)) (reset! uana/!!analyze-defnt analyze-defn) From c0b96f9bd2ac41cc9d9e0f818e5f084aaf72ef2d Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 5 Dec 2018 13:38:30 -0700 Subject: [PATCH 796/810] Closer in making test work --- src-untyped/quantum/untyped/core/analyze.cljc | 10 +- .../quantum/untyped/core/type/defnt.cljc | 30 +--- .../test/untyped/core/type/compare.cljc | 3 +- .../quantum/test/untyped/core/type/defnt.cljc | 148 +++++++++--------- 4 files changed, 90 insertions(+), 101 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 8901feb1..83ec228d 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -709,10 +709,18 @@ (defns- overload-type-datum>reify-name [type-datum _, fn|name symbol? > qualified-symbol?] (symbol (-> type-datum :ns-name name) (str (name fn|name) "|__" (:id type-datum)))) +(defn aget* [x i] + #?(:clj (list '. 'clojure.lang.RT 'aget x i) + :cljs (list 'cljs.core/aget x i))) + +(defn aset* [x i v] + #?(:clj (list '. 'clojure.lang.RT 'aset x i v) + :cljs (list 'cljs.core/aset x i v))) + (defns- >direct-dispatch|reify-call [caller|node uast/node?, caller|type _, type-datum _, args-codelist (us/seq-of t/any?)] (if-let [fn|name (utr/fn-type>fn-name caller|type)] - `(. ~(overload-type-datum>reify-name type-datum fn|name) + `(. ~(aget* (symbol (str (name fn|name) "|__fs")) (:id type-datum)) ~direct-dispatch-method-sym ~@args-codelist) (err! "No name found for typed fn corresponding to caller; cannot create direct dispatch call" (assoc (select-keys caller|node [:unanalyzed-form :form]) :type caller|type)))) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index e8e74e49..63375997 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -942,14 +942,6 @@ ;; ===== Dynamic dispatch ===== ;; -(c/defn aget* [x i] - #?(:clj (list '. 'clojure.lang.RT 'aget x i) - :cljs (list 'cljs.core/aget x i))) - -(c/defn aset* [x i v] - #?(:clj (list '. 'clojure.lang.RT 'aset x i v) - :cljs (list 'cljs.core/aset x i v))) - (defns >direct-dispatch|reify-call [overload|id ::overload|id, reify|interface class?, fs|name simple-symbol? relevant-arglist (us/vec-of simple-symbol?)] @@ -1329,13 +1321,6 @@ (intern-with-rollback! fn|ns-name fn|ts-name ts) ts)) -(defns- >overload-types|form [{:as fn|opts :keys [compilation-mode _]} ::opts, fn|types ::fn|types] - (when (= compilation-mode :test) - (->> fn|types :overload-types - (uc/map (c/fn [{:keys [id index inline? arg-types output-type]}] - [id index inline? arg-types output-type])) - fedn/-edn))) - ;; TODO lazily and incrementally analyze this; maybe we want to do code transformations which don't ;; require analysis, as shown in tests (defns- analyze-fn* @@ -1370,15 +1355,12 @@ ~@(->> direct-dispatch-seq (map (c/fn [{:as reify-data :keys [id form]}] (aset* fn|fs-name id form)))) - ~fn|name|global) - overall-form (case kind - :fn fn-form - :defn `(uvar/defmeta-from ~fn|name|global ~fn-form) - ;; FIXME extend-defn should redefine the fs, ts, and dynamic dispatch of the existing TypedFn object - :extend-fn! (TODO)) - overload-types|form (>overload-types|form opts fn|types)] - {:form `(do ~@(cond-> [] overload-types|form (conj overload-types|form)) - ~overall-form) + ~fn|name|global)] + {:form (case kind + :fn fn-form + :defn `(uvar/defmeta-from ~fn|name|global ~fn-form) + ;; FIXME extend-defn should redefine the fs, ts, and dynamic dispatch of the existing TypedFn object + :extend-fn! (TODO)) :overloads (->> direct-dispatch-seq (uc/map (c/fn [{:keys [overload]}] diff --git a/test/quantum/test/untyped/core/type/compare.cljc b/test/quantum/test/untyped/core/type/compare.cljc index 869bd4ad..73242fe0 100644 --- a/test/quantum/test/untyped/core/type/compare.cljc +++ b/test/quantum/test/untyped/core/type/compare.cljc @@ -1331,8 +1331,7 @@ (testing "universal class(-set) identity" (is (t/= t/val? (& t/any? t/val?))))) -;; TODO incorporate into the other test? -(deftest test|fn +(deftest test|ftype #_"When we compare a t/ftype to another t/ftype, we are comparing set extensionality, as always. If we take the Wiener–Hausdorff–Kuratowski definition of a function as our definition of choice, then we may model a function as a set of ordered pairs, each of whose first element diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 0cfc5100..7a5edbe6 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -33,9 +33,8 @@ ;; TODO test `:inline` -;; Just in case -(clojure.spec.test.alpha/unstrument) (do (require '[orchestra.spec.test :as st]) + (clojure.spec.test.alpha/unstrument) (orchestra.spec.test/unstrument) (orchestra.spec.test/instrument)) @@ -2515,86 +2514,87 @@ (macroexpand ' ;: FIXME this contract is not being held up when returning nil (self/defn f0|test [a (t/or tt/boolean? tt/double?) - > (t/ftype [tt/byte? :> (t/ftype [tt/char?])])] + ;> (t/ftype [tt/byte? :> (t/ftype [tt/char?])]) + ] ;; TODO this fits into a larger scheme of, should we have output types be ;; `(t/and actual declared)` or should we just have them be `declared`? The ;; latter is easier but it seems like the `t/fn` dispatch forces our hand ;; towards the former. We need to think about this more. (self/fn [b (t/or tt/byte? tt/char?) - > (t/ftype [(t/or (t/type a) tt/short?)])] + ;> (t/ftype [(t/or (t/type a) tt/short?)]) + ] (self/fn f1|test [c (t/or (t/type a) tt/short?)] b (f1|test a) (f1|test c)))))) expected - (case (env-lang) - :clj - ($ (do [[0 0 false [] (t/ftype tt/boolean? [tt/byte? :> (t/ftype [tt/char?])])]] - (defmeta-from ~'f0|test - (let* [~'f0|test|__fs (*<>|sized 2) - ~'f0|test - (new TypedFn - {:quantum.core.type/type ~'f0|test|__type} - ... - ~'f0|test|__fs - (fn* ([~&ts ~&fs ~'x00__] - (ifs (~(aget* (aget* &ts 0) 0) ~'x00__) - (. ~(aget* &ts 0) ~'invoke ~'x00__) - (~(aget* (aget* &ts 1) 0) ~'x00__) - (. ~(aget* &ts 1) ~'invoke ~'x00__) - (unsupported! `f0|test [~'x00__] 0)))))] - ~(aset* f0|test|__fs 0 - `(reify* [~(csym `B__O)] - (~'invoke [~&this ~(B 'a)] - ;; From `(self/fn [b ...])` - (let* [~'f__0|__fs (*<>|sized 2) - ~'f__0 - (new TypedFn nil - ;; TODO perhaps extern this (and parts thereof) whenever - ;; possible in `let*` statement on the very outside of the fn - ;; (so around the outer `reify*`) ? - (*<> (*<> t/byte?) (*<> t/char?)) - ~'f__0|__fs - (fn* ([~&ts ~&fs ~'x00__] - (ifs (~(aget* (aget* ~&ts 0) 0) ~'x00__) - (. ~(>Y__O (aget* &fs 0)) ~'invoke ~'x00__) - (~(aget* (aget* ~&ts 1) 0) ~'x00__) - (. ~(>C__O (aget* &fs 1)) ~'invoke ~'x00__) - (unsupported! [~'x00__] 0)))))] - ~(aset* f__0|__fs 0 - `(reify* [~(csym `Y__O)] - (~'invoke [~'_0__ ~(Y 'b)] - ;; From `(self/fn [c ...])` - (let* [~'f1|test|__fs (*<>|sized 2) - ~'f1|test - (new TypedFn nil - (*<> (*<> t/boolean?) (*<> t/short?)) - ~'f1|test|__fs - (fn* ([~&ts ~&fs ~'x00] - (ifs (~(aget* (aget* &ts 0) 0) ~'x00__) - (. ~(>B__O (aget* &fs 0)) ~'invoke ~'x00__) - (~(aget* (aget* &ts 1) 0) ~'x00__) - (. ~(>S__O (aget* &fs 1)) ~'invoke ~'x00__) - (unsupported! [~'x00__] 0))))))] - ~(aset* f1|test|__fs 0 - `(reify* [~(csym `B__O)] - (~'invoke [~&this (B 'c)] - ~'b - (. ~(>B__O (aget* 'f1|test|__fs 0)) ~'invoke ~'a) - (. ~(>B__O (aget* 'f1|test|__fs 0)) ~'invoke ~'c)))) - ~(aset* f1|test|__fs 1 - `(reify* [~(csym `S__O)] - (~'invoke [~&this (S 'c)] - ~'b - (. ~(>B__O (aget* 'f1|test|__fs 0)) ~'invoke ~'a) - (. ~(>S__O (aget* 'f1|test|__fs 1)) ~'invoke ~'c)))) - ~'f1|test))) - ~(aset* f__0|__fs 1 - (reify* [~(csym `C__O)] - (~'invoke [~&this ~(C 'a)] ...))) - ~'f__0)))) - ~(aset* f0|test|__fs 1 - `(reify* [~(csym `D__O)] - (~'invoke [~&this ~(D 'a)] ...))) - ~'f0|test)))))])) + (case (env-lang) + :clj + ($ (defmeta-from ~'f0|test + (let* [~'f0|test|__fs (*<>|sized 2) + ~'f0|test + (new TypedFn + {:quantum.core.type/type f0|test|__type} + f0|test|__ts + ~'f0|test|__fs + (fn* ([~&ts ~&fs ~'x00__] + (ifs (~(aget* (aget* &ts 0) 0) ~'x00__) + (. ~(aget* &fs 0) ~'invoke ~'x00__) + (~(aget* (aget* &ts 1) 0) ~'x00__) + (. ~(aget* &fs 1) ~'invoke ~'x00__) + (unsupported! `f0|test [~'x00__] 0)))))] + ~(aset* 'f0|test|__fs 0 + `(reify* [~(csym `B__O)] + (~'invoke [~&this ~(B 'a)] + ;; From `(self/fn [b ...])` + (let* [~'f__0|__fs (*<>|sized 2) + ~'f__0 + (new TypedFn nil + ;; TODO perhaps extern this (and parts thereof) whenever + ;; possible in `let*` statement on the very outside of the fn + ;; (so around the outer `reify*`) ? + (*<> (*<> t/byte?) (*<> t/char?)) + ~'f__0|__fs + (fn* ([~&ts ~&fs ~'x00__] + (ifs (~(aget* (aget* ~&ts 0) 0) ~'x00__) + (. ~(>Y__O (aget* &fs 0)) ~'invoke ~'x00__) + (~(aget* (aget* ~&ts 1) 0) ~'x00__) + (. ~(>C__O (aget* &fs 1)) ~'invoke ~'x00__) + (unsupported! [~'x00__] 0)))))] + ~(aset* 'f__0|__fs 0 + `(reify* [~(csym `Y__O)] + (~'invoke [~'_0__ ~(Y 'b)] + ;; From `(self/fn [c ...])` + (let* [~'f1|test|__fs (*<>|sized 2) + ~'f1|test + (new TypedFn nil + (*<> (*<> t/boolean?) (*<> t/short?)) + ~'f1|test|__fs + (fn* ([~&ts ~&fs ~'x00] + (ifs (~(aget* (aget* &ts 0) 0) ~'x00__) + (. ~(>B__O (aget* &fs 0)) ~'invoke ~'x00__) + (~(aget* (aget* &ts 1) 0) ~'x00__) + (. ~(>S__O (aget* &fs 1)) ~'invoke ~'x00__) + (unsupported! [~'x00__] 0))))))] + ~(aset* 'f1|test|__fs 0 + `(reify* [~(csym `B__O)] + (~'invoke [~&this (B 'c)] + ~'b + (. ~(>B__O (aget* 'f1|test|__fs 0)) ~'invoke ~'a) + (. ~(>B__O (aget* 'f1|test|__fs 0)) ~'invoke ~'c)))) + ~(aset* 'f1|test|__fs 1 + `(reify* [~(csym `S__O)] + (~'invoke [~&this (S 'c)] + ~'b + (. ~(>B__O (aget* 'f1|test|__fs 0)) ~'invoke ~'a) + (. ~(>S__O (aget* 'f1|test|__fs 1)) ~'invoke ~'c)))) + ~'f1|test))) + ~(aset* 'f__0|__fs 1 + (reify* [~(csym `C__O)] + (~'invoke [~&this ~(C 'a)] ...))) + ~'f__0)))) + ~(aset* 'f0|test|__fs 1 + `(reify* [~(csym `D__O)] + (~'invoke [~&this ~(D 'a)] ...))) + ~'f0|test))))])) (testing "Calling fns" (let [actual (binding [self/*compilation-mode* :test] (macroexpand ' From 1bbfda4fa3920a938e1c774e3a988cde673da665 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 5 Dec 2018 14:20:52 -0700 Subject: [PATCH 797/810] First time t/fn has compiled!! --- .../quantum/untyped/core/type/defnt.cljc | 201 +++++++++--------- .../quantum/test/untyped/core/type/defnt.cljc | 16 +- 2 files changed, 111 insertions(+), 106 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 63375997..15685609 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -108,21 +108,19 @@ (err! nil "Unable to roll back all effects" {:failed-rollback-fn rollback-fn} nil rollback-err))))))) -(defns- with-rollback! [!overload-queue _, !rollback-queue _, f fn?] +(defns- with-rollback! [!rollback-queue _, f fn?] (uerr/catch-all (f) e (do (ulog/ppr :error e) (drain-rollback-queue! !rollback-queue) (err! nil "Exception; rolled back successfully" nil nil e)) - (do (uvec/alist-empty! !rollback-queue) - (uvec/alist-empty! !overload-queue)))) + (do (uvec/alist-empty! !rollback-queue)))) (defns- analyze-with-rollback! - ([unanalyzed-form _] - (analyze-with-rollback! !global-overload-queue !global-rollback-queue unanalyzed-form)) - ([!overload-queue _, !rollback-queue _, unanalyzed-form _] - (with-rollback! !overload-queue !rollback-queue + ([unanalyzed-form _] (analyze-with-rollback! !global-rollback-queue unanalyzed-form)) + ([!rollback-queue _, unanalyzed-form _] + (with-rollback! !rollback-queue (c/fn [] (-> unanalyzed-form uana/analyze :form))))) ;; ===== Macros ===== ;; @@ -574,7 +572,7 @@ `t/fn` overload, which is the foundation for one `reify`." [{:as opts :keys [gen-gensym _, kind _]} ::opts {:as fn|globals :keys [fn|globals-name _, fn|name _, fn|ns-name _, fn|output-type _ - fn|overload-types-name _]} ::fn|globals + fn|overload-types-name|local _]} ::fn|globals env ::uana/env {:as unanalyzed-overload :keys [arg-classes _, arg-types _, arglist-code|hinted _, arglist-code|reify|unhinted _, @@ -587,19 +585,18 @@ > ::overload] (let [;; Not sure if `nil` is the right approach for the value ?recursive-ast-node-reference - (when (and fn|name (not= kind :extend-defn!)) (uast/symbol {} fn|name nil fn|type)) + (when fn|name (uast/symbol {} fn|name nil fn|type)) local-env (->> (zipmap (keys args-form) arg-types) (uc/map' (c/fn [[arg-binding arg-type]] [arg-binding (uast/unbound nil arg-binding arg-type)])) ;; To support recursion - (<- (cond-> - (and fn|name (not= kind :extend-defn!)) - (assoc fn|name - ?recursive-ast-node-reference - ;; TODO maybe there's a better way for fns - (uid/qualify fn|ns-name fn|overload-types-name) - (uast/var-value fn|overload-types-name fn|overload-types - (t/value fn|overload-types)))))) + (<- (cond-> fn|name + (assoc fn|name + ?recursive-ast-node-reference + ;; TODO maybe there's a better way for `t/fn`s + (uid/qualify fn|ns-name fn|overload-types-name|local) + (uast/var-value fn|overload-types-name|local fn|overload-types + (t/value fn|overload-types)))))) env' (-> env (merge local-env) (assoc-in [:opts :ns] (-> unanalyzed-overload :ns-name the-ns))) @@ -677,8 +674,7 @@ (apply uarr/*<>|fn (-> ?!fn|types ?norx-deref :overload-types (get overload-index) :arg-types))) (c/defn overload-types>ftype - [fn|ns-name #_simple-symbol? - fn|name|global #_simple-symbol? + [{:as opts :keys [fn|name|local fn|ns-name]} #_::opts overload-types #_(vec-of ::type-datum) fn|output-type #_t/type?] (let [overload-types' (->> overload-types @@ -686,7 +682,7 @@ (cond-> arg-types pre-type (conj :| pre-type) output-type (conj :> output-type)))))] - (apply t/ftype (uid/qualify fn|ns-name fn|name|global) fn|output-type overload-types'))) + (apply t/ftype (uid/qualify fn|ns-name fn|name|local) fn|output-type overload-types'))) (c/defn- dedupe-overload-types-data [fn|ns-name fn|name types-decl-data] (->> types-decl-data @@ -841,7 +837,7 @@ existing-fn-types (us/nilable ::fn|types) {:as opts :keys [kind _]} ::opts {:as fn|globals - :keys [fn|name _, fn|name|global _, fn|ns-name _, fn|output-type _, fn|overload-types-name _]} + :keys [fn|name _, fn|name|local _, fn|ns-name _, fn|output-type _, fn|overload-types-name _]} ::fn|globals env ::uana/env > ::fn|types] @@ -859,7 +855,7 @@ fn|globals env overload-bases-data existing-overload-types))] (or existing-fn-types {:fn|output-type-norx fn|output-type-norx - :fn|type-norx (t/ftype (uid/qualify fn|ns-name fn|name|global) fn|output-type-norx) + :fn|type-norx (t/ftype (uid/qualify fn|ns-name fn|name|local) fn|output-type-norx) :overload-types []}) (let [sorted-changed-unanalyzed-overloads (->> changed-unanalyzed-overloads @@ -891,8 +887,7 @@ (uc/map-indexed (c/fn [i datum] (assoc datum :index i))))) ;; Partially for recursive purposes fn|type-norx - (overload-types>ftype - fn|ns-name fn|name|global overload-types-with-replacing-ids fn|output-type-norx) + (overload-types>ftype fn|globals overload-types-with-replacing-ids fn|output-type-norx) ;; We should analyze everything first in order to figure out body-dependent input types ;; before we can compare them against each other, but we're ignoring body-dependent input ;; types for now @@ -1245,11 +1240,13 @@ (defns- >fn|opts "`opts` are per invocation of `t/defn` and/or `extend-defn!`, while `globals` persist for as long as the `t/defn` does." - [kind ::kind, compilation-mode ::compilation-mode > ::opts] - (let [gen-gensym-base (if (= compilation-mode :test) - (ufgen/>reproducible-gensym|generator) - gensym) - gen-gensym (c/fn [x] (symbol (str (gen-gensym-base x) "__")))] + [env ::uana/env, kind ::kind, compilation-mode ::compilation-mode > ::opts] + (let [gen-gensym (or (-> env :opts :gen-gensym) + (let [gen-gensym-base + (if (= compilation-mode :test) + (ufgen/>reproducible-gensym|generator) + gensym)] + (c/fn [x] (symbol (str (gen-gensym-base x) "__")))))] (kw-map compilation-mode gen-gensym kind))) (defns- >fn|globals+?overload-bases-form @@ -1279,26 +1276,29 @@ fn|name|global (if (= kind :fn) (symbol (str fn|name (when fn|name "|") (gen-gensym "__anon"))) fn|name) + fn|name|local (or fn|name fn|name|global) fn|globals-name (symbol (str fn|name|global "|__globals"))] (if (= kind :extend-defn!) {:fn|globals (-> (uid/qualify fn|ns-name fn|globals-name) resolve var-get) :overload-bases-form overload-bases-form} - (let [fn|inline? (if (nil? (:inline fn|meta)) - false - (us/validate (:inline fn|meta) t/boolean?)) - fn|meta (dissoc fn|meta :inline) - fn|output-type|form (or (second output-spec) `t/any?) + (let [fn|inline? (if (nil? (:inline fn|meta)) + false + (us/validate (:inline fn|meta) t/boolean?)) + fn|meta (dissoc fn|meta :inline) + fn|output-type|form (or (second output-spec) `t/any?) ;; TODO this needs to be analyzed for dependent types referring to local vars - fn|output-type (eval fn|output-type|form) - fn|overload-bases-name (symbol (str fn|name|global "|__bases")) - fn|overload-types-name (symbol (str fn|name|global "|__types")) - fn|type-name (symbol (str fn|name|global "|__type")) - fn|ts-name (symbol (str fn|name|global "|__ts")) - fn|fs-name (symbol (str fn|name|global "|__fs")) + fn|output-type (eval fn|output-type|form) + fn|overload-bases-name (symbol (str fn|name|global "|__bases")) + fn|overload-types-name (symbol (str fn|name|global "|__types")) + fn|overload-types-name|local (symbol (str fn|name|local "|__types")) + fn|type-name (symbol (str fn|name|global "|__type")) + fn|ts-name (symbol (str fn|name|global "|__ts")) + fn|fs-name (symbol (str fn|name|local "|__fs")) fn|globals ; TODO use record here (kw-map fn|fs-name fn|globals-name fn|inline? fn|meta fn|name fn|name|global - fn|ns-name fn|output-type|form fn|output-type fn|overload-bases-name - fn|overload-types-name fn|ts-name fn|type-name)] + fn|name|local fn|ns-name fn|output-type|form fn|output-type + fn|overload-bases-name fn|overload-types-name fn|overload-types-name|local + fn|ts-name fn|type-name)] (when-not (= kind :fn) (intern-with-rollback! fn|ns-name fn|globals-name fn|globals)) (kw-map fn|globals overload-bases-form))))) @@ -1325,62 +1325,67 @@ ;; require analysis, as shown in tests (defns- analyze-fn* [kind #{:defn :extend-defn! :fn}, env ::uana/env, unanalyzed-form _ > uast/node?] - (let [opts (>fn|opts kind *compilation-mode*) - {:keys [fn|globals overload-bases-form] - {:keys [fn|fs-name fn|globals-name fn|meta fn|name fn|name|global fn|ns-name fn|ts-name - fn|type-name]} - :fn|globals} - (>fn|globals+?overload-bases-form opts unanalyzed-form) - !overload-bases (>!overload-bases opts fn|globals env overload-bases-form) - !fn|types (>!fn|types opts fn|globals env !overload-bases) - fn|types (norx-deref !fn|types) - fn|ts (>fn|ts opts fn|globals fn|types) - !fn|type (>!fn|type opts fn|globals !fn|types) - {:keys [form overloads]} - (if (empty? (norx-deref !overload-bases)) - (if (= kind :defn) - {:form `(declare ~(:fn|name|global fn|globals)) - :overloads []} - (err! "Overloads cannot be empty for non-`t/defn`s." {:form unanalyzed-form})) - (let [fn|meta (cond-> fn|meta - (not= kind :fn) (merge {:quantum.core.type/type - (uid/qualify fn|ns-name fn|type-name)})) - direct-dispatch-seq (>direct-dispatch-seq opts fn|globals fn|types) - dynamic-dispatch (>dynamic-dispatch opts fn|globals fn|types) - qualified-ts-name (uid/qualify fn|ns-name fn|ts-name) - fn-form - `(let* [~fn|fs-name (uarr/*<>|sized ~(-> fn|types :overload-types count)) - ~fn|name|global (new TypedFn ~fn|meta ~qualified-ts-name ~fn|fs-name - ~(:form dynamic-dispatch))] - ~@(->> direct-dispatch-seq - (map (c/fn [{:as reify-data :keys [id form]}] - (aset* fn|fs-name id form)))) - ~fn|name|global)] - {:form (case kind - :fn fn-form - :defn `(uvar/defmeta-from ~fn|name|global ~fn-form) - ;; FIXME extend-defn should redefine the fs, ts, and dynamic dispatch of the existing TypedFn object - :extend-fn! (TODO)) - :overloads (->> direct-dispatch-seq - (uc/map - (c/fn [{:keys [overload]}] - {:type (:output-type overload) - :arg-types (:arg-types overload) - :body (:body-node overload)})))})) - ast-basis - {:env env - :unanalyzed-form unanalyzed-form - :name fn|name - :meta fn|meta - :overloads overloads - :form form - ;; TODO is `norx-deref` the right approach? What if something else refers - ;; to the defn that then is extended? Will that not happen correctly? - :type (norx-deref !fn|type)}] - (case kind - :fn (uast/fnt-node ast-basis) - :defn (uast/defnt-node ast-basis) - :extend-defn! (uast/extend-defnt-node ast-basis)))) + (try + (let [opts (>fn|opts env kind *compilation-mode*) + env (assoc-in env [:opts :gen-gensym] (:gen-gensym opts)) + {:keys [fn|globals overload-bases-form] + {:keys [fn|fs-name fn|globals-name fn|meta fn|name fn|name|global fn|ns-name fn|ts-name + fn|type-name]} + :fn|globals} + (>fn|globals+?overload-bases-form opts unanalyzed-form) + !overload-bases (>!overload-bases opts fn|globals env overload-bases-form) + !fn|types (>!fn|types opts fn|globals env !overload-bases) + fn|types (norx-deref !fn|types) + fn|ts (>fn|ts opts fn|globals fn|types) + !fn|type (>!fn|type opts fn|globals !fn|types) + {:keys [form overloads]} + (if (empty? (norx-deref !overload-bases)) + (if (= kind :defn) + {:form `(declare ~(:fn|name|global fn|globals)) + :overloads []} + (err! "Overloads cannot be empty for non-`t/defn`s." {:form unanalyzed-form})) + (let [fn|meta (cond-> fn|meta + (not= kind :fn) (merge {:quantum.core.type/type + (uid/qualify fn|ns-name fn|type-name)})) + direct-dispatch-seq (>direct-dispatch-seq opts fn|globals fn|types) + dynamic-dispatch (>dynamic-dispatch opts fn|globals fn|types) + qualified-ts-name (uid/qualify fn|ns-name fn|ts-name) + fn-form + `(let* [~fn|fs-name (uarr/*<>|sized ~(-> fn|types :overload-types count)) + ~fn|name|global (new TypedFn ~fn|meta ~qualified-ts-name ~fn|fs-name + ~(:form dynamic-dispatch))] + ~@(->> direct-dispatch-seq + (map (c/fn [{:as reify-data :keys [id form]}] + (aset* fn|fs-name id form)))) + ~fn|name|global)] + {:form (case kind + :fn fn-form + :defn `(do (uvar/defmeta-from ~fn|name|global ~fn-form)) + ;; FIXME extend-defn should redefine the fs, ts, and dynamic + ;; dispatch of the existing TypedFn object + :extend-defn! (TODO)) + :overloads (->> direct-dispatch-seq + (uc/map + (c/fn [{:keys [overload]}] + {:type (:output-type overload) + :arg-types (:arg-types overload) + :body (:body-node overload)})))})) + ast-basis + {:env env + :unanalyzed-form unanalyzed-form + :name fn|name + :meta fn|meta + :overloads overloads + :form form + ;; TODO is `norx-deref` the right approach? What if something else + ;; refers to the defn that then is extended? Will that not happen + ;; correctly? + :type (norx-deref !fn|type)}] + (case kind + :fn (uast/fnt-node ast-basis) + :defn (uast/defnt-node ast-basis) + :extend-defn! (uast/extend-defnt-node ast-basis))) + (finally (uvec/alist-empty! !global-overload-queue)))) (defns analyze-fn [env ::uana/env, form _] (analyze-fn* :fn env form)) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 7a5edbe6..80308405 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -2528,7 +2528,7 @@ expected (case (env-lang) :clj - ($ (defmeta-from ~'f0|test + ($ (do (defmeta-from ~'f0|test (let* [~'f0|test|__fs (*<>|sized 2) ~'f0|test (new TypedFn @@ -2545,21 +2545,21 @@ `(reify* [~(csym `B__O)] (~'invoke [~&this ~(B 'a)] ;; From `(self/fn [b ...])` - (let* [~'f__0|__fs (*<>|sized 2) - ~'f__0 + (let* [~'__anon0__|__fs (*<>|sized 2) + ~'__anon0__ (new TypedFn nil ;; TODO perhaps extern this (and parts thereof) whenever ;; possible in `let*` statement on the very outside of the fn ;; (so around the outer `reify*`) ? (*<> (*<> t/byte?) (*<> t/char?)) - ~'f__0|__fs + ~'__anon0__|__fs (fn* ([~&ts ~&fs ~'x00__] (ifs (~(aget* (aget* ~&ts 0) 0) ~'x00__) (. ~(>Y__O (aget* &fs 0)) ~'invoke ~'x00__) (~(aget* (aget* ~&ts 1) 0) ~'x00__) (. ~(>C__O (aget* &fs 1)) ~'invoke ~'x00__) (unsupported! [~'x00__] 0)))))] - ~(aset* 'f__0|__fs 0 + ~(aset* '__anon0__|__fs 0 `(reify* [~(csym `Y__O)] (~'invoke [~'_0__ ~(Y 'b)] ;; From `(self/fn [c ...])` @@ -2587,10 +2587,10 @@ (. ~(>B__O (aget* 'f1|test|__fs 0)) ~'invoke ~'a) (. ~(>S__O (aget* 'f1|test|__fs 1)) ~'invoke ~'c)))) ~'f1|test))) - ~(aset* 'f__0|__fs 1 + ~(aset* '__anon0__|__fs 1 (reify* [~(csym `C__O)] (~'invoke [~&this ~(C 'a)] ...))) - ~'f__0)))) + ~'__anon0__)))) ~(aset* 'f0|test|__fs 1 `(reify* [~(csym `D__O)] (~'invoke [~&this ~(D 'a)] ...))) @@ -2739,7 +2739,7 @@ ;; - We need to know overload ID of `f1` with input types ;; `[tt/string?]` (f1 "11")))) - ~'j|test))))))] + ~'j|test)))))))] ...))) ;; Automatically analyzes the body of `fnt?`s which have at least one input of `t/fn?` From 94d4c7b9d7d3e93d5873e4bab7201857dfc285eb Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Wed, 5 Dec 2018 17:54:24 -0700 Subject: [PATCH 798/810] `t/fn` actually works as expected!! --- src-untyped/quantum/untyped/core/analyze.cljc | 99 +++++----- .../quantum/untyped/core/type/defnt.cljc | 172 +++++++++--------- .../untyped/core/type/reifications.cljc | 13 +- .../quantum/test/untyped/core/type/defnt.cljc | 7 +- 4 files changed, 147 insertions(+), 144 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index 83ec228d..a9334b2d 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -1,46 +1,49 @@ (ns quantum.untyped.core.analyze - (:require - ;; TODO excise this reference - [quantum.core.type.core :as tcore] - [quantum.untyped.core.analyze.ast :as uast] - [quantum.untyped.core.analyze.expr :as uxp] - [quantum.untyped.core.collections :as uc - :refer [>vec]] - [quantum.untyped.core.collections.logic :as clogic] - [quantum.untyped.core.compare :as ucomp] - [quantum.untyped.core.core - :refer [istr]] - [quantum.untyped.core.data - :refer [kw-map]] - [quantum.untyped.core.data.reactive :as urx] - [quantum.untyped.core.data.set :as uset] - [quantum.untyped.core.defnt - :refer [defns defns- fns]] - [quantum.untyped.core.error :as uerr - :refer [TODO err!]] - [quantum.untyped.core.fn - :refer [<- fn-> fn->> fn1]] - [quantum.untyped.core.form :as uform] - [quantum.untyped.core.form.evaluate :as ufeval] - [quantum.untyped.core.form.type-hint :as ufth] - [quantum.untyped.core.identifiers :as uid] - [quantum.untyped.core.log :as ulog - :refer [prl!]] - [quantum.untyped.core.logic :as l - :refer [if-not-let ifs]] - [quantum.untyped.core.print - :refer [ppr]] - [quantum.untyped.core.reducers :as ur - :refer [educe join reducei]] - [quantum.untyped.core.refs :as uref - :refer [>!thread-local]] - [quantum.untyped.core.spec :as us] - [quantum.untyped.core.type :as t - :refer [?]] - [quantum.untyped.core.type.compare :as utcomp] - [quantum.untyped.core.type.reifications :as utr] - [quantum.untyped.core.vars :as uvar - :refer [update-meta]])) + (:require + ;; TODO excise this reference + [quantum.core.type.core :as tcore] + [quantum.untyped.core.analyze.ast :as uast] + [quantum.untyped.core.analyze.expr :as uxp] + [quantum.untyped.core.collections :as uc + :refer [>vec]] + [quantum.untyped.core.collections.logic :as clogic] + [quantum.untyped.core.compare :as ucomp] + [quantum.untyped.core.core + :refer [istr]] + [quantum.untyped.core.data + :refer [kw-map]] + [quantum.untyped.core.data.reactive :as urx] + [quantum.untyped.core.data.set :as uset] + [quantum.untyped.core.defnt + :refer [defns defns- fns]] + [quantum.untyped.core.error :as uerr + :refer [TODO err!]] + [quantum.untyped.core.fn + :refer [<- fn-> fn->> fn1]] + [quantum.untyped.core.form :as uform] + [quantum.untyped.core.form.evaluate :as ufeval] + [quantum.untyped.core.form.type-hint :as ufth] + [quantum.untyped.core.identifiers :as uid] + [quantum.untyped.core.log :as ulog + :refer [prl!]] + [quantum.untyped.core.logic :as l + :refer [if-not-let ifs]] + [quantum.untyped.core.print + :refer [ppr]] + [quantum.untyped.core.reducers :as ur + :refer [educe join reducei]] + [quantum.untyped.core.refs :as uref + :refer [>!thread-local]] + [quantum.untyped.core.spec :as us] + [quantum.untyped.core.type :as t + :refer [?]] + [quantum.untyped.core.type.compare :as utcomp] + [quantum.untyped.core.type.reifications :as utr + #?@(:cljs [:refer [TypedFn]])] + [quantum.untyped.core.vars :as uvar + :refer [update-meta]]) +#?(:clj (:import + [quantum.untyped.core.type.reifications TypedFn]))) (def special-metadata-keys #{:val}) @@ -720,7 +723,12 @@ (defns- >direct-dispatch|reify-call [caller|node uast/node?, caller|type _, type-datum _, args-codelist (us/seq-of t/any?)] (if-let [fn|name (utr/fn-type>fn-name caller|type)] - `(. ~(aget* (symbol (str (name fn|name) "|__fs")) (:id type-datum)) + `(. ~(ufth/with-type-hint + (aget* `(. ~(-> fn|name name symbol + (ufth/with-type-hint (ufth/>body-embeddable-tag TypedFn))) + ~'getFs) + (:id type-datum)) + (-> type-datum :interface ufth/>body-embeddable-tag)) ~direct-dispatch-method-sym ~@args-codelist) (err! "No name found for typed fn corresponding to caller; cannot create direct dispatch call" (assoc (select-keys caller|node [:unanalyzed-form :form]) :type caller|type)))) @@ -1117,7 +1125,6 @@ > uast/node? ([form _] (analyze {} form)) ([env ::env, form _] - (when (and (-> env (dissoc :opts) empty?) (-> form first name (= "fn"))) (throw (Exception.))) (uref/set! !!analyze-depth 0) (binding [*analyzing?* true] (analyze* env form)))) @@ -1132,14 +1139,14 @@ (binding [quantum.untyped.core.analyze.ast/*print-env?* false quantum.untyped.core.print/*collapse-symbols?* true *print-meta* true - *print-level* 10] + *print-level* 20] (quantum.untyped.core.print/ppr x))) (defn pr-no-meta! [x] (binding [quantum.untyped.core.analyze.ast/*print-env?* false quantum.untyped.core.print/*collapse-symbols?* true *print-meta* false - *print-level* 10] + *print-level* 20] (quantum.untyped.core.print/ppr x))) #?(:clj diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 15685609..970bae7d 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -328,18 +328,22 @@ (us/def ::unanalyzed-overload (us/kv {:ns-name simple-symbol? :arg-classes (us/vec-of class?) + :arg-classes|reify (us/vec-of class?) :arg-types (us/vec-of t/type?) :arglist-code|hinted (us/vec-of simple-symbol?) :arglist-code|reify|unhinted (us/vec-of simple-symbol?) :arglist-form|unanalyzed t/any? :args-form map? ; from binding to form :varargs-vorm (us/nilable map?) ; from binding to form + :output-class class? + :output-class|reify class? :output-type|form t/any? :output-type t/type? :pre-type (us/nilable t/type?) :body-codelist (us/vec-of t/any?) :i|basis index? - :inline? boolean?})) + :inline? boolean? + :interface class?})) ;; This is the overload after the input specs are split by their respective `t/or` constituents, ;; and after primitivization, but before readiness for incorporation into a `reify`. @@ -381,22 +385,16 @@ :pre-type (us/nilable t/type?) :output-type t/type?})) -(def types-decl-datum-kv-basis - {:id ::overload|id - :index index? ; overload-index (position in the overall types-decl) - :ns-name simple-symbol? - :interface class? - :arglist-code|hinted (us/vec-of simple-symbol?) - :arg-types (us/vec-of t/type?) - :output-type t/type? - :body-codelist (us/vec-of t/any?) - :inline? boolean?}) - -(us/def ::types-decl-datum-without-interface - (us/kv (dissoc types-decl-datum-kv-basis :interface))) - (us/def ::types-decl-datum - (us/kv types-decl-datum-kv-basis)) + (us/kv {:id ::overload|id + :index index? ; overload-index (position in the overall types-decl) + :ns-name simple-symbol? + :interface class? + :arglist-code|hinted (us/vec-of simple-symbol?) + :arg-types (us/vec-of t/type?) + :output-type t/type? + :body-codelist (us/vec-of t/any?) + :inline? boolean?})) ;; Interned as `!fn|types` (us/def ::fn|types @@ -433,6 +431,7 @@ (not (t/type-ref? t))) t/class>most-primitive-class)))))) +;; TODO we may want to prefer actual output types; not sure yet (defns- with-validate-output-type [declared-output-type t/type?, body-node uast/node? > t/type?] (let [err-info {:form (:form body-node) :type (:type body-node) @@ -540,32 +539,6 @@ ;; ===== `unanalyzed-overload>overload` ===== ;; -(defns- class>interface-part-name [c class? > string?] - (case (>name c) - "java.lang.Object" "O" - "boolean" "B" - "byte" "Y" - "short" "S" - "char" "C" - "int" "I" - "long" "L" - "float" "F" - "double" "D")) - -(defns- overload-classes>interface-sym [args-classes (us/seq-of class?), out-class class? > symbol?] - (>symbol (str (->> args-classes (uc/lmap class>interface-part-name) (apply str)) - "__" (class>interface-part-name out-class)))) - -(defns- overload-classes>interface - [args-classes (us/vec-of class?), out-class class?, gen-gensym fn?] - (let [interface-sym (overload-classes>interface-sym args-classes out-class) - hinted-method-sym (ufth/with-type-hint uana/direct-dispatch-method-sym - (ufth/>interface-method-tag out-class)) - hinted-args (ufth/hint-arglist-with - (ufgen/gen-args 0 (count args-classes) "x" gen-gensym) - (map ufth/>interface-method-tag args-classes))] - `(~'definterface ~interface-sym (~hinted-method-sym ~hinted-args)))) - #?(:clj (defns- unanalyzed-overload>overload "Given an `::unanalyzed-overload`, performs type analysis on the body and computes a resulting @@ -575,12 +548,13 @@ fn|overload-types-name|local _]} ::fn|globals env ::uana/env {:as unanalyzed-overload - :keys [arg-classes _, arg-types _, arglist-code|hinted _, arglist-code|reify|unhinted _, - arglist-form|unanalyzed _, args-form _, body-codelist _ output-type|form _ - varargs-form _, variadic? _] - declared-output-type [:output-type _]} ::unanalyzed-overload + :keys [arg-classes _, arg-classes|reify _, arg-types _, arglist-code|hinted _, + arglist-code|reify|unhinted _, arglist-form|unanalyzed _, args-form _, body-codelist _, + interface _, output-class|reify _, output-type|form _, varargs-form _, variadic? _] + declared-output-class [:output-class _] + declared-output-type [:output-type _]} ::unanalyzed-overload overload|id index? - fn|overload-types (us/vec-of ::types-decl-datum-without-interface) + fn|overload-types (us/vec-of ::types-decl-datum) fn|type (us/nilable t/type?) > ::overload] (let [;; Not sure if `nil` is the right approach for the value @@ -602,7 +576,7 @@ (assoc-in [:opts :ns] (-> unanalyzed-overload :ns-name the-ns))) body-node (uana/analyze env' (ufgen/?wrap-do body-codelist)) output-type (with-validate-output-type declared-output-type body-node) - output-class (type>class output-type) + output-class declared-output-class body-node (-> body-node (cond-> (t/run? output-type) @@ -623,16 +597,7 @@ variadic?))) arglist-code|fn|hinted (cond-> (->> args-form keys (uc/map-indexed hint-arg|fn)) - variadic? (conj '& (-> varargs-form keys first))) - arg-classes|reify (->> arg-classes (uc/map class>simplest-class)) - output-class|reify (class>simplest-class output-class) - interface-k [output-class|reify arg-classes|reify] - interface - (-> *interfaces - (swap! update interface-k - #(or % (eval (overload-classes>interface arg-classes|reify output-class|reify - gen-gensym)))) - (uc/get interface-k))] + variadic? (conj '& (-> varargs-form keys first)))] (kw-map arg-classes arg-classes|reify arg-types arglist-code|fn|hinted arglist-code|hinted arglist-code|reify|unhinted arglist-form|unanalyzed body-node interface output-class output-class|reify output-type positional-args-ct variadic?)))) @@ -745,13 +710,50 @@ (->> arg-types|basis (uc/run! ?deref)) (?deref output-type|basis))))) +(defns- class>interface-part-name [c class? > string?] + (case (>name c) + "java.lang.Object" "O" + "boolean" "B" + "byte" "Y" + "short" "S" + "char" "C" + "int" "I" + "long" "L" + "float" "F" + "double" "D")) + +(defns- overload-classes>interface-sym [args-classes (us/seq-of class?), out-class class? > symbol?] + (>symbol (str (->> args-classes (uc/lmap class>interface-part-name) (apply str)) + "__" (class>interface-part-name out-class)))) + +(defns- overload-classes>interface + [args-classes (us/vec-of class?), out-class class?, gen-gensym fn?] + (let [interface-sym (overload-classes>interface-sym args-classes out-class) + hinted-method-sym (ufth/with-type-hint uana/direct-dispatch-method-sym + (ufth/>interface-method-tag out-class)) + hinted-args (ufth/hint-arglist-with + (ufgen/gen-args 0 (count args-classes) "x" gen-gensym) + (map ufth/>interface-method-tag args-classes))] + `(~'definterface ~interface-sym (~hinted-method-sym ~hinted-args)))) + (defns- >unanalyzed-overload - [{:as basis :keys [args-form _, varargs-form _]} ::overload-basis + [{:as opts :keys [gen-gensym _]} ::opts + {:as basis :keys [args-form _, varargs-form _]} ::overload-basis i|basis index? type-datum ::type-datum > ::unanalyzed-overload] - (let [variadic? (not (empty? varargs-form)) - arg-classes (->> type-datum :arg-types (uc/map type>class)) + (let [variadic? (not (empty? varargs-form)) + arg-classes (->> type-datum :arg-types (uc/map type>class)) + arg-classes|reify (->> arg-classes (uc/map class>simplest-class)) + output-class (-> type-datum :output-type type>class) + output-class|reify (class>simplest-class output-class) + interface-k [output-class|reify arg-classes|reify] + interface + (-> *interfaces + (swap! update interface-k + #(or % (eval (overload-classes>interface arg-classes|reify output-class|reify + gen-gensym)))) + (uc/get interface-k)) arglist-code|reify|unhinted (cond-> (-> args-form keys vec) variadic? (conj (-> varargs-form keys first))) @@ -767,8 +769,8 @@ :varargs-form]) (merge type-datum) (assoc :ns-name (:ns-name basis)) - (merge (kw-map arg-classes arglist-code|hinted arglist-code|reify|unhinted i|basis - variadic?))))) + (merge (kw-map arg-classes arg-classes|reify arglist-code|hinted arglist-code|reify|unhinted + i|basis interface output-class output-class|reify variadic?))))) (defns- >changed-unanalyzed-overloads "A 'changed' overload here means one of three things: @@ -784,7 +786,8 @@ 'Cheaply' O(m•n) where `m` is the number split types resulting from changed overload bases, and `n` is the size of the existing overload types. 'Cheap' because only a `=` check is performed `n` times for each `m`. All other computations are done only once for each `m`." - [fn|globals ::fn|globals + [opts ::opts + fn|globals ::fn|globals env ::uana/env {:keys [prev-norx _, current _]} ::overload-bases-data existing-overload-types (us/nilable (us/vec-of ::types-decl-datum)) @@ -810,7 +813,7 @@ (= (:body-codelist basis) (:body-codelist prev-basis))) (uc/remove+ type-signature-equal-to-existing?)) (uc/map+ (c/fn [type-datum] - (>unanalyzed-overload basis i|basis type-datum))))))))) + (>unanalyzed-overload opts basis i|basis type-datum))))))))) (uc/filter+ identity) uc/cat))) @@ -852,7 +855,7 @@ :fn|output-type|new fn|output-type-norx})) (if-not-let [changed-unanalyzed-overloads (seq (>changed-unanalyzed-overloads - fn|globals env overload-bases-data existing-overload-types))] + opts fn|globals env overload-bases-data existing-overload-types))] (or existing-fn-types {:fn|output-type-norx fn|output-type-norx :fn|type-norx (t/ftype (uid/qualify fn|ns-name fn|name|local) fn|output-type-norx) @@ -866,10 +869,11 @@ sorted-changed-overload-types (->> sorted-changed-unanalyzed-overloads (uc/map-indexed - (c/fn [i {:as unanalyzed-overload - :keys [arg-types output-type body-codelist arglist-code|hinted - inline?]}] - (-> (kw-map arg-types output-type arglist-code|hinted body-codelist inline?) + (c/fn [i unanalyzed-overload] + (-> unanalyzed-overload + (select-keys + [:arg-types :arglist-code|hinted :body-codelist :inline? :interface + :output-type]) (assoc :id (+ i first-current-overload-id) :ns-name (:ns-name unanalyzed-overload)))))) ;; We need to maintain the `overload-types` ordering by type-specificity so the dynamic @@ -905,15 +909,13 @@ (let [id (or (:replacing-id datum) (:id datum)) datum' (if (>= id first-current-overload-id) - (let [overload (get sorted-changed-overloads - (- id first-current-overload-id)) - datum' (assoc datum :interface (:interface overload))] - ;; So that direct dispatch can use `overload` later on - (alist-conj! - !global-overload-queue (assoc datum :overload overload)) - datum') + (do ;; So that direct dispatch can use `overload` later on + (alist-conj! !global-overload-queue + (assoc datum :overload + (get sorted-changed-overloads + (- id first-current-overload-id)))) + datum) datum)] - (dissoc datum' :replacing-id)))))] ;; TODO use records here and other memory-friendly things (kw-map fn|output-type-norx fn|type-norx overload-types))))) @@ -940,7 +942,7 @@ (defns >direct-dispatch|reify-call [overload|id ::overload|id, reify|interface class?, fs|name simple-symbol? relevant-arglist (us/vec-of simple-symbol?)] - `(. ~(ufth/with-type-hint (aget* fs|name overload|id) (>name reify|interface)) + `(. ~(ufth/with-type-hint (aget* fs|name overload|id) (ufth/>body-embeddable-tag reify|interface)) ~uana/direct-dispatch-method-sym ~@relevant-arglist)) ;; TODO spec @@ -1329,8 +1331,8 @@ (let [opts (>fn|opts env kind *compilation-mode*) env (assoc-in env [:opts :gen-gensym] (:gen-gensym opts)) {:keys [fn|globals overload-bases-form] - {:keys [fn|fs-name fn|globals-name fn|meta fn|name fn|name|global fn|ns-name fn|ts-name - fn|type-name]} + {:keys [fn|fs-name fn|globals-name fn|meta fn|name fn|name|global fn|name|local + fn|ns-name fn|ts-name fn|type-name]} :fn|globals} (>fn|globals+?overload-bases-form opts unanalyzed-form) !overload-bases (>!overload-bases opts fn|globals env overload-bases-form) @@ -1351,13 +1353,13 @@ dynamic-dispatch (>dynamic-dispatch opts fn|globals fn|types) qualified-ts-name (uid/qualify fn|ns-name fn|ts-name) fn-form - `(let* [~fn|fs-name (uarr/*<>|sized ~(-> fn|types :overload-types count)) - ~fn|name|global (new TypedFn ~fn|meta ~qualified-ts-name ~fn|fs-name - ~(:form dynamic-dispatch))] + `(let* [~fn|fs-name (uarr/*<>|sized ~(-> fn|types :overload-types count)) + ~fn|name|local (new TypedFn ~fn|meta ~qualified-ts-name ~fn|fs-name + ~(:form dynamic-dispatch))] ~@(->> direct-dispatch-seq (map (c/fn [{:as reify-data :keys [id form]}] (aset* fn|fs-name id form)))) - ~fn|name|global)] + ~fn|name|local)] {:form (case kind :fn fn-form :defn `(do (uvar/defmeta-from ~fn|name|global ~fn-form)) diff --git a/src-untyped/quantum/untyped/core/type/reifications.cljc b/src-untyped/quantum/untyped/core/type/reifications.cljc index be6076c2..b19d8d36 100644 --- a/src-untyped/quantum/untyped/core/type/reifications.cljc +++ b/src-untyped/quantum/untyped/core/type/reifications.cljc @@ -500,24 +500,17 @@ ;; ----- TypedFn (for FnType) ----- ;; ;; TODO figure out where this goes -(defprotocol PTypedFn - (setFs [this fs']) - (setTs [this ts'])) - ;; TODO should we provide one with no `^:!` metadata, for optimization purposes? (udt/deftype TypedFn [meta ;; The types for direct dispatch overloads - ^:! #?(:clj ^"[Ljava.lang.Object;" ts :cljs ^array ts) + ^:! ^:get ^:set #?(:clj ^"[Ljava.lang.Object;" ts :cljs ^array ts) ;; The direct dispatch fns / `reify` overloads ;; Keys/indices are overload IDs, not dynamic overload-indices - ^:! #?(:clj ^"[Ljava.lang.Object;" fs :cljs ^array fs) + ^:! ^:get ^:set #?(:clj ^"[Ljava.lang.Object;" fs :cljs ^array fs) ;; The dynamic dispatch fn #?(:clj ^clojure.lang.IFn dynf :cljs dynf)] - {PTypedFn - {setTs ([this ts'] (set! ts ts') this) - setFs ([this fs'] (set! fs fs') this)} - clojure.lang.IFn + {clojure.lang.IFn {invoke (([ this] (.invoke dynf ts fs)) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 80308405..74eb74fb 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -6,6 +6,7 @@ [quantum.core.type :refer [dotyped]] [quantum.test.untyped.core.type :as tt] + [quantum.untyped.core.analyze :as uana] [quantum.untyped.core.data.array :refer [*<> *<>|sized]] [quantum.untyped.core.form @@ -86,12 +87,12 @@ (->> ^:val (java.lang.management.ManagementFactory/getRuntimeMXBean) (.getName))))) expected - ($ (do [[0 0 false [] (t/or t/nil? t/string?)]] - (defmeta-from ~'pid + ($ (do (defmeta-from ~'pid (let* [~'pid|__fs (*<>|sized 1) ~'pid (new TypedFn {:quantum.core.type/type pid|__type} - pid|__ts ; defined/created within `t/defn` + ;; [[0 0 false [] (t/or t/nil? t/string?)]] + pid|__ts ; defined/created within `t/defn` ; FIXME make it so the arrays are shown here ~'pid|__fs (fn* ([~&ts ~&fs] (. ~(>__O (aget* &fs 0)) ~'invoke))))] ~(aset* 'pid|__fs 0 From d9c18235bd77df5498e4b081707de73a0e8a4816 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 16 Dec 2018 22:38:56 -0700 Subject: [PATCH 799/810] `equinumerous?` --- resources-dev/defnt.cljc | 3 +++ 1 file changed, 3 insertions(+) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index 79983bd7..c29cae63 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -7,6 +7,9 @@ Note that for anything built-in js/, the `t/isa?` predicates might nee ;; TO MOVE +(defn equinumerous? + [xs0 (t/input count :?), xs1 (t/input count :?) > boolean?] (= (count xs0) (count xs1))) + #?(:clj (def thread? (isa? java.lang.Thread))) #?(:clj (def class? (isa? java.lang.Class))) ;; TODO for CLJS based on untyped impl From 6f358fc6e2ef5dbb274dc0df8abba25db403bee1 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 16 Dec 2018 22:40:03 -0700 Subject: [PATCH 800/810] Compilation --- src-untyped/quantum/untyped/core/type/defnt.cljc | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 970bae7d..745c6942 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -942,7 +942,8 @@ (defns >direct-dispatch|reify-call [overload|id ::overload|id, reify|interface class?, fs|name simple-symbol? relevant-arglist (us/vec-of simple-symbol?)] - `(. ~(ufth/with-type-hint (aget* fs|name overload|id) (ufth/>body-embeddable-tag reify|interface)) + `(. ~(ufth/with-type-hint + (uana/aget* fs|name overload|id) (ufth/>body-embeddable-tag reify|interface)) ~uana/direct-dispatch-method-sym ~@relevant-arglist)) ;; TODO spec @@ -969,7 +970,7 @@ (c/fn [i|arg arg-type] {:i i|arg :t arg-type - :getf `(~(aget* (with-array-type-hint (aget* ts|name id)) i|arg) + :getf `(~(uana/aget* (with-array-type-hint (uana/aget* ts|name id)) i|arg) ~(get relevant-arglist i|arg))})))]))))) (defns- >dynamic-dispatch|body-for-arity @@ -1358,7 +1359,7 @@ ~(:form dynamic-dispatch))] ~@(->> direct-dispatch-seq (map (c/fn [{:as reify-data :keys [id form]}] - (aset* fn|fs-name id form)))) + (uana/aset* fn|fs-name id form)))) ~fn|name|local)] {:form (case kind :fn fn-form @@ -1397,6 +1398,6 @@ (reset! uana/!!analyze-defnt analyze-defn) -(defns analyze-extend-defn [env ::uana/env, form _] (analyze-defn* :extend-defn! env form)) +(defns analyze-extend-defn [env ::uana/env, form _] (analyze-fn* :extend-defn! env form)) (reset! uana/!!analyze-extend-defnt analyze-extend-defn) From f16d1dc0e65430d34a0ee84d299db116f5b01395 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 16 Dec 2018 22:40:13 -0700 Subject: [PATCH 801/810] Add Mapbox link --- src/quantum/location/core.clj | 1 + 1 file changed, 1 insertion(+) diff --git a/src/quantum/location/core.clj b/src/quantum/location/core.clj index f5a3e85d..36514296 100644 --- a/src/quantum/location/core.clj +++ b/src/quantum/location/core.clj @@ -13,6 +13,7 @@ ; TO EXPLORE ; - http://developer.factual.com for Factual (Geo, etc.) API +; - https://www.mapbox.com/ — The premiere solution for map/geographical related things. Used by pretty much everybody important ; - Factual/geo ; - Countries of the world ; - (http/request! {:url http://restcountries.eu/rest/v1/all :parse? true}) From c79ebbfa45c04a2346c42532c435ba8813c5705e Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 16 Dec 2018 22:40:48 -0700 Subject: [PATCH 802/810] Making `test|fn` work --- .../quantum/test/untyped/core/type/defnt.cljc | 183 ++++++++++++++---- 1 file changed, 147 insertions(+), 36 deletions(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 74eb74fb..637914a0 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -6,7 +6,8 @@ [quantum.core.type :refer [dotyped]] [quantum.test.untyped.core.type :as tt] - [quantum.untyped.core.analyze :as uana] + [quantum.untyped.core.analyze :as uana + :refer [aget* aset*]] [quantum.untyped.core.data.array :refer [*<> *<>|sized]] [quantum.untyped.core.form @@ -22,7 +23,7 @@ :refer [deftest is is= is-code= testing throws]] [quantum.untyped.core.type :as t] [quantum.untyped.core.type.defnt :as self - :refer [aget* aset* unsupported!]] + :refer [unsupported!]] [quantum.untyped.core.type.reifications :as utr] [quantum.untyped.core.vars :refer [defmeta-from]]) @@ -62,13 +63,18 @@ (defn >__O [form] (tag (cstr `__O) form)) (defn >B__B [form] (tag (cstr `B__B) form)) +(defn >B__O [form] (tag (cstr `B__O) form)) (defn >Y__Y [form] (tag (cstr `Y__Y) form)) +(defn >Y__O [form] (tag (cstr `Y__O) form)) (defn >S__S [form] (tag (cstr `S__S) form)) +(defn >S__O [form] (tag (cstr `S__O) form)) (defn >C__C [form] (tag (cstr `C__C) form)) +(defn >C__O [form] (tag (cstr `C__O) form)) (defn >I__I [form] (tag (cstr `I__I) form)) (defn >L__L [form] (tag (cstr `L__L) form)) (defn >F__F [form] (tag (cstr `F__F) form)) (defn >D__D [form] (tag (cstr `D__D) form)) +(defn >D__O [form] (tag (cstr `D__O) form)) (defn >O__F [form] (tag (cstr `O__F) form)) (defn >O__O [form] (tag (cstr `O__O) form)) @@ -2509,6 +2515,17 @@ [(t/ref (t/isa? Comparable)) (t/ref (t/isa? Comparable))] [(t/value nil) (t/not (t/value nil))]])) +(defn- test|fn|gen-dynf [n hintf0 hintf1 unsupported-sym] + (let [ts (O<> (symbol (str "ts" n "__"))) + fs (O<> (symbol (str "fs" n "__"))) + x (symbol (str "x0" n "__"))] + `(fn* ([~(O<> 'ts6__) ~(O<> 'fs6__) ~x] + (ifs (~(aget* (O<> (aget* ts 0)) 0) ~x) + (. ~(hintf0 (aget* (O<> 'fs6__) 0)) ~'invoke ~x) + (~(aget* (O<> (aget* ts 1)) 0) ~x) + (. ~(hintf1 (aget* (O<> 'fs6__) 1)) ~'invoke ~x) + (unsupported! ~(list 'quote unsupported-sym) [~x] 0)))))) + (deftest test|fn (testing "Nested fns" (let [actual (binding [self/*compilation-mode* :test] @@ -2536,15 +2553,10 @@ {:quantum.core.type/type f0|test|__type} f0|test|__ts ~'f0|test|__fs - (fn* ([~&ts ~&fs ~'x00__] - (ifs (~(aget* (aget* &ts 0) 0) ~'x00__) - (. ~(aget* &fs 0) ~'invoke ~'x00__) - (~(aget* (aget* &ts 1) 0) ~'x00__) - (. ~(aget* &fs 1) ~'invoke ~'x00__) - (unsupported! `f0|test [~'x00__] 0)))))] + ~(test|fn|gen-dynf 6 >B__O >D__O `f0|test))] ~(aset* 'f0|test|__fs 0 `(reify* [~(csym `B__O)] - (~'invoke [~&this ~(B 'a)] + (~(O 'invoke) [~'_12__ ~(B 'a)] ;; From `(self/fn [b ...])` (let* [~'__anon0__|__fs (*<>|sized 2) ~'__anon0__ @@ -2554,49 +2566,148 @@ ;; (so around the outer `reify*`) ? (*<> (*<> t/byte?) (*<> t/char?)) ~'__anon0__|__fs - (fn* ([~&ts ~&fs ~'x00__] - (ifs (~(aget* (aget* ~&ts 0) 0) ~'x00__) - (. ~(>Y__O (aget* &fs 0)) ~'invoke ~'x00__) - (~(aget* (aget* ~&ts 1) 0) ~'x00__) - (. ~(>C__O (aget* &fs 1)) ~'invoke ~'x00__) - (unsupported! [~'x00__] 0)))))] + (fn* ([~(O<> 'ts2__) ~(O<> 'fs2__) ~'x02__] + (ifs (~(aget* (aget* 'ts2__ 0) 0) ~'x02__) + (. ~(>Y__O (aget* 'fs2__ 0)) ~'invoke ~'x02__) + (~(aget* (aget* 'ts2__ 1) 0) ~'x02__) + (. ~(>C__O (aget* 'fs2__ 1)) ~'invoke ~'x02__) + (unsupported! ~' [~'x02__] 0)))))] ~(aset* '__anon0__|__fs 0 `(reify* [~(csym `Y__O)] - (~'invoke [~'_0__ ~(Y 'b)] + (~(O 'invoke) [~'_0__ ~(Y 'b)] ;; From `(self/fn [c ...])` (let* [~'f1|test|__fs (*<>|sized 2) ~'f1|test (new TypedFn nil (*<> (*<> t/boolean?) (*<> t/short?)) ~'f1|test|__fs - (fn* ([~&ts ~&fs ~'x00] - (ifs (~(aget* (aget* &ts 0) 0) ~'x00__) - (. ~(>B__O (aget* &fs 0)) ~'invoke ~'x00__) - (~(aget* (aget* &ts 1) 0) ~'x00__) - (. ~(>S__O (aget* &fs 1)) ~'invoke ~'x00__) - (unsupported! [~'x00__] 0))))))] + (fn* + ([~(O<> 'ts0__) ~(O<> 'fs0__) ~'x00__] + (ifs (~(aget* (aget* 'ts0__ 0) 0) ~'x00__) + (. ~(>B__O (aget* &fs 0)) ~'invoke ~'x00__) + (~(aget* (aget* 'ts0__ 1) 0) ~'x00__) + (. ~(>S__O (aget* 'fs0__ 1)) ~'invoke ~'x00__) + (unsupported! ~'f1|test [~'x00__] 0)))))] + ~(aset* 'f1|test|__fs 0 + `(reify* [~(csym `B__O)] + (~(O 'invoke) [~&this (B 'c)] + ~'b + (. ~(>B__O (aget* '(. f1|test getFs) 0)) ~'invoke ~'a) + (. ~(>B__O (aget* '(. f1|test getFs) 0)) ~'invoke ~'c)))) + ~(aset* 'f1|test|__fs 1 + `(reify* [~(csym `S__O)] + (~(O 'invoke) [~&this (S 'c)] + ~'b + (. ~(>B__O (aget* '(. f1|test getFs) 0)) ~'invoke ~'a) + (. ~(>S__O (aget* '(. f1|test getFs) 1)) ~'invoke ~'c)))) + ~'f1|test)))) + ~(aset* '__anon0__|__fs 1 + `(reify* [~(csym `C__O)] + (~(O 'invoke) [~'_5__ ~(C 'b)] + ;; From `(self/fn [c ...])` + (let* [~'f1|test|__fs (*<>|sized 2) + ~'f1|test + (new TypedFn nil + ... + ~'f1|test|__fs + (fn* + ([~(O<> 'ts1__) ~(O<> 'fs1__) ~'x01__] + (ifs (~(aget* (aget* 'ts1__ 0) 0) ~'x01__) + (. ~(>B__O (aget* &fs 0)) ~'invoke ~'x01__) + (~(aget* (aget* 'ts1__ 1) 0) ~'x01__) + (. ~(>S__O (aget* 'fs1__ 1)) ~'invoke ~'x01__) + (unsupported! ~'f1|test [~'x01__] 0)))))] ~(aset* 'f1|test|__fs 0 `(reify* [~(csym `B__O)] - (~'invoke [~&this (B 'c)] + (~(O 'invoke) [~'_2__ (B 'c)] ~'b - (. ~(>B__O (aget* 'f1|test|__fs 0)) ~'invoke ~'a) - (. ~(>B__O (aget* 'f1|test|__fs 0)) ~'invoke ~'c)))) + (. ~(>B__O (aget* '(. f1|test getFs) 0)) ~'invoke ~'a) + (. ~(>B__O (aget* '(. f1|test getFs) 0)) ~'invoke ~'c)))) ~(aset* 'f1|test|__fs 1 `(reify* [~(csym `S__O)] - (~'invoke [~&this (S 'c)] + (~(O 'invoke) [~&this (S 'c)] ~'b - (. ~(>B__O (aget* 'f1|test|__fs 0)) ~'invoke ~'a) - (. ~(>S__O (aget* 'f1|test|__fs 1)) ~'invoke ~'c)))) - ~'f1|test))) - ~(aset* '__anon0__|__fs 1 - (reify* [~(csym `C__O)] - (~'invoke [~&this ~(C 'a)] ...))) - ~'__anon0__)))) + (. ~(>B__O (aget* '(. f1|test getFs) 0)) ~'invoke ~'a) + (. ~(>S__O (aget* '(. f1|test getFs) 1)) ~'invoke ~'c)))) + ~'f1|test)))) + ~'__anon0__)))) ~(aset* 'f0|test|__fs 1 `(reify* [~(csym `D__O)] - (~'invoke [~&this ~(D 'a)] ...))) - ~'f0|test))))])) - (testing "Calling fns" + (~(O 'invoke) [~'_13__ ~(D 'a)] + ;; From `(self/fn [b ...])` + (let* [~'__anon3__|__fs (*<>|sized 2) + ~'__anon3__ + (new TypedFn nil + ... + ~'__anon0__|__fs + (fn* ([~'(O<> ts5__) ~(O<> 'fs5__) ~'x05__] + (ifs (~(aget* (aget* 'ts5__ 0) 0) ~'x05__) + (. ~(>Y__O (aget* 'fs5__ 0)) ~'invoke ~'x05__) + (~(aget* (aget* 'ts5__ 1) 0) ~'x05__) + (. ~(>C__O (aget* 'fs5__ 1)) ~'invoke ~'x05__) + (unsupported! ~' [~'x05__] 0)))))] + ~(aset* '__anon3__|__fs 0 + `(reify* [~(csym `Y__O)] + (~(O 'invoke) [~'_10__ ~(Y 'b)] + ;; From `(self/fn [c ...])` + (let* [~'f1|test|__fs (*<>|sized 2) + ~'f1|test + (new TypedFn nil + ... + ~'f1|test|__fs + (fn* + ([~(O<> 'ts3__) ~(O<> 'fs3__) ~'x03__] + (ifs (~(aget* (aget* 'ts3__ 0) 0) ~'x03__) + (. ~(>B__O (aget* &fs 0)) ~'invoke ~'x03__) + (~(aget* (aget* 'ts3__ 1) 0) ~'x03__) + (. ~(>S__O (aget* 'fs3__ 1)) ~'invoke ~'x03__) + (unsupported! ~'f1|test [~'x03__] 0)))))] + ~(aset* 'f1|test|__fs 0 + `(reify* [~(csym `S__O)] + (~(O 'invoke) [~'_6__ (S 'c)] + ~'b + (. ~(>B__O (aget* '(. f1|test getFs) 1)) ~'invoke ~'a) + (. ~(>B__O (aget* '(. f1|test getFs) 0)) ~'invoke ~'c)))) + ~(aset* 'f1|test|__fs 1 + `(reify* [~(csym `D__O)] + (~(O 'invoke) [~'_7__ (D 'c)] + ~'b + (. ~(>B__O (aget* '(. f1|test getFs) 1)) ~'invoke ~'a) + (. ~(>S__O (aget* '(. f1|test getFs) 1)) ~'invoke ~'c)))) + ~'f1|test)))) + ~(aset* '__anon3__|__fs 1 + `(reify* [~(csym `C__O)] + (~(O 'invoke) [~'_11__ ~(C 'b)] + ;; From `(self/fn [c ...])` + (let* [~'f1|test|__fs (*<>|sized 2) + ~'f1|test + (new TypedFn nil + ... + ~'f1|test|__fs + (fn* + ([~(O<> 'ts4__) ~(O<> 'fs4__) ~'x04__] + (ifs (~(aget* (aget* 'ts4__ 0) 0) ~'x04__) + (. ~(>B__O (aget* &fs 0)) ~'invoke ~'x04__) + (~(aget* (aget* 'ts4__ 1) 0) ~'x04__) + (. ~(>S__O (aget* 'fs4__ 1)) ~'invoke ~'x04__) + (unsupported! ~'f1|test [~'x04__] 0)))))] + ~(aset* 'f1|test|__fs 0 + `(reify* [~(csym `S__O)] + (~(O 'invoke) [~'_8__ (S 'c)] + ~'b + (. ~(>B__O (aget* '(. f1|test getFs) 1)) ~'invoke ~'a) + (. ~(>B__O (aget* '(. f1|test getFs) 0)) ~'invoke ~'c)))) + ~(aset* 'f1|test|__fs 1 + `(reify* [~(csym `D__O)] + (~(O 'invoke) [~'_9__ (D 'c)] + ~'b + (. ~(>B__O (aget* '(. f1|test getFs) 1)) ~'invoke ~'a) + (. ~(>S__O (aget* '(. f1|test getFs) 1)) ~'invoke ~'c)))) + ~'f1|test)))) + ~'__anon3__)))) + ~'f0|test)))))] + (is-code= actual expected))) + #_(testing "Calling fns" (let [actual (binding [self/*compilation-mode* :test] (macroexpand ' (do (self/defn g|test [f0 (t/ftype [tt/long? :> tt/float?]) > tt/float?] From 28ce8ab8f04b0ad3d2c8fa0c65ea5aa94c28206c Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 16 Dec 2018 23:29:34 -0700 Subject: [PATCH 803/810] The code is now equivalent! --- .../quantum/untyped/core/type/defnt.cljc | 20 ++- .../quantum/test/untyped/core/type/defnt.cljc | 120 ++++++------------ 2 files changed, 50 insertions(+), 90 deletions(-) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 745c6942..1d8bc07a 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -1315,14 +1315,23 @@ [{:as opts :keys [kind _]} ::opts {:as fn|globals :keys [fn|ns-name _, fn|ts-name _]} ::fn|globals fn|types ::fn|types - #_> #_(t/of oarray? (t/of oarray? t/type?))] + > (us/kv {:ts t/any? ; (t/of oarray? (t/of oarray? t/type?) + :form t/any?})] + ;; TODO perhaps extern this (and parts thereof) whenever possible in `let*` statement on the very + ;; outside of the fn (so around the outer `reify*`) ? (let [ts (->> fn|types :overload-types (uc/map+ (fn-> :arg-types uc/>array)) uc/>array)] - ;; TODO need to avoid this in CLJS and when there are closed over locals in the type - (intern-with-rollback! fn|ns-name fn|ts-name ts) - ts)) + (if (= kind :fn) + (let [form (list* `uarr/*<> + (->> fn|types + :overload-types + (uc/lmap (fn->> :arg-types (uc/lmap >form) (list* `uarr/*<>)))))] + {:ts ts :form form}) + (do ;; TODO need to avoid this in CLJS and when there are closed over locals in the type + (intern-with-rollback! fn|ns-name fn|ts-name ts) + {:ts ts :form (uid/qualify fn|ns-name fn|ts-name)})))) ;; TODO lazily and incrementally analyze this; maybe we want to do code transformations which don't ;; require analysis, as shown in tests @@ -1352,10 +1361,9 @@ (uid/qualify fn|ns-name fn|type-name)})) direct-dispatch-seq (>direct-dispatch-seq opts fn|globals fn|types) dynamic-dispatch (>dynamic-dispatch opts fn|globals fn|types) - qualified-ts-name (uid/qualify fn|ns-name fn|ts-name) fn-form `(let* [~fn|fs-name (uarr/*<>|sized ~(-> fn|types :overload-types count)) - ~fn|name|local (new TypedFn ~fn|meta ~qualified-ts-name ~fn|fs-name + ~fn|name|local (new TypedFn ~fn|meta ~(:form fn|ts) ~fn|fs-name ~(:form dynamic-dispatch))] ~@(->> direct-dispatch-seq (map (c/fn [{:as reify-data :keys [id form]}] diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 637914a0..3f947499 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -2519,13 +2519,18 @@ (let [ts (O<> (symbol (str "ts" n "__"))) fs (O<> (symbol (str "fs" n "__"))) x (symbol (str "x0" n "__"))] - `(fn* ([~(O<> 'ts6__) ~(O<> 'fs6__) ~x] + `(fn* ([~(O<> ts) ~(O<> fs) ~x] (ifs (~(aget* (O<> (aget* ts 0)) 0) ~x) - (. ~(hintf0 (aget* (O<> 'fs6__) 0)) ~'invoke ~x) + (. ~(hintf0 (aget* (O<> fs) 0)) ~'invoke ~x) (~(aget* (O<> (aget* ts 1)) 0) ~x) - (. ~(hintf1 (aget* (O<> 'fs6__) 1)) ~'invoke ~x) + (. ~(hintf1 (aget* (O<> fs) 1)) ~'invoke ~x) (unsupported! ~(list 'quote unsupported-sym) [~x] 0)))))) +(defn- test|fn|reify-body [hintf0 i0 hintf1 i1] + (O `(do ~'b + ~(O `(. ~(hintf0 (aget* `(. ~(tag (cstr `TypedFn) 'f1|test) ~'getFs) i0)) ~'invoke ~'a)) + ~(O `(. ~(hintf1 (aget* `(. ~(tag (cstr `TypedFn) 'f1|test) ~'getFs) i1)) ~'invoke ~'c))))) + (deftest test|fn (testing "Nested fns" (let [actual (binding [self/*compilation-mode* :test] @@ -2561,45 +2566,27 @@ (let* [~'__anon0__|__fs (*<>|sized 2) ~'__anon0__ (new TypedFn nil - ;; TODO perhaps extern this (and parts thereof) whenever - ;; possible in `let*` statement on the very outside of the fn - ;; (so around the outer `reify*`) ? (*<> (*<> t/byte?) (*<> t/char?)) ~'__anon0__|__fs - (fn* ([~(O<> 'ts2__) ~(O<> 'fs2__) ~'x02__] - (ifs (~(aget* (aget* 'ts2__ 0) 0) ~'x02__) - (. ~(>Y__O (aget* 'fs2__ 0)) ~'invoke ~'x02__) - (~(aget* (aget* 'ts2__ 1) 0) ~'x02__) - (. ~(>C__O (aget* 'fs2__ 1)) ~'invoke ~'x02__) - (unsupported! ~' [~'x02__] 0)))))] + ~(test|fn|gen-dynf 2 >Y__O >C__O '))] ~(aset* '__anon0__|__fs 0 `(reify* [~(csym `Y__O)] - (~(O 'invoke) [~'_0__ ~(Y 'b)] + (~(O 'invoke) [~'_4__ ~(Y 'b)] ;; From `(self/fn [c ...])` (let* [~'f1|test|__fs (*<>|sized 2) ~'f1|test (new TypedFn nil (*<> (*<> t/boolean?) (*<> t/short?)) ~'f1|test|__fs - (fn* - ([~(O<> 'ts0__) ~(O<> 'fs0__) ~'x00__] - (ifs (~(aget* (aget* 'ts0__ 0) 0) ~'x00__) - (. ~(>B__O (aget* &fs 0)) ~'invoke ~'x00__) - (~(aget* (aget* 'ts0__ 1) 0) ~'x00__) - (. ~(>S__O (aget* 'fs0__ 1)) ~'invoke ~'x00__) - (unsupported! ~'f1|test [~'x00__] 0)))))] + ~(test|fn|gen-dynf 0 >B__O >S__O 'f1|test))] ~(aset* 'f1|test|__fs 0 `(reify* [~(csym `B__O)] - (~(O 'invoke) [~&this (B 'c)] - ~'b - (. ~(>B__O (aget* '(. f1|test getFs) 0)) ~'invoke ~'a) - (. ~(>B__O (aget* '(. f1|test getFs) 0)) ~'invoke ~'c)))) + (~(O 'invoke) [~'_0__ ~(B 'c)] + ~(test|fn|reify-body >B__O 0 >B__O 0)))) ~(aset* 'f1|test|__fs 1 `(reify* [~(csym `S__O)] - (~(O 'invoke) [~&this (S 'c)] - ~'b - (. ~(>B__O (aget* '(. f1|test getFs) 0)) ~'invoke ~'a) - (. ~(>S__O (aget* '(. f1|test getFs) 1)) ~'invoke ~'c)))) + (~(O 'invoke) [~'_1__ ~(S 'c)] + ~(test|fn|reify-body >B__O 0 >S__O 1)))) ~'f1|test)))) ~(aset* '__anon0__|__fs 1 `(reify* [~(csym `C__O)] @@ -2608,27 +2595,17 @@ (let* [~'f1|test|__fs (*<>|sized 2) ~'f1|test (new TypedFn nil - ... + (*<> (*<> t/boolean?) (*<> t/short?)) ~'f1|test|__fs - (fn* - ([~(O<> 'ts1__) ~(O<> 'fs1__) ~'x01__] - (ifs (~(aget* (aget* 'ts1__ 0) 0) ~'x01__) - (. ~(>B__O (aget* &fs 0)) ~'invoke ~'x01__) - (~(aget* (aget* 'ts1__ 1) 0) ~'x01__) - (. ~(>S__O (aget* 'fs1__ 1)) ~'invoke ~'x01__) - (unsupported! ~'f1|test [~'x01__] 0)))))] + ~(test|fn|gen-dynf 1 >B__O >S__O 'f1|test))] ~(aset* 'f1|test|__fs 0 `(reify* [~(csym `B__O)] - (~(O 'invoke) [~'_2__ (B 'c)] - ~'b - (. ~(>B__O (aget* '(. f1|test getFs) 0)) ~'invoke ~'a) - (. ~(>B__O (aget* '(. f1|test getFs) 0)) ~'invoke ~'c)))) + (~(O 'invoke) [~'_2__ ~(B 'c)] + ~(test|fn|reify-body >B__O 0 >B__O 0)))) ~(aset* 'f1|test|__fs 1 `(reify* [~(csym `S__O)] - (~(O 'invoke) [~&this (S 'c)] - ~'b - (. ~(>B__O (aget* '(. f1|test getFs) 0)) ~'invoke ~'a) - (. ~(>S__O (aget* '(. f1|test getFs) 1)) ~'invoke ~'c)))) + (~(O 'invoke) [~'_3__ ~(S 'c)] + ~(test|fn|reify-body >B__O 0 >S__O 1)))) ~'f1|test)))) ~'__anon0__)))) ~(aset* 'f0|test|__fs 1 @@ -2638,14 +2615,9 @@ (let* [~'__anon3__|__fs (*<>|sized 2) ~'__anon3__ (new TypedFn nil - ... - ~'__anon0__|__fs - (fn* ([~'(O<> ts5__) ~(O<> 'fs5__) ~'x05__] - (ifs (~(aget* (aget* 'ts5__ 0) 0) ~'x05__) - (. ~(>Y__O (aget* 'fs5__ 0)) ~'invoke ~'x05__) - (~(aget* (aget* 'ts5__ 1) 0) ~'x05__) - (. ~(>C__O (aget* 'fs5__ 1)) ~'invoke ~'x05__) - (unsupported! ~' [~'x05__] 0)))))] + (*<> (*<> t/byte?) (*<> t/char?)) + ~'__anon3__|__fs + ~(test|fn|gen-dynf 5 >Y__O >C__O '))] ~(aset* '__anon3__|__fs 0 `(reify* [~(csym `Y__O)] (~(O 'invoke) [~'_10__ ~(Y 'b)] @@ -2653,27 +2625,17 @@ (let* [~'f1|test|__fs (*<>|sized 2) ~'f1|test (new TypedFn nil - ... + (*<> (*<> t/short?) (*<> t/double?)) ~'f1|test|__fs - (fn* - ([~(O<> 'ts3__) ~(O<> 'fs3__) ~'x03__] - (ifs (~(aget* (aget* 'ts3__ 0) 0) ~'x03__) - (. ~(>B__O (aget* &fs 0)) ~'invoke ~'x03__) - (~(aget* (aget* 'ts3__ 1) 0) ~'x03__) - (. ~(>S__O (aget* 'fs3__ 1)) ~'invoke ~'x03__) - (unsupported! ~'f1|test [~'x03__] 0)))))] + ~(test|fn|gen-dynf 3 >S__O >D__O 'f1|test))] ~(aset* 'f1|test|__fs 0 `(reify* [~(csym `S__O)] - (~(O 'invoke) [~'_6__ (S 'c)] - ~'b - (. ~(>B__O (aget* '(. f1|test getFs) 1)) ~'invoke ~'a) - (. ~(>B__O (aget* '(. f1|test getFs) 0)) ~'invoke ~'c)))) + (~(O 'invoke) [~'_6__ ~(S 'c)] + ~(test|fn|reify-body >D__O 1 >S__O 0)))) ~(aset* 'f1|test|__fs 1 `(reify* [~(csym `D__O)] - (~(O 'invoke) [~'_7__ (D 'c)] - ~'b - (. ~(>B__O (aget* '(. f1|test getFs) 1)) ~'invoke ~'a) - (. ~(>S__O (aget* '(. f1|test getFs) 1)) ~'invoke ~'c)))) + (~(O 'invoke) [~'_7__ ~(D 'c)] + ~(test|fn|reify-body >D__O 1 >D__O 1)))) ~'f1|test)))) ~(aset* '__anon3__|__fs 1 `(reify* [~(csym `C__O)] @@ -2682,27 +2644,17 @@ (let* [~'f1|test|__fs (*<>|sized 2) ~'f1|test (new TypedFn nil - ... + (*<> (*<> t/short?) (*<> t/double?)) ~'f1|test|__fs - (fn* - ([~(O<> 'ts4__) ~(O<> 'fs4__) ~'x04__] - (ifs (~(aget* (aget* 'ts4__ 0) 0) ~'x04__) - (. ~(>B__O (aget* &fs 0)) ~'invoke ~'x04__) - (~(aget* (aget* 'ts4__ 1) 0) ~'x04__) - (. ~(>S__O (aget* 'fs4__ 1)) ~'invoke ~'x04__) - (unsupported! ~'f1|test [~'x04__] 0)))))] + ~(test|fn|gen-dynf 4 >S__O >D__O 'f1|test))] ~(aset* 'f1|test|__fs 0 `(reify* [~(csym `S__O)] - (~(O 'invoke) [~'_8__ (S 'c)] - ~'b - (. ~(>B__O (aget* '(. f1|test getFs) 1)) ~'invoke ~'a) - (. ~(>B__O (aget* '(. f1|test getFs) 0)) ~'invoke ~'c)))) + (~(O 'invoke) [~'_8__ ~(S 'c)] + ~(test|fn|reify-body >D__O 1 >S__O 0)))) ~(aset* 'f1|test|__fs 1 `(reify* [~(csym `D__O)] - (~(O 'invoke) [~'_9__ (D 'c)] - ~'b - (. ~(>B__O (aget* '(. f1|test getFs) 1)) ~'invoke ~'a) - (. ~(>S__O (aget* '(. f1|test getFs) 1)) ~'invoke ~'c)))) + (~(O 'invoke) [~'_9__ ~(D 'c)] + ~(test|fn|reify-body >D__O 1 >D__O 1)))) ~'f1|test)))) ~'__anon3__)))) ~'f0|test)))))] From 414e0baaa93c17b0dbe765cc3aa1d038bac2aac2 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Sun, 16 Dec 2018 23:33:01 -0700 Subject: [PATCH 804/810] Tests pass! :D --- test/quantum/test/untyped/core/type/defnt.cljc | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index 3f947499..daf6d8f1 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -2658,7 +2658,10 @@ ~'f1|test)))) ~'__anon3__)))) ~'f0|test)))))] - (is-code= actual expected))) + (testing "code equivalence" (is-code= actual expected)) + (testing "functionality" + (eval actual) + (eval '((f0|test true) \A))))) #_(testing "Calling fns" (let [actual (binding [self/*compilation-mode* :test] (macroexpand ' From 69a1cbf182c8f41555639b1c1d7f00143a31cdce Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 17 Jan 2019 14:25:09 -0700 Subject: [PATCH 805/810] Update voltdb.sql --- doc/voltdb.sql | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/doc/voltdb.sql b/doc/voltdb.sql index 02f0176c..adcaf20e 100644 --- a/doc/voltdb.sql +++ b/doc/voltdb.sql @@ -1,3 +1,6 @@ +-- ~/voltdb-community-8.3.3/bin/voltdb start --http=8081 +-- ./bin/voltdb/sqlcmd + -- TODO performance-test this against Datomic! Generate a bunch of random data till it gets big drop table entities; @@ -30,8 +33,7 @@ create index vaet on entities (v, a, e, t); create index t on entities (t); -- TODO is this wise? It seems the best partitioning but might not be -partition table entities on column t; - +partition table entities on column e; -- Multiple insert in one clause is not supported insert into entities (t, e, a, v) values (0, -9223372036854775807, 'db|attribute' , 'db|attribute'); @@ -68,7 +70,7 @@ select max(e) + 1 from entities; -- TODO make sure revisions (changes in value of an identity across time) are addressed here select customer.e - from entities as concert, + from s as concert, entities as booking, entities as customer where ( concert.a = "concert/organization" @@ -76,10 +78,10 @@ select customer.e or ( booking.a = "booking/concert" and booking.v = concert.e) or ( booking.a = "booking/customer" - and booking.v = customer.e) + and booking.v = customer.e); -- This is probably as much effort as the type system. I think we should do it only when we start to -- scale, and only if it proves to have performance gains that Datomic can't match. We should code -- to the Datomic interface though. Plus if we preserve all the data in datom format, it's about the -- easiest thing to migrate (in theory). Perhaps we should do it either way — having source code we --- can configure and edit it really helpful. +-- can configure and edit will be really helpful. From c54b71db0a04ab651b5ad3178bf4d832f6a9f059 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 17 Jan 2019 14:25:21 -0700 Subject: [PATCH 806/810] Excise Datomic; add VoltDB --- project-base.clj | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/project-base.clj b/project-base.clj index bddd593d..d5e5031d 100644 --- a/project-base.clj +++ b/project-base.clj @@ -198,14 +198,7 @@ #_[binaryage/devtools "0.5.2" ] [environ "1.0.3" ] ; ==== DB ==== - ; DATOMIC - #_[quantum/datomic-pro "0.9.5206" ; Doesn't work, apparnetly - :exclusions [joda-time - org.slf4j/slf4j-nop - org.slf4j/log4j-over-slf4j - org.slf4j/jul-to-slf4j - org.slf4j/jcl-over-slf4j - org.codehaus.janino/commons-compiler-jdk] ] + [org.voltdb/voltdbclient "8.3"] [com.datomic/datomic-free "0.9.5407" :exclusions [org.slf4j/slf4j-nop org.slf4j/log4j-over-slf4j From b1198581c79350105b10e46d7759eab9c4e4c770 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 17 Jan 2019 14:25:40 -0700 Subject: [PATCH 807/810] Went through this --- resources-dev/clojure-lang-numbers-temp.java | 123 ------------------- 1 file changed, 123 deletions(-) diff --git a/resources-dev/clojure-lang-numbers-temp.java b/resources-dev/clojure-lang-numbers-temp.java index 97277209..d316d468 100644 --- a/resources-dev/clojure-lang-numbers-temp.java +++ b/resources-dev/clojure-lang-numbers-temp.java @@ -1650,10 +1650,6 @@ static public Number divide(long x, long y){ return divide((Number)x, (Number)y); } -static public double max(double x, double y){ - return Math.max(x, y); -} - static public Object max(double x, long y){ if(Double.isNaN(x)){ return x; @@ -1665,19 +1661,6 @@ static public Object max(double x, long y){ } } -static public Object max(double x, Object y){ - if(Double.isNaN(x)){ - return x; - } else if(isNaN(y)){ - return y; - } - if(x > ((Number)y).doubleValue()){ - return x; - } else { - return y; - } -} - static public Object max(long x, double y){ if(Double.isNaN(y)){ return y; @@ -1690,50 +1673,6 @@ static public Object max(long x, double y){ } -static public long max(long x, long y){ - if(x > y) { - return x; - } else { - return y; - } -} - - -static public Object max(long x, Object y){ - if(isNaN(y)){ - return y; - } - if(gt(x,y)){ - return x; - } else { - return y; - } -} - -static public Object max(Object x, long y){ - if(isNaN(x)){ - return x; - } - if(gt(x,y)){ - return x; - } else { - return y; - } -} - -static public Object max(Object x, double y){ - if (isNaN(x)){ - return x; - } else if(Double.isNaN(y)){ - return y; - } - if(((Number)x).doubleValue() > y){ - return x; - } else { - return y; - } -} - static public Object max(Object x, Object y){ if(isNaN(x)){ return x; @@ -1747,11 +1686,6 @@ static public Object max(Object x, Object y){ } } - -static public double min(double x, double y){ - return Math.min(x, y); -} - static public Object min(double x, long y){ if (Double.isNaN(x)){ return x; @@ -1763,19 +1697,6 @@ static public Object min(double x, long y){ } } -static public Object min(double x, Object y){ - if(Double.isNaN(x)){ - return x; - } else if(isNaN(y)){ - return y; - } - if(x < ((Number)y).doubleValue()){ - return x; - } else { - return y; - } -} - static public Object min(long x, double y){ if(Double.isNaN(y)){ return y; @@ -1787,50 +1708,6 @@ static public Object min(long x, double y){ } } - -static public long min(long x, long y){ - if(x < y) { - return x; - } else { - return y; - } -} - -static public Object min(long x, Object y){ - if(isNaN(y)){ - return y; - } - if(lt(x,y)){ - return x; - } else { - return y; - } -} - -static public Object min(Object x, long y){ - if(isNaN(x)){ - return x; - } - if(lt(x,y)){ - return x; - } else { - return y; - } -} - -static public Object min(Object x, double y){ - if(isNaN(x)){ - return x; - } else if(Double.isNaN(y)){ - return y; - } - if(((Number)x).doubleValue() < y){ - return x; - } else { - return y; - } -} - static public Object min(Object x, Object y){ if (isNaN(x)){ return x; From 192fb915d877bfa1142b223ad14c5db9e119c929 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 17 Jan 2019 14:25:43 -0700 Subject: [PATCH 808/810] Create voltdb.cljc --- src/quantum/db/voltdb.cljc | 57 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 57 insertions(+) create mode 100644 src/quantum/db/voltdb.cljc diff --git a/src/quantum/db/voltdb.cljc b/src/quantum/db/voltdb.cljc new file mode 100644 index 00000000..72eb6dfb --- /dev/null +++ b/src/quantum/db/voltdb.cljc @@ -0,0 +1,57 @@ +(ns quantum.db.voltdb + (:require + [com.stuartsierra.component :as comp]) + #?(:clj (:import + [org.voltdb SQLStmt] + [org.voltdb.client Client ClientConfig ClientFactory]))) + +(do + +(defrecord VoltDB [^Client client host username password] + comp/Lifecycle + (start [this] + (let [^String username (or username "") + ^String password (or password "") + config (ClientConfig. username password) + _ (.setTopologyChangeAware config true) + client (ClientFactory/createClient config)] + (.createConnection client (or host "localhost")) + (assoc this :client client))) + (stop [this] + (.drain client) + (.close client) + (assoc this :client nil))) + +(let [{:as db :keys [^Client client]} (comp/start (map->VoltDB {}))] + (try + ( client) + (finally (comp/stop db))))) + + +public final SQLStmt GetSeats = new SQLStmt( + "SELECT numberofseats FROM Flight WHERE flightid=?;"); + +voltQueueSQL(GetSeats, EXPECT_ONE_ROW, flightid); +VoltTable[] recordset = voltExecuteSQL(); + + +VoltTable[] results; + +try { results = client.callProcedure("LookupFlight", 1 + origin, + dest, + departtime).getResults(); 2 +} catch (Exception e) { 3 + e.printStackTrace(); + System.exit(-1); +} + + +Asynchronous Invocation +To invoke stored procedures asynchronously, use the callProcedure() method with an additional first argument, a callback that will be notified when the procedure completes (or an error occurs). For example, to invoke a NewCustomer() stored procedure asynchronously, the call to callProcedure() might look like the following: + +client.callProcedure(new MyCallback(), + "NewCustomer", + firstname, + lastname, + custID}; From fa7efbd371fe124d172f18b56a11a12053cadafa Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 17 Jan 2019 14:26:03 -0700 Subject: [PATCH 809/810] Start back work on tests --- src-untyped/quantum/untyped/core/analyze.cljc | 15 ++-- .../quantum/untyped/core/type/defnt.cljc | 2 +- .../quantum/test/untyped/core/type/defnt.cljc | 89 +++++++++---------- 3 files changed, 51 insertions(+), 55 deletions(-) diff --git a/src-untyped/quantum/untyped/core/analyze.cljc b/src-untyped/quantum/untyped/core/analyze.cljc index a9334b2d..a6fcdcb7 100644 --- a/src-untyped/quantum/untyped/core/analyze.cljc +++ b/src-untyped/quantum/untyped/core/analyze.cljc @@ -693,19 +693,20 @@ (defns- caller>overload-type-data-for-arity [env ::env, caller|node uast/node?, caller|type _, inputs-ct _] - (if-let [fn|name (utr/fn-type>fn-name caller|type)] + ;; FIXME pull name from local binding if not present on type + (if-not-let [fn|name (utr/fn-type>fn-name caller|type)] + (err! "No name found for typed fn corresponding to caller" + (assoc (select-keys caller|node [:unanalyzed-form :form]) :type caller|type)) (let [overload-types-name (symbol (namespace fn|name) (str (name fn|name) "|__types"))] (if-let [fn|types-node (get env overload-types-name)] (->> fn|types-node :value (uc/filter #(-> % :arg-types count (= inputs-ct)))) - (if-let [fn|types-var (uvar/resolve (or (-> env :opts :ns) *ns*) overload-types-name)] - (->> fn|types-var var-get urx/norx-deref :overload-types - (uc/filter #(-> % :arg-types count (= inputs-ct)))) + (if-not-let [fn|types-var (uvar/resolve (or (-> env :opts :ns) *ns*) overload-types-name)] (err! "Overload-types not found for typed fn" {:fn|name fn|name :caller (assoc (select-keys caller|node [:unanalyzed-form :form]) - :type caller|type)})))) - (err! "No name found for typed fn corresponding to caller" - (assoc (select-keys caller|node [:unanalyzed-form :form]) :type caller|type)))) + :type caller|type)}) + (->> fn|types-var var-get urx/norx-deref :overload-types + (uc/filter #(-> % :arg-types count (= inputs-ct))))))))) (def direct-dispatch-method-sym 'invoke) diff --git a/src-untyped/quantum/untyped/core/type/defnt.cljc b/src-untyped/quantum/untyped/core/type/defnt.cljc index 1d8bc07a..831c627b 100644 --- a/src-untyped/quantum/untyped/core/type/defnt.cljc +++ b/src-untyped/quantum/untyped/core/type/defnt.cljc @@ -33,7 +33,7 @@ [quantum.untyped.core.error :as uerr :refer [TODO err!]] [quantum.untyped.core.fn - :refer [<- aritoid fn' fn1 fn-> with-do with-do-let]] + :refer [<- aritoid fn' fn1 fn-> fn->> with-do with-do-let]] [quantum.untyped.core.form :as uform :refer [>form]] [quantum.untyped.core.form.evaluate :as ufeval] diff --git a/test/quantum/test/untyped/core/type/defnt.cljc b/test/quantum/test/untyped/core/type/defnt.cljc index daf6d8f1..3ce7bb81 100644 --- a/test/quantum/test/untyped/core/type/defnt.cljc +++ b/test/quantum/test/untyped/core/type/defnt.cljc @@ -2449,7 +2449,7 @@ (deftest test|sort-overload-types - (is= (self/sort-overload-types core/identity + (is-code= (self/sort-overload-types core/identity [[(t/isa? Boolean) (t/value nil)] [(t/isa? Double) (t/isa? Byte)] [(t/isa? Double) (t/isa? Short)] @@ -2483,37 +2483,37 @@ [(t/ref (t/isa? Comparable)) (t/isa? Double)] [(t/ref (t/isa? Comparable)) (t/ref (t/isa? Comparable))]]) [[(t/value nil) (t/value nil)] - [(t/isa? Boolean) (t/value nil)] [(t/value nil) (t/isa? Boolean)] [(t/value nil) (t/isa? Byte)] - [(t/isa? Double) (t/isa? Byte)] [(t/value nil) (t/isa? Short)] - [(t/isa? Double) (t/isa? Short)] [(t/value nil) (t/isa? Character)] - [(t/isa? Double) (t/isa? Character)] [(t/value nil) (t/isa? Integer)] - [(t/isa? Double) (t/isa? Integer)] [(t/value nil) (t/isa? Long)] - [(t/isa? Double) (t/isa? Long)] [(t/value nil) (t/isa? Float)] - [(t/isa? Double) (t/isa? Float)] [(t/value nil) (t/isa? Double)] - [(t/isa? Double) (t/isa? Double)] - [(t/isa? Double) (t/ref (t/isa? Comparable))] + [(t/value nil) (t/not (t/value nil))] + [(t/isa? Boolean) (t/value nil)] [(t/isa? Double) (t/value nil)] - [(t/value true) (t/value false)] + [(t/isa? Double) (t/isa? Byte)] + [(t/isa? Double) (t/isa? Short)] + [(t/isa? Double) (t/isa? Character)] + [(t/isa? Double) (t/isa? Integer)] + [(t/isa? Double) (t/isa? Long)] + [(t/isa? Double) (t/isa? Float)] + [(t/isa? Double) (t/isa? Double)] [(t/value true) (t/value true)] - [(t/value false) (t/value false)] + [(t/value true) (t/value false)] [(t/value false) (t/value true)] + [(t/value false) (t/value false)] [(t/ref (t/isa? Comparable)) (t/isa? Byte)] [(t/ref (t/isa? Comparable)) (t/isa? Short)] + [(t/isa? Double) (t/ref (t/isa? Comparable))] [(t/ref (t/isa? Comparable)) (t/isa? Character)] [(t/ref (t/isa? Comparable)) (t/isa? Integer)] [(t/ref (t/isa? Comparable)) (t/isa? Long)] [(t/ref (t/isa? Comparable)) (t/isa? Float)] [(t/ref (t/isa? Comparable)) (t/isa? Double)] - [(t/ref (t/isa? Comparable)) (t/ref (t/isa? Comparable))] - [(t/value nil) (t/not (t/value nil))]])) + [(t/ref (t/isa? Comparable)) (t/ref (t/isa? Comparable))]])) (defn- test|fn|gen-dynf [n hintf0 hintf1 unsupported-sym] (let [ts (O<> (symbol (str "ts" n "__"))) @@ -2662,39 +2662,34 @@ (testing "functionality" (eval actual) (eval '((f0|test true) \A))))) - #_(testing "Calling fns" - (let [actual (binding [self/*compilation-mode* :test] - (macroexpand ' - (do (self/defn g|test [f0 (t/ftype [tt/long? :> tt/float?]) > tt/float?] - (f0 5)) - (self/defn h|test [f0 (t/ftype [tt/string? :> tt/char?]) > (t/type f0)] - f0) - ;; This won't compile - #_(self/defn i|test [f0 (t/ftype [tt/string? :> tt/char?]) - > (t/ftype' [tt/string? :> tt/char?])] - f0) - (self/defn i|test [f0 (t/ftype' [tt/string? :> tt/char?]) > (t/type f0)] - f0) - (self/defn j|test [f0 (t/ftype [tt/long? :> tt/float?] - [tt/string? :> tt/char?]) - f1 (t/ftype [tt/byte? :> tt/boolean?] - [tt/long? :> tt/char?] - [tt/string? :> tt/char?]) - f2 (t/ftype' [tt/long? :> tt/float?]) - > tt/char?] - (f0 7) - (f1 21) - (g|test f0) - ((h|test f0) "63") - ;; This won't compile - #_((i|test f0) "98") - ((i|test ^:wrap f0) "98") - (j|test f1 f0) - ;; FIXME for `t/ftype` comparison: what if `f1` also has the overload - ;; `[(t/and tt/string? (fn-> count (= 2))) :> tt/double?]`? - ;; Then yes `f1` accepts at least `tt/string?`, which outputs no more - ;; than `tt/boolean?`, but it's not clear whether `tt/double?` or `tt/char?` gets output - (f1 "11"))))) + (testing "Calling fns" + (eval '(self/defn g|test [f0 (t/ftype [tt/long? :> tt/float?]) > tt/float?] (f0 5))) + (eval '(self/defn h|test [f0 (t/ftype [tt/string? :> tt/char?]) > (t/type f0)] f0)) + (eval '(self/defn i|test [f0 (t/ftype' [tt/string? :> tt/char?]) > (t/type f0)] f0)) + (let [j|test|actual + (binding [self/*compilation-mode* :test] + (macroexpand ' + (self/defn j|test [f0 (t/ftype [tt/long? :> tt/float?] + [tt/string? :> tt/char?]) + f1 (t/ftype [tt/byte? :> tt/boolean?] + [tt/long? :> tt/char?] + [tt/string? :> tt/char?]) + f2 (t/ftype' [tt/long? :> tt/float?]) + > tt/char?] + (f0 7) + (f1 21) + (g|test f0) + ((h|test f0) "63") + ;; This won't compile + #_((i|test f0) "98") + ((i|test ^:wrap f0) "98") + (j|test f1 f0) + ;; FIXME for `t/ftype` comparison: what if `f1` also has the overload + ;; `[(t/and tt/string? (fn-> count (= 2))) :> tt/double?]`? + ;; Then yes `f1` accepts at least `tt/string?`, which outputs no more than + ;; `tt/boolean?`, but it's not clear whether `tt/double?` or `tt/char?` gets + ;; output + (f1 "11")))) expected (case (env-lang) :clj From abfafe809c627b54f886c3e61ee6957cc7ec2b66 Mon Sep 17 00:00:00 2001 From: Alex Gunnarson Date: Thu, 17 Jan 2019 14:26:11 -0700 Subject: [PATCH 810/810] Put todos elsewhere --- resources-dev/defnt.cljc | 25 ------------------------- 1 file changed, 25 deletions(-) diff --git a/resources-dev/defnt.cljc b/resources-dev/defnt.cljc index c29cae63..13140ae2 100644 --- a/resources-dev/defnt.cljc +++ b/resources-dev/defnt.cljc @@ -66,31 +66,6 @@ Legend: - [!] : refused - TODO implement the following: - [-] t/fn - [-] Get `t/defn` working with `let*` + TypedFn way of doing things - [ ] Sketch out `defnt/analyze-fn` using tests as a guide - [ ] t/ftype should automatically split types, while perhaps t/ftype* should just assume - they're split (for use by e.g. `t/fn` and `t/defn`) - [ ] test t/fn to make sure meta 'sticks' : `(t/fn {...} [] ...)` - [ ] support `ts` and `types` referring to closed-over local vars - - Should do e.g. `(OrType. ... [t/boolean? (AndType. ...)])` to have minimal overhead - [2] `?` : type inference - - use logic programming and variable unification e.g. `?1` `?2` ? - - For this situation: `?` is `(t/- dc/counted?)` - ([n dn/std-integer?, xs dc/counted?] (count xs)) - ([n dn/std-integer?, xs ?] ...) - - [ ] No trailing `>` means `> ?` - [3] inner expansion (see tests to see how this could work) - [4] t/numerically : e.g. a double representing exactly what a float is able to represent - - and variants thereof: `numerically-long?` etc. - - t/numerically-integer? - - Primitive conversions not requiring checks can go in data.primitive - - core.data.numeric (requires data.primitive) - - numeric definitions - - numeric ranges - - numeric characteristics - [ ] Probably should disallow recursive type references, including: - `(t/defn f [x (t/input f ...)])` [ ] Perhaps it's the case that we can't actually have type bases but rather reactive splits. In the case of `narrowest`, it expects a split and fails without it: `[a (t/- integer? int?), b integer? > (narrowest (t/type a) (t/type b))]`