expound
This commit is contained in:
Michiel Borkent
parent
988a21b73b
commit
847c802cad
3 changed files with 135 additions and 125 deletions
|
|
@ -2,11 +2,10 @@
|
|||
{:no-doc true}
|
||||
(:require [babashka.impl.clojure.spec.alpha :as s :refer [sns]]
|
||||
[babashka.impl.clojure.spec.gen.alpha :as gen]
|
||||
[babashka.impl.clojure.spec.test.alpha :as test]
|
||||
[babashka.impl.clojure.spec.test.alpha :as test :refer [tns]]
|
||||
[clojure.core :as c]
|
||||
[sci.core :as sci :refer [copy-var]]))
|
||||
|
||||
(def tns (sci/create-ns 'clojure.spec.test.alpha nil))
|
||||
(def gns (sci/create-ns 'clojure.spec.gen.alpha nil))
|
||||
|
||||
(defn- ns-qualify
|
||||
|
|
@ -92,13 +91,20 @@
|
|||
'assert* (copy-var s/assert* sns)
|
||||
'explain-printer (copy-var s/explain-printer sns)
|
||||
;; PRIVATE, but exposed for expound
|
||||
'maybe-spec (copy-var s/maybe-spec sns)})
|
||||
'maybe-spec (copy-var s/maybe-spec sns)
|
||||
'spec-name (copy-var s/spec-name sns)
|
||||
'explain-data* (copy-var s/explain-data* sns)
|
||||
'->sym (copy-var s/->sym sns)
|
||||
'explain-str (copy-var s/explain-str sns)})
|
||||
|
||||
#_:clj-kondo/ignore
|
||||
(def test-namespace
|
||||
{'instrument (copy-var test/instrument tns)
|
||||
'unstrument (copy-var test/unstrument tns)
|
||||
'with-instrument-disabled (copy-var test/with-instrument-disabled tns)})
|
||||
'*instrument-enabled* test/instrument-enabled-var
|
||||
'with-instrument-disabled (copy-var test/with-instrument-disabled tns)
|
||||
'stacktrace-relevant-to-instrument (copy-var test/stacktrace-relevant-to-instrument tns)
|
||||
'spec-checking-fn (copy-var test/spec-checking-fn tns)})
|
||||
|
||||
#_:clj-kondo/ignore
|
||||
(def gen-namespace
|
||||
|
|
|
|||
|
|
@ -95,7 +95,7 @@
|
|||
(instance? clojure.lang.IObj spec)
|
||||
(with-meta spec (assoc (meta spec) :clojure.spec.alpha/name name))))
|
||||
|
||||
(defn- spec-name [spec]
|
||||
(defn spec-name [spec]
|
||||
(cond
|
||||
(ident? spec) spec
|
||||
|
||||
|
|
@ -234,27 +234,28 @@
|
|||
(defn explain-printer
|
||||
"Default printer for explain-data. nil indicates a successful validation."
|
||||
[ed]
|
||||
(if ed
|
||||
(let [problems (->> (:clojure.spec.alpha/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!")))
|
||||
(binding [*out* sci/out]
|
||||
(if ed
|
||||
(let [problems (->> (:clojure.spec.alpha/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 sns (sci/create-ns 'clojure.spec.alpha nil))
|
||||
|
||||
|
|
@ -274,7 +275,7 @@
|
|||
(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)))
|
||||
(sci/with-out-str (explain spec x)))
|
||||
|
||||
(declare valid?)
|
||||
|
||||
|
|
@ -304,7 +305,7 @@
|
|||
([spec] (gen spec nil))
|
||||
([spec overrides] (gensub spec overrides [] {:clojure.spec.alpha/recursion-limit *recursion-limit*} spec)))
|
||||
|
||||
(defn- ->sym
|
||||
(defn ->sym
|
||||
"Returns a symbol from a symbol or var"
|
||||
[x]
|
||||
(if (var? x)
|
||||
|
|
|
|||
|
|
@ -12,7 +12,8 @@
|
|||
[babashka.impl.clojure.spec.alpha :as s]
|
||||
[babashka.impl.clojure.spec.gen.alpha :as gen]
|
||||
[babashka.impl.pprint :as pp]
|
||||
[clojure.string :as str]))
|
||||
[clojure.string :as str]
|
||||
[sci.core :as sci]))
|
||||
|
||||
(in-ns 'clojure.spec.test.check)
|
||||
(in-ns 'babashka.impl.clojure.spec.test.alpha)
|
||||
|
|
@ -27,13 +28,13 @@
|
|||
(@#'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")))))))
|
||||
[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]
|
||||
|
|
@ -43,7 +44,7 @@
|
|||
|
||||
(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."
|
||||
returns the set of all symbols naming vars in those nses."
|
||||
[ns-sym-or-syms]
|
||||
(into
|
||||
#{}
|
||||
|
|
@ -56,25 +57,29 @@ returns the set of all symbols naming vars in those nses."
|
|||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; instrument ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(def ^:private ^:dynamic *instrument-enabled*
|
||||
"if false, instrumented fns call straight through"
|
||||
true)
|
||||
(def tns (sci/create-ns 'clojure.spec.test.alpha))
|
||||
|
||||
(def instrument-enabled-var (sci/new-dynamic-var '*instrument-enabled* true {:ns tns} ))
|
||||
|
||||
#_(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)))
|
||||
"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]
|
||||
`(binding [clojure.spec.test.alpha/*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
|
||||
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
|
||||
|
|
@ -83,7 +88,7 @@ guessing the original Clojure names. Returns a map with
|
|||
: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."
|
||||
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 %)
|
||||
|
|
@ -100,11 +105,11 @@ For non-Clojure fns, :scope and :local-fn will be absent."
|
|||
(when local
|
||||
{:local-fn (symbol (degensym local))}))))
|
||||
|
||||
(defn- stacktrace-relevant-to-instrument
|
||||
(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."
|
||||
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))]
|
||||
|
|
@ -114,7 +119,7 @@ failure in instrument."
|
|||
(drop-while plumbing?))
|
||||
elems)))
|
||||
|
||||
(defn- spec-checking-fn
|
||||
(defn spec-checking-fn
|
||||
[v f fn-spec]
|
||||
(let [fn-spec (@#'s/maybe-spec fn-spec)
|
||||
conform! (fn [v role spec data args]
|
||||
|
|
@ -124,9 +129,9 @@ failure in instrument."
|
|||
stacktrace-relevant-to-instrument
|
||||
first)
|
||||
ed (merge (assoc (s/explain-data* spec [] [] [] data)
|
||||
::s/fn (->sym v)
|
||||
::s/args args
|
||||
::s/failure :instrument)
|
||||
::s/fn (->sym v)
|
||||
::s/args args
|
||||
::s/failure :instrument)
|
||||
(when caller
|
||||
{::caller (dissoc caller :class :method)}))]
|
||||
(throw (ex-info
|
||||
|
|
@ -134,13 +139,13 @@ failure in instrument."
|
|||
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)))))
|
||||
[& args]
|
||||
(if @instrument-enabled-var
|
||||
(sci/binding [@instrument-enabled-var false]
|
||||
(when (:args fn-spec) (conform! v :args (:args fn-spec) args args))
|
||||
(sci/binding [@instrument-enabled-var true]
|
||||
(.applyTo ^clojure.lang.IFn f args)))
|
||||
(.applyTo ^clojure.lang.IFn f args)))))
|
||||
|
||||
(defn- no-fspec
|
||||
[v spec]
|
||||
|
|
@ -191,9 +196,9 @@ failure in instrument."
|
|||
(->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))]))
|
||||
"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]
|
||||
|
|
@ -206,11 +211,11 @@ failure in instrument."
|
|||
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))])))
|
||||
(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
|
||||
|
|
@ -252,14 +257,14 @@ 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)))))
|
||||
(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
|
||||
|
|
@ -267,13 +272,13 @@ 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)))))
|
||||
(locking instrumented-vars
|
||||
(into
|
||||
[]
|
||||
(comp (filter symbol?)
|
||||
(map unstrument-1)
|
||||
(remove nil?))
|
||||
(collectionize sym-or-syms)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; testing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
@ -283,9 +288,9 @@ Returns a collection of syms naming the vars unstrumented."
|
|||
"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))))
|
||||
::args args
|
||||
::val v
|
||||
::s/failure :check-failed))))
|
||||
|
||||
(defn- check-call
|
||||
"Returns true if call passes specs, otherwise *returns* an exception
|
||||
|
|
@ -331,20 +336,20 @@ with explain-data + ::s/failure."
|
|||
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))))))
|
||||
(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]
|
||||
|
|
@ -363,17 +368,17 @@ with explain-data + ::s/failure."
|
|||
'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)))
|
||||
(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))])))
|
||||
(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
|
||||
|
|
@ -381,7 +386,7 @@ 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:
|
||||
aliases clojure.spec.test.check:
|
||||
|
||||
::stc/opts opts to flow through test.check/quick-check
|
||||
:gen map from spec names to generator overrides
|
||||
|
|
@ -411,10 +416,10 @@ spec itself will have an ::s/failure value in ex-data:
|
|||
([] (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)))))
|
||||
(->> (collectionize sym-or-syms)
|
||||
(filter (checkable-syms opts))
|
||||
(pmap
|
||||
#(check-1 (sym->check-map %) opts)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; check reporting ;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
@ -437,9 +442,9 @@ spec itself will have an ::s/failure value in ex-data:
|
|||
[ret]
|
||||
(let [failure (:failure ret)]
|
||||
(cond
|
||||
(nil? failure) :check-passed
|
||||
(failure-type failure) (failure-type failure)
|
||||
:default :check-threw)))
|
||||
(nil? failure) :check-passed
|
||||
(failure-type failure) (failure-type failure)
|
||||
:default :check-threw)))
|
||||
|
||||
(defn abbrev-result
|
||||
"Given a check result, returns an abbreviated version
|
||||
|
|
@ -459,13 +464,11 @@ 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)))
|
||||
|
||||
|
||||
(reduce
|
||||
(fn [summary result]
|
||||
(pp/pprint (summary-result result))
|
||||
(-> summary
|
||||
(update :total inc)
|
||||
(update (result-type result) (fnil inc 0))))
|
||||
{:total 0}
|
||||
check-results)))
|
||||
|
|
|
|||
Loading…
Reference in a new issue