;; clojure.spec.alpha — M1: skeleton + predicate specs + and/or;
;; M2: explain machinery + keys/merge;
;; M3: derivative-based regex engine (cat/alt/*/+/?/&);
;; M4: collection specs (every/coll-of/map-of/every-kv),
;; tuple/nilable/multi-spec/conformer, leaf helpers
;; (int-in/double-in/nonconforming);
;; M5: fspec/fdef (fn-specs registered into the same
;; registry as s/def, keyed by qualified symbol),
;; s/assert + check-asserts, with-gen/gen/exercise/
;; exercise-fn (throwing stubs — see
;; clojure.spec.gen.alpha). instrument/unstrument
;; live in the sibling clojure.spec.test.alpha ns.
;;
;; This is a from-scratch, spec-compatible-in-spirit implementation for the
;; clojurust runtime. It does NOT use `reify` for spec objects (every `reify`
;; call here would permanently leak a fresh protocol-impl tag into the global
;; `Protocol.impls` map — see `crates/cljrs-interp/src/special.rs`), so
;; compound specs are `defrecord` instances extended with the `Spec` protocol
;; instead. Bare predicates, sets, keywords, and symbols are made directly
;; usable as specs (zero wrapping) by extending `Spec` onto their type tags;
;; regex ops are upstream-style ::op-tagged plain maps given Spec behavior
;; via the Map type tag.
;;
;; This is the final milestone for this file; clojure.spec.test.alpha and
;; clojure.spec.gen.alpha (both new files) round out the M5 deliverable.
(ns clojure.spec.alpha)
;; ── Spec protocol ─────────────────────────────────────────────────────────────
;;
;; Every spec — bare predicate, set, registry-keyword ref, var-symbol ref, or
;; one of our defrecord-based compound specs — implements these four methods.
(defprotocol Spec
(conform* [spec x])
(unform* [spec x])
(explain* [spec path via in x])
(describe* [spec]))
;; ── Runtime workaround: polymorphic re-dispatch inside a method body ──────────
;;
;; DISCOVERED RUNTIME BUG (affects any protocol, not spec-specific): every
;; extend-type method impl fn is named after its method (`build_impl_fn` in
;; `crates/cljrs-interp/src/special.rs` sets the fn's `name` from the method
;; symbol), and `call_cljrs_fn` (`crates/cljrs-interp/src/apply.rs:526-534`)
;; unconditionally self-binds that name inside the fn body on every call (the
;; mechanism that makes named `fn`/`letfn` self-recursion work). That
;; self-binding shadows the *global* protocol fn var for the duration of the
;; method body — so a method impl that calls its own method name again,
;; intending ordinary polymorphic dispatch on a *different* value (e.g.
;; `extend-type Keyword`'s `conform*` calling `(conform* resolved-spec x)`),
;; instead re-enters the same impl. The observable symptom depends on body
;; shape and tail position — anywhere from an infinite loop to side effects
;; running twice to accidentally-correct results — confirmed with minimal
;; defprotocol/extend-type repros outside this file. Calling a
;; *different*-named protocol method recursively (e.g. `explain*` calling
;; `conform*`) is unaffected — only same-name recursion is shadowed.
;;
;; Workaround (no Rust changes needed): capture each protocol fn under a
;; private alias *before* any extend-type runs. The alias var's name never
;; collides with any method impl fn's own self-bound name, so looking it up
;; from inside a method body always finds the real polymorphic ProtocolFn
;; value instead of the self-binding. Every same-name recursive call in the
;; extend-type bodies below uses these aliases instead of calling
;; conform*/unform*/explain*/describe* directly.
(def ^:private conform*-dispatch conform*)
(def ^:private unform*-dispatch unform*)
(def ^:private explain*-dispatch explain*)
(def ^:private describe*-dispatch describe*)
;; ── Registry ──────────────────────────────────────────────────────────────────
;;
;; Children are stored UNRESOLVED (a bare keyword/symbol/set/fn, or a compound
;; spec record) and re-resolved lazily every time they're conformed against —
;; this is what makes forward references and re-`s/def`-ing a spec work with
;; no `delay`/promise machinery: `extend-type Keyword Spec` below just looks
;; the keyword back up in the registry on every `conform*` call.
(def ^:private registry-ref (atom {}))
(defn registry
"Returns a snapshot (a plain map) of the full spec registry: qualified
keyword/symbol name -> registered spec value."
[]
@registry-ref)
(defn get-spec
"Returns the spec registered for keyword/symbol k, or nil if unregistered."
[k]
(get @registry-ref k))
;; ── invalid ───────────────────────────────────────────────────────────────────
(def invalid ::invalid)
(defn invalid?
"True if x is the ::invalid sentinel returned by a failed conform."
[x]
(= x ::invalid))
;; ── explain problem helpers ───────────────────────────────────────────────────
;;
;; `explain*` on every spec kind returns a vector of these problem maps, or
;; nil when the value is valid. `explain-data`/`explain`/`explain-str` (below,
;; in the public API section) assemble them into the upstream-shaped
;; explain-data map and printable output.
(defn- problem
"Builds a single explain-data problem map."
[path pred val via in]
{:path path :pred pred :val val :via via :in in})
(defn- explain-1
"Upstream-shaped single-child explain: if pred is a keyword (registry ref)
or one of our record-based spec objects, delegate to its explain* — the
Keyword impl pushes itself onto via; a named record spec pushes its
registered name. Bare predicates/sets report a single problem carrying the
literal form. (References spec?/spec-name defined later in this file — fine,
since vars resolve at call time; and uses the *-dispatch aliases so this
helper is safe to call from inside any protocol method body.)"
[form pred path via in v]
(cond
(keyword? pred)
(explain*-dispatch pred path via in v)
(or (spec? pred) (regex? pred))
(explain*-dispatch pred path
(if-let [n (spec-name pred)] (conj via n) via)
in v)
:else
[(problem path form v via in)]))
;; ── Bare values as specs ────────────────────────────────────────────────────────
;;
;; `Fn` covers Fn/NativeFunction/ProtocolFn/MultiFn — all callables share the
;; "Fn" dispatch tag (crates/cljrs-env/src/apply.rs). A predicate call is
;; wrapped in try/catch so a predicate that throws on an unexpected shape of
;; `x` (e.g. `even?` on a non-number) fails conform instead of blowing up the
;; caller.
(extend-type Fn Spec
(conform* [spec x]
(try
(if (spec x) x ::invalid)
(catch Exception _e ::invalid)))
(unform* [spec x] x)
(explain* [spec path via in x]
(when (invalid? (conform* spec x))
[(problem path spec x via in)]))
(describe* [spec] spec))
;; A set used as a spec conforms/validates via set membership (enum spec).
(extend-type Set Spec
(conform* [spec x]
(if (contains? spec x) x ::invalid))
(unform* [spec x] x)
(explain* [spec path via in x]
(when (invalid? (conform* spec x))
[(problem path spec x via in)]))
(describe* [spec] spec))
;; A keyword used as a spec is a live reference into the registry, re-resolved
;; on every call — this is what makes forward references and re-registration
;; (re-`s/def`-ing a spec) work correctly with no extra bookkeeping.
(extend-type Keyword Spec
(conform* [spec x]
(if-let [s (get-spec spec)]
(conform*-dispatch s x)
(throw (ex-info (str "Unable to resolve spec: " spec) {:spec spec}))))
(unform* [spec x]
(if-let [s (get-spec spec)]
(unform*-dispatch s x)
(throw (ex-info (str "Unable to resolve spec: " spec) {:spec spec}))))
(explain* [spec path via in x]
(if-let [s (get-spec spec)]
(explain*-dispatch s path (conj via spec) in x)
[(problem path spec x via in)]))
(describe* [spec]
(if-let [s (get-spec spec)]
(if (keyword? s) s (describe*-dispatch s))
spec)))
;; A symbol used as a spec resolves to a var and delegates to its value —
;; e.g. `(s/def ::x 'my.ns/my-pred)`.
(extend-type Symbol Spec
(conform* [spec x] (conform*-dispatch @(resolve spec) x))
(unform* [spec x] (unform*-dispatch @(resolve spec) x))
(explain* [spec path via in x]
(explain*-dispatch @(resolve spec) path (conj via spec) in x))
(describe* [spec] spec))
;; ── PredicateSpec ─────────────────────────────────────────────────────────────
;;
;; Wraps a predicate/spec together with its literal form, so `describe`/`form`
;; can show `even?` instead of an opaque function value. `:pred` is usually a
;; raw predicate fn, but `(s/spec (s/or ...))`-style wrapping of an
;; already-compound spec is also supported: conform*/unform* delegate to the
;; wrapped spec's own protocol methods whenever `:pred` isn't itself callable.
(defrecord PredicateSpec [form pred name])
(extend-type PredicateSpec Spec
(conform* [spec x]
(let [pred (:pred spec)]
(if (fn? pred)
(try
(if (pred x) x ::invalid)
(catch Exception _e ::invalid))
(conform*-dispatch pred x))))
(unform* [spec x]
(let [pred (:pred spec)]
(if (fn? pred) x (unform*-dispatch pred x))))
(explain* [spec path via in x]
(when (invalid? (conform* spec x))
[(problem path (:form spec) x via in)]))
(describe* [spec] (:form spec)))
;; ── AndSpec ───────────────────────────────────────────────────────────────────
;;
;; conform* threads each pred's conformed result into the next, short-
;; circuiting to ::invalid on the first failure. unform* mirrors upstream
;; clojure.spec.alpha's simplification: only the *last* pred's unform matters
;; (all earlier preds are assumed to be plain, non-transforming predicates).
(defrecord AndSpec [form forms preds name])
(extend-type AndSpec Spec
(conform* [spec x]
(loop [ret x preds (:preds spec)]
(if (empty? preds)
ret
(let [conformed (conform*-dispatch (first preds) ret)]
(if (invalid? conformed)
::invalid
(recur conformed (rest preds)))))))
(unform* [spec x]
(if (empty? (:preds spec))
x
(unform*-dispatch (last (:preds spec)) x)))
(explain* [spec path via in x]
(loop [ret x preds (:preds spec) forms (:forms spec)]
(if (empty? preds)
nil
(let [conformed (conform* (first preds) ret)]
(if (invalid? conformed)
(explain-1 (first forms) (first preds) path via in ret)
(recur conformed (rest preds) (rest forms)))))))
(describe* [spec] (:form spec)))
(defn and-spec-impl
"Impl fn for s/and. `forms` are the literal per-branch spec forms (a
vector); `preds` are their evaluated spec values in the same order — each
may be a bare predicate/set/keyword/symbol or another compound spec, since
all of those already implement Spec directly (no `specize` wrapping step
needed)."
[forms preds]
(->AndSpec (cons 'and forms) (vec forms) (vec preds) nil))
;; ── OrSpec ────────────────────────────────────────────────────────────────────
;;
;; conform* returns `[tag conformed]` for the first matching branch, else
;; ::invalid.
(defrecord OrSpec [form keys forms preds name])
(defn- or-pred-for
"Looks up the pred registered under tag k in an OrSpec."
[spec k]
(some (fn [[kk pred]] (when (= kk k) pred))
(map vector (:keys spec) (:preds spec))))
(extend-type OrSpec Spec
(conform* [spec x]
(loop [ks (:keys spec) preds (:preds spec)]
(cond
(empty? preds) ::invalid
:else
(let [conformed (conform*-dispatch (first preds) x)]
(if (invalid? conformed)
(recur (rest ks) (rest preds))
[(first ks) conformed])))))
(unform* [spec x]
(let [[k v] x]
(unform*-dispatch (or-pred-for spec k) v)))
(explain* [spec path via in x]
(when (invalid? (conform* spec x))
(let [probs (apply concat
(map (fn [k form pred]
(explain-1 form pred (conj path k) via in x))
(:keys spec) (:forms spec) (:preds spec)))]
(when (seq probs)
(vec probs)))))
(describe* [spec] (:form spec)))
(defn or-spec-impl
"Impl fn for s/or. `keys` are the branch tag keywords, `forms` their literal
spec forms, `preds` their evaluated spec values — all parallel vectors."
[keys forms preds]
(->OrSpec (cons 'or (interleave keys forms)) (vec keys) (vec forms) (vec preds) nil))
;; ── KeysSpec ──────────────────────────────────────────────────────────────────
;;
;; `s/keys` with :req/:opt/:req-un/:opt-un. :req and :req-un accept nested
;; `(and ...)`/`(or ...)` connective forms per upstream (presence logic only —
;; value validation is per-key regardless). Upstream semantics for values:
;; EVERY map entry whose (qualified) key has a registered spec is
;; validated/conformed — even keys never mentioned in the keys spec. For
;; un-variants the map key is `(keyword (name k))` and the validating spec is
;; the qualified k; `un-map` below carries that unqualified→qualified mapping.
;;
;; Records (TypeInstance) are supported as maps: `seq` yields their fields as
;; map entries, `assoc` preserves their type tag, and presence checks go
;; through `get` with a sentinel because `contains?` has no record support in
;; this runtime.
(def ^:private sentinel ::not-found)
(defn- has-key?
"Presence check that works on maps AND records — `contains?` has no
TypeInstance arm in this runtime, `get` does."
[m k]
(not= (get m k sentinel) sentinel))
(defn- map-like?
[x]
(or (map? x) (record? x)))
(defn- key-present?
"Evaluates a :req/:req-un element — a qualified keyword or a nested
(and ...)/(or ...) connective form — as a presence check against map m.
un? true means check the unqualified (name-only) form of each keyword."
[m form un?]
(cond
(keyword? form)
(has-key? m (if un? (keyword (name form)) form))
(seq? form)
(let [op (name (first form))]
(cond
(= op "and") (every? (fn [f] (key-present? m f un?)) (rest form))
(= op "or") (boolean (some (fn [f] (key-present? m f un?)) (rest form)))
:else (throw (ex-info (str "s/keys: unsupported connective " (pr-str form))
{:form form}))))
:else
(throw (ex-info (str "s/keys: unsupported :req element " (pr-str form))
{:form form}))))
(defn- req-pred-form
"Builds the reportable pred form for a missing-req problem, upstream-style:
a keyword k becomes (contains? % k); connectives wrap recursively, e.g.
(or (contains? % ::a) (contains? % ::b))."
[form un?]
(if (keyword? form)
(list 'contains? '% (if un? (keyword (name form)) form))
(cons (first form) (map (fn [f] (req-pred-form f un?)) (rest form)))))
(defn- req-spec-keys
"All qualified keywords mentioned in a :req/:req-un element (a bare keyword
or a nested connective form)."
[form]
(if (keyword? form)
[form]
(mapcat req-spec-keys (rest form))))
(defrecord KeysSpec [form req opt req-un opt-un un-map name])
(extend-type KeysSpec Spec
(conform* [spec x]
(if (not (map-like? x))
::invalid
(if (not (and (every? (fn [f] (key-present? x f false)) (:req spec))
(every? (fn [f] (key-present? x f true)) (:req-un spec))))
::invalid
(loop [ret x entries (seq x)]
(if entries
(let [e (first entries)
k (key e)
v (val e)
sname (get (:un-map spec) k k)]
(if (get-spec sname)
(let [cv (conform*-dispatch sname v)]
(if (invalid? cv)
::invalid
(recur (assoc ret k cv) (next entries))))
(recur ret (next entries))))
ret)))))
(unform* [spec x]
(if (not (map-like? x))
x
(loop [ret x entries (seq x)]
(if entries
(let [e (first entries)
k (key e)
v (val e)
sname (get (:un-map spec) k k)]
(if (get-spec sname)
(recur (assoc ret k (unform*-dispatch sname v)) (next entries))
(recur ret (next entries))))
ret))))
(explain* [spec path via in x]
(if (not (map-like? x))
[(problem path 'map? x via in)]
(let [req-probs (keep (fn [f]
(when (not (key-present? x f false))
(problem path (req-pred-form f false) x via in)))
(:req spec))
req-un-probs (keep (fn [f]
(when (not (key-present? x f true))
(problem path (req-pred-form f true) x via in)))
(:req-un spec))
val-probs (mapcat (fn [e]
(let [k (key e)
v (val e)
sname (get (:un-map spec) k k)]
(when (get-spec sname)
(when (invalid? (conform*-dispatch sname v))
(explain*-dispatch sname (conj path k) via
(conj in k) v)))))
(seq x))
probs (concat req-probs req-un-probs val-probs)]
(when (seq probs)
(vec probs)))))
(describe* [spec] (:form spec)))
(defn keys-impl
"Impl fn for s/keys. req/opt/req-un/opt-un are the literal (unevaluated)
option vectors — req and req-un may contain (and ...)/(or ...) connective
forms; opt and opt-un are plain qualified keywords. form is the literal
(keys ...) form for describe."
[req opt req-un opt-un form]
(let [req (vec (or req []))
opt (vec (or opt []))
req-un (vec (or req-un []))
opt-un (vec (or opt-un []))
all-ks (concat (mapcat req-spec-keys req) opt
(mapcat req-spec-keys req-un) opt-un)]
(when (not (every? (fn [k] (and (keyword? k) (namespace k))) all-ks))
(throw (ex-info "s/keys: all key specs must be namespace-qualified keywords"
{:input all-ks})))
(let [un-map (into {}
(map (fn [k] [(keyword (name k)) k])
(concat (mapcat req-spec-keys req-un) opt-un)))]
(->KeysSpec form req opt req-un opt-un un-map nil))))
;; ── MergeSpec ─────────────────────────────────────────────────────────────────
;;
;; `s/merge` — each child (usually a keys spec or a keyword ref to one) is
;; conformed against the whole value; valid iff all children are valid;
;; conform returns the clojure.core/merge of the children's conformed maps
;; (upstream semantics). NOTE: internal uses of core merge below must stay
;; qualified — this ns shadows `merge` with the s/merge macro.
(defrecord MergeSpec [form forms preds name])
(extend-type MergeSpec Spec
(conform* [spec x]
(loop [ms [] preds (:preds spec)]
(if (empty? preds)
(apply clojure.core/merge ms)
(let [cv (conform*-dispatch (first preds) x)]
(if (invalid? cv)
::invalid
(recur (conj ms cv) (rest preds)))))))
(unform* [spec x]
(apply clojure.core/merge
(map (fn [pred] (unform*-dispatch pred x))
(reverse (:preds spec)))))
(explain* [spec path via in x]
(let [probs (apply concat
(map (fn [form pred]
(when (invalid? (conform*-dispatch pred x))
(explain-1 form pred path via in x)))
(:forms spec) (:preds spec)))]
(when (seq probs)
(vec probs))))
(describe* [spec] (:form spec)))
(defn merge-spec-impl
"Impl fn for s/merge. `forms` are the literal child spec forms, `preds`
their evaluated spec values — parallel vectors."
[forms preds]
(->MergeSpec (cons 'merge forms) (vec forms) (vec preds) nil))
;; ── Regex engine (s/cat, s/alt, s/*, s/+, s/?, s/&) ──────────────────────────
;;
;; Port of upstream clojure.spec.alpha's derivative-based regex engine. Regex
;; ops are plain data — maps tagged with the namespaced ::op key (so user
;; maps can't collide) — NOT record-wrapped specs. This preserves upstream's
;; composition semantics: nesting a regex op inside another describes a
;; SINGLE flat sequence (in `(s/cat :a (s/* int?) :b string?)` the s/*
;; splices into the cat), and a keyword ref that resolves to a registered
;; regex ALSO splices (upstream reg-resolve! semantics: after
;; `(s/def ::r (s/* int?))`, `(s/cat :a ::r :b string?)` conforms [1 2 "x"]
;; to {:a [1 2] :b "x"}). To match a nested sub-sequence as one element
;; instead, wrap it with `(s/spec (s/* ...))` — the PredicateSpec boundary
;; consumes exactly one element. A keyword ref to a NON-regex spec likewise
;; consumes exactly one element via ordinary protocol dispatch.
;;
;; Ops: ::accept ::pcat ::alt ::rep ::amp. nil op = a plain pred (fn / set /
;; keyword / symbol / spec record) consuming one element.
;;
;; The engine fns are mutually recursive; vars resolve at call time in this
;; runtime, so plain defn- order works without `declare`.
(defn regex?
"Returns x if x is a regex op (a map produced by cat/alt/*/+/?/&), else
nil/false."
[x]
(and (map? x) (get x ::op) x))
(defn- op-of
"The ::op tag of a regex map; nil for anything else (plain preds)."
[p]
(when (map? p) (get p ::op)))
(defn- reg-resolve
"Resolves an ident through the registry alias chain to the underlying spec
or regex value; returns non-idents unchanged; nil if unregistered."
[k]
(if (ident? k)
(let [reg @registry-ref
s (get reg k)]
(when s
(loop [s s]
(if (ident? s)
(recur (get reg s))
s))))
k))
(defn- reg-resolve!
"Like reg-resolve but throws on an unresolvable ident."
[k]
(if (ident? k)
(or (reg-resolve k)
(throw (ex-info (str "Unable to resolve spec: " k) {:spec k})))
k))
(defn- accept [x] {::op ::accept :ret x})
(defn- accept? [p] (= ::accept (op-of p)))
(defn- pcat*
"Core cat constructor/normalizer over {:ps :ks :forms :ret :rep+}. Any nil
in :ps kills the whole branch (returns nil) — that is how failed
derivatives propagate."
[m]
(let [ps (:ps m) ks (:ks m) forms (:forms m) ret (:ret m) rep+form (:rep+ m)
p1 (first ps) pr (next ps)
k1 (first ks) kr (next ks)
fr (next forms)]
(when (every? identity ps)
(if (accept? p1)
(let [r1 (:ret p1)
ret (conj ret (if ks {k1 r1} r1))]
(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+form}))))
(defn cat-impl
"Impl fn for s/cat. ks/ps/forms are parallel: tag keywords, evaluated
preds, literal pred forms."
[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}]
(if (accept? p1)
(assoc r :p1 p2 :ret (conj ret (:ret p1)))
(assoc r :p1 p1 :ret ret)))))
(defn rep-impl
"Impl fn for s/*."
[form p]
(rep* p p [] false form))
(defn rep+impl
"Impl fn for s/+ — a pcat of one mandatory pred followed by a splicing
rep."
[form p]
(pcat* {:ps [p (rep* p p [] true form)]
:forms [form (list '* form)]
:ret []
:rep+ form}))
(defn amp-impl
"Impl fn for s/& — regex re further constrained by preds applied to the
conformed result."
[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 (or ks forms)
(let [pks (filter (fn [t] (f (first t)))
(map vector ps
(or (seq ks) (repeat nil))
(or (seq forms) (repeat nil))))]
[(seq (map first pks))
(when ks (seq (map second pks)))
(when forms (seq (map (fn [t] (nth t 2)) pks)))])
[(seq (filter f ps)) ks forms]))
(defn- alt* [ps ks forms]
(let [res (filter-alt ps ks forms identity)
ps (nth res 0) ks (nth res 1) forms (nth res 2)
p1 (first ps) pr (next ps) k1 (first ks)]
(when ps
(let [ret {::op ::alt :ps ps :ks ks :forms forms}]
(if (nil? pr)
(if k1
(if (accept? p1)
(accept [k1 (:ret p1)])
ret)
p1)
ret)))))
(defn- alt2 [p1 p2]
(if (and p1 p2)
(alt* [p1 p2] nil nil)
(or p1 p2)))
(defn alt-impl
"Impl fn for s/alt. ks/ps/forms parallel as in cat-impl."
[ks ps forms]
(alt* ps ks forms))
(defn maybe-impl
"Impl fn for s/?."
[p form]
(assoc (alt* [p (accept ::nil)] nil [form ::nil]) :maybe form))
(defn- and-preds
"Threads x through preds (conforming at each step), short-circuiting to
::invalid. forms are display-only (kept for upstream parity)."
[x preds forms]
(loop [ret x preds (seq preds) forms (seq forms)]
(cond
(invalid? ret) ::invalid
preds (let [nret (conform*-dispatch (first preds) ret)]
(if (invalid? nret)
::invalid
(recur nret (next preds) (next forms))))
:else ret)))
(defn- explain-pred-list
[forms preds path via in x]
(loop [ret x forms (seq forms) preds (seq preds)]
(when preds
(let [nret (conform*-dispatch (first preds) ret)]
(if (invalid? nret)
(explain-1 (first forms) (first preds) path via in ret)
(recur nret (next forms) (next preds)))))))
(defn- noret? [p1 pret]
(or (= pret ::nil)
(and (contains? #{::rep ::pcat}
(op-of (if (ident? p1) (reg-resolve! p1) p1)))
(empty? pret))))
(defn- accept-nil? [p]
(let [rp (if (ident? p) (reg-resolve! p) p)
op (op-of rp)]
(cond
(= op ::accept) true
(nil? op) nil
(= op ::amp) (and (accept-nil? (:p1 rp))
(let [ret (and-preds (preturn (:p1 rp)) (:ps rp) (:forms rp))]
(not (invalid? ret))))
(= op ::rep) (or (identical? (:p1 rp) (:p2 rp)) (accept-nil? (:p1 rp)))
(= op ::pcat) (every? accept-nil? (:ps rp))
(= op ::alt) (boolean (some accept-nil? (:ps rp))))))
(defn- preturn [p]
(let [rp (if (ident? p) (reg-resolve! p) p)
op (op-of rp)]
(cond
(= op ::accept) (:ret rp)
(nil? op) nil
(= op ::amp) (let [pret (preturn (:p1 rp))]
(if (noret? (:p1 rp) pret)
::nil
(and-preds pret (:ps rp) (:forms rp))))
(= op ::rep) (add-ret (:p1 rp) (:ret rp) nil)
(= op ::pcat) (add-ret (first (:ps rp)) (:ret rp) (first (:ks rp)))
(= op ::alt)
(let [res (filter-alt (:ps rp) (:ks rp) (:forms rp) accept-nil?)
p0 (first (nth res 0))
k0 (first (nth res 1))
r (if (nil? p0) ::nil (preturn p0))]
(if k0 [k0 r] r)))))
(defn- add-ret [p r k]
(let [rp (if (ident? p) (reg-resolve! p) p)
op (op-of rp)]
(cond
(nil? op) r
(contains? #{::alt ::accept ::amp} op)
(let [ret (preturn rp)]
(if (= ret ::nil) r (conj r (if k {k ret} ret))))
:else ;; ::rep / ::pcat
(let [ret (preturn rp)]
(if (empty? ret)
r
((if (:splice rp) into conj) r (if k {k ret} ret)))))))
(defn- deriv
"The derivative of regex p with respect to one input element x — the regex
matching the rest of the input — or nil if x can't begin a match."
[p x]
(let [rp (if (ident? p) (reg-resolve! p) p)]
(when rp
(let [op (op-of rp)]
(cond
(= op ::accept) nil
;; Plain pred: consumes exactly one element. Dispatches on the
;; ORIGINAL p (not rp) so keyword refs stay live and push
;; themselves onto via during explain.
(nil? op)
(let [ret (conform*-dispatch p x)]
(when (not (invalid? ret)) (accept ret)))
(= op ::amp)
(when-let [p1 (deriv (:p1 rp) x)]
(if (= ::accept (op-of p1))
(let [ret (and-preds (preturn p1) (:ps rp) (:forms rp))]
(when (not (invalid? ret))
(accept ret)))
(amp-impl p1 (:amp rp) (:ps rp) (:forms rp))))
(= op ::pcat)
(let [ps (:ps rp) ks (:ks rp) forms (:forms rp) ret (:ret rp)
p0 (first ps) pr (next ps) k0 (first ks) kr (next ks)]
(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))))
(= op ::alt)
(alt* (map (fn [q] (deriv q x)) (:ps rp)) (:ks rp) (:forms rp))
(= op ::rep)
(alt2 (rep* (deriv (:p1 rp) x) (:p2 rp) (:ret rp) (:splice rp) (:forms rp))
(when (accept-nil? (:p1 rp))
(deriv (rep* (:p2 rp) (:p2 rp) (add-ret (:p1 rp) (:ret rp) nil)
(:splice rp) (:forms rp))
x))))))))
(defn- op-describe [p]
(let [rp (if (ident? p) (reg-resolve! p) p)
op (op-of rp)]
(when rp
(cond
(= op ::accept) nil
(nil? op) (if (ident? p) p (describe*-dispatch p))
(= op ::amp) (cons '& (cons (:amp rp) (:forms rp)))
(= op ::pcat) (if (:rep+ rp)
(list '+ (:rep+ rp))
(if (:ks rp)
(cons 'cat (interleave (:ks rp) (:forms rp)))
(cons 'cat (:forms rp))))
(= op ::alt) (if (:maybe rp)
(list '? (:maybe rp))
(cons 'alt (interleave (:ks rp) (:forms rp))))
(= op ::rep) (list (if (:splice rp) '+ '*) (:forms rp))))))
(defn- op-unform
"Inverse of the conform machinery for one regex op; returns a SEQ of
original input elements."
[p x]
(let [rp (if (ident? p) (reg-resolve! p) p)
op (op-of rp)]
(cond
(= op ::accept) [(:ret rp)]
(nil? op) [(unform*-dispatch p x)]
(= op ::amp)
(let [px (reduce (fn [acc pred] (unform*-dispatch pred acc))
x (reverse (:ps rp)))]
(op-unform (:p1 rp) px))
(= op ::rep) (mapcat (fn [v] (op-unform (:p1 rp) v)) x)
(= op ::pcat)
(if (:rep+ rp)
(mapcat (fn [v] (op-unform (first (:ps rp)) v)) x)
(let [kps (zipmap (:ks rp) (:ps rp))]
(mapcat (fn [k]
(when (contains? x k)
(op-unform (get kps k) (get x k))))
(:ks rp))))
(= op ::alt)
(if (:maybe rp)
;; conform of an empty ? is nil — unform back to no elements.
;; (Deviation from upstream, which unforms nil through the child
;; pred; ours round-trips (s/? p) on [] correctly instead.)
(if (nil? x)
[]
[(unform*-dispatch (first (:ps rp)) x)])
(let [k (nth x 0)
v (nth x 1)
kps (zipmap (:ks rp) (:ps rp))]
(op-unform (get kps k) v))))))
(defn- re-conform [p data]
(loop [p p data (seq data)]
(if (nil? data)
(if (accept-nil? p)
(let [ret (preturn p)]
(if (= ret ::nil)
nil
ret))
::invalid)
(if-let [dp (deriv p (first data))]
(recur dp (next data))
::invalid))))
(defn- pad-to
"coll as an n-element vector, right-padded with nils."
[coll n]
(let [v (vec (or coll []))]
(mapv (fn [i] (get v i)) (range n))))
(defn- op-explain [form p path via in input]
(let [rp (if (ident? p) (reg-resolve! p) p)
x (first input)
via (if-let [n (when (map? rp) (get rp ::name))] (conj via n) via)
op (op-of rp)
insufficient (fn [path form]
[{:path path
:reason "Insufficient input"
:pred form
:val ()
:via via
:in in}])]
(when rp
(cond
(= op ::accept) nil
(nil? op)
(if (empty? input)
(insufficient path form)
(explain-1 form p path via in x))
(= op ::amp)
(if (empty? input)
(if (accept-nil? (:p1 rp))
(explain-pred-list (:forms rp) (:ps rp) path via in (preturn (:p1 rp)))
(insufficient path (:amp rp)))
(if-let [p1 (deriv (:p1 rp) x)]
(explain-pred-list (:forms rp) (:ps rp) path via in (preturn p1))
(op-explain (:amp rp) (:p1 rp) path via in input)))
(= op ::pcat)
(let [ps (vec (:ps rp))
n (count ps)
ks (pad-to (:ks rp) n)
forms (pad-to (:forms rp) n)
pkfs (map vector ps ks forms)
pkf (if (= 1 n)
(first pkfs)
(first (remove (fn [t] (accept-nil? (first t))) pkfs)))
pred (first pkf)
k (second pkf)
f (nth pkf 2)
path (if k (conj path k) path)
form (or f (op-describe pred))]
(if (and (empty? input) (not pred))
(insufficient path form)
(op-explain form pred path via in input)))
(= op ::alt)
(if (empty? input)
(insufficient path (op-describe rp))
(let [ps (vec (:ps rp))
n (count ps)
ks (pad-to (:ks rp) n)
forms (pad-to (:forms rp) n)]
(apply concat
(map (fn [k f pred]
(op-explain (or f (op-describe pred))
pred
(if k (conj path k) path)
via in input))
ks forms ps))))
(= op ::rep)
(op-explain (if (identical? (:p1 rp) (:p2 rp))
(:forms rp)
(op-describe (:p1 rp)))
(:p1 rp) path via in input)))))
(defn- re-explain [path via in re input]
(loop [p re data (seq input) i 0]
(if (nil? data)
(if (accept-nil? p)
nil
(op-explain (op-describe p) p path via in nil))
(let [x (first data)
dp (deriv p x)]
(if dp
(recur dp (next data) (inc i))
(if (accept? p)
[{:path path
:reason "Extra input"
:pred (op-describe re)
:val data
:via via
:in (conj in i)}]
(or (op-explain (op-describe p) p path via (conj in i) data)
[{:path path
:reason "Extra input"
:pred (op-describe re)
:val data
:via via
:in (conj in i)}])))))))
;; Regex maps get their Spec behavior via the Map type tag. A plain map that
;; is NOT a regex op is not a valid spec (upstream: maps are not specs) —
;; using one as a spec throws an informative error.
(defn- not-a-spec! [m]
(throw (ex-info "map is not a valid spec (only regex-op maps produced by cat/alt/*/+/?/& are)"
{:map m})))
(extend-type Map Spec
(conform* [spec x]
(if (regex? spec)
(if (or (nil? x) (sequential? x))
(re-conform spec (seq x))
::invalid)
(not-a-spec! spec)))
(unform* [spec x]
(if (regex? spec)
(if (nil? x)
nil
(op-unform spec x))
(not-a-spec! spec)))
(explain* [spec path via in x]
(if (regex? spec)
(if (or (nil? x) (sequential? x))
(re-explain path via in spec (seq x))
[(problem path (op-describe spec) x via in)])
(not-a-spec! spec)))
(describe* [spec]
(if (regex? spec)
(op-describe spec)
(not-a-spec! spec))))
;; ── def-impl / naming ─────────────────────────────────────────────────────────
(defn- with-name
"Attaches name (a qualified keyword or symbol) to spec, returning the
(possibly updated) spec. Bare Fn/Set/Keyword/Symbol specs are returned
unchanged: they already carry their own identity (a set prints itself, a
keyword/symbol re-resolves through the registry every time), and — per the
'never with-meta on a dispatching value' rule for this runtime — there is
nowhere safe to stash a name on them without breaking protocol dispatch.
Only our own defrecord-based spec objects (PredicateSpec/AndSpec/OrSpec,
...) get an assoc'd :name field, since `assoc` on a record preserves its
type tag here; regex-op maps carry their name under the namespaced ::name
key (plain assoc keeps them regex maps)."
[spec name]
(cond
(record? spec) (assoc spec :name name)
(regex? spec) (assoc spec ::name name)
:else spec))
(defn spec-name
"Returns the registered name of spec, if it has one. Keyword refs report
their own keyword; record-based specs report their assoc'd :name; regex
maps their ::name (nil if never named via s/def); anything else (bare
fn/set/symbol) has none."
[spec]
(cond
(keyword? spec) spec
(record? spec) (:name spec)
(regex? spec) (get spec ::name)
:else nil))
(defn spec-impl
"Wraps pred (a predicate fn, or another spec) together with its literal
form into a PredicateSpec, so describe/form can show the form as written."
([form pred] (spec-impl form pred nil))
([form pred name] (->PredicateSpec form pred name)))
(defn def-impl
"Impl fn for s/def. k must be a qualified keyword or symbol. If spec is
already one of our record-based spec objects, or a bare keyword/symbol
(registry ref) or set (enum spec), it's stored as-is so live
re-resolution/forward-refs keep working; a bare predicate fn is wrapped in
a PredicateSpec first so describe/form can show its literal form. Returns
k."
[k form spec]
(when-not (and (ident? k) (namespace k))
(throw (ex-info (str "s/def requires a qualified keyword or symbol, got: " (pr-str k))
{:key k})))
(let [s (cond
(spec? spec) spec
(regex? spec) spec
(keyword? spec) spec
(symbol? spec) spec
(set? spec) spec
:else (spec-impl form spec nil))]
(swap! registry-ref assoc k (with-name s k))
k))
;; ── Macros ────────────────────────────────────────────────────────────────────
;;
;; NOTE: `def`/`and`/`or` are special forms in this runtime, dispatched on the
;; raw head-symbol text — so unqualified `(def ...)`/`(and ...)`/`(or ...)`
;; anywhere ABOVE this point always hits the special form, never these
;; macros. External callers only reach these via an alias, e.g.
;; `(s/def ::x even?)`, `(s/and int? even?)`, `(s/or :i int? :s string?)`.
;;
;; A second, more surprising consequence of special-form names being
;; reserved: `defmacro` cannot itself be named `def`/`and`/`or` directly.
;; `(defmacro def [...] ...)` builds the underlying fn via the same
;; self-name-as-optional-first-arg logic as `fn*`, which explicitly skips
;; treating the name as a self-reference when it's a special form
;; (`crates/cljrs-interp/src/special.rs` — `!is_special_form(s)` guard) —
;; but the fn-parsing code never falls back to "there's no self-name after
;; all" in that case, so it misreads the name symbol itself as the arity
;; clause and throws "fn* expects vector or arity clauses". Worked around by
;; defining each macro under a `-form`-suffixed name and then re-binding the
;; resulting `Macro` value onto the desired var with a plain `def` (`def` the
;; special form just interns whatever value it's given — no such guard on
;; the *target* name of a `def`, only on fn/macro self-reference names).
(defmacro def-form
"Given a namespace-qualified keyword or symbol k, and a spec, predicate, or
regex-op form, makes an entry in the registry mapping k to the spec. Do NOT
put a def in a defn — spec kits should be at the top level. Returns k."
[k spec-form]
`(def-impl '~k '~spec-form ~spec-form))
(def def def-form)
(defmacro spec
"Takes a single predicate/spec form and returns a spec object wrapping it,
preserving the literal form for describe/form output."
[pred-form]
`(spec-impl '~pred-form ~pred-form nil))
(defmacro and-form
"Takes predicate/spec-forms, e.g. (s/and int? even?), and returns a spec
that returns the conformed value of the last predicate if all pass, else
::invalid."
[& pred-forms]
`(and-spec-impl '~(vec pred-forms) [~@pred-forms]))
(def and and-form)
(defmacro or-form
"Takes key/pred-form pairs, e.g. (s/or :i int? :s string?), and returns a
spec that returns [key conformed] for the first matching branch, else
::invalid."
[& key-pred-forms]
(let [pairs (partition 2 key-pred-forms)
ks (mapv first pairs)
pred-forms (mapv second pairs)]
`(or-spec-impl '~ks '~pred-forms [~@pred-forms])))
(def or or-form)
;; `keys`/`merge` are NOT special forms, so they can be defmacro'd under their
;; own names directly — but doing so shadows clojure.core/keys and
;; clojure.core/merge for ALL unqualified references in this namespace
;; (interned vars beat refers). Any internal use of the core fns in this file
;; must be written clojure.core/keys / clojure.core/merge.
(defmacro keys
"Creates and returns a map validating spec. :req and :opt are vectors of
namespace-qualified keywords (in :req, `(and ...)`/`(or ...)` connective
forms are also accepted for presence logic). :req-un/:opt-un use the
qualified keyword's spec to validate the UNqualified key in the map.
Regardless of options, every map entry whose (qualified) key has a
registered spec is conformed/validated."
[& kspecs]
(let [opts (apply hash-map kspecs)
req (get opts :req [])
opt (get opts :opt [])
req-un (get opts :req-un [])
opt-un (get opts :opt-un [])]
`(keys-impl '~req '~opt '~req-un '~opt-un '~(cons 'keys kspecs))))
(defmacro merge
"Takes map-validating specs (e.g. keys specs or keyword refs to them) and
returns a spec that returns a conformed map satisfying all of the specs."
[& pred-forms]
`(merge-spec-impl '~(vec pred-forms) [~@pred-forms]))
;; Regex-op macros. `cat`/`alt` are plain names; `*` and `+` shadow
;; clojure.core arithmetic and `cat` shadows the core transducer for
;; unqualified references in THIS namespace from here on (external callers
;; are unaffected — they go through the `s/` alias). No code in this file
;; uses bare `*`, `+`, or `cat` as core fns; if a later milestone needs
;; arithmetic, it must write clojure.core/+ etc. `?` and `&` occupy otherwise
;; unused names (`&` is only special inside params vectors).
(defmacro cat
"Takes key+pred pairs, e.g. (s/cat :a int? :b string?), and returns a
regex op that matches (all) values in sequence, returning a map with the
keys of each pred and the corresponding conformed value."
[& key-pred-forms]
(let [pairs (partition 2 key-pred-forms)
ks (mapv first pairs)
pred-forms (mapv second pairs)]
(when (odd? (count key-pred-forms))
(throw (ex-info "s/cat expects an even number of key/pred forms"
{:forms key-pred-forms})))
`(cat-impl '~ks [~@pred-forms] '~pred-forms)))
(defmacro alt
"Takes key+pred pairs, e.g. (s/alt :i int? :s string?), and returns a
regex op that returns a [key conformed-value] vector for the first
matching alternative."
[& key-pred-forms]
(let [pairs (partition 2 key-pred-forms)
ks (mapv first pairs)
pred-forms (mapv second pairs)]
(when (odd? (count key-pred-forms))
(throw (ex-info "s/alt expects an even number of key/pred forms"
{:forms key-pred-forms})))
`(alt-impl '~ks [~@pred-forms] '~pred-forms)))
(defmacro *
"Returns a regex op that matches zero or more values matching pred,
conforming to a vector."
[pred-form]
`(rep-impl '~pred-form ~pred-form))
(defmacro +
"Returns a regex op that matches one or more values matching pred,
conforming to a vector."
[pred-form]
`(rep+impl '~pred-form ~pred-form))
(defmacro ?
"Returns a regex op that matches zero or one value matching pred,
conforming to the single conformed value (or nil when absent)."
[pred-form]
`(maybe-impl ~pred-form '~pred-form))
(defmacro &
"Takes a regex op re and one or more predicates; returns a regex op that
matches re and whose conformed result must additionally satisfy all the
preds (threaded left to right, like s/and)."
[re & preds]
`(amp-impl ~re '~re [~@preds] '~(vec preds)))
;; ── Public API ────────────────────────────────────────────────────────────────
(defn spec?
"Returns x if x is one of our own record-based spec objects (created by
spec-impl/and-spec-impl/or-spec-impl/...), else nil. Note: this diverges
from upstream clojure.spec.alpha, where spec? is true for anything
spec-conforming. Here bare predicates/sets/keywords/symbols all implement
the Spec protocol directly (via extend-type) but are NOT `spec?` — this is
what lets def-impl/with-name know precisely when a :name field can safely
be assoc'd, without special-casing every kind of value that can act as a
spec."
[x]
(when (and (record? x) (satisfies? Spec x))
x))
(defn conform
"Given a spec and a value, returns :clojure.spec.alpha/invalid if the
value doesn't match the spec, else the (possibly destructured) conformed
value."
[spec x]
(conform* spec x))
(defn unform
"Given a spec and a conformed value, returns the unconformed (original
form) value."
[spec x]
(unform* spec x))
(defn valid?
"Returns true if x is valid according to spec."
[spec x]
(not (invalid? (conform spec x))))
(defn form
"Returns the spec as data, in a form suitable for re-parsing."
[spec]
(describe* spec))
(defn describe
"Returns an abbreviated description of the spec, suitable for presenting
to a user."
[spec]
(describe* spec))
;; ── explain ───────────────────────────────────────────────────────────────────
(defn explain-data*
"Like explain-data but with explicit path/via/in seeds. Returns the
explain-data map, or nil when x is valid."
[spec path via in x]
(let [probs (explain* spec path via in x)]
(when (seq probs)
{:clojure.spec.alpha/problems (vec probs)
:clojure.spec.alpha/spec spec
:clojure.spec.alpha/value x})))
(defn explain-data
"Given a spec and a value x that fails to conform, returns a map with at
least :clojure.spec.alpha/problems (a vector of problem maps with keys
:path :pred :val :via :in), plus :clojure.spec.alpha/spec and
:clojure.spec.alpha/value. Returns nil when x conforms. (Explicit qualified
keywords — the reader has no #:ns{...} literal support.)
via seeding: only a NAMED record-based spec seeds via with its registered
name here. A keyword spec pushes itself onto via inside the Keyword
explain* impl, so seeding it here too would double it."
[spec x]
(explain-data* spec []
(if-let [n (and (record? spec) (spec-name spec))] [n] [])
[] x))
(defn explain-printer
"Default printer for explain-data. Prints one line per problem, upstream-ish:
<val> - failed: <pred> in: <in> at: <path> spec: <last-via>. Prints
Success! when ed is nil."
[ed]
(if ed
(doseq [p (:clojure.spec.alpha/problems ed)]
(let [path (:path p)
pred (:pred p)
v (:val p)
via (:via p)
in (:in p)]
(println (str (pr-str v)
" - failed: " (pr-str pred)
(if (empty? in) "" (str " in: " (pr-str in)))
(if (empty? path) "" (str " at: " (pr-str path)))
(if (empty? via) "" (str " spec: " (pr-str (last via))))))))
(println "Success!")))
(def ^:dynamic *explain-out* explain-printer)
(defn explain-out
"Prints explanation data (per *explain-out*, default explain-printer) to
*out*."
[ed]
(*explain-out* ed))
(defn explain
"Given a spec and a value that fails to conform, prints an explanation to
*out*; prints Success! otherwise."
[spec x]
(explain-out (explain-data spec x)))
(defn explain-str
"Like explain, but returns the explanation as a string."
[spec x]
(with-out-str (explain spec x)))
;; ── EverySpec (s/every, s/coll-of, s/map-of, s/every-kv) ────────────────────
;;
;; Options (all literal at the macro call site): :kind (a whole-collection
;; predicate, e.g. vector?), :count, :min-count, :max-count, :distinct,
;; :into ([] () {} #{} — the target shape to conform INTO). :gen-max/:gen are
;; accepted and silently ignored (generators are not implemented in this
;; port). `s/coll-of`/`s/map-of` conform every element/entry and rebuild the
;; collection; `s/every`/`s/every-kv` only VALIDATE elements/entries and
;; return x unchanged when valid (mirroring upstream's every/every-kv, which
;; exist so large/infinite collections don't have to be fully conformed).
;;
;; `s/map-of` conforms keys with the key-spec only when :conform-keys true;
;; by default keys must be VALID (checked against the key-spec) but the
;; ORIGINAL key is kept in the conformed result. `s/every-kv` validates both
;; keys and values but, like `every`, never rebuilds.
;;
;; DEVIATION FROM UPSTREAM: upstream's every-impl always builds the
;; conformed result via `(reduce conj (empty into-target-or-x) ...)`, even
;; when :into is omitted — which means a *list* input with no :into would
;; silently come back element-reversed (conj on a list prepends). We only
;; replicate that raw conj-onto-empty behavior when :into is given
;; EXPLICITLY (so `:into '()` still reverses, matching upstream's
;; well-documented gotcha and plain `into` semantics). When :into is
;; omitted, we preserve input order for all four kinds — vector/map/set
;; conj naturally preserves the order that matters for each, and list/seq
;; input is rebuilt via `map`/`seq` (order-preserving) rather than raw conj
;; onto `()`. This is judged friendlier and closer to what most callers
;; actually rely on; documented here since it's an intentional divergence.
;;
;; Explain reports only the FIRST failing element/entry (a simplification of
;; upstream's `*coll-error-limit*`, which defaults to 1 anyway but is a
;; rebindable dynamic var upstream — not implemented here).
(defrecord EverySpec [form pred kfn kind kind-form
cnt min-count max-count distinct
into-given? into-target conform-all conform-keys name])
(defn- every-kind-ok? [spec x]
(let [k (:kind spec)]
(or (nil? k) (boolean (k x)))))
(defn- every-count-ok? [spec x]
(let [c (count x)
cnt (:cnt spec) mn (:min-count spec) mx (:max-count spec)]
(and (or (nil? cnt) (= c cnt))
(or (nil? mn) (<= mn c))
(or (nil? mx) (<= c mx)))))
(defn- every-distinct-ok? [spec x]
(or (not (:distinct spec)) (empty? x) (apply distinct? (seq x))))
(defn- every-shape-ok? [spec x]
(try
(and (every-kind-ok? spec x) (every-count-ok? spec x) (every-distinct-ok? spec x))
(catch Exception _e false)))
(defn- every-count-pred-form [spec]
(let [cnt (:cnt spec) mn (:min-count spec) mx (:max-count spec)]
(cond
cnt (list '= (list 'count '%) cnt)
(and mn mx) (list '<= mn (list 'count '%) mx)
mn (list '<= mn (list 'count '%))
mx (list '<= (list 'count '%) mx)
:else 'true)))
(defn- every-shape-problem [spec path via in x]
(try
(cond
(not (every-kind-ok? spec x))
[(problem path (or (:kind-form spec) (:kind spec)) x via in)]
(not (every-count-ok? spec x))
[(problem path (every-count-pred-form spec) x via in)]
(not (every-distinct-ok? spec x))
[(problem path 'distinct? x via in)]
:else nil)
(catch Exception _e
[(problem path (or (:kind-form spec) (:kind spec) 'coll?) x via in)])))
(defn- every-default-empty
"The empty accumulator to conj conformed elements/entries onto when no
:into was given — chosen so vector/map/set inputs conj back into their
own kind directly; list/seq inputs accumulate into a vector (converted to
a seq by `every-build-finish` below, to preserve order)."
[x]
(cond
(vector? x) []
(map? x) {}
(set? x) #{}
:else []))
(defn- every-build-empty [spec x]
(if (:into-given? spec) (empty (:into-target spec)) (every-default-empty x)))
(defn- every-build-finish [spec x ret]
(if (or (:into-given? spec) (vector? x) (map? x) (set? x))
ret
(seq ret)))
(defn- every-conform-seq [spec x]
(loop [ret (every-build-empty spec x) items (seq x)]
(if (nil? items)
(every-build-finish spec x ret)
(let [cv (conform*-dispatch (:pred spec) (first items))]
(if (invalid? cv)
::invalid
(recur (conj ret cv) (next items)))))))
(defn- every-validate-seq [spec x]
(if (every? (fn [v] (not (invalid? (conform*-dispatch (:pred spec) v)))) x)
x
::invalid))
(defn- every-conform-map [spec x]
(loop [ret (every-build-empty spec x) entries (seq x)]
(if (nil? entries)
(every-build-finish spec x ret)
(let [e (first entries)
k (key e)
v (val e)
ck (conform*-dispatch (:kfn spec) k)
vc (conform*-dispatch (:pred spec) v)]
(if (or (invalid? ck) (invalid? vc))
::invalid
(recur (conj ret [(if (:conform-keys spec) ck k) vc]) (next entries)))))))
(defn- every-validate-map [spec x]
(if (every? (fn [e] (and (not (invalid? (conform*-dispatch (:kfn spec) (key e))))
(not (invalid? (conform*-dispatch (:pred spec) (val e))))))
(seq x))
x
::invalid))
(defn- every-unform-coll [spec x]
(let [items (map (fn [v] (unform*-dispatch (:pred spec) v)) x)]
(cond
(vector? x) (vec items)
(set? x) (set items)
:else (seq items))))
(defn- every-unform-map [spec x]
(into (empty x)
(map (fn [e]
(let [k (key e)
v (val e)
uk (if (:conform-keys spec) (unform*-dispatch (:kfn spec) k) k)]
[uk (unform*-dispatch (:pred spec) v)]))
x)))
(defn- every-explain-seq [spec path via in x]
(or (every-shape-problem spec path via in x)
(loop [items (seq x) idx 0]
(when items
(let [probs (explain-1 (:form spec) (:pred spec) path via (conj in idx) (first items))]
(if (seq probs)
(vec probs)
(recur (next items) (inc idx))))))))
(defn- every-explain-map [spec path via in x]
(or (every-shape-problem spec path via in x)
(loop [entries (seq x)]
(when entries
(let [e (first entries)
k (key e)
v (val e)
kprobs (explain-1 (:form spec) (:kfn spec) path via (conj in k) k)]
(if (seq kprobs)
(vec kprobs)
(let [vprobs (explain-1 (:form spec) (:pred spec) path via (conj in k) v)]
(if (seq vprobs)
(vec vprobs)
(recur (next entries))))))))))
(extend-type EverySpec Spec
(conform* [spec x]
(if (:kfn spec)
(if (or (not (map? x)) (not (every-shape-ok? spec x)))
::invalid
(if (:conform-all spec) (every-conform-map spec x) (every-validate-map spec x)))
(if (or (not (coll? x)) (not (every-shape-ok? spec x)))
::invalid
(if (:conform-all spec) (every-conform-seq spec x) (every-validate-seq spec x)))))
(unform* [spec x]
(if (:conform-all spec)
(if (:kfn spec) (every-unform-map spec x) (every-unform-coll spec x))
x))
(explain* [spec path via in x]
(if (:kfn spec)
(if (not (map? x))
[(problem path 'map? x via in)]
(every-explain-map spec path via in x))
(if (not (coll? x))
[(problem path 'coll? x via in)]
(every-explain-seq spec path via in x))))
(describe* [spec] (:form spec)))
(defn every-impl
"Shared impl fn for s/every, s/coll-of, s/map-of, s/every-kv. `form` is the
literal macro call (for describe/form). `pred` is the evaluated value
spec; `kfn` the evaluated key spec (nil unless map-of/every-kv). `kind` is
the evaluated :kind predicate (or nil); `kind-form` its literal form.
`cnt`/`min-count`/`max-count`/`distinct` are the evaluated option values.
`into-given?`/`into-target` record whether :into was supplied and its
evaluated value. `conform-all?` is true for coll-of/map-of (rebuild),
false for every/every-kv (validate only). `conform-keys?` is only
meaningful for map-of."
[form pred kfn kind kind-form cnt min-count max-count distinct
into-given? into-target conform-all? conform-keys?]
(->EverySpec form pred kfn kind kind-form cnt min-count max-count distinct
into-given? into-target conform-all? conform-keys? nil))
(defmacro every
"Returns a spec that VALIDATES (but does not conform) every element of a
collection against pred-form; conform returns x unchanged when valid.
Options: :kind :count :min-count :max-count :distinct :into (accepted for
describe parity though every never rebuilds) :gen-max :gen (ignored)."
[pred-form & opts]
(let [o (apply hash-map opts)]
`(every-impl '~(list* 'every pred-form opts) ~pred-form nil
~(:kind o) '~(:kind o)
~(:count o) ~(:min-count o) ~(:max-count o) ~(:distinct o)
~(contains? o :into) ~(:into o) false false)))
(defmacro coll-of
"Returns a spec that conforms every element of a collection against
pred-form and rebuilds the collection (into :into if given, else
preserving the input's own kind — see EverySpec doc comment above).
Options as per s/every."
[pred-form & opts]
(let [o (apply hash-map opts)]
`(every-impl '~(list* 'coll-of pred-form opts) ~pred-form nil
~(:kind o) '~(:kind o)
~(:count o) ~(:min-count o) ~(:max-count o) ~(:distinct o)
~(contains? o :into) ~(:into o) true false)))
(defmacro every-kv
"Returns a spec that VALIDATES every key/value pair of a map against
kpred-form/vpred-form; conform returns x unchanged when valid."
[kpred-form vpred-form & opts]
(let [o (apply hash-map opts)]
`(every-impl '~(list* 'every-kv kpred-form vpred-form opts) ~vpred-form ~kpred-form
~(:kind o) '~(:kind o)
~(:count o) ~(:min-count o) ~(:max-count o) ~(:distinct o)
~(contains? o :into) ~(:into o) false false)))
(defmacro map-of
"Returns a spec that conforms every key/value pair of a map against
kpred-form/vpred-form and rebuilds the map. Keys must be valid against
kpred-form always; they are only replaced with their conformed value when
:conform-keys true (default false, matching upstream)."
[kpred-form vpred-form & opts]
(let [o (apply hash-map opts)]
`(every-impl '~(list* 'map-of kpred-form vpred-form opts) ~vpred-form ~kpred-form
~(:kind o) '~(:kind o)
~(:count o) ~(:min-count o) ~(:max-count o) ~(:distinct o)
~(contains? o :into) ~(:into o) true ~(:conform-keys o))))
;; ── TupleSpec (s/tuple) ───────────────────────────────────────────────────
(defrecord TupleSpec [form preds forms name])
(extend-type TupleSpec Spec
(conform* [spec x]
(let [preds (:preds spec) n (count preds)]
(if (or (not (vector? x)) (not (= (count x) n)))
::invalid
(loop [ret [] i 0]
(if (= i n)
ret
(let [cv (conform*-dispatch (nth preds i) (nth x i))]
(if (invalid? cv)
::invalid
(recur (conj ret cv) (inc i)))))))))
(unform* [spec x]
(let [preds (:preds spec) n (count preds)]
(loop [ret [] i 0]
(if (= i n)
ret
(recur (conj ret (unform*-dispatch (nth preds i) (nth x i))) (inc i))))))
(explain* [spec path via in x]
(let [preds (:preds spec) forms (:forms spec) n (count preds)]
(cond
(not (vector? x)) [(problem path 'vector? x via in)]
(not (= (count x) n)) [(problem path (list '= (list 'count '%) n) x via in)]
:else
(loop [i 0]
(when (< i n)
(let [cv (conform*-dispatch (nth preds i) (nth x i))]
(if (invalid? cv)
(explain-1 (nth forms i) (nth preds i) (conj path i) via (conj in i) (nth x i))
(recur (inc i)))))))))
(describe* [spec] (:form spec)))
(defn tuple-impl
"Impl fn for s/tuple. forms/preds parallel: literal per-index spec forms,
their evaluated spec values."
[forms preds]
(->TupleSpec (cons 'tuple forms) (vec preds) (vec forms) nil))
(defmacro tuple
"Returns a spec for a fixed-length vector, positionally conforming each
element against the corresponding pred-form."
[& pred-forms]
`(tuple-impl '~(vec pred-forms) [~@pred-forms]))
;; ── NilableSpec (s/nilable) ───────────────────────────────────────────────
(defrecord NilableSpec [form pred name])
(extend-type NilableSpec Spec
(conform* [spec x]
(if (nil? x) nil (conform*-dispatch (:pred spec) x)))
(unform* [spec x]
(if (nil? x) nil (unform*-dispatch (:pred spec) x)))
(explain* [spec path via in x]
;; Upstream shape: on a non-nil invalid value, report the WRAPPED
;; spec's own problems at path+[::pred] AND a synthetic nil? problem at
;; path+[::nil] (`::pred`/`::nil` auto-resolve to
;; :clojure.spec.alpha/pred and :clojure.spec.alpha/nil in this ns).
(when (and (not (nil? x)) (invalid? (conform*-dispatch (:pred spec) x)))
(vec (concat (explain-1 (:form spec) (:pred spec) (conj path ::pred) via in x)
[(problem (conj path ::nil) 'nil? x via in)]))))
(describe* [spec] (list 'nilable (:form spec))))
(defn nilable-impl
[form pred]
(->NilableSpec form pred nil))
(defmacro nilable
"Returns a spec that accepts nil (conforming to nil) or delegates to
pred-form."
[pred-form]
`(nilable-impl '~pred-form ~pred-form))
;; ── MultiSpec (s/multi-spec) ──────────────────────────────────────────────
;;
;; conform*/explain* call `(mm x)` to get the spec registered for x's
;; dispatch branch, then delegate. A dispatch miss throws in this runtime
;; (`crates/cljrs-env/src/apply.rs`: "No method in multimethod ... for
;; dispatch value ..."), caught here via `(catch Exception ...)` — same
;; pattern already used for predicate-spec calls above. We deliberately do
;; NOT enumerate `(methods mm)` — its keys are Display strings in this
;; runtime, not the original dispatch values, so it can't be used to
;; reconstruct or validate the dispatch table.
;;
;; SIMPLIFICATION vs upstream: real clojure.spec.alpha's `retag` re-tags the
;; conformed value with the dispatch value before unforming, so unform can
;; work even when the conformed shape no longer carries a natural dispatch
;; value. We accept and store `retag` (a keyword or fn, per upstream) for
;; API compatibility but don't apply it: our unform* instead re-dispatches
;; `(mm x)` directly off the CONFORMED value x. This works whenever the
;; conformed shape still carries whatever `mm`'s dispatch fn inspects (true
;; for the common case of a keys-spec branch preserving the dispatch key);
;; it can misbehave for specs whose conform strips the dispatch value
;; entirely — a known, documented gap.
(defrecord MultiSpec [form mm retag name])
(extend-type MultiSpec Spec
(conform* [spec x]
(try
(conform*-dispatch ((:mm spec) x) x)
(catch Exception _e ::invalid)))
(unform* [spec x]
(try
(unform*-dispatch ((:mm spec) x) x)
(catch Exception _e x)))
(explain* [spec path via in x]
(try
(explain*-dispatch ((:mm spec) x) path via in x)
(catch Exception _e
[{:path path :pred (:form spec) :val x :via via :in in :reason "no method"}])))
(describe* [spec] (:form spec)))
(defn multi-spec-impl
[form mm retag]
(->MultiSpec form mm retag nil))
(defmacro multi-spec
"Takes mm-form (a multimethod, e.g. a symbol naming one defined via
defmulti/defmethod) and retag-form (a keyword or fn — see doc comment on
MultiSpec above for how this runtime's unform* simplifies retagging).
Returns a spec whose conform*/explain* delegate to whichever spec
`(mm x)` returns."
[mm-form retag-form]
`(multi-spec-impl '~(list 'multi-spec mm-form retag-form) ~mm-form ~retag-form))
;; ── ConformerSpec (s/conformer) ───────────────────────────────────────────
(defrecord ConformerSpec [form f unf name])
(extend-type ConformerSpec Spec
(conform* [spec x]
((:f spec) x))
(unform* [spec x]
(if (:unf spec) ((:unf spec) x) x))
(explain* [spec path via in x]
(when (invalid? (conform*-dispatch spec x))
[(problem path (:form spec) x via in)]))
(describe* [spec] (:form spec)))
(defn conformer-impl
([form f] (conformer-impl form f nil))
([form f unf] (->ConformerSpec form f unf nil)))
(defmacro conformer
"Takes a fn f of one arg (returning the conformed value, or ::invalid to
fail) and an optional inverse unf for unform. Threads transformed values
through s/and like any other predicate/spec."
([f-form] `(conformer-impl '~f-form ~f-form))
([f-form unf-form] `(conformer-impl '~f-form ~f-form ~unf-form)))
;; ── Leaf helpers: int-in / double-in / inst-in / nonconforming ──────────────
(defn int-in-range?
"True if x is an int? in the range [start, end) — start inclusive, end
exclusive."
[start end x]
(and (int? x) (>= x start) (< x end)))
(defn int-in
"Returns a spec validating ints in the range [start, end)."
[start end]
(spec-impl (list 'int-in start end) (fn [x] (int-in-range? start end x)) nil))
(defn double-in
"Returns a spec validating doubles. Options (all optional, keyword args):
:min :max (inclusive bounds), :infinite? (default true — whether ##Inf/
##-Inf are accepted), :NaN? (default true — whether ##NaN is accepted).
Reuses this runtime's existing NaN?/infinite? bootstrap predicates
(crates/cljrs-builtins/src/bootstrap.cljrs) rather than reimplementing
IEEE-754 checks."
[& opts]
(let [o (apply hash-map opts)
mn (:min o)
mx (:max o)
inf-opt (get o :infinite? true)
nan-opt (get o :NaN? true)]
(spec-impl (list* 'double-in opts)
(fn [x]
(and (double? x)
(cond
(NaN? x) nan-opt
(infinite? x) inf-opt
:else (and (or (nil? mn) (>= x mn))
(or (nil? mx) (<= x mx))))))
nil)))
(defn inst-in
"NOT IMPLEMENTED: this runtime has no Instant/Date value type and no real
#inst support — the reader parses the #inst tag but
`crates/cljrs-interp/src/eval.rs`'s `eval_tagged_literal` just returns the
inner string unchanged (TODO there), and there is no `inst?` predicate
anywhere in builtins/bootstrap. Throws immediately with a clear message
rather than silently misbehaving."
[start end]
(throw (ex-info
"s/inst-in is not implemented: this runtime has no Instant/Date value type or #inst support"
{:start start :end end})))
(defrecord NonconformingSpec [pred name])
(extend-type NonconformingSpec Spec
(conform* [spec x]
(if (invalid? (conform*-dispatch (:pred spec) x)) ::invalid x))
(unform* [spec x] x)
(explain* [spec path via in x]
(explain*-dispatch (:pred spec) path via in x))
(describe* [spec] (list 'nonconforming (describe*-dispatch (:pred spec)))))
(defn nonconforming-impl
[pred]
(->NonconformingSpec pred nil))
(defmacro nonconforming
"Wraps pred-form so conform validates but returns x UNCONFORMED on
success (::invalid on failure, as usual); unform is identity."
[pred-form]
`(nonconforming-impl ~pred-form))
;; ── FSpec (s/fspec) + fdef / fn-specs registry ──────────────────────────────
;;
;; `s/fspec` describes a fn's shape via optional :args/:ret/:fn specs.
;; Without generative testing (see clojure.spec.gen.alpha — a stub namespace
;; whose fns all throw), the strongest `conform*` can do is check that x is
;; callable; the child specs are stored (for `s/form`/`describe`, and for
;; `clojure.spec.test.alpha/instrument`, which DOES check :args on every real
;; call) but never exercised here.
;;
;; `s/fdef` registers an FSpec into the SAME registry `s/def` uses (fn-specs
;; are not a separate table upstream either), keyed by the fn's
;; FULLY-QUALIFIED symbol. An unqualified symbol as written is qualified
;; against `*ns*` AT MACROEXPANSION TIME — safe because a macro body runs
;; while evaluating the caller's form, so `*ns*` at that point is the
;; caller's namespace. This is what makes `(s/get-spec sym)` and
;; `clojure.spec.test.alpha/instrument` work off a plain symbol key.
(defrecord FSpec [args ret fn form name])
(extend-type FSpec Spec
(conform* [spec x]
(if (fn? x) x ::invalid))
(unform* [spec x] x)
(explain* [spec path via in x]
(when (not (fn? x))
[(problem path 'fn? x via in)]))
(describe* [spec] (:form spec)))
(defn fspec-impl
"Impl fn for s/fspec. args/ret/fn are the evaluated :args/:ret/:fn specs
(nil if that option was omitted); form is the literal (fspec ...) call for
describe."
[args ret fn-spec form]
(->FSpec args ret fn-spec form nil))
(defn fspec?
"True if x is an FSpec (created via s/fspec, including indirectly via
s/fdef)."
[x]
(instance? FSpec x))
(defmacro fspec
"Returns a spec for a fn, described via optional :args/:ret/:fn specs
(each defaults to nil, meaning unconstrained). Without generators,
conform* can only check that a value is callable — see the FSpec doc
comment above. The :args/:ret/:fn specs are stored and available via
s/form / (:args ...) etc., and :args is used by
clojure.spec.test.alpha/instrument."
[& opts]
(let [o (apply hash-map opts)]
`(fspec-impl ~(:args o) ~(:ret o) ~(:fn o) '~(list* 'fspec opts))))
(defmacro fdef
"Takes a symbol naming a fn (var) and the same options as s/fspec
(:args/:ret/:fn, each optional). Registers an FSpec into the spec
registry keyed by the fully-qualified symbol — an unqualified sym is
qualified against the CALLING ns's *ns* at macroexpansion time. Returns
the fully-qualified symbol."
[sym & opts]
(let [qsym (if (namespace sym) sym (symbol (str (ns-name *ns*)) (name sym)))]
`(def-impl '~qsym '(fspec ~@opts) (fspec ~@opts))))
;; ── s/assert ─────────────────────────────────────────────────────────────────
;;
;; DEVIATION FROM UPSTREAM (documented): real clojure.spec.alpha reads
;; *compile-asserts* once, at AOT/JVM compile time, baking the decision into
;; the compiled bytecode. This interpreter has no separate compile phase —
;; every top-level form is macroexpanded as part of evaluating it — so `assert`
;; below reads *compile-asserts* at MACROEXPANSION time, which in practice
;; means "current value at the moment this particular s/assert form is
;; evaluated." The net effect (toggling `check-asserts` changes behavior of
;; s/assert forms evaluated afterward, but not ones already macroexpanded and
;; cached, e.g. inside a previously-defined fn body) is a harmless divergence
;; but worth knowing about.
(def ^:dynamic *compile-asserts* true)
(defn check-asserts?
"Returns the current value of *compile-asserts*."
[]
*compile-asserts*)
(defn check-asserts
"Sets *compile-asserts* to flag (globally, via alter-var-root — this
interpreter has no compile-time-only phase to gate on, so the change is
visible immediately; see the s/assert doc comment above). Returns flag."
[flag]
(alter-var-root #'*compile-asserts* (fn [_] flag))
flag)
(defn assert-spec
"Impl fn for s/assert. Returns x unchanged if it's valid? against spec;
otherwise throws an ex-info whose data is explain-data spec x, with
:clojure.spec.alpha/failure :assertion-failed assoc'd in, and whose
message includes the explain-str output."
[spec-form spec x]
(if (valid? spec x)
x
(let [ed (assoc (explain-data spec x) :clojure.spec.alpha/failure :assertion-failed)]
(throw (ex-info (str "Spec assertion failed\n" (explain-str spec x)) ed)))))
(defmacro assert
"Like clojure.core/assert, but takes a spec (rather than a boolean test)
and checks x against it via s/valid?, returning x on success. A no-op
(expands to plain x-form, no check at all) when *compile-asserts* is false
at MACROEXPANSION time — see the s/assert doc comment above for how that
differs from upstream's true compile-time gating."
[spec-form x-form]
(if *compile-asserts*
`(assert-spec '~spec-form ~spec-form ~x-form)
x-form))
;; ── with-gen / gen / exercise / exercise-fn ────────────────────────────────
;;
;; Generators are not implemented in this port — see clojure.spec.gen.alpha,
;; a small stub namespace whose public fns all throw a clear ex-info.
;; `s/with-gen` stores the supplied gen-fn without ever invoking it, which is
;; harmless since nothing here ever calls :gen. Bare (non-record) specs
;; (Fn/Set/Keyword/Symbol) have nowhere safe to stash a :gen — same
;; "never with-meta on a dispatching value" rule as with-name — so with-gen
;; on one of those is a documented no-op.
(defn with-gen
"Takes a spec and a no-arg fn that would (in upstream) return a
generator. Stores gen-fn under :gen on record-based specs (assoc
preserves the record's type tag in this runtime); bare
predicate/set/keyword/symbol specs have no field to stash it on, so this
is a no-op for them. Since generators aren't implemented, :gen is never
actually invoked anywhere in this file."
[spec gen-fn]
(if (record? spec)
(assoc spec :gen gen-fn)
spec))
(defn- gen-not-implemented
[spec]
(throw (ex-info "clojure.spec.gen.alpha generators are not implemented in clojurust"
{:spec spec})))
(defn gen
"NOT IMPLEMENTED: this port has no generative testing support (no
clojure.spec.gen.alpha generator engine)."
([spec] (gen-not-implemented spec))
([spec _overrides] (gen-not-implemented spec)))
(defn exercise
"NOT IMPLEMENTED: this port has no generative testing support."
([spec] (gen-not-implemented spec))
([spec _n] (gen-not-implemented spec))
([spec _n _overrides] (gen-not-implemented spec)))
(defn exercise-fn
"NOT IMPLEMENTED: this port has no generative testing support."
([sym] (gen-not-implemented sym))
([sym _n] (gen-not-implemented sym)))