[#487] Include clojure.test.check as preparation for clojure.spec
This commit is contained in:
Michiel Borkent
GitHub
parent
c4bb42df3e
commit
931fadabb2
15 changed files with 3048 additions and 45 deletions
3
deps.edn
3
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"}
|
||||
|
|
|
|||
61
feature-spec-alpha/babashka/impl/spec.clj
Normal file
61
feature-spec-alpha/babashka/impl/spec.clj
Normal file
|
|
@ -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
|
||||
177
feature-test-check/babashka/impl/clojure/test/check.clj
Normal file
177
feature-test-check/babashka/impl/clojure/test/check.clj
Normal file
|
|
@ -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)})
|
||||
|
|
@ -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"]]}]
|
||||
|
|
|
|||
|
|
@ -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[@]}"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
2001
src/babashka/impl/clojure/spec/alpha.clj
Normal file
2001
src/babashka/impl/clojure/spec/alpha.clj
Normal file
File diff suppressed because it is too large
Load diff
208
src/babashka/impl/clojure/spec/gen/alpha.clj
Executable file
208
src/babashka/impl/clojure/spec/gen/alpha.clj
Executable file
|
|
@ -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)
|
||||
|
||||
)
|
||||
|
||||
|
||||
471
src/babashka/impl/clojure/spec/test/alpha.clj
Normal file
471
src/babashka/impl/clojure/spec/test/alpha.clj
Normal file
|
|
@ -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)))
|
||||
|
||||
|
||||
|
|
@ -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]))
|
||||
|
|
|
|||
|
|
@ -4,10 +4,11 @@
|
|||
[sci.core :as sci]
|
||||
[sci.impl.vars :as vars]))
|
||||
|
||||
(alter-var-root #'pprint/write-option-table
|
||||
(defonce patch-option-table
|
||||
(alter-var-root #'pprint/write-option-table
|
||||
(fn [m]
|
||||
(zipmap (keys m)
|
||||
(map find-var (vals m)))))
|
||||
(map find-var (vals m))))))
|
||||
|
||||
(def new-table-ize
|
||||
(fn [t m]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
19
test-resources/lib_tests/test_check/smoke_test.clj
Normal file
19
test-resources/lib_tests/test_check/smoke_test.clj
Normal file
|
|
@ -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]))))
|
||||
Loading…
Reference in a new issue