diff --git a/deps.edn b/deps.edn index bcce61de..c3bad5bf 100644 --- a/deps.edn +++ b/deps.edn @@ -5,6 +5,8 @@ "feature-lanterna" "feature-core-match" "feature-hiccup" + "feature-test-check" + "feature-spec-alpha" "sci/src" "babashka.curl/src" "pods/src" "babashka.nrepl/src" "depstar/src" "process/src" @@ -21,6 +23,7 @@ org.clojure/data.xml {:mvn/version "0.2.0-alpha6"} clj-commons/clj-yaml {:mvn/version "0.7.2"} com.cognitect/transit-clj {:mvn/version "1.0.324"} + org.clojure/test.check {:mvn/version "1.1.0"} nrepl/bencode {:mvn/version "1.1.0"} seancorfield/next.jdbc {:mvn/version "1.1.610"} org.postgresql/postgresql {:mvn/version "42.2.18"} diff --git a/feature-spec-alpha/babashka/impl/spec.clj b/feature-spec-alpha/babashka/impl/spec.clj new file mode 100644 index 00000000..7e01d189 --- /dev/null +++ b/feature-spec-alpha/babashka/impl/spec.clj @@ -0,0 +1,61 @@ +(ns babashka.impl.spec + {:no-doc true} + (:require [babashka.impl.clojure.spec.alpha :as s] + [babashka.impl.clojure.spec.gen.alpha :as gen] + [babashka.impl.clojure.spec.test.alpha :as test] + [clojure.core :as c] + [sci.core :as sci :refer [copy-var]] + [sci.impl.vars :as vars])) + +(def sns (vars/->SciNamespace 'clojure.spec.alpha nil)) +(def tns (vars/->SciNamespace 'clojure.spec.test.alpha nil)) +(def gns (vars/->SciNamespace 'clojure.spec.gen.alpha nil)) + +(defn- ns-qualify + "Qualify symbol s by resolving it or using the current *ns*." + [s] + (if-let [ns-sym (some-> s namespace symbol)] + (c/or (some-> (get (ns-aliases *ns*) ns-sym) str (symbol (name s))) + s) + (symbol (str (.name *ns*)) (str s)))) + +(c/defn def + "Given a namespace-qualified keyword or resolvable symbol k, and a + spec, spec-name, predicate or regex-op makes an entry in the + registry mapping k to the spec. Use nil to remove an entry in + the registry for k." + [_ _ k spec-form] + (let [k (if (symbol? k) (ns-qualify k) k)] + `(clojure.spec.alpha/def-impl '~k '~(s/res spec-form) ~spec-form))) + +;; TODO: fix error in clj-kondo: def is a special form which should always be resolved as the special form +#_:clj-kondo/ignore +(def spec-namespace + {'def (sci/copy-var s/def sns) + 'def-impl (copy-var s/def-impl sns) + 'valid? (copy-var s/valid? sns) + 'gen (copy-var s/gen sns) + 'cat (copy-var s/cat sns) + 'cat-impl (copy-var s/cat-impl sns) + 'fdef (copy-var s/fdef sns) + 'fspec (copy-var s/fspec sns) + 'fspec-impl (copy-var s/fspec-impl sns) + ;; 372 + 'spec (copy-var s/spec sns) + 'spec-impl (copy-var s/spec-impl sns) + #_#_'explain-data (copy-var s/explain-data sns)}) + +#_:clj-kondo/ignore +(def test-namespace + {'instrument (copy-var test/instrument tns) + 'unstrument (copy-var test/unstrument tns)}) + +#_:clj-kondo/ignore +(def gen-namespace + {'generate (copy-var gen/generate gns)}) + +;; def-impl +;; -> spec? ;; OK +;; regex? +;; spec-impl +;; with-name diff --git a/feature-test-check/babashka/impl/clojure/test/check.clj b/feature-test-check/babashka/impl/clojure/test/check.clj new file mode 100644 index 00000000..6febea0c --- /dev/null +++ b/feature-test-check/babashka/impl/clojure/test/check.clj @@ -0,0 +1,177 @@ +(ns babashka.impl.clojure.test.check + {:no-doc true} + (:require [clojure.test.check.random :as random] + [sci.core :as sci])) + +(def next-rng + "Returns a random-number generator. Successive calls should return + independent results." + (let [a (atom (delay (random/make-java-util-splittable-random (System/currentTimeMillis)))) + thread-local + (proxy [ThreadLocal] [] + (initialValue [] + (first (random/split (swap! a #(second (random/split (force %))))))))] + (fn [] + (let [rng (.get thread-local) + [rng1 rng2] (random/split rng)] + (.set thread-local rng2) + rng1)))) + +(defn make-random + "Given an optional Long seed, returns an object that satisfies the + IRandom protocol." + ([] (next-rng)) + ([seed] (random/make-java-util-splittable-random seed))) + +(alter-var-root #'random/next-rng (constantly next-rng)) +(alter-var-root #'random/make-random (constantly make-random)) + +(def r-ns (sci/create-ns 'clojure.test.check.random nil)) + +#_(doseq [k (sort (keys (ns-publics 'clojure.test.check.random)))] + (println (str "'" k) (format "(sci/copy-var random/%s r-ns)" k))) + +(def random-namespace + {'make-java-util-splittable-random (sci/copy-var random/make-java-util-splittable-random r-ns) + 'make-random (sci/copy-var random/make-random r-ns) + 'rand-double (sci/copy-var random/rand-double r-ns) + 'rand-long (sci/copy-var random/rand-long r-ns) + 'split (sci/copy-var random/split r-ns) + 'split-n (sci/copy-var random/split-n r-ns)}) + +(require '[clojure.test.check.generators :as gen]) + +(def gen-ns (sci/create-ns 'clojure.test.check.generators nil)) + +#_(doseq [k (sort (keys (ns-publics 'clojure.test.check.generators)))] + (println (str "'" k) (format "(sci/copy-var gen/%s gen-ns)" k))) + +(def generators-namespace + {'->Generator (sci/copy-var gen/->Generator gen-ns) + 'any (sci/copy-var gen/any gen-ns) + 'any-equatable (sci/copy-var gen/any-equatable gen-ns) + 'any-printable (sci/copy-var gen/any-printable gen-ns) + 'any-printable-equatable (sci/copy-var gen/any-printable-equatable gen-ns) + 'big-ratio (sci/copy-var gen/big-ratio gen-ns) + 'bind (sci/copy-var gen/bind gen-ns) + 'boolean (sci/copy-var gen/boolean gen-ns) + 'byte (sci/copy-var gen/byte gen-ns) + 'bytes (sci/copy-var gen/bytes gen-ns) + 'call-gen (sci/copy-var gen/call-gen gen-ns) + 'char (sci/copy-var gen/char gen-ns) + 'char-alpha (sci/copy-var gen/char-alpha gen-ns) + 'char-alpha-numeric (sci/copy-var gen/char-alpha-numeric gen-ns) + 'char-alphanumeric (sci/copy-var gen/char-alphanumeric gen-ns) + 'char-ascii (sci/copy-var gen/char-ascii gen-ns) + 'choose (sci/copy-var gen/choose gen-ns) + 'container-type (sci/copy-var gen/container-type gen-ns) + 'double (sci/copy-var gen/double gen-ns) + 'double* (sci/copy-var gen/double* gen-ns) + 'elements (sci/copy-var gen/elements gen-ns) + 'fmap (sci/copy-var gen/fmap gen-ns) + 'frequency (sci/copy-var gen/frequency gen-ns) + 'gen-bind (sci/copy-var gen/gen-bind gen-ns) + 'gen-fmap (sci/copy-var gen/gen-fmap gen-ns) + 'gen-pure (sci/copy-var gen/gen-pure gen-ns) + 'generate (sci/copy-var gen/generate gen-ns) + 'generator? (sci/copy-var gen/generator? gen-ns) + 'hash-map (sci/copy-var gen/hash-map gen-ns) + 'int (sci/copy-var gen/int gen-ns) + 'keyword (sci/copy-var gen/keyword gen-ns) + 'keyword-ns (sci/copy-var gen/keyword-ns gen-ns) + 'large-integer (sci/copy-var gen/large-integer gen-ns) + 'large-integer* (sci/copy-var gen/large-integer* gen-ns) + 'lazy-random-states (sci/copy-var gen/lazy-random-states gen-ns) + 'let (sci/copy-var gen/let gen-ns) + 'list (sci/copy-var gen/list gen-ns) + 'list-distinct (sci/copy-var gen/list-distinct gen-ns) + 'list-distinct-by (sci/copy-var gen/list-distinct-by gen-ns) + 'make-size-range-seq (sci/copy-var gen/make-size-range-seq gen-ns) + 'map (sci/copy-var gen/map gen-ns) + 'map->Generator (sci/copy-var gen/map->Generator gen-ns) + 'nat (sci/copy-var gen/nat gen-ns) + 'neg-int (sci/copy-var gen/neg-int gen-ns) + 'no-shrink (sci/copy-var gen/no-shrink gen-ns) + 'not-empty (sci/copy-var gen/not-empty gen-ns) + 'one-of (sci/copy-var gen/one-of gen-ns) + 'pos-int (sci/copy-var gen/pos-int gen-ns) + 'ratio (sci/copy-var gen/ratio gen-ns) + 'recursive-gen (sci/copy-var gen/recursive-gen gen-ns) + 'resize (sci/copy-var gen/resize gen-ns) + 'return (sci/copy-var gen/return gen-ns) + 's-neg-int (sci/copy-var gen/s-neg-int gen-ns) + 's-pos-int (sci/copy-var gen/s-pos-int gen-ns) + 'sample (sci/copy-var gen/sample gen-ns) + 'sample-seq (sci/copy-var gen/sample-seq gen-ns) + 'scale (sci/copy-var gen/scale gen-ns) + 'set (sci/copy-var gen/set gen-ns) + 'shrink-2 (sci/copy-var gen/shrink-2 gen-ns) + 'shuffle (sci/copy-var gen/shuffle gen-ns) + 'simple-type (sci/copy-var gen/simple-type gen-ns) + 'simple-type-equatable (sci/copy-var gen/simple-type-equatable gen-ns) + 'simple-type-printable (sci/copy-var gen/simple-type-printable gen-ns) + 'simple-type-printable-equatable (sci/copy-var gen/simple-type-printable-equatable gen-ns) + 'size-bounded-bigint (sci/copy-var gen/size-bounded-bigint gen-ns) + 'sized (sci/copy-var gen/sized gen-ns) + 'small-integer (sci/copy-var gen/small-integer gen-ns) + 'sorted-set (sci/copy-var gen/sorted-set gen-ns) + 'string (sci/copy-var gen/string gen-ns) + 'string-alpha-numeric (sci/copy-var gen/string-alpha-numeric gen-ns) + 'string-alphanumeric (sci/copy-var gen/string-alphanumeric gen-ns) + 'string-ascii (sci/copy-var gen/string-ascii gen-ns) + 'such-that (sci/copy-var gen/such-that gen-ns) + 'symbol (sci/copy-var gen/symbol gen-ns) + 'symbol-ns (sci/copy-var gen/symbol-ns gen-ns) + 'tuple (sci/copy-var gen/tuple gen-ns) + 'uuid (sci/copy-var gen/uuid gen-ns) + 'vector (sci/copy-var gen/vector gen-ns) + 'vector-distinct (sci/copy-var gen/vector-distinct gen-ns) + 'vector-distinct-by (sci/copy-var gen/vector-distinct-by gen-ns)}) + +(require '[clojure.test.check.rose-tree :as rose-tree]) + +(def rose-ns (sci/create-ns 'clojure.test.check.rose-tree nil)) + +#_(doseq [k (sort (keys (ns-publics 'clojure.test.check.rose-tree)))] + (println (str "'" k) (format "(sci/copy-var rose-tree/%s rose-ns)" k))) + +(def rose-tree-namespace + {'->RoseTree (sci/copy-var rose-tree/->RoseTree rose-ns) + 'bind (sci/copy-var rose-tree/bind rose-ns) + 'children (sci/copy-var rose-tree/children rose-ns) + 'collapse (sci/copy-var rose-tree/collapse rose-ns) + 'filter (sci/copy-var rose-tree/filter rose-ns) + 'fmap (sci/copy-var rose-tree/fmap rose-ns) + 'join (sci/copy-var rose-tree/join rose-ns) + 'make-rose (sci/copy-var rose-tree/make-rose rose-ns) + 'permutations (sci/copy-var rose-tree/permutations rose-ns) + 'pure (sci/copy-var rose-tree/pure rose-ns) + 'remove (sci/copy-var rose-tree/remove rose-ns) + 'root (sci/copy-var rose-tree/root rose-ns) + 'seq (sci/copy-var rose-tree/seq rose-ns) + 'shrink (sci/copy-var rose-tree/shrink rose-ns) + 'shrink-vector (sci/copy-var rose-tree/shrink-vector rose-ns) + 'zip (sci/copy-var rose-tree/zip rose-ns)}) + +(require '[clojure.test.check.properties :as properties]) + +(def p-ns (sci/create-ns 'clojure.test.check.properties nil)) + +#_(doseq [k (sort (keys (ns-publics 'clojure.test.check.properties)))] + (println (str "'" k) (format "(sci/copy-var properties/%s p-ns)" k))) + +(def properties-namespace + {'->ErrorResult (sci/copy-var properties/->ErrorResult p-ns) + 'for-all (sci/copy-var properties/for-all p-ns) + 'for-all* (sci/copy-var properties/for-all* p-ns) + 'map->ErrorResult (sci/copy-var properties/map->ErrorResult p-ns)}) + +(require '[clojure.test.check :as tc]) + +(def tc-ns (sci/create-ns 'clojure.test.check nil)) + +#_(doseq [k (sort (keys (ns-publics 'clojure.test.check)))] + (println (str "'" k) (format "(sci/copy-var tc/%s p-ns)" k))) + +(def test-check-namespace + {'quick-check (sci/copy-var tc/quick-check p-ns)}) diff --git a/project.clj b/project.clj index bffcb55a..916f0306 100644 --- a/project.clj +++ b/project.clj @@ -21,6 +21,7 @@ [cheshire "5.10.0"] [nrepl/bencode "1.1.0"] [borkdude/sci.impl.reflector "0.0.1-java11"] + [org.clojure/test.check "1.1.0"] [org.clojure/math.combinatorics "0.1.6"]] :profiles {:feature/xml {:source-paths ["feature-xml"] :dependencies [[org.clojure/data.xml "0.2.0-alpha6"]]} @@ -50,6 +51,8 @@ :dependencies [[org.clojure/core.match "1.0.0"]]} :feature/hiccup {:source-paths ["feature-hiccup"] :dependencies [[hiccup/hiccup "2.0.0-alpha2"]]} + :feature/test-check {:source-paths ["feature-test-check"]} + :feature/spec-alpha {:source-paths ["feature-spec-alpha"]} :test [:feature/xml :feature/lanterna :feature/yaml @@ -63,6 +66,8 @@ :feature/httpkit-server :feature/core-match :feature/hiccup + :feature/test-check + :feature/spec-alpha {:dependencies [[clj-commons/conch "0.9.2"] [com.clojure-goes-fast/clj-async-profiler "0.4.1"] [com.opentable.components/otj-pg-embedded "0.13.3"]]}] diff --git a/script/compile b/script/compile index 6a594250..db5d91d4 100755 --- a/script/compile +++ b/script/compile @@ -96,6 +96,8 @@ then export BABASHKA_FEATURE_HTTPKIT_SERVER="${BABASHKA_FEATURE_HTTPKIT_SERVER:-false}" export BABASHKA_FEATURE_CORE_MATCH="${BABASHKA_FEATURE_CORE_MATCH:-false}" export BABASHKA_FEATURE_HICCUP="${BABASHKA_FEATURE_HICCUP:-false}" + export BABASHKA_FEATURE_TEST_CHECK="${BABASHKA_FEATURE_TEST_CHECK:-false}" + export BABASHKA_FEATURE_SPEC_ALPHA="${BABASHKA_FEATURE_SPEC_ALPHA:-false}" fi "$GRAALVM_HOME/bin/native-image" "${args[@]}" diff --git a/script/uberjar b/script/uberjar index afe654e4..56e64669 100755 --- a/script/uberjar +++ b/script/uberjar @@ -132,6 +132,20 @@ else BABASHKA_LEIN_PROFILES+=",-feature/hiccup" fi +if [ "$BABASHKA_FEATURE_TEST_CHECK" != "false" ] +then + BABASHKA_LEIN_PROFILES+=",+feature/test-check" +else + BABASHKA_LEIN_PROFILES+=",-feature/test-check" +fi + +if [ "$BABASHKA_FEATURE_SPEC_ALPHA" = "true" ] +then + BABASHKA_LEIN_PROFILES+=",+feature/spec-alpha" +else + BABASHKA_LEIN_PROFILES+=",-feature/spec-alpha" +fi + if [ -z "$BABASHKA_JAR" ]; then lein with-profiles "$BABASHKA_LEIN_PROFILES,+reflection,-uberjar" do run lein with-profiles "$BABASHKA_LEIN_PROFILES" do clean, uberjar diff --git a/script/uberjar.bat b/script/uberjar.bat index 8abe99d6..6e71856f 100755 --- a/script/uberjar.bat +++ b/script/uberjar.bat @@ -100,6 +100,18 @@ set BABASHKA_LEIN_PROFILES=%BABASHKA_LEIN_PROFILES%,+feature/hiccup set BABASHKA_LEIN_PROFILES=%BABASHKA_LEIN_PROFILES%,-feature/hiccup ) +if not "%BABASHKA_FEATURE_TEST_CHECK%"=="false" ( +set BABASHKA_LEIN_PROFILES=%BABASHKA_LEIN_PROFILES%,+feature/test-check +) else ( +set BABASHKA_LEIN_PROFILES=%BABASHKA_LEIN_PROFILES%,-feature/test-check +) + +if "%BABASHKA_FEATURE_SPEC_ALPHA%"=="true" ( +set BABASHKA_LEIN_PROFILES=%BABASHKA_LEIN_PROFILES%,+feature/spec-alpha +) else ( +set BABASHKA_LEIN_PROFILES=%BABASHKA_LEIN_PROFILES%,-feature/spec-alpha +) + call lein with-profiles %BABASHKA_LEIN_PROFILES% bb "(+ 1 2 3)" call lein with-profiles %BABASHKA_LEIN_PROFILES%,+reflection,-uberjar do run diff --git a/src/babashka/impl/clojure/spec/alpha.clj b/src/babashka/impl/clojure/spec/alpha.clj new file mode 100644 index 00000000..2c54c417 --- /dev/null +++ b/src/babashka/impl/clojure/spec/alpha.clj @@ -0,0 +1,2001 @@ +;; Copyright (c) Rich Hickey. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns + ^{:doc "The spec library specifies the structure of data or functions and provides + operations to validate, conform, explain, describe, and generate data based on + the specs. + + Rationale: https://clojure.org/about/spec + Guide: https://clojure.org/guides/spec"} + babashka.impl.clojure.spec.alpha + (:refer-clojure :exclude [+ * and assert or cat def keys merge]) + (:require [babashka.impl.clojure.spec.gen.alpha :as gen] + [clojure.walk :as walk])) + +(alias 'c 'clojure.core) + +(set! *warn-on-reflection* true) + +(def ^:dynamic *recursion-limit* + "A soft limit on how many times a branching spec (or/alt/*/opt-keys/multi-spec) + can be recursed through during generation. After this a + non-recursive branch will be chosen." + 4) + +(def ^:dynamic *fspec-iterations* + "The number of times an anonymous fn specified by fspec will be (generatively) tested during conform" + 21) + +(def ^:dynamic *coll-check-limit* + "The number of elements validated in a collection spec'ed with 'every'" + 101) + +(def ^:dynamic *coll-error-limit* + "The number of errors reported by explain in a collection spec'ed with 'every'" + 20) + +(defprotocol Spec + (conform* [spec x]) + (unform* [spec y]) + (explain* [spec path via in x]) + (gen* [spec overrides path rmap]) + (with-gen* [spec gfn]) + (describe* [spec])) + +(defonce ^:private registry-ref (atom {})) + +(defn- deep-resolve [reg k] + (loop [spec k] + (if (ident? spec) + (recur (get reg spec)) + spec))) + +(defn- reg-resolve + "returns the spec/regex at end of alias chain starting with k, nil if not found, k if k not ident" + [k] + (if (ident? k) + (let [reg @registry-ref + spec (get reg k)] + (if-not (ident? spec) + spec + (deep-resolve reg spec))) + k)) + +(defn- reg-resolve! + "returns the spec/regex at end of alias chain starting with k, throws if not found, k if k not ident" + [k] + (if (ident? k) + (c/or (reg-resolve k) + (throw (Exception. (str "Unable to resolve spec: " k)))) + k)) + +(defn spec? + "returns x if x is a spec object, else logical false" + [x] + (when (instance? clojure.spec.alpha.Spec x) + x)) + +(defn regex? + "returns x if x is a (clojure.spec) regex op, else logical false" + [x] + (c/and (::op x) x)) + +(defn- with-name [spec name] + (cond + (ident? spec) spec + (regex? spec) (assoc spec ::name name) + + (instance? clojure.lang.IObj spec) + (with-meta spec (assoc (meta spec) ::name name)))) + +(defn- spec-name [spec] + (cond + (ident? spec) spec + + (regex? spec) (::name spec) + + (instance? clojure.lang.IObj spec) + (-> (meta spec) ::name))) + +(declare spec-impl) +(declare regex-spec-impl) + +(defn- maybe-spec + "spec-or-k must be a spec, regex or resolvable kw/sym, else returns nil." + [spec-or-k] + (let [s (c/or (c/and (ident? spec-or-k) (reg-resolve spec-or-k)) + (spec? spec-or-k) + (regex? spec-or-k) + nil)] + (if (regex? s) + (with-name (regex-spec-impl s nil) (spec-name s)) + s))) + +(defn- the-spec + "spec-or-k must be a spec, regex or kw/sym, else returns nil. Throws if unresolvable kw/sym" + [spec-or-k] + (c/or (maybe-spec spec-or-k) + (when (ident? spec-or-k) + (throw (Exception. (str "Unable to resolve spec: " spec-or-k)))))) + +(defprotocol Specize + (specize* [_] [_ form])) + +(defn- fn-sym [^Object f] + (let [[_ f-ns f-n] (re-matches #"(.*)\$(.*?)(__[0-9]+)?" (.. f getClass getName))] + ;; check for anonymous function + (when (not= "fn" f-n) + (symbol (clojure.lang.Compiler/demunge f-ns) (clojure.lang.Compiler/demunge f-n))))) + +(extend-protocol Specize + clojure.lang.Keyword + (specize* ([k] (specize* (reg-resolve! k))) + ([k _] (specize* (reg-resolve! k)))) + + clojure.lang.Symbol + (specize* ([s] (specize* (reg-resolve! s))) + ([s _] (specize* (reg-resolve! s)))) + + clojure.lang.IPersistentSet + (specize* ([s] (spec-impl s s nil nil)) + ([s form] (spec-impl form s nil nil))) + + Object + (specize* ([o] (if (c/and (not (map? o)) (ifn? o)) + (if-let [s (fn-sym o)] + (spec-impl s o nil nil) + (spec-impl ::unknown o nil nil)) + (spec-impl ::unknown o nil nil))) + ([o form] (spec-impl form o nil nil)))) + +(defn- specize + ([s] (c/or (spec? s) (specize* s))) + ([s form] (c/or (spec? s) (specize* s form)))) + +(defn invalid? + "tests the validity of a conform return value" + [ret] + (identical? ::invalid ret)) + +(defn conform + "Given a spec and a value, returns :clojure.spec.alpha/invalid + if value does not match spec, else the (possibly destructured) value." + [spec x] + (conform* (specize spec) x)) + +(defn unform + "Given a spec and a value created by or compliant with a call to + 'conform' with the same spec, returns a value with all conform + destructuring undone." + [spec x] + (unform* (specize spec) x)) + +(defn form + "returns the spec as data" + [spec] + ;;TODO - incorporate gens + (describe* (specize spec))) + +(defn abbrev [form] + (cond + (seq? form) + (walk/postwalk (fn [form] + (cond + (c/and (symbol? form) (namespace form)) + (-> form name symbol) + + (c/and (seq? form) (= 'fn (first form)) (= '[%] (second form))) + (last form) + + :else form)) + form) + + (c/and (symbol? form) (namespace form)) + (-> form name symbol) + + :else form)) + +(defn describe + "returns an abbreviated description of the spec as data" + [spec] + (abbrev (form spec))) + +(defn with-gen + "Takes a spec and a no-arg, generator-returning fn and returns a version of that spec that uses that generator" + [spec gen-fn] + (let [spec (reg-resolve spec)] + (if (regex? spec) + (assoc spec ::gfn gen-fn) + (with-gen* (specize spec) gen-fn)))) + +(defn explain-data* [spec path via in x] + (let [probs (explain* (specize spec) path via in x)] + (when-not (empty? probs) + {::problems probs + ::spec spec + ::value x}))) + +(defn explain-data + "Given a spec and a value x which ought to conform, returns nil if x + conforms, else a map with at least the key ::problems whose value is + a collection of problem-maps, where problem-map has at least :path :pred and :val + keys describing the predicate and the value that failed at that + path." + [spec x] + (explain-data* spec [] (if-let [name (spec-name spec)] [name] []) [] x)) + +(defn explain-printer + "Default printer for explain-data. nil indicates a successful validation." + [ed] + (if ed + (let [problems (->> (::problems ed) + (sort-by #(- (count (:in %)))) + (sort-by #(- (count (:path %)))))] + ;;(prn {:ed ed}) + (doseq [{:keys [path pred val reason via in] :as prob} problems] + (pr val) + (print " - failed: ") + (if reason (print reason) (pr (abbrev pred))) + (when-not (empty? in) + (print (str " in: " (pr-str in)))) + (when-not (empty? path) + (print (str " at: " (pr-str path)))) + (when-not (empty? via) + (print (str " spec: " (pr-str (last via))))) + (doseq [[k v] prob] + (when-not (#{:path :pred :val :reason :via :in} k) + (print "\n\t" (pr-str k) " ") + (pr v))) + (newline))) + (println "Success!"))) + +(def ^:dynamic *explain-out* explain-printer) + +(defn explain-out + "Prints explanation data (per 'explain-data') to *out* using the printer in *explain-out*, + by default explain-printer." + [ed] + (*explain-out* ed)) + +(defn explain + "Given a spec and a value that fails to conform, prints an explanation to *out*." + [spec x] + (explain-out (explain-data spec x))) + +(defn explain-str + "Given a spec and a value that fails to conform, returns an explanation as a string." + [spec x] + (with-out-str (explain spec x))) + +(declare valid?) + +(defn- gensub + [spec overrides path rmap form] + ;;(prn {:spec spec :over overrides :path path :form form}) + (let [spec (specize spec)] + (if-let [g (c/or (when-let [gfn (c/or (get overrides (c/or (spec-name spec) spec)) + (get overrides path))] + (gfn)) + (gen* spec overrides path rmap))] + (gen/such-that #(valid? spec %) g 100) + (let [abbr (abbrev form)] + (throw (ex-info (str "Unable to construct gen at: " path " for: " abbr) + {::path path ::form form ::failure :no-gen})))))) + +(defn gen + "Given a spec, returns the generator for it, or throws if none can + be constructed. Optionally an overrides map can be provided which + should map spec names or paths (vectors of keywords) to no-arg + generator-creating fns. These will be used instead of the generators at those + names/paths. Note that parent generator (in the spec or overrides + map) will supersede those of any subtrees. A generator for a regex + op must always return a sequential collection (i.e. a generator for + s/? should return either an empty sequence/vector or a + sequence/vector with one item in it)" + ([spec] (gen spec nil)) + ([spec overrides] (gensub spec overrides [] {::recursion-limit *recursion-limit*} spec))) + +(defn- ->sym + "Returns a symbol from a symbol or var" + [x] + (if (var? x) + (let [^clojure.lang.Var v x] + (symbol (str (.name (.ns v))) + (str (.sym v)))) + x)) + +(defn- unfn [expr] + (if (c/and (seq? expr) + (symbol? (first expr)) + (= "fn*" (name (first expr)))) + (let [[[s] & form] (rest expr)] + (conj (walk/postwalk-replace {s '%} form) '[%] 'fn)) + expr)) + +(defn res [form] + (cond + (keyword? form) form + (symbol? form) (c/or + ;; TODO: insert sci resolve here + #_(-> form resolve ->sym) form) + (sequential? form) (walk/postwalk #(if (symbol? %) (res %) %) (unfn form)) + :else form)) + +(defn ^:skip-wiki def-impl + "Do not call this directly, use 'def'" + [k form spec] + (c/assert (c/and (ident? k) (namespace k)) "k must be namespaced keyword or resolvable symbol") + (if (nil? spec) + (swap! registry-ref dissoc k) + (let [spec (if (c/or (spec? spec) (regex? spec) (get @registry-ref spec)) + spec + (spec-impl form spec nil nil))] + (swap! registry-ref assoc k (with-name spec k)))) + k) + +(defn ns-qualify + "Qualify symbol s by resolving it or using the current *ns*." + [s] + (if-let [ns-sym (some-> s namespace symbol)] + (c/or (some-> + ;; TODO: use sci ns-aliases + (get (ns-aliases *ns*) ns-sym) str (symbol (name s))) + s) + ;; TODO: use sci current-ns! + (symbol (str (.name *ns*)) (str s)))) + +(defmacro def + "Given a namespace-qualified keyword or resolvable symbol k, and a + spec, spec-name, predicate or regex-op makes an entry in the + registry mapping k to the spec. Use nil to remove an entry in + the registry for k." + [k spec-form] + (let [k (if (symbol? k) (ns-qualify k) k)] + `(clojure.spec.alpha/def-impl '~k '~(res spec-form) ~spec-form))) + +(defn registry + "returns the registry map, prefer 'get-spec' to lookup a spec by name" + [] + @registry-ref) + +(defn get-spec + "Returns spec registered for keyword/symbol/var k, or nil." + [k] + (get (registry) (if (keyword? k) k (->sym k)))) + +(defmacro spec + "Takes a single predicate form, e.g. can be the name of a predicate, + like even?, or a fn literal like #(< % 42). Note that it is not + generally necessary to wrap predicates in spec when using the rest + of the spec macros, only to attach a unique generator + + Can also be passed the result of one of the regex ops - + cat, alt, *, +, ?, in which case it will return a regex-conforming + spec, useful when nesting an independent regex. + --- + + Optionally takes :gen generator-fn, which must be a fn of no args that + returns a test.check generator. + + Returns a spec." + [form & {:keys [gen]}] + (when form + `(clojure.spec.alpha/spec-impl '~(res form) ~form ~gen nil))) + +(defmacro multi-spec + "Takes the name of a spec/predicate-returning multimethod and a + tag-restoring keyword or fn (retag). Returns a spec that when + conforming or explaining data will pass it to the multimethod to get + an appropriate spec. You can e.g. use multi-spec to dynamically and + extensibly associate specs with 'tagged' data (i.e. data where one + of the fields indicates the shape of the rest of the structure). + + (defmulti mspec :tag) + + The methods should ignore their argument and return a predicate/spec: + (defmethod mspec :int [_] (s/keys :req-un [::tag ::i])) + + retag is used during generation to retag generated values with + matching tags. retag can either be a keyword, at which key the + dispatch-tag will be assoc'ed, or a fn of generated value and + dispatch-tag that should return an appropriately retagged value. + + Note that because the tags themselves comprise an open set, + the tag key spec cannot enumerate the values, but can e.g. + test for keyword?. + + Note also that the dispatch values of the multimethod will be + included in the path, i.e. in reporting and gen overrides, even + though those values are not evident in the spec. + " + [mm retag] + `(multi-spec-impl '~(res mm) (var ~mm) ~retag)) + +(defmacro keys + "Creates and returns a map validating spec. :req and :opt are both + vectors of namespaced-qualified keywords. The validator will ensure + the :req keys are present. The :opt keys serve as documentation and + may be used by the generator. + + The :req key vector supports 'and' and 'or' for key groups: + + (s/keys :req [::x ::y (or ::secret (and ::user ::pwd))] :opt [::z]) + + There are also -un versions of :req and :opt. These allow + you to connect unqualified keys to specs. In each case, fully + qualfied keywords are passed, which name the specs, but unqualified + keys (with the same name component) are expected and checked at + conform-time, and generated during gen: + + (s/keys :req-un [:my.ns/x :my.ns/y]) + + The above says keys :x and :y are required, and will be validated + and generated by specs (if they exist) named :my.ns/x :my.ns/y + respectively. + + In addition, the values of *all* namespace-qualified keys will be validated + (and possibly destructured) by any registered specs. Note: there is + no support for inline value specification, by design. + + Optionally takes :gen generator-fn, which must be a fn of no args that + returns a test.check generator." + [& {:keys [req req-un opt opt-un gen]}] + (let [unk #(-> % name keyword) + req-keys (filterv keyword? (flatten req)) + req-un-specs (filterv keyword? (flatten req-un)) + _ (c/assert (every? #(c/and (keyword? %) (namespace %)) (concat req-keys req-un-specs opt opt-un)) + "all keys must be namespace-qualified keywords") + req-specs (into req-keys req-un-specs) + req-keys (into req-keys (map unk req-un-specs)) + opt-keys (into (vec opt) (map unk opt-un)) + opt-specs (into (vec opt) opt-un) + gx (gensym) + parse-req (fn [rk f] + (map (fn [x] + (if (keyword? x) + `(contains? ~gx ~(f x)) + (walk/postwalk + (fn [y] (if (keyword? y) `(contains? ~gx ~(f y)) y)) + x))) + rk)) + pred-exprs [`(map? ~gx)] + pred-exprs (into pred-exprs (parse-req req identity)) + pred-exprs (into pred-exprs (parse-req req-un unk)) + keys-pred `(fn* [~gx] (c/and ~@pred-exprs)) + pred-exprs (mapv (fn [e] `(fn* [~gx] ~e)) pred-exprs) + pred-forms (walk/postwalk res pred-exprs)] + ;; `(map-spec-impl ~req-keys '~req ~opt '~pred-forms ~pred-exprs ~gen) + `(map-spec-impl {:req '~req :opt '~opt :req-un '~req-un :opt-un '~opt-un + :req-keys '~req-keys :req-specs '~req-specs + :opt-keys '~opt-keys :opt-specs '~opt-specs + :pred-forms '~pred-forms + :pred-exprs ~pred-exprs + :keys-pred ~keys-pred + :gfn ~gen}))) + +(defmacro or + "Takes key+pred pairs, e.g. + + (s/or :even even? :small #(< % 42)) + + Returns a destructuring spec that returns a map entry containing the + key of the first matching pred and the corresponding value. Thus the + 'key' and 'val' functions can be used to refer generically to the + components of the tagged return." + [& key-pred-forms] + (let [pairs (partition 2 key-pred-forms) + keys (mapv first pairs) + pred-forms (mapv second pairs) + pf (mapv res pred-forms)] + (c/assert (c/and (even? (count key-pred-forms)) (every? keyword? keys)) "spec/or expects k1 p1 k2 p2..., where ks are keywords") + `(or-spec-impl ~keys '~pf ~pred-forms nil))) + +(defmacro and + "Takes predicate/spec-forms, e.g. + + (s/and even? #(< % 42)) + + Returns a spec that returns the conformed value. Successive + conformed values propagate through rest of predicates." + [& pred-forms] + `(and-spec-impl '~(mapv res pred-forms) ~(vec pred-forms) nil)) + +(defmacro merge + "Takes map-validating specs (e.g. 'keys' specs) and + returns a spec that returns a conformed map satisfying all of the + specs. Unlike 'and', merge can generate maps satisfying the + union of the predicates." + [& pred-forms] + `(merge-spec-impl '~(mapv res pred-forms) ~(vec pred-forms) nil)) + +(defn- res-kind + [opts] + (let [{kind :kind :as mopts} opts] + (->> + (if kind + (assoc mopts :kind `~(res kind)) + mopts) + (mapcat identity)))) + +(defmacro every + "takes a pred and validates collection elements against that pred. + + Note that 'every' does not do exhaustive checking, rather it samples + *coll-check-limit* elements. Nor (as a result) does it do any + conforming of elements. 'explain' will report at most *coll-error-limit* + problems. Thus 'every' should be suitable for potentially large + collections. + + Takes several kwargs options that further constrain the collection: + + :kind - a pred that the collection type must satisfy, e.g. vector? + (default nil) Note that if :kind is specified and :into is + not, this pred must generate in order for every to generate. + :count - specifies coll has exactly this count (default nil) + :min-count, :max-count - coll has count (<= min-count count max-count) (defaults nil) + :distinct - all the elements are distinct (default nil) + + And additional args that control gen + + :gen-max - the maximum coll size to generate (default 20) + :into - one of [], (), {}, #{} - the default collection to generate into + (default: empty coll as generated by :kind pred if supplied, else []) + + Optionally takes :gen generator-fn, which must be a fn of no args that + returns a test.check generator + + See also - coll-of, every-kv +" + [pred & {:keys [into kind count max-count min-count distinct gen-max gen] :as opts}] + (let [desc (::describe opts) + nopts (-> opts + (dissoc :gen ::describe) + (assoc ::kind-form `'~(res (:kind opts)) + ::describe (c/or desc `'(every ~(res pred) ~@(res-kind opts))))) + gx (gensym) + cpreds (cond-> [(list (c/or kind `coll?) gx)] + count (conj `(= ~count (bounded-count ~count ~gx))) + + (c/or min-count max-count) + (conj `(<= (c/or ~min-count 0) + (bounded-count (if ~max-count (inc ~max-count) ~min-count) ~gx) + (c/or ~max-count Integer/MAX_VALUE))) + + distinct + (conj `(c/or (empty? ~gx) (apply distinct? ~gx))))] + `(every-impl '~pred ~pred ~(assoc nopts ::cpred `(fn* [~gx] (c/and ~@cpreds))) ~gen))) + +(defmacro every-kv + "like 'every' but takes separate key and val preds and works on associative collections. + + Same options as 'every', :into defaults to {} + + See also - map-of" + + [kpred vpred & opts] + (let [desc `(every-kv ~(res kpred) ~(res vpred) ~@(res-kind opts))] + `(every (tuple ~kpred ~vpred) ::kfn (fn [i# v#] (nth v# 0)) :into {} ::describe '~desc ~@opts))) + +(defmacro coll-of + "Returns a spec for a collection of items satisfying pred. Unlike + 'every', coll-of will exhaustively conform every value. + + Same options as 'every'. conform will produce a collection + corresponding to :into if supplied, else will match the input collection, + avoiding rebuilding when possible. + + See also - every, map-of" + [pred & opts] + (let [desc `(coll-of ~(res pred) ~@(res-kind opts))] + `(every ~pred ::conform-all true ::describe '~desc ~@opts))) + +(defmacro map-of + "Returns a spec for a map whose keys satisfy kpred and vals satisfy + vpred. Unlike 'every-kv', map-of will exhaustively conform every + value. + + Same options as 'every', :kind defaults to map?, with the addition of: + + :conform-keys - conform keys as well as values (default false) + + See also - every-kv" + [kpred vpred & opts] + (let [desc `(map-of ~(res kpred) ~(res vpred) ~@(res-kind opts))] + `(every-kv ~kpred ~vpred ::conform-all true :kind map? ::describe '~desc ~@opts))) + + +(defmacro * + "Returns a regex op that matches zero or more values matching + pred. Produces a vector of matches iff there is at least one match" + [pred-form] + `(rep-impl '~(res pred-form) ~pred-form)) + +(defmacro + + "Returns a regex op that matches one or more values matching + pred. Produces a vector of matches" + [pred-form] + `(rep+impl '~(res pred-form) ~pred-form)) + +(defmacro ? + "Returns a regex op that matches zero or one value matching + pred. Produces a single value (not a collection) if matched." + [pred-form] + `(maybe-impl ~pred-form '~(res pred-form))) + +(defmacro alt + "Takes key+pred pairs, e.g. + + (s/alt :even even? :small #(< % 42)) + + Returns a regex op that returns a map entry containing the key of the + first matching pred and the corresponding value. Thus the + 'key' and 'val' functions can be used to refer generically to the + components of the tagged return" + [& key-pred-forms] + (let [pairs (partition 2 key-pred-forms) + keys (mapv first pairs) + pred-forms (mapv second pairs) + pf (mapv res pred-forms)] + (c/assert (c/and (even? (count key-pred-forms)) (every? keyword? keys)) "alt expects k1 p1 k2 p2..., where ks are keywords") + `(alt-impl ~keys ~pred-forms '~pf))) + +(defmacro cat + "Takes key+pred pairs, e.g. + + (s/cat :e even? :o odd?) + + Returns a regex op that matches (all) values in sequence, returning a map + containing the keys of each pred and the corresponding value." + [& key-pred-forms] + (let [pairs (partition 2 key-pred-forms) + keys (mapv first pairs) + pred-forms (mapv second pairs) + pf (mapv res pred-forms)] + ;;(prn key-pred-forms) + (c/assert (c/and (even? (count key-pred-forms)) (every? keyword? keys)) "cat expects k1 p1 k2 p2..., where ks are keywords") + `(clojure.spec.alpha/cat-impl ~keys ~pred-forms '~pf))) + +(defmacro & + "takes a regex op re, and predicates. Returns a regex-op that consumes + input as per re but subjects the resulting value to the + conjunction of the predicates, and any conforming they might perform." + [re & preds] + (let [pv (vec preds)] + `(amp-impl ~re '~(res re) ~pv '~(mapv res pv)))) + +(defmacro conformer + "takes a predicate function with the semantics of conform i.e. it should return either a + (possibly converted) value or :clojure.spec.alpha/invalid, and returns a + spec that uses it as a predicate/conformer. Optionally takes a + second fn that does unform of result of first" + ([f] `(spec-impl '(conformer ~(res f)) ~f nil true)) + ([f unf] `(spec-impl '(conformer ~(res f) ~(res unf)) ~f nil true ~unf))) + +(defmacro fspec + "takes :args :ret and (optional) :fn kwargs whose values are preds + and returns a spec whose conform/explain take a fn and validates it + using generative testing. The conformed value is always the fn itself. + + See 'fdef' for a single operation that creates an fspec and + registers it, as well as a full description of :args, :ret and :fn + + fspecs can generate functions that validate the arguments and + fabricate a return value compliant with the :ret spec, ignoring + the :fn spec if present. + + Optionally takes :gen generator-fn, which must be a fn of no args + that returns a test.check generator." + + [& {:keys [args ret fn gen] :or {ret `any?}}] + `(clojure.spec.alpha/fspec-impl + (clojure.spec.alpha/spec ~args) '~(res args) + (clojure.spec.alpha/spec ~ret) '~(res ret) + (clojure.spec.alpha/spec ~fn) '~(res fn) ~gen)) + +(defmacro tuple + "takes one or more preds and returns a spec for a tuple, a vector + where each element conforms to the corresponding pred. Each element + will be referred to in paths using its ordinal." + [& preds] + (c/assert (not (empty? preds))) + `(tuple-impl '~(mapv res preds) ~(vec preds))) + +(defn- macroexpand-check + [v args] + (let [fn-spec (get-spec v)] + (when-let [arg-spec (:args fn-spec)] + (when (invalid? (conform arg-spec args)) + (let [ed (assoc (explain-data* arg-spec [] + (if-let [name (spec-name arg-spec)] [name] []) [] args) + ::args args)] + (throw (ex-info + (str "Call to " (->sym v) " did not conform to spec.") + ed))))))) + +(defmacro fdef + "Takes a symbol naming a function, and one or more of the following: + + :args A regex spec for the function arguments as they were a list to be + passed to apply - in this way, a single spec can handle functions with + multiple arities + :ret A spec for the function's return value + :fn A spec of the relationship between args and ret - the + value passed is {:args conformed-args :ret conformed-ret} and is + expected to contain predicates that relate those values + + Qualifies fn-sym with resolve, or using *ns* if no resolution found. + Registers an fspec in the global registry, where it can be retrieved + by calling get-spec with the var or fully-qualified symbol. + + Once registered, function specs are included in doc, checked by + instrument, tested by the runner clojure.spec.test.alpha/check, and (if + a macro) used to explain errors during macroexpansion. + + Note that :fn specs require the presence of :args and :ret specs to + conform values, and so :fn specs will be ignored if :args or :ret + are missing. + + Returns the qualified fn-sym. + + For example, to register function specs for the symbol function: + + (s/fdef clojure.core/symbol + :args (s/alt :separate (s/cat :ns string? :n string?) + :str string? + :sym symbol?) + :ret symbol?)" + [fn-sym & specs] + `(clojure.spec.alpha/def ~fn-sym (clojure.spec.alpha/fspec ~@specs))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; impl ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defn- recur-limit? [rmap id path k] + (c/and (> (get rmap id) (::recursion-limit rmap)) + (contains? (set path) k))) + +(defn- inck [m k] + (assoc m k (inc (c/or (get m k) 0)))) + +(defn- dt + ([pred x form] (dt pred x form nil)) + ([pred x form cpred?] + (if pred + (if-let [spec (the-spec pred)] + (conform spec x) + (if (ifn? pred) + (if cpred? + (pred x) + (if (pred x) x ::invalid)) + (throw (Exception. (str (pr-str form) " is not a fn, expected predicate fn"))))) + x))) + +(defn valid? + "Helper function that returns true when x is valid for spec." + ([spec x] + (let [spec (specize spec)] + (not (invalid? (conform* spec x))))) + ([spec x form] + (let [spec (specize spec form)] + (not (invalid? (conform* spec x)))))) + +(defn- pvalid? + "internal helper function that returns true when x is valid for spec." + ([pred x] + (not (invalid? (dt pred x ::unknown)))) + ([pred x form] + (not (invalid? (dt pred x form))))) + +(defn- explain-1 [form pred path via in v] + ;;(prn {:form form :pred pred :path path :in in :v v}) + (let [pred (maybe-spec pred)] + (if (spec? pred) + (explain* pred path (if-let [name (spec-name pred)] (conj via name) via) in v) + [{:path path :pred form :val v :via via :in in}]))) + +(declare or-k-gen and-k-gen) + +(defn- k-gen + "returns a generator for form f, which can be a keyword or a list + starting with 'or or 'and." + [f] + (cond + (keyword? f) (gen/return f) + (= 'or (first f)) (or-k-gen 1 (rest f)) + (= 'and (first f)) (and-k-gen (rest f)))) + +(defn- or-k-gen + "returns a tuple generator made up of generators for a random subset + of min-count (default 0) to all elements in s." + ([s] (or-k-gen 0 s)) + ([min-count s] + (gen/bind (gen/tuple + (gen/choose min-count (count s)) + (gen/shuffle (map k-gen s))) + (fn [[n gens]] + (apply gen/tuple (take n gens)))))) + +(defn- and-k-gen + "returns a tuple generator made up of generators for every element + in s." + [s] + (apply gen/tuple (map k-gen s))) + + +(defn ^:skip-wiki map-spec-impl + "Do not call this directly, use 'spec' with a map argument" + [{:keys [req-un opt-un keys-pred pred-exprs opt-keys req-specs req req-keys opt-specs pred-forms opt gfn] + :as argm}] + (let [k->s (zipmap (concat req-keys opt-keys) (concat req-specs opt-specs)) + keys->specnames #(c/or (k->s %) %) + id (java.util.UUID/randomUUID)] + (reify + Specize + (specize* [s] s) + (specize* [s _] s) + + Spec + (conform* [_ m] + (if (keys-pred m) + (let [reg (registry)] + (loop [ret m, [[k v] & ks :as keys] m] + (if keys + (let [sname (keys->specnames k)] + (if-let [s (get reg sname)] + (let [cv (conform s v)] + (if (invalid? cv) + ::invalid + (recur (if (identical? cv v) ret (assoc ret k cv)) + ks))) + (recur ret ks))) + ret))) + ::invalid)) + (unform* [_ m] + (let [reg (registry)] + (loop [ret m, [k & ks :as keys] (c/keys m)] + (if keys + (if (contains? reg (keys->specnames k)) + (let [cv (get m k) + v (unform (keys->specnames k) cv)] + (recur (if (identical? cv v) ret (assoc ret k v)) + ks)) + (recur ret ks)) + ret)))) + (explain* [_ path via in x] + (if-not (map? x) + [{:path path :pred `map? :val x :via via :in in}] + (let [reg (registry)] + (apply concat + (when-let [probs (->> (map (fn [pred form] (when-not (pred x) form)) + pred-exprs pred-forms) + (keep identity) + seq)] + (map + #(identity {:path path :pred % :val x :via via :in in}) + probs)) + (map (fn [[k v]] + (when-not (c/or (not (contains? reg (keys->specnames k))) + (pvalid? (keys->specnames k) v k)) + (explain-1 (keys->specnames k) (keys->specnames k) (conj path k) via (conj in k) v))) + (seq x)))))) + (gen* [_ overrides path rmap] + (if gfn + (gfn) + (let [rmap (inck rmap id) + rgen (fn [k s] [k (gensub s overrides (conj path k) rmap k)]) + ogen (fn [k s] + (when-not (recur-limit? rmap id path k) + [k (gen/delay (gensub s overrides (conj path k) rmap k))])) + reqs (map rgen req-keys req-specs) + opts (remove nil? (map ogen opt-keys opt-specs))] + (when (every? identity (concat (map second reqs) (map second opts))) + (gen/bind + (gen/tuple + (and-k-gen req) + (or-k-gen opt) + (and-k-gen req-un) + (or-k-gen opt-un)) + (fn [[req-ks opt-ks req-un-ks opt-un-ks]] + (let [qks (flatten (concat req-ks opt-ks)) + unqks (map (comp keyword name) (flatten (concat req-un-ks opt-un-ks)))] + (->> (into reqs opts) + (filter #((set (concat qks unqks)) (first %))) + (apply concat) + (apply gen/hash-map))))))))) + (with-gen* [_ gfn] (map-spec-impl (assoc argm :gfn gfn))) + (describe* [_] (cons `keys + (cond-> [] + req (conj :req req) + opt (conj :opt opt) + req-un (conj :req-un req-un) + opt-un (conj :opt-un opt-un))))))) + + + + +(defn ^:skip-wiki spec-impl + "Do not call this directly, use 'spec'" + ([form pred gfn cpred?] (spec-impl form pred gfn cpred? nil)) + ([form pred gfn cpred? unc] + (cond + (spec? pred) (cond-> pred gfn (with-gen gfn)) + (regex? pred) (regex-spec-impl pred gfn) + (ident? pred) (cond-> (the-spec pred) gfn (with-gen gfn)) + :else + (reify + Specize + (specize* [s] s) + (specize* [s _] s) + + Spec + (conform* [_ x] (let [ret (pred x)] + (if cpred? + ret + (if ret x ::invalid)))) + (unform* [_ x] (if cpred? + (if unc + (unc x) + (throw (IllegalStateException. "no unform fn for conformer"))) + x)) + (explain* [_ path via in x] + (when (invalid? (dt pred x form cpred?)) + [{:path path :pred form :val x :via via :in in}])) + (gen* [_ _ _ _] (if gfn + (gfn) + (gen/gen-for-pred pred))) + (with-gen* [_ gfn] (spec-impl form pred gfn cpred? unc)) + (describe* [_] form))))) + +(defn ^:skip-wiki multi-spec-impl + "Do not call this directly, use 'multi-spec'" + ([form mmvar retag] (multi-spec-impl form mmvar retag nil)) + ([form mmvar retag gfn] + (let [id (java.util.UUID/randomUUID) + predx #(let [^clojure.lang.MultiFn mm @mmvar] + (c/and (.getMethod mm ((.dispatchFn mm) %)) + (mm %))) + dval #((.dispatchFn ^clojure.lang.MultiFn @mmvar) %) + tag (if (keyword? retag) + #(assoc %1 retag %2) + retag)] + (reify + Specize + (specize* [s] s) + (specize* [s _] s) + + Spec + (conform* [_ x] (if-let [pred (predx x)] + (dt pred x form) + ::invalid)) + (unform* [_ x] (if-let [pred (predx x)] + (unform pred x) + (throw (IllegalStateException. (str "No method of: " form " for dispatch value: " (dval x)))))) + (explain* [_ path via in x] + (let [dv (dval x) + path (conj path dv)] + (if-let [pred (predx x)] + (explain-1 form pred path via in x) + [{:path path :pred form :val x :reason "no method" :via via :in in}]))) + (gen* [_ overrides path rmap] + (if gfn + (gfn) + (let [gen (fn [[k f]] + (let [p (f nil)] + (let [rmap (inck rmap id)] + (when-not (recur-limit? rmap id path k) + (gen/delay + (gen/fmap + #(tag % k) + (gensub p overrides (conj path k) rmap (list 'method form k)))))))) + gs (->> (methods @mmvar) + (remove (fn [[k]] (invalid? k))) + (map gen) + (remove nil?))] + (when (every? identity gs) + (gen/one-of gs))))) + (with-gen* [_ gfn] (multi-spec-impl form mmvar retag gfn)) + (describe* [_] `(multi-spec ~form ~retag)))))) + +(defn ^:skip-wiki tuple-impl + "Do not call this directly, use 'tuple'" + ([forms preds] (tuple-impl forms preds nil)) + ([forms preds gfn] + (let [specs (delay (mapv specize preds forms)) + cnt (count preds)] + (reify + Specize + (specize* [s] s) + (specize* [s _] s) + + Spec + (conform* [_ x] + (let [specs @specs] + (if-not (c/and (vector? x) + (= (count x) cnt)) + ::invalid + (loop [ret x, i 0] + (if (= i cnt) + ret + (let [v (x i) + cv (conform* (specs i) v)] + (if (invalid? cv) + ::invalid + (recur (if (identical? cv v) ret (assoc ret i cv)) + (inc i))))))))) + (unform* [_ x] + (c/assert (c/and (vector? x) + (= (count x) (count preds)))) + (loop [ret x, i 0] + (if (= i (count x)) + ret + (let [cv (x i) + v (unform (preds i) cv)] + (recur (if (identical? cv v) ret (assoc ret i v)) + (inc i)))))) + (explain* [_ path via in x] + (cond + (not (vector? x)) + [{:path path :pred `vector? :val x :via via :in in}] + + (not= (count x) (count preds)) + [{:path path :pred `(= (count ~'%) ~(count preds)) :val x :via via :in in}] + + :else + (apply concat + (map (fn [i form pred] + (let [v (x i)] + (when-not (pvalid? pred v) + (explain-1 form pred (conj path i) via (conj in i) v)))) + (range (count preds)) forms preds)))) + (gen* [_ overrides path rmap] + (if gfn + (gfn) + (let [gen (fn [i p f] + (gensub p overrides (conj path i) rmap f)) + gs (map gen (range (count preds)) preds forms)] + (when (every? identity gs) + (apply gen/tuple gs))))) + (with-gen* [_ gfn] (tuple-impl forms preds gfn)) + (describe* [_] `(tuple ~@forms)))))) + +(defn- tagged-ret [tag ret] + (clojure.lang.MapEntry. tag ret)) + +(defn ^:skip-wiki or-spec-impl + "Do not call this directly, use 'or'" + [keys forms preds gfn] + (let [id (java.util.UUID/randomUUID) + kps (zipmap keys preds) + specs (delay (mapv specize preds forms)) + cform (case (count preds) + 2 (fn [x] + (let [specs @specs + ret (conform* (specs 0) x)] + (if (invalid? ret) + (let [ret (conform* (specs 1) x)] + (if (invalid? ret) + ::invalid + (tagged-ret (keys 1) ret))) + (tagged-ret (keys 0) ret)))) + 3 (fn [x] + (let [specs @specs + ret (conform* (specs 0) x)] + (if (invalid? ret) + (let [ret (conform* (specs 1) x)] + (if (invalid? ret) + (let [ret (conform* (specs 2) x)] + (if (invalid? ret) + ::invalid + (tagged-ret (keys 2) ret))) + (tagged-ret (keys 1) ret))) + (tagged-ret (keys 0) ret)))) + (fn [x] + (let [specs @specs] + (loop [i 0] + (if (< i (count specs)) + (let [spec (specs i)] + (let [ret (conform* spec x)] + (if (invalid? ret) + (recur (inc i)) + (tagged-ret (keys i) ret)))) + ::invalid)))))] + (reify + Specize + (specize* [s] s) + (specize* [s _] s) + + Spec + (conform* [_ x] (cform x)) + (unform* [_ [k x]] (unform (kps k) x)) + (explain* [this path via in x] + (when-not (pvalid? this x) + (apply concat + (map (fn [k form pred] + (when-not (pvalid? pred x) + (explain-1 form pred (conj path k) via in x))) + keys forms preds)))) + (gen* [_ overrides path rmap] + (if gfn + (gfn) + (let [gen (fn [k p f] + (let [rmap (inck rmap id)] + (when-not (recur-limit? rmap id path k) + (gen/delay + (gensub p overrides (conj path k) rmap f))))) + gs (remove nil? (map gen keys preds forms))] + (when-not (empty? gs) + (gen/one-of gs))))) + (with-gen* [_ gfn] (or-spec-impl keys forms preds gfn)) + (describe* [_] `(or ~@(mapcat vector keys forms)))))) + +(defn- and-preds [x preds forms] + (loop [ret x + [pred & preds] preds + [form & forms] forms] + (if pred + (let [nret (dt pred ret form)] + (if (invalid? nret) + ::invalid + ;;propagate conformed values + (recur nret preds forms))) + ret))) + +(defn- explain-pred-list + [forms preds path via in x] + (loop [ret x + [form & forms] forms + [pred & preds] preds] + (when pred + (let [nret (dt pred ret form)] + (if (invalid? nret) + (explain-1 form pred path via in ret) + (recur nret forms preds)))))) + +(defn ^:skip-wiki and-spec-impl + "Do not call this directly, use 'and'" + [forms preds gfn] + (let [specs (delay (mapv specize preds forms)) + cform + (case (count preds) + 2 (fn [x] + (let [specs @specs + ret (conform* (specs 0) x)] + (if (invalid? ret) + ::invalid + (conform* (specs 1) ret)))) + 3 (fn [x] + (let [specs @specs + ret (conform* (specs 0) x)] + (if (invalid? ret) + ::invalid + (let [ret (conform* (specs 1) ret)] + (if (invalid? ret) + ::invalid + (conform* (specs 2) ret)))))) + (fn [x] + (let [specs @specs] + (loop [ret x i 0] + (if (< i (count specs)) + (let [nret (conform* (specs i) ret)] + (if (invalid? nret) + ::invalid + ;;propagate conformed values + (recur nret (inc i)))) + ret)))))] + (reify + Specize + (specize* [s] s) + (specize* [s _] s) + + Spec + (conform* [_ x] (cform x)) + (unform* [_ x] (reduce #(unform %2 %1) x (reverse preds))) + (explain* [_ path via in x] (explain-pred-list forms preds path via in x)) + (gen* [_ overrides path rmap] (if gfn (gfn) (gensub (first preds) overrides path rmap (first forms)))) + (with-gen* [_ gfn] (and-spec-impl forms preds gfn)) + (describe* [_] `(and ~@forms))))) + +(defn ^:skip-wiki merge-spec-impl + "Do not call this directly, use 'merge'" + [forms preds gfn] + (reify + Specize + (specize* [s] s) + (specize* [s _] s) + + Spec + (conform* [_ x] (let [ms (map #(dt %1 x %2) preds forms)] + (if (some invalid? ms) + ::invalid + (apply c/merge ms)))) + (unform* [_ x] (apply c/merge (map #(unform % x) (reverse preds)))) + (explain* [_ path via in x] + (apply concat + (map #(explain-1 %1 %2 path via in x) + forms preds))) + (gen* [_ overrides path rmap] + (if gfn + (gfn) + (gen/fmap + #(apply c/merge %) + (apply gen/tuple (map #(gensub %1 overrides path rmap %2) + preds forms))))) + (with-gen* [_ gfn] (merge-spec-impl forms preds gfn)) + (describe* [_] `(merge ~@forms)))) + +(defn- coll-prob [x kfn kform distinct count min-count max-count + path via in] + (let [pred (c/or kfn coll?) + kform (c/or kform `coll?)] + (cond + (not (pvalid? pred x)) + (explain-1 kform pred path via in x) + + (c/and count (not= count (bounded-count count x))) + [{:path path :pred `(= ~count (c/count ~'%)) :val x :via via :in in}] + + (c/and (c/or min-count max-count) + (not (<= (c/or min-count 0) + (bounded-count (if max-count (inc max-count) min-count) x) + (c/or max-count Integer/MAX_VALUE)))) + [{:path path :pred `(<= ~(c/or min-count 0) (c/count ~'%) ~(c/or max-count 'Integer/MAX_VALUE)) :val x :via via :in in}] + + (c/and distinct (not (empty? x)) (not (apply distinct? x))) + [{:path path :pred 'distinct? :val x :via via :in in}]))) + +(def ^:private empty-coll {`vector? [], `set? #{}, `list? (), `map? {}}) + +(defn ^:skip-wiki every-impl + "Do not call this directly, use 'every', 'every-kv', 'coll-of' or 'map-of'" + ([form pred opts] (every-impl form pred opts nil)) + ([form pred {conform-into :into + describe-form ::describe + :keys [kind ::kind-form count max-count min-count distinct gen-max ::kfn ::cpred + conform-keys ::conform-all] + :or {gen-max 20} + :as opts} + gfn] + (let [gen-into (if conform-into (empty conform-into) (get empty-coll kind-form)) + spec (delay (specize pred)) + check? #(valid? @spec %) + kfn (c/or kfn (fn [i v] i)) + addcv (fn [ret i v cv] (conj ret cv)) + cfns (fn [x] + ;;returns a tuple of [init add complete] fns + (cond + (c/and (vector? x) (c/or (not conform-into) (vector? conform-into))) + [identity + (fn [ret i v cv] + (if (identical? v cv) + ret + (assoc ret i cv))) + identity] + + (c/and (map? x) (c/or (c/and kind (not conform-into)) (map? conform-into))) + [(if conform-keys empty identity) + (fn [ret i v cv] + (if (c/and (identical? v cv) (not conform-keys)) + ret + (assoc ret (nth (if conform-keys cv v) 0) (nth cv 1)))) + identity] + + (c/or (list? conform-into) (seq? conform-into) (c/and (not conform-into) (c/or (list? x) (seq? x)))) + [(constantly ()) addcv reverse] + + :else [#(empty (c/or conform-into %)) addcv identity]))] + (reify + Specize + (specize* [s] s) + (specize* [s _] s) + + Spec + (conform* [_ x] + (let [spec @spec] + (cond + (not (cpred x)) ::invalid + + conform-all + (let [[init add complete] (cfns x)] + (loop [ret (init x), i 0, [v & vs :as vseq] (seq x)] + (if vseq + (let [cv (conform* spec v)] + (if (invalid? cv) + ::invalid + (recur (add ret i v cv) (inc i) vs))) + (complete ret)))) + + + :else + (if (indexed? x) + (let [step (max 1 (long (/ (c/count x) *coll-check-limit*)))] + (loop [i 0] + (if (>= i (c/count x)) + x + (if (valid? spec (nth x i)) + (recur (c/+ i step)) + ::invalid)))) + (let [limit *coll-check-limit*] + (loop [i 0 [v & vs :as vseq] (seq x)] + (cond + (c/or (nil? vseq) (= i limit)) x + (valid? spec v) (recur (inc i) vs) + :else ::invalid))))))) + (unform* [_ x] + (if conform-all + (let [spec @spec + [init add complete] (cfns x)] + (loop [ret (init x), i 0, [v & vs :as vseq] (seq x)] + (if (>= i (c/count x)) + (complete ret) + (recur (add ret i v (unform* spec v)) (inc i) vs)))) + x)) + (explain* [_ path via in x] + (c/or (coll-prob x kind kind-form distinct count min-count max-count + path via in) + (apply concat + ((if conform-all identity (partial take *coll-error-limit*)) + (keep identity + (map (fn [i v] + (let [k (kfn i v)] + (when-not (check? v) + (let [prob (explain-1 form pred path via (conj in k) v)] + prob)))) + (range) x)))))) + (gen* [_ overrides path rmap] + (if gfn + (gfn) + (let [pgen (gensub pred overrides path rmap form)] + (gen/bind + (cond + gen-into (gen/return gen-into) + kind (gen/fmap #(if (empty? %) % (empty %)) + (gensub kind overrides path rmap form)) + :else (gen/return [])) + (fn [init] + (gen/fmap + #(if (vector? init) % (into init %)) + (cond + distinct + (if count + (gen/vector-distinct pgen {:num-elements count :max-tries 100}) + (gen/vector-distinct pgen {:min-elements (c/or min-count 0) + :max-elements (c/or max-count (max gen-max (c/* 2 (c/or min-count 0)))) + :max-tries 100})) + + count + (gen/vector pgen count) + + (c/or min-count max-count) + (gen/vector pgen (c/or min-count 0) (c/or max-count (max gen-max (c/* 2 (c/or min-count 0))))) + + :else + (gen/vector pgen 0 gen-max)))))))) + + (with-gen* [_ gfn] (every-impl form pred opts gfn)) + (describe* [_] (c/or describe-form `(every ~(res form) ~@(mapcat identity opts)))))))) + +;;;;;;;;;;;;;;;;;;;;;;; regex ;;;;;;;;;;;;;;;;;;; +;;See: +;; http://matt.might.net/articles/implementation-of-regular-expression-matching-in-scheme-with-derivatives/ +;; http://www.ccs.neu.edu/home/turon/re-deriv.pdf + +;;ctors +(defn- accept [x] {::op ::accept :ret x}) + +(defn- accept? [{:keys [::op]}] + (= ::accept op)) + +(defn- pcat* [{[p1 & pr :as ps] :ps, [k1 & kr :as ks] :ks, [f1 & fr :as forms] :forms, ret :ret, rep+ :rep+}] + (when (every? identity ps) + (if (accept? p1) + (let [rp (:ret p1) + ret (conj ret (if ks {k1 rp} rp))] + (if pr + (pcat* {:ps pr :ks kr :forms fr :ret ret}) + (accept ret))) + {::op ::pcat, :ps ps, :ret ret, :ks ks, :forms forms :rep+ rep+}))) + +(defn- pcat [& ps] (pcat* {:ps ps :ret []})) + +(defn ^:skip-wiki cat-impl + "Do not call this directly, use 'cat'" + [ks ps forms] + (pcat* {:ks ks, :ps ps, :forms forms, :ret {}})) + +(defn- rep* [p1 p2 ret splice form] + (when p1 + (let [r {::op ::rep, :p2 p2, :splice splice, :forms form :id (java.util.UUID/randomUUID)}] + (if (accept? p1) + (assoc r :p1 p2 :ret (conj ret (:ret p1))) + (assoc r :p1 p1, :ret ret))))) + +(defn ^:skip-wiki rep-impl + "Do not call this directly, use '*'" + [form p] (rep* p p [] false form)) + +(defn ^:skip-wiki rep+impl + "Do not call this directly, use '+'" + [form p] + (pcat* {:ps [p (rep* p p [] true form)] :forms `[~form (* ~form)] :ret [] :rep+ form})) + +(defn ^:skip-wiki amp-impl + "Do not call this directly, use '&'" + [re re-form preds pred-forms] + {::op ::amp :p1 re :amp re-form :ps preds :forms pred-forms}) + +(defn- filter-alt [ps ks forms f] + (if (c/or ks forms) + (let [pks (->> (map vector ps + (c/or (seq ks) (repeat nil)) + (c/or (seq forms) (repeat nil))) + (filter #(-> % first f)))] + [(seq (map first pks)) (when ks (seq (map second pks))) (when forms (seq (map #(nth % 2) pks)))]) + [(seq (filter f ps)) ks forms])) + +(defn- alt* [ps ks forms] + (let [[[p1 & pr :as ps] [k1 :as ks] forms] (filter-alt ps ks forms identity)] + (when ps + (let [ret {::op ::alt, :ps ps, :ks ks :forms forms}] + (if (nil? pr) + (if k1 + (if (accept? p1) + (accept (tagged-ret k1 (:ret p1))) + ret) + p1) + ret))))) + +(defn- alts [& ps] (alt* ps nil nil)) +(defn- alt2 [p1 p2] (if (c/and p1 p2) (alts p1 p2) (c/or p1 p2))) + +(defn ^:skip-wiki alt-impl + "Do not call this directly, use 'alt'" + [ks ps forms] (assoc (alt* ps ks forms) :id (java.util.UUID/randomUUID))) + +(defn ^:skip-wiki maybe-impl + "Do not call this directly, use '?'" + [p form] (assoc (alt* [p (accept ::nil)] nil [form ::nil]) :maybe form)) + +(defn- noret? [p1 pret] + (c/or (= pret ::nil) + (c/and (#{::rep ::pcat} (::op (reg-resolve! p1))) ;;hrm, shouldn't know these + (empty? pret)) + nil)) + +(declare preturn) + +(defn- accept-nil? [p] + (let [{:keys [::op ps p1 p2 forms] :as p} (reg-resolve! p)] + (case op + ::accept true + nil nil + ::amp (c/and (accept-nil? p1) + (let [ret (-> (preturn p1) (and-preds ps (next forms)))] + (not (invalid? ret)))) + ::rep (c/or (identical? p1 p2) (accept-nil? p1)) + ::pcat (every? accept-nil? ps) + ::alt (c/some accept-nil? ps)))) + +(declare add-ret) + +(defn- preturn [p] + (let [{[p0 & pr :as ps] :ps, [k :as ks] :ks, :keys [::op p1 ret forms] :as p} (reg-resolve! p)] + (case op + ::accept ret + nil nil + ::amp (let [pret (preturn p1)] + (if (noret? p1 pret) + ::nil + (and-preds pret ps forms))) + ::rep (add-ret p1 ret k) + ::pcat (add-ret p0 ret k) + ::alt (let [[[p0] [k0]] (filter-alt ps ks forms accept-nil?) + r (if (nil? p0) ::nil (preturn p0))] + (if k0 (tagged-ret k0 r) r))))) + +(defn- op-unform [p x] + ;;(prn {:p p :x x}) + (let [{[p0 & pr :as ps] :ps, [k :as ks] :ks, :keys [::op p1 ret forms rep+ maybe] :as p} (reg-resolve! p) + kps (zipmap ks ps)] + (case op + ::accept [ret] + nil [(unform p x)] + ::amp (let [px (reduce #(unform %2 %1) x (reverse ps))] + (op-unform p1 px)) + ::rep (mapcat #(op-unform p1 %) x) + ::pcat (if rep+ + (mapcat #(op-unform p0 %) x) + (mapcat (fn [k] + (when (contains? x k) + (op-unform (kps k) (get x k)))) + ks)) + ::alt (if maybe + [(unform p0 x)] + (let [[k v] x] + (op-unform (kps k) v)))))) + +(defn- add-ret [p r k] + (let [{:keys [::op ps splice] :as p} (reg-resolve! p) + prop #(let [ret (preturn p)] + (if (empty? ret) r ((if splice into conj) r (if k {k ret} ret))))] + (case op + nil r + (::alt ::accept ::amp) + (let [ret (preturn p)] + ;;(prn {:ret ret}) + (if (= ret ::nil) r (conj r (if k {k ret} ret)))) + + (::rep ::pcat) (prop)))) + +(defn- deriv + [p x] + (let [{[p0 & pr :as ps] :ps, [k0 & kr :as ks] :ks, :keys [::op p1 p2 ret splice forms amp] :as p} (reg-resolve! p)] + (when p + (case op + ::accept nil + nil (let [ret (dt p x p)] + (when-not (invalid? ret) (accept ret))) + ::amp (when-let [p1 (deriv p1 x)] + (if (= ::accept (::op p1)) + (let [ret (-> (preturn p1) (and-preds ps (next forms)))] + (when-not (invalid? ret) + (accept ret))) + (amp-impl p1 amp ps forms))) + ::pcat (alt2 (pcat* {:ps (cons (deriv p0 x) pr), :ks ks, :forms forms, :ret ret}) + (when (accept-nil? p0) (deriv (pcat* {:ps pr, :ks kr, :forms (next forms), :ret (add-ret p0 ret k0)}) x))) + ::alt (alt* (map #(deriv % x) ps) ks forms) + ::rep (alt2 (rep* (deriv p1 x) p2 ret splice forms) + (when (accept-nil? p1) (deriv (rep* p2 p2 (add-ret p1 ret nil) splice forms) x))))))) + +(defn- op-describe [p] + (let [{:keys [::op ps ks forms splice p1 rep+ maybe amp] :as p} (reg-resolve! p)] + ;;(prn {:op op :ks ks :forms forms :p p}) + (when p + (case op + ::accept nil + nil p + ::amp (list* 'clojure.spec.alpha/& amp forms) + ::pcat (if rep+ + (list `+ rep+) + (cons `cat (mapcat vector (c/or (seq ks) (repeat :_)) forms))) + ::alt (if maybe + (list `? maybe) + (cons `alt (mapcat vector ks forms))) + ::rep (list (if splice `+ `*) forms))))) + +(defn- op-explain [form p path via in input] + ;;(prn {:form form :p p :path path :input input}) + (let [[x :as input] input + {:keys [::op ps ks forms splice p1 p2] :as p} (reg-resolve! p) + via (if-let [name (spec-name p)] (conj via name) via) + insufficient (fn [path form] + [{:path path + :reason "Insufficient input" + :pred form + :val () + :via via + :in in}])] + (when p + (case op + ::accept nil + nil (if (empty? input) + (insufficient path form) + (explain-1 form p path via in x)) + ::amp (if (empty? input) + (if (accept-nil? p1) + (explain-pred-list forms ps path via in (preturn p1)) + (insufficient path (:amp p))) + (if-let [p1 (deriv p1 x)] + (explain-pred-list forms ps path via in (preturn p1)) + (op-explain (:amp p) p1 path via in input))) + ::pcat (let [pkfs (map vector + ps + (c/or (seq ks) (repeat nil)) + (c/or (seq forms) (repeat nil))) + [pred k form] (if (= 1 (count pkfs)) + (first pkfs) + (first (remove (fn [[p]] (accept-nil? p)) pkfs))) + path (if k (conj path k) path) + form (c/or form (op-describe pred))] + (if (c/and (empty? input) (not pred)) + (insufficient path form) + (op-explain form pred path via in input))) + ::alt (if (empty? input) + (insufficient path (op-describe p)) + (apply concat + (map (fn [k form pred] + (op-explain (c/or form (op-describe pred)) + pred + (if k (conj path k) path) + via + in + input)) + (c/or (seq ks) (repeat nil)) + (c/or (seq forms) (repeat nil)) + ps))) + ::rep (op-explain (if (identical? p1 p2) + forms + (op-describe p1)) + p1 path via in input))))) + +(defn- re-gen [p overrides path rmap f] + ;;(prn {:op op :ks ks :forms forms}) + (let [origp p + {:keys [::op ps ks p1 p2 forms splice ret id ::gfn] :as p} (reg-resolve! p) + rmap (if id (inck rmap id) rmap) + ggens (fn [ps ks forms] + (let [gen (fn [p k f] + ;;(prn {:k k :path path :rmap rmap :op op :id id}) + (when-not (c/and rmap id k (recur-limit? rmap id path k)) + (if id + (gen/delay (re-gen p overrides (if k (conj path k) path) rmap (c/or f p))) + (re-gen p overrides (if k (conj path k) path) rmap (c/or f p)))))] + (map gen ps (c/or (seq ks) (repeat nil)) (c/or (seq forms) (repeat nil)))))] + (c/or (when-let [gfn (c/or (get overrides (spec-name origp)) + (get overrides (spec-name p) ) + (get overrides path))] + (case op + (:accept nil) (gen/fmap vector (gfn)) + (gfn))) + (when gfn + (gfn)) + (when p + (case op + ::accept (if (= ret ::nil) + (gen/return []) + (gen/return [ret])) + nil (when-let [g (gensub p overrides path rmap f)] + (gen/fmap vector g)) + ::amp (re-gen p1 overrides path rmap (op-describe p1)) + ::pcat (let [gens (ggens ps ks forms)] + (when (every? identity gens) + (apply gen/cat gens))) + ::alt (let [gens (remove nil? (ggens ps ks forms))] + (when-not (empty? gens) + (gen/one-of gens))) + ::rep (if (recur-limit? rmap id [id] id) + (gen/return []) + (when-let [g (re-gen p2 overrides path rmap forms)] + (gen/fmap #(apply concat %) + (gen/vector g))))))))) + +(defn- re-conform [p [x & xs :as data]] + ;;(prn {:p p :x x :xs xs}) + (if (empty? data) + (if (accept-nil? p) + (let [ret (preturn p)] + (if (= ret ::nil) + nil + ret)) + ::invalid) + (if-let [dp (deriv p x)] + (recur dp xs) + ::invalid))) + +(defn- re-explain [path via in re input] + (loop [p re [x & xs :as data] input i 0] + ;;(prn {:p p :x x :xs xs :re re}) (prn) + (if (empty? data) + (if (accept-nil? p) + nil ;;success + (op-explain (op-describe p) p path via in nil)) + (if-let [dp (deriv p x)] + (recur dp xs (inc i)) + (if (accept? p) + (if (= (::op p) ::pcat) + (op-explain (op-describe p) p path via (conj in i) (seq data)) + [{:path path + :reason "Extra input" + :pred (op-describe re) + :val data + :via via + :in (conj in i)}]) + (c/or (op-explain (op-describe p) p path via (conj in i) (seq data)) + [{:path path + :reason "Extra input" + :pred (op-describe p) + :val data + :via via + :in (conj in i)}])))))) + +(defn ^:skip-wiki regex-spec-impl + "Do not call this directly, use 'spec' with a regex op argument" + [re gfn] + (reify + Specize + (specize* [s] s) + (specize* [s _] s) + + Spec + (conform* [_ x] + (if (c/or (nil? x) (sequential? x)) + (re-conform re (seq x)) + ::invalid)) + (unform* [_ x] (op-unform re x)) ;; so far OK + (explain* [_ path via in x] + (if (c/or (nil? x) (sequential? x)) + (re-explain path via in re (seq x)) + [{:path path :pred (res `#(c/or (nil? %) (sequential? %))) :val x :via via :in in}])) + (gen* [_ overrides path rmap] + (if gfn + (gfn) + (re-gen re overrides path rmap (op-describe re)))) + (with-gen* [_ gfn] (regex-spec-impl re gfn)) + (describe* [_] (op-describe re)))) + +;;;;;;;;;;;;;;;;; HOFs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- call-valid? + [f specs args] + (let [cargs (conform (:args specs) args)] + (when-not (invalid? cargs) + (let [ret (apply f args) + cret (conform (:ret specs) ret)] + (c/and (not (invalid? cret)) + (if (:fn specs) + (pvalid? (:fn specs) {:args cargs :ret cret}) + true)))))) + +(defn- validate-fn + "returns f if valid, else smallest" + [f specs iters] + (let [g (gen (:args specs)) + prop (gen/for-all* [g] #(call-valid? f specs %))] + (let [ret (gen/quick-check iters prop)] + (if-let [[smallest] (-> ret :shrunk :smallest)] + smallest + f)))) + +(defn ^:skip-wiki fspec-impl + "Do not call this directly, use 'fspec'" + [argspec aform retspec rform fnspec fform gfn] + (let [specs {:args argspec :ret retspec :fn fnspec}] + (reify + clojure.lang.ILookup + (valAt [this k] (get specs k)) + (valAt [_ k not-found] (get specs k not-found)) + + Specize + (specize* [s] s) + (specize* [s _] s) + + Spec + (conform* [this f] (if argspec + (if (ifn? f) + (if (identical? f (validate-fn f specs *fspec-iterations*)) f ::invalid) + ::invalid) + (throw (Exception. (str "Can't conform fspec without args spec: " (pr-str (describe this))))))) + (unform* [_ f] f) + (explain* [_ path via in f] + (if (ifn? f) + (let [args (validate-fn f specs 100)] + (if (identical? f args) ;;hrm, we might not be able to reproduce + nil + (let [ret (try (apply f args) (catch Throwable t t))] + (if (instance? Throwable ret) + ;;TODO add exception data + [{:path path :pred '(apply fn) :val args :reason (.getMessage ^Throwable ret) :via via :in in}] + + (let [cret (dt retspec ret rform)] + (if (invalid? cret) + (explain-1 rform retspec (conj path :ret) via in ret) + (when fnspec + (let [cargs (conform argspec args)] + (explain-1 fform fnspec (conj path :fn) via in {:args cargs :ret cret}))))))))) + [{:path path :pred 'ifn? :val f :via via :in in}])) + (gen* [_ overrides _ _] (if gfn + (gfn) + (gen/return + (fn [& args] + (c/assert (pvalid? argspec args) (with-out-str (explain argspec args))) + (gen/generate (gen retspec overrides)))))) + (with-gen* [_ gfn] (fspec-impl argspec aform retspec rform fnspec fform gfn)) + (describe* [_] `(fspec :args ~aform :ret ~rform :fn ~fform))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; non-primitives ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(clojure.spec.alpha/def ::kvs->map (conformer #(zipmap (map ::k %) (map ::v %)) #(map (fn [[k v]] {::k k ::v v}) %))) + +(defmacro keys* + "takes the same arguments as spec/keys and returns a regex op that matches sequences of key/values, + converts them into a map, and conforms that map with a corresponding + spec/keys call: + + user=> (s/conform (s/keys :req-un [::a ::c]) {:a 1 :c 2}) + {:a 1, :c 2} + user=> (s/conform (s/keys* :req-un [::a ::c]) [:a 1 :c 2]) + {:a 1, :c 2} + + the resulting regex op can be composed into a larger regex: + + user=> (s/conform (s/cat :i1 integer? :m (s/keys* :req-un [::a ::c]) :i2 integer?) [42 :a 1 :c 2 :d 4 99]) + {:i1 42, :m {:a 1, :c 2, :d 4}, :i2 99}" + [& kspecs] + `(let [mspec# (keys ~@kspecs)] + (with-gen (clojure.spec.alpha/& (* (cat ::k keyword? ::v any?)) ::kvs->map mspec#) + (fn [] (gen/fmap (fn [m#] (apply concat m#)) (gen mspec#)))))) + +(defn ^:skip-wiki nonconforming + "takes a spec and returns a spec that has the same properties except + 'conform' returns the original (not the conformed) value. Note, will specize regex ops." + [spec] + (let [spec (delay (specize spec))] + (reify + Specize + (specize* [s] s) + (specize* [s _] s) + + Spec + (conform* [_ x] (let [ret (conform* @spec x)] + (if (invalid? ret) + ::invalid + x))) + (unform* [_ x] x) + (explain* [_ path via in x] (explain* @spec path via in x)) + (gen* [_ overrides path rmap] (gen* @spec overrides path rmap)) + (with-gen* [_ gfn] (nonconforming (with-gen* @spec gfn))) + (describe* [_] `(nonconforming ~(describe* @spec)))))) + +(defn ^:skip-wiki nilable-impl + "Do not call this directly, use 'nilable'" + [form pred gfn] + (let [spec (delay (specize pred form))] + (reify + Specize + (specize* [s] s) + (specize* [s _] s) + + Spec + (conform* [_ x] (if (nil? x) nil (conform* @spec x))) + (unform* [_ x] (if (nil? x) nil (unform* @spec x))) + (explain* [_ path via in x] + (when-not (c/or (pvalid? @spec x) (nil? x)) + (conj + (explain-1 form pred (conj path ::pred) via in x) + {:path (conj path ::nil) :pred 'nil? :val x :via via :in in}))) + (gen* [_ overrides path rmap] + (if gfn + (gfn) + (gen/frequency + [[1 (gen/delay (gen/return nil))] + [9 (gen/delay (gensub pred overrides (conj path ::pred) rmap form))]]))) + (with-gen* [_ gfn] (nilable-impl form pred gfn)) + (describe* [_] `(nilable ~(res form)))))) + +(defmacro nilable + "returns a spec that accepts nil and values satisfying pred" + [pred] + (let [pf (res pred)] + `(nilable-impl '~pf ~pred nil))) + +(defn exercise + "generates a number (default 10) of values compatible with spec and maps conform over them, + returning a sequence of [val conformed-val] tuples. Optionally takes + a generator overrides map as per gen" + ([spec] (exercise spec 10)) + ([spec n] (exercise spec n nil)) + ([spec n overrides] + (map #(vector % (conform spec %)) (gen/sample (gen spec overrides) n)))) + +(defn exercise-fn + "exercises the fn named by sym (a symbol) by applying it to + n (default 10) generated samples of its args spec. When fspec is + supplied its arg spec is used, and sym-or-f can be a fn. Returns a + sequence of tuples of [args ret]. " + ([sym] (exercise-fn sym 10)) + ([sym n] (exercise-fn sym n (get-spec sym))) + ([sym-or-f n fspec] + (let [f (if (symbol? sym-or-f) (resolve sym-or-f) sym-or-f)] + (if-let [arg-spec (c/and fspec (:args fspec))] + (for [args (gen/sample (gen arg-spec) n)] + [args (apply f args)]) + (throw (Exception. "No :args spec found, can't generate")))))) + +(defn inst-in-range? + "Return true if inst at or after start and before end" + [start end inst] + (c/and (inst? inst) + (let [t (inst-ms inst)] + (c/and (<= (inst-ms start) t) (< t (inst-ms end)))))) + +(defmacro inst-in + "Returns a spec that validates insts in the range from start + (inclusive) to end (exclusive)." + [start end] + `(let [st# (inst-ms ~start) + et# (inst-ms ~end) + mkdate# (fn [d#] (java.util.Date. ^{:tag ~'long} d#))] + (spec (and inst? #(inst-in-range? ~start ~end %)) + :gen (fn [] + (gen/fmap mkdate# + (gen/large-integer* {:min st# :max et#})))))) + +(defn int-in-range? + "Return true if start <= val, val < end and val is a fixed + precision integer." + [start end val] + (c/and (int? val) (<= start val) (< val end))) + +(defmacro int-in + "Returns a spec that validates fixed precision integers in the + range from start (inclusive) to end (exclusive)." + [start end] + `(spec (and int? #(int-in-range? ~start ~end %)) + :gen #(gen/large-integer* {:min ~start :max (dec ~end)}))) + +(defmacro double-in + "Specs a 64-bit floating point number. Options: + + :infinite? - whether +/- infinity allowed (default true) + :NaN? - whether NaN allowed (default true) + :min - minimum value (inclusive, default none) + :max - maximum value (inclusive, default none)" + [& {:keys [infinite? NaN? min max] + :or {infinite? true NaN? true} + :as m}] + `(spec (and c/double? + ~@(when-not infinite? '[#(not (Double/isInfinite %))]) + ~@(when-not NaN? '[#(not (Double/isNaN %))]) + ~@(when max `[#(<= % ~max)]) + ~@(when min `[#(<= ~min %)])) + :gen #(gen/double* ~m))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; assert ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defonce + ^{:dynamic true + :doc "If true, compiler will enable spec asserts, which are then +subject to runtime control via check-asserts? If false, compiler +will eliminate all spec assert overhead. See 'assert'. + +Initially set to boolean value of clojure.spec.compile-asserts +system property. Defaults to true."} + *compile-asserts* + (not= "false" (System/getProperty "clojure.spec.compile-asserts"))) + +(defn check-asserts? + "Returns the value set by check-asserts." + [] + clojure.lang.RT/checkSpecAsserts) + +(defn check-asserts + "Enable or disable spec asserts that have been compiled + with '*compile-asserts*' true. See 'assert'. + + Initially set to boolean value of clojure.spec.check-asserts + system property. Defaults to false." + [flag] + (set! (. clojure.lang.RT checkSpecAsserts) flag)) + +(defn assert* + "Do not call this directly, use 'assert'." + [spec x] + (if (valid? spec x) + x + (let [ed (c/merge (assoc (explain-data* spec [] [] [] x) + ::failure :assertion-failed))] + (throw (ex-info + (str "Spec assertion failed\n" (with-out-str (explain-out ed))) + ed))))) + +(defmacro assert + "spec-checking assert expression. Returns x if x is valid? according + to spec, else throws an ex-info with explain-data plus ::failure of + :assertion-failed. + + Can be disabled at either compile time or runtime: + + If *compile-asserts* is false at compile time, compiles to x. Defaults + to value of 'clojure.spec.compile-asserts' system property, or true if + not set. + + If (check-asserts?) is false at runtime, always returns x. Defaults to + value of 'clojure.spec.check-asserts' system property, or false if not + set. You can toggle check-asserts? with (check-asserts bool)." + [spec x] + (if *compile-asserts* + `(if clojure.lang.RT/checkSpecAsserts + (assert* ~spec ~x) + ~x) + x)) diff --git a/src/babashka/impl/clojure/spec/gen/alpha.clj b/src/babashka/impl/clojure/spec/gen/alpha.clj new file mode 100755 index 00000000..d0370657 --- /dev/null +++ b/src/babashka/impl/clojure/spec/gen/alpha.clj @@ -0,0 +1,208 @@ +; Copyright (c) Rich Hickey. All rights reserved. +; The use and distribution terms for this software are covered by the +; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +; which can be found in the file epl-v10.html at the root of this distribution. +; By using this software in any fashion, you are agreeing to be bound by +; the terms of this license. +; You must not remove this notice, or any other, from this software. + +(ns babashka.impl.clojure.spec.gen.alpha + (:refer-clojure :exclude [boolean bytes cat hash-map list map not-empty set vector + char double int keyword symbol string uuid delay shuffle]) + (:require [clojure.test.check] + [clojure.test.check.generators] + [clojure.test.check.properties])) + +(alias 'c 'clojure.core) + +(def ^:private quick-check-ref (c/delay clojure.test.check/quick-check)) +(defn quick-check + [& args] + (apply @quick-check-ref args)) + +(def ^:private for-all*-ref + (c/delay (clojure.test.check.properties/for-all*))) +(defn for-all* + "Dynamically loaded clojure.test.check.properties/for-all*." + [& args] + (apply @for-all*-ref args)) + +(let [g? clojure.test.check.generators/generator? + g clojure.test.check.generators/generate + mkg clojure.test.check.generators/->Generator] + (defn- generator? + [x] + (g? x)) + (defn- generator + [gfn] + (mkg gfn)) + (defn generate + "Generate a single value using generator." + [generator] + (g generator))) + +(defn ^:skip-wiki delay-impl + [gfnd] + ;;N.B. depends on test.check impl details + (generator (fn [rnd size] + ((:gen @gfnd) rnd size)))) + +(defmacro delay + "given body that returns a generator, returns a + generator that delegates to that, but delays + creation until used." + [& body] + `(delay-impl (c/delay ~@body))) + +(defmacro ^:skip-wiki lazy-combinator + "Implementation macro, do not call directly." + [s] + (let [fqn (c/symbol "clojure.test.check.generators" (name s)) + doc (str "Lazy loaded version of " fqn)] + `(let [g# (c/delay ~fqn)] + (defn ~s + ~doc + [& ~'args] + (apply @g# ~'args))))) + +(defmacro ^:skip-wiki lazy-combinators + "Implementation macro, do not call directly." + [& syms] + `(do + ~@(c/map + (fn [s] (c/list 'lazy-combinator s)) + syms))) + +(lazy-combinators hash-map list map not-empty set vector vector-distinct fmap elements + bind choose fmap one-of such-that tuple sample return + large-integer* double* frequency shuffle) + +(defmacro ^:skip-wiki lazy-prim + "Implementation macro, do not call directly." + [s] + (let [fqn (c/symbol "clojure.test.check.generators" (name s)) + doc (str "Fn returning " fqn)] + `(let [g# (c/delay ~fqn)] + (defn ~s + ~doc + [& ~'args] + @g#)))) + +(defmacro ^:skip-wiki lazy-prims + "Implementation macro, do not call directly." + [& syms] + `(do + ~@(c/map + (fn [s] (c/list 'lazy-prim s)) + syms))) + +(lazy-prims any any-printable boolean bytes char char-alpha char-alphanumeric char-ascii double + int keyword keyword-ns large-integer ratio simple-type simple-type-printable + string string-ascii string-alphanumeric symbol symbol-ns uuid) + +(defn cat + "Returns a generator of a sequence catenated from results of +gens, each of which should generate something sequential." + [& gens] + (fmap #(apply concat %) + (apply tuple gens))) + +(defn- qualified? [ident] (not (nil? (namespace ident)))) + +(def ^:private + gen-builtins + (c/delay + (let [simple (simple-type-printable)] + {any? (one-of [(return nil) (any-printable)]) + some? (such-that some? (any-printable)) + number? (one-of [(large-integer) (double)]) + integer? (large-integer) + int? (large-integer) + pos-int? (large-integer* {:min 1}) + neg-int? (large-integer* {:max -1}) + nat-int? (large-integer* {:min 0}) + float? (double) + double? (double) + boolean? (boolean) + string? (string-alphanumeric) + ident? (one-of [(keyword-ns) (symbol-ns)]) + simple-ident? (one-of [(keyword) (symbol)]) + qualified-ident? (such-that qualified? (one-of [(keyword-ns) (symbol-ns)])) + keyword? (keyword-ns) + simple-keyword? (keyword) + qualified-keyword? (such-that qualified? (keyword-ns)) + symbol? (symbol-ns) + simple-symbol? (symbol) + qualified-symbol? (such-that qualified? (symbol-ns)) + uuid? (uuid) + uri? (fmap #(java.net.URI/create (str "http://" % ".com")) (uuid)) + decimal? (fmap #(BigDecimal/valueOf %) + (double* {:infinite? false :NaN? false})) + inst? (fmap #(java.util.Date. %) + (large-integer)) + seqable? (one-of [(return nil) + (list simple) + (vector simple) + (map simple simple) + (set simple) + (string-alphanumeric)]) + indexed? (vector simple) + map? (map simple simple) + vector? (vector simple) + list? (list simple) + seq? (list simple) + char? (char) + set? (set simple) + nil? (return nil) + false? (return false) + true? (return true) + zero? (return 0) + rational? (one-of [(large-integer) (ratio)]) + coll? (one-of [(map simple simple) + (list simple) + (vector simple) + (set simple)]) + empty? (elements [nil '() [] {} #{}]) + associative? (one-of [(map simple simple) (vector simple)]) + sequential? (one-of [(list simple) (vector simple)]) + ratio? (such-that ratio? (ratio)) + bytes? (bytes)}))) + +(defn gen-for-pred + "Given a predicate, returns a built-in generator if one exists." + [pred] + (if (set? pred) + (elements pred) + (get @gen-builtins pred))) + +(comment + (require :reload 'clojure.spec.gen.alpha) + (in-ns 'clojure.spec.gen.alpha) + + ;; combinators, see call to lazy-combinators above for complete list + (generate (one-of [(gen-for-pred integer?) (gen-for-pred string?)])) + (generate (such-that #(< 10000 %) (gen-for-pred integer?))) + (let [reqs {:a (gen-for-pred number?) + :b (gen-for-pred ratio?)} + opts {:c (gen-for-pred string?)}] + (generate (bind (choose 0 (count opts)) + #(let [args (concat (seq reqs) (c/shuffle (seq opts)))] + (->> args + (take (+ % (count reqs))) + (mapcat identity) + (apply hash-map)))))) + (generate (cat (list (gen-for-pred string?)) + (list (gen-for-pred ratio?)))) + + ;; load your own generator + (gen-for-name 'clojure.test.check.generators/int) + + ;; failure modes + (gen-for-name 'unqualified) + (gen-for-name 'clojure.core/+) + (gen-for-name 'clojure.core/name-does-not-exist) + (gen-for-name 'ns.does.not.exist/f) + + ) + + diff --git a/src/babashka/impl/clojure/spec/test/alpha.clj b/src/babashka/impl/clojure/spec/test/alpha.clj new file mode 100644 index 00000000..7a5f497c --- /dev/null +++ b/src/babashka/impl/clojure/spec/test/alpha.clj @@ -0,0 +1,471 @@ +;; Copyright (c) Rich Hickey. All rights reserved. +;; The use and distribution terms for this software are covered by the +;; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) +;; which can be found in the file epl-v10.html at the root of this distribution. +;; By using this software in any fashion, you are agreeing to be bound by +;; the terms of this license. +;; You must not remove this notice, or any other, from this software. + +(ns babashka.impl.clojure.spec.test.alpha + (:refer-clojure :exclude [test]) + (:require + [babashka.impl.clojure.spec.alpha :as s] + [babashka.impl.clojure.spec.gen.alpha :as gen] + [babashka.impl.pprint :as pp] + [clojure.string :as str])) + +(in-ns 'clojure.spec.test.check) +(in-ns 'babashka.impl.clojure.spec.test.alpha) +(alias 'stc 'clojure.spec.test.check) + +(defn- throwable? + [x] + (instance? Throwable x)) + +(defn ->sym + [x] + (@#'s/->sym x)) + +#_(defn- ->var + [s-or-v] + (if (var? s-or-v) + s-or-v + (let [v (and (symbol? s-or-v) (resolve s-or-v))] + (if (var? v) + v + (throw (IllegalArgumentException. (str (pr-str s-or-v) " does not name a var"))))))) + +(defn- collectionize + [x] + (if (symbol? x) + (list x) + x)) + +(defn enumerate-namespace + "Given a symbol naming an ns, or a collection of such symbols, +returns the set of all symbols naming vars in those nses." + [ns-sym-or-syms] + (into + #{} + (mapcat (fn [ns-sym] + (map + (fn [name-sym] + (symbol (name ns-sym) (name name-sym))) + (keys (ns-interns ns-sym))))) + (collectionize ns-sym-or-syms))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; instrument ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(def ^:private ^:dynamic *instrument-enabled* + "if false, instrumented fns call straight through" + true) + +#_(defn- fn-spec? + "Fn-spec must include at least :args or :ret specs." + [m] + (or (:args m) (:ret m))) + +(defmacro with-instrument-disabled + "Disables instrument's checking of calls, within a scope." + [& body] + `(binding [*instrument-enabled* nil] + ~@body)) + +(defn- interpret-stack-trace-element + "Given the vector-of-syms form of a stacktrace element produced +by e.g. Throwable->map, returns a map form that adds some keys +guessing the original Clojure names. Returns a map with + + :class class name symbol from stack trace + :method method symbol from stack trace + :file filename from stack trace + :line line number from stack trace + :var-scope optional Clojure var symbol scoping fn def + :local-fn optional local Clojure symbol scoping fn def + +For non-Clojure fns, :scope and :local-fn will be absent." + [[cls method file line]] + (let [clojure? (contains? '#{invoke invokeStatic} method) + demunge #(clojure.lang.Compiler/demunge %) + degensym #(str/replace % #"--.*" "") + [ns-sym name-sym local] (when clojure? + (->> (str/split (str cls) #"\$" 3) + (map demunge)))] + (merge {:file file + :line line + :method method + :class cls} + (when (and ns-sym name-sym) + {:var-scope (symbol ns-sym name-sym)}) + (when local + {:local-fn (symbol (degensym local))})))) + +(defn- stacktrace-relevant-to-instrument + "Takes a coll of stack trace elements (as returned by +StackTraceElement->vec) and returns a coll of maps as per +interpret-stack-trace-element that are relevant to a +failure in instrument." + [elems] + (let [plumbing? (fn [{:keys [var-scope]}] + (contains? '#{clojure.spec.test.alpha/spec-checking-fn} var-scope))] + (sequence (comp (map StackTraceElement->vec) + (map interpret-stack-trace-element) + (filter :var-scope) + (drop-while plumbing?)) + elems))) + +(defn- spec-checking-fn + [v f fn-spec] + (let [fn-spec (@#'s/maybe-spec fn-spec) + conform! (fn [v role spec data args] + (let [conformed (s/conform spec data)] + (if (= ::s/invalid conformed) + (let [caller (->> (.getStackTrace (Thread/currentThread)) + stacktrace-relevant-to-instrument + first) + ed (merge (assoc (s/explain-data* spec [] [] [] data) + ::s/fn (->sym v) + ::s/args args + ::s/failure :instrument) + (when caller + {::caller (dissoc caller :class :method)}))] + (throw (ex-info + (str "Call to " v " did not conform to spec.") + ed))) + conformed)))] + (fn + [& args] + (if *instrument-enabled* + (with-instrument-disabled + (when (:args fn-spec) (conform! v :args (:args fn-spec) args args)) + (binding [*instrument-enabled* true] + (.applyTo ^clojure.lang.IFn f args))) + (.applyTo ^clojure.lang.IFn f args))))) + +(defn- no-fspec + [v spec] + (ex-info (str "Fn at " v " is not spec'ed.") + {:var v :spec spec ::s/failure :no-fspec})) + +(defonce ^:private instrumented-vars (atom {})) + +(defn- instrument-choose-fn + "Helper for instrument." + [f spec sym {over :gen :keys [stub replace]}] + (if (some #{sym} stub) + (-> spec (s/gen over) gen/generate) + (get replace sym f))) + +(defn- instrument-choose-spec + "Helper for instrument" + [spec sym {overrides :spec}] + (get overrides sym spec)) + +(defn- instrument-1 + [s opts] + ;; TODO: sci resolve + (when-let [v nil #_(resolve s)] + (when-not (-> v meta :macro) + (let [spec (s/get-spec v) + {:keys [raw wrapped]} (get @instrumented-vars v) + current @v + to-wrap (if (= wrapped current) raw current) + ospec (or (instrument-choose-spec spec s opts) + (throw (no-fspec v spec))) + ofn (instrument-choose-fn to-wrap ospec s opts) + checked (spec-checking-fn v ofn ospec)] + ;; TODO: use sci alter-var-root + (alter-var-root v (constantly checked)) + (swap! instrumented-vars assoc v {:raw to-wrap :wrapped checked}) + (->sym v))))) + +(defn- unstrument-1 + [s] + (when-let [v nil #_(resolve s)] + (when-let [{:keys [raw wrapped]} (get @instrumented-vars v)] + (swap! instrumented-vars dissoc v) + (let [current @v] + (when (= wrapped current) + ;; TODO: use sci-alter-var-root + (alter-var-root v (constantly raw)) + (->sym v)))))) + +#_(defn- opt-syms + "Returns set of symbols referenced by 'instrument' opts map" + [opts] + (reduce into #{} [(:stub opts) (keys (:replace opts)) (keys (:spec opts))])) + +(defn- fn-spec-name? + [s] + (and (symbol? s) + ;; TODO: sci resolve + #_(not (some-> (resolve s) meta :macro)))) + +(defn instrumentable-syms + "Given an opts map as per instrument, returns the set of syms +that can be instrumented." + ([] (instrumentable-syms nil)) + ([opts] + (assert (every? ident? (keys (:gen opts))) "instrument :gen expects ident keys") + (reduce into #{} [(filter fn-spec-name? (keys (s/registry))) + (keys (:spec opts)) + (:stub opts) + (keys (:replace opts))]))) + +(defn instrument + "Instruments the vars named by sym-or-syms, a symbol or collection +of symbols, or all instrumentable vars if sym-or-syms is not +specified. + +If a var has an :args fn-spec, sets the var's root binding to a +fn that checks arg conformance (throwing an exception on failure) +before delegating to the original fn. + +The opts map can be used to override registered specs, and/or to +replace fn implementations entirely. Opts for symbols not included +in sym-or-syms are ignored. This facilitates sharing a common +options map across many different calls to instrument. + +The opts map may have the following keys: + + :spec a map from var-name symbols to override specs + :stub a set of var-name symbols to be replaced by stubs + :gen a map from spec names to generator overrides + :replace a map from var-name symbols to replacement fns + +:spec overrides registered fn-specs with specs your provide. Use +:spec overrides to provide specs for libraries that do not have +them, or to constrain your own use of a fn to a subset of its +spec'ed contract. + +:stub replaces a fn with a stub that checks :args, then uses the +:ret spec to generate a return value. + +:gen overrides are used only for :stub generation. + +:replace replaces a fn with a fn that checks args conformance, then +invokes the fn you provide, enabling arbitrary stubbing and mocking. + +:spec can be used in combination with :stub or :replace. + +Returns a collection of syms naming the vars instrumented." + ([] (instrument (instrumentable-syms))) + ([sym-or-syms] (instrument sym-or-syms nil)) + ([sym-or-syms opts] + (locking instrumented-vars + (into + [] + (comp (filter (instrumentable-syms opts)) + (distinct) + (map #(instrument-1 % opts)) + (remove nil?)) + (collectionize sym-or-syms))))) + +(defn unstrument + "Undoes instrument on the vars named by sym-or-syms, specified +as in instrument. With no args, unstruments all instrumented vars. +Returns a collection of syms naming the vars unstrumented." + ([] (unstrument (map ->sym (keys @instrumented-vars)))) + ([sym-or-syms] + (locking instrumented-vars + (into + [] + (comp (filter symbol?) + (map unstrument-1) + (remove nil?)) + (collectionize sym-or-syms))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; testing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- explain-check + [args spec v role] + (ex-info + "Specification-based check failed" + (when-not (s/valid? spec v nil) + (assoc (s/explain-data* spec [role] [] [] v) + ::args args + ::val v + ::s/failure :check-failed)))) + +(defn- check-call + "Returns true if call passes specs, otherwise *returns* an exception +with explain-data + ::s/failure." + [f specs args] + (let [cargs (when (:args specs) (s/conform (:args specs) args))] + (if (= cargs ::s/invalid) + (explain-check args (:args specs) args :args) + (let [ret (apply f args) + cret (when (:ret specs) (s/conform (:ret specs) ret))] + (if (= cret ::s/invalid) + (explain-check args (:ret specs) ret :ret) + (if (and (:args specs) (:ret specs) (:fn specs)) + (if (s/valid? (:fn specs) {:args cargs :ret cret}) + true + (explain-check args (:fn specs) {:args cargs :ret cret} :fn)) + true)))))) + +(defn- quick-check + [f specs {gen :gen opts ::stc/opts}] + (let [{:keys [num-tests] :or {num-tests 1000}} opts + g (try (s/gen (:args specs) gen) (catch Throwable t t))] + (if (throwable? g) + {:result g} + (let [prop (gen/for-all* [g] #(check-call f specs %))] + (apply gen/quick-check num-tests prop (mapcat identity opts)))))) + +(defn- make-check-result + "Builds spec result map." + [check-sym spec test-check-ret] + (merge {:spec spec + ::stc/ret test-check-ret} + (when check-sym + {:sym check-sym}) + (when-let [result (-> test-check-ret :result)] + (when-not (true? result) {:failure result})) + (when-let [shrunk (-> test-check-ret :shrunk)] + {:failure (:result shrunk)}))) + +(defn- check-1 + [{:keys [s f v spec]} opts] + (let [re-inst? (and v (seq (unstrument s)) true) + f (or f (when v @v)) + specd (s/spec spec)] + (try + (cond + (or (nil? f) (some-> v meta :macro)) + {:failure (ex-info "No fn to spec" {::s/failure :no-fn}) + :sym s :spec spec} + + (:args specd) + (let [tcret (quick-check f specd opts)] + (make-check-result s spec tcret)) + + :default + {:failure (ex-info "No :args spec" {::s/failure :no-args-spec}) + :sym s :spec spec}) + (finally + (when re-inst? (instrument s)))))) + +(defn- sym->check-map + [s] + ;; TODO: resolve + (let [v nil #_(resolve s)] + {:s s + :v v + :spec (when v (s/get-spec v))})) + +(defn- validate-check-opts + [opts] + (assert (every? ident? (keys (:gen opts))) "check :gen expects ident keys")) + +(defn check-fn + "Runs generative tests for fn f using spec and opts. See +'check' for options and return." + ([f spec] (check-fn f spec nil)) + ([f spec opts] + (validate-check-opts opts) + (check-1 {:f f :spec spec} opts))) + +(defn checkable-syms + "Given an opts map as per check, returns the set of syms that +can be checked." + ([] (checkable-syms nil)) + ([opts] + (validate-check-opts opts) + (reduce into #{} [(filter fn-spec-name? (keys (s/registry))) + (keys (:spec opts))]))) + +(defn check + "Run generative tests for spec conformance on vars named by +sym-or-syms, a symbol or collection of symbols. If sym-or-syms +is not specified, check all checkable vars. + +The opts map includes the following optional keys, where stc +aliases clojure.spec.test.check: + +::stc/opts opts to flow through test.check/quick-check +:gen map from spec names to generator overrides + +The ::stc/opts include :num-tests in addition to the keys +documented by test.check. Generator overrides are passed to +spec/gen when generating function args. + +Returns a lazy sequence of check result maps with the following +keys + +:spec the spec tested +:sym optional symbol naming the var tested +:failure optional test failure +::stc/ret optional value returned by test.check/quick-check + +The value for :failure can be any exception. Exceptions thrown by +spec itself will have an ::s/failure value in ex-data: + +:check-failed at least one checked return did not conform +:no-args-spec no :args spec provided +:no-fn no fn provided +:no-fspec no fspec provided +:no-gen unable to generate :args +:instrument invalid args detected by instrument +" + ([] (check (checkable-syms))) + ([sym-or-syms] (check sym-or-syms nil)) + ([sym-or-syms opts] + (->> (collectionize sym-or-syms) + (filter (checkable-syms opts)) + (pmap + #(check-1 (sym->check-map %) opts))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; check reporting ;;;;;;;;;;;;;;;;;;;;;;;; + +(defn- failure-type + [x] + (::s/failure (ex-data x))) + +(defn- unwrap-failure + [x] + (if (failure-type x) + (ex-data x) + x)) + +(defn- result-type + "Returns the type of the check result. This can be any of the +::s/failure keywords documented in 'check', or: + + :check-passed all checked fn returns conformed + :check-threw checked fn threw an exception" + [ret] + (let [failure (:failure ret)] + (cond + (nil? failure) :check-passed + (failure-type failure) (failure-type failure) + :default :check-threw))) + +(defn abbrev-result + "Given a check result, returns an abbreviated version +suitable for summary use." + [x] + (if (:failure x) + (-> (dissoc x ::stc/ret) + (update :spec s/describe) + (update :failure unwrap-failure)) + (dissoc x :spec ::stc/ret))) + +(defn summarize-results + "Given a collection of check-results, e.g. from 'check', pretty +prints the summary-result (default abbrev-result) of each. + +Returns a map with :total, the total number of results, plus a +key with a count for each different :type of result." + ([check-results] (summarize-results check-results abbrev-result)) + ([check-results summary-result] + (reduce + (fn [summary result] + (pp/pprint (summary-result result)) + (-> summary + (update :total inc) + (update (result-type result) (fnil inc 0)))) + {:total 0} + check-results))) + + diff --git a/src/babashka/impl/features.clj b/src/babashka/impl/features.clj index dbf6fa62..ee097903 100644 --- a/src/babashka/impl/features.clj +++ b/src/babashka/impl/features.clj @@ -13,6 +13,7 @@ (def httpkit-server? (not= "false" (System/getenv "BABASHKA_FEATURE_HTTPKIT_SERVER"))) (def core-match? (not= "false" (System/getenv "BABASHKA_FEATURE_CORE_MATCH"))) (def hiccup? (not= "false" (System/getenv "BABASHKA_FEATURE_HICCUP"))) +(def test-check? (not= "false" (System/getenv "BABASHKA_FEATURE_TEST_CHECK"))) ;; excluded by default (def jdbc? (= "true" (System/getenv "BABASHKA_FEATURE_JDBC"))) @@ -21,3 +22,47 @@ (def hsqldb? (= "true" (System/getenv "BABASHKA_FEATURE_HSQLDB"))) (def datascript? (= "true" (System/getenv "BABASHKA_FEATURE_DATASCRIPT"))) (def lanterna? (= "true" (System/getenv "BABASHKA_FEATURE_LANTERNA"))) +(def spec-alpha? (= "true" (System/getenv "BABASHKA_FEATURE_SPEC_ALPHA"))) + +(when xml? + (require '[babashka.impl.xml])) + +(when yaml? + (require '[babashka.impl.yaml] + '[babashka.impl.ordered])) + +(when jdbc? + (require '[babashka.impl.jdbc])) + +(when core-async? + (require '[babashka.impl.async])) + +(when csv? + (require '[babashka.impl.csv])) + +(when transit? + (require '[babashka.impl.transit])) + +(when datascript? + (require '[babashka.impl.datascript])) + +(when httpkit-client? + (require '[babashka.impl.httpkit-client])) + +(when httpkit-server? + (require '[babashka.impl.httpkit-server])) + +(when lanterna? + (require '[babashka.impl.lanterna])) + +(when core-match? + (require '[babashka.impl.match])) + +(when hiccup? + (require '[babashka.impl.hiccup])) + +(when test-check? + (require '[babashka.impl.clojure.test.check])) + +(when spec-alpha? + (require '[babashka.impl.spec])) diff --git a/src/babashka/impl/pprint.clj b/src/babashka/impl/pprint.clj index 943f323c..ed1c7027 100644 --- a/src/babashka/impl/pprint.clj +++ b/src/babashka/impl/pprint.clj @@ -4,10 +4,11 @@ [sci.core :as sci] [sci.impl.vars :as vars])) -(alter-var-root #'pprint/write-option-table - (fn [m] - (zipmap (keys m) - (map find-var (vals m))))) +(defonce patch-option-table + (alter-var-root #'pprint/write-option-table + (fn [m] + (zipmap (keys m) + (map find-var (vals m)))))) (def new-table-ize (fn [t m] diff --git a/src/babashka/main.clj b/src/babashka/main.clj index a0aa5553..8fc9aa5e 100644 --- a/src/babashka/main.clj +++ b/src/babashka/main.clj @@ -63,43 +63,6 @@ (def pipe-signal-received? (constantly false)) (def handle-sigint! (constantly nil)))) -(when features/xml? - (require '[babashka.impl.xml])) - -(when features/yaml? - (require '[babashka.impl.yaml] - '[babashka.impl.ordered])) - -(when features/jdbc? - (require '[babashka.impl.jdbc])) - -(when features/core-async? - (require '[babashka.impl.async])) - -(when features/csv? - (require '[babashka.impl.csv])) - -(when features/transit? - (require '[babashka.impl.transit])) - -(when features/datascript? - (require '[babashka.impl.datascript])) - -(when features/httpkit-client? - (require '[babashka.impl.httpkit-client])) - -(when features/httpkit-server? - (require '[babashka.impl.httpkit-server])) - -(when features/lanterna? - (require '[babashka.impl.lanterna])) - -(when features/core-match? - (require '[babashka.impl.match])) - -(when features/hiccup? - (require '[babashka.impl.hiccup])) - (sci/alter-var-root sci/in (constantly *in*)) (sci/alter-var-root sci/out (constantly *out*)) (sci/alter-var-root sci/err (constantly *err*)) @@ -307,7 +270,9 @@ Use -- to separate script command line args from bb command line args. :feature/httpkit-client %s :feature/lanterna %s :feature/core-match %s - :feature/hiccup %s}") + :feature/hiccup %s + :feature/test-check %s + :feature/spec-alpha %s}") version features/core-async? features/csv? @@ -322,7 +287,9 @@ Use -- to separate script command line args from bb command line args. features/httpkit-client? features/lanterna? features/core-match? - features/hiccup?))) + features/hiccup? + features/test-check? + features/spec-alpha?))) (defn read-file [file] (let [f (io/file file)] @@ -413,8 +380,8 @@ Use -- to separate script command line args from bb command line args. 'clojure.java.browse browse-namespace 'clojure.datafy datafy-namespace 'clojure.core.protocols protocols-namespace - 'clojure.core.server clojure-core-server 'babashka.process process-namespace + 'clojure.core.server clojure-core-server 'babashka.deps deps-namespace} features/xml? (assoc 'clojure.data.xml @(resolve 'babashka.impl.xml/xml-namespace)) features/yaml? (assoc 'clj-yaml.core @(resolve 'babashka.impl.yaml/yaml-namespace) @@ -436,7 +403,22 @@ Use -- to separate script command line args from bb command line args. features/hiccup? (-> (assoc 'hiccup.core @(resolve 'babashka.impl.hiccup/hiccup-namespace)) (assoc 'hiccup2.core @(resolve 'babashka.impl.hiccup/hiccup2-namespace)) (assoc 'hiccup.util @(resolve 'babashka.impl.hiccup/hiccup-util-namespace)) - (assoc 'hiccup.compiler @(resolve 'babashka.impl.hiccup/hiccup-compiler-namespace))))) + (assoc 'hiccup.compiler @(resolve 'babashka.impl.hiccup/hiccup-compiler-namespace))) + ;; ensure load before babashka.impl.clojure.spec.alpha for random patch! + features/test-check? (assoc 'clojure.test.check.random + @(resolve 'babashka.impl.clojure.test.check/random-namespace) + 'clojure.test.check.generators + @(resolve 'babashka.impl.clojure.test.check/generators-namespace) + 'clojure.test.check.rose-tree + @(resolve 'babashka.impl.clojure.test.check/rose-tree-namespace) + 'clojure.test.check.properties + @(resolve 'babashka.impl.clojure.test.check/properties-namespace) + 'clojure.test.check + @(resolve 'babashka.impl.clojure.test.check/test-check-namespace)) + features/spec-alpha? (-> (assoc ;; spec + 'clojure.spec.alpha @(resolve 'babashka.impl.spec/spec-namespace) + 'clojure.spec.gen.alpha @(resolve 'babashka.impl.spec/gen-namespace) + 'clojure.spec.test.alpha @(resolve 'babashka.impl.spec/test-namespace))))) (def imports '{ArithmeticException java.lang.ArithmeticException diff --git a/test-resources/lib_tests/babashka/run_all_libtests.clj b/test-resources/lib_tests/babashka/run_all_libtests.clj index 905351a2..c331d749 100644 --- a/test-resources/lib_tests/babashka/run_all_libtests.clj +++ b/test-resources/lib_tests/babashka/run_all_libtests.clj @@ -174,6 +174,8 @@ (test-namespaces 'hiccup.core-test) (test-namespaces 'hiccup2.core-test) +(test-namespaces 'test-check.smoke-test) + ;;;; final exit code (let [{:keys [:test :fail :error] :as m} @status] diff --git a/test-resources/lib_tests/test_check/smoke_test.clj b/test-resources/lib_tests/test_check/smoke_test.clj new file mode 100644 index 00000000..92e8af8b --- /dev/null +++ b/test-resources/lib_tests/test_check/smoke_test.clj @@ -0,0 +1,19 @@ +(ns test-check.smoke-test) + +(require '[clojure.test :as t] + '[clojure.test.check :as tc] + '[clojure.test.check.generators :as gen] + '[clojure.test.check.properties :as prop]) + +(def property + (prop/for-all [v (gen/vector gen/small-integer)] + (let [s (sort v)] + (and (= (count v) (count s)) + (or (empty? s) + (apply <= s)))))) + +;; test our property +(t/deftest smoke-test + (t/is (= {:result true, :pass? true, :num-tests 100} + (select-keys (tc/quick-check 100 property) + [:result :pass? :num-tests]))))