Skip to content

Commit

Permalink
improve impl
Browse files Browse the repository at this point in the history
  • Loading branch information
@frenchy64
frenchy64 committed Jan 13, 2025
1 parent 684ffe2 commit 50993bb
Show file tree
Hide file tree
Showing 4 changed files with 166 additions and 161 deletions.
6 changes: 3 additions & 3 deletions README.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -513,7 +513,7 @@ The `:iff` schema requires either all or none of its children to be satisfied.

(me/humanize
(m/explain UserPass {:user "a"}))
; => {:pass ["missing required key"], :malli/error ["should not have key :user"]}
; => {:pass ["missing required key"]}
```

The `:implies` schema is satisfied if either its first child is _not_ satisfied or
Expand All @@ -534,7 +534,7 @@ all of its children are satisfied.

(me/humanize
(m/explain TagImpliesSha {:git/tag "v1.0.0"}))
; => {:git/sha ["missing required key"], :malli/error ["should not have key :git/tag"]}
; => {:git/sha ["missing required key"]}
```

The `:disjoint` schema is similar to `:xor` but also permits zero schemas to match.
Expand Down Expand Up @@ -630,7 +630,7 @@ this additional constraint.
;; combining :or with :disjoint helps enforce this case
(me/humanize
(m/explain SecretOrCreds {:secret "1234" :user "user"}))
;=> ["should not have key :user"]
; => ["should not have key :user"]
```

## Seqable schemas
Expand Down
282 changes: 139 additions & 143 deletions src/malli/core.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -813,98 +813,140 @@

(defn -or-schema
([] (-or-schema nil))
([{:keys [min max] :or {min 1}}]
(let [type (case [min max]
[1 nil] :or
[1 1] :xor
[0 1] :disjoint)]
^{:type ::into-schema}
(reify IntoSchema
(-type [_] type)
(-type-properties [_])
(-properties-schema [_ _])
(-children-schema [_ _])
(-into-schema [parent properties children options]
(-check-children! type properties children 1 nil)
(let [children (-vmap #(schema % options) children)
nchildren (count children)
neg-children (delay (-vmap #(schema [:not nil %] options) children))
form (delay (-simple-form parent properties children -form options))
cache (-create-cache options)
->parser (fn [f] (let [parsers (-vmap f children)]
(if (= :or type)
#(reduce (fn [_ parser] (miu/-map-valid reduced (parser %))) ::invalid parsers)
(let [disjoint (= :disjoint type)]
(fn [v]
(let [nvalid (volatile! 0)
res (reduce (fn [result parser]
(let [candidate (parser v)]
(if (miu/-invalid? candidate)
result
(do (vswap! nvalid inc)
(if (miu/-invalid? result)
candidate
(reduced ::invalid))))))
::invalid parsers)]
(if (and (zero? @nvalid) disjoint)
v
res)))))))]
^{:type ::schema}
(reify
Schema
(-validator [_]
(let [validators (-vmap -validator children)
->pred (case type :or miu/-some-pred :xor miu/-one-pred :disjoint miu/-zero-or-one-pred)]
(->pred validators)))
(-explainer [_ path]
(let [explainers (-vmap (fn [[i c]] (-explainer c (conj path i))) (map-indexed vector children))]
(case type
:or (fn explain [x in acc]
(reduce
(fn [acc' explainer]
(let [acc'' (explainer x in acc')]
(if (identical? acc' acc'') (reduced acc) acc'')))
acc explainers))
(:disjoint :xor)
(let [nchildren (count children)
neg-explainers (-vmap (fn [[i c]] (-explainer c (conj path (+ nchildren i)))) (map-indexed vector @neg-children))
disjoint (= :disjoint type)]
(fn explain-xor [x in acc]
(let [nvalid (volatile! 0)
res (reduce
(fn [acc' i]
(let [pos (zero? @nvalid)
explainer (nth (if pos explainers neg-explainers) i)
acc'' (explainer x in acc')]
(if (= (identical? acc' acc'') pos)
(if (= 1 (vswap! nvalid inc))
acc
(reduced acc''))
acc'')))
acc (range nchildren))]
(if (and (zero? @nvalid) disjoint)
acc
res)))))))
(-parser [_] (->parser -parser))
(-unparser [_] (->parser -unparser))
(-transformer [this transformer method options]
(-or-transformer this transformer children method options))
(-walk [this walker path options] (-walk-indexed this walker path options))
(-properties [_] properties)
(-options [_] options)
(-children [_] children)
(-parent [_] parent)
(-form [_] @form)
Cached
(-cache [_] cache)
LensSchema
(-keep [_])
(-get [_ key default] (case type
:or (get children key default)
(:disjoint :xor) (if (and (number? key) (< key nchildren))
(get children key default)
(get @neg-children key default))))
(-set [this key value] (-set-assoc-children this key value)))))))))
([{:keys [type] :or {type :or}}]
^{:type ::into-schema}
(reify IntoSchema
(-type [_] type)
(-type-properties [_])
(-properties-schema [_ _])
(-children-schema [_ _])
(-into-schema [parent properties children options]
(case type
(:or :disjoint :xor) (-check-children! type properties children 1 nil)
:if (-check-children! type properties children 3 3)
:implies (-check-children! type properties children 2 2)
:iff (-check-children! type properties children 2 nil))
(let [children (-vmap #(schema % options) children)
nchildren (count children)
neg-children (delay (-vmap #(schema [:not nil %] options) children))
form (delay (-simple-form parent properties children -form options))
cache (-create-cache options)
->parser (fn [f] (case type
:or (let [parsers (-vmap f children)]
#(reduce (fn [_ parser] (miu/-map-valid reduced (parser %))) ::invalid parsers))
:if (let [[test then else] (-vmap f children)]
(fn [x]
(let [x' (test x)]
(if (miu/-invalid? x')
(else x)
(then x')))))
:implies (let [[test then] (-vmap f children)]
(fn [x]
(let [x' (test x)]
(if (miu/-invalid? x')
x
(then x')))))
:iff (let [[test & thens] (-vmap f children)
test (f test)
then (-> [:and nil] (into thens) (schema options) f)
else (-> [:and nil] (into (map #(schema [:not nil %] options)) thens) (schema options) f)]
(fn [x]
(let [x' (test x)]
(if (miu/-invalid? x')
(else x)
(then x')))))
(:disjoint :xor) (let [parsers (eduction (map f) children)
disjoint (= :disjoint type)]
(fn [v]
(let [nvalid (volatile! 0)
res (reduce (fn [result parser]
(let [candidate (parser v)]
(if (miu/-invalid? candidate)
result
(do (vswap! nvalid inc)
(if (miu/-invalid? result)
candidate
(reduced ::invalid))))))
::invalid parsers)]
(if (and (zero? @nvalid) disjoint)
v
res))))))]
^{:type ::schema}
(reify
Schema
(-validator [_]
(let [validators (-vmap -validator children)
->pred (case type
:or miu/-some-pred
:xor miu/-one-pred
:disjoint miu/-zero-or-one-pred
:implies miu/-implies-pred
:if miu/-if-pred
:iff miu/-iff-pred)]
(->pred validators)))
(-explainer [_ path]
(let [explainers (-vmap (fn [[i c]] (-explainer c (conj path i))) (map-indexed vector children))
nchildren (count children)]
(case type
:or (fn explain [x in acc]
(reduce
(fn [acc' explainer]
(let [acc'' (explainer x in acc')]
(if (identical? acc' acc'') (reduced acc) acc'')))
acc explainers))
:implies (let [[a c] explainers]
(fn explain-implies [x in acc]
(if (identical? acc (a x in acc))
(c x in acc)
acc)))
:if (let [[test then else] explainers]
(fn explain-if [x in acc]
(if (identical? acc (test x in acc))
(then x in acc)
(else x in acc))))
:iff (let [[test & thens] explainers
elses (-vmap (fn [[i c]] (-explainer (schema [:not nil c] options) (conj path (+ nchildren i)))) (map-indexed vector children))]
(fn explain-iff [x in acc]
(reduce (fn [acc explainer] (explainer x in acc)) acc (if (identical? acc (test x in acc)) thens elses))))
(:disjoint :xor)
(let [neg-explainers (-vmap (fn [[i c]] (-explainer c (conj path (+ nchildren i)))) (map-indexed vector @neg-children))
disjoint (= :disjoint type)]
(fn explain-xor [x in acc]
(let [nvalid (volatile! 0)
res (reduce
(fn [acc' i]
(let [pos (zero? @nvalid)
explainer (nth (if pos explainers neg-explainers) i)
acc'' (explainer x in acc')]
(if (= (identical? acc' acc'') pos)
(if (= 1 (vswap! nvalid inc))
acc
(reduced acc''))
acc'')))
acc (range nchildren))]
(if (and (zero? @nvalid) disjoint)
acc
res)))))))
(-parser [_] (->parser -parser))
(-unparser [_] (->parser -unparser))
(-transformer [this transformer method options]
(-or-transformer this transformer children method options))
(-walk [this walker path options] (-walk-indexed this walker path options))
(-properties [_] properties)
(-options [_] options)
(-children [_] children)
(-parent [_] parent)
(-form [_] @form)
Cached
(-cache [_] cache)
LensSchema
(-keep [_])
(-get [_ key default] (case type
(:or :if :implies) (get children key default)
(:disjoint :xor :iff) (if (and (number? key) (< key nchildren))
(get children key default)
(get @neg-children key default))))
(-set [this key value] (-set-assoc-children this key value))))))))

(defn -orn-schema []
^{:type ::into-schema}
Expand Down Expand Up @@ -1011,52 +1053,6 @@
(-get [_ key default] (get children key default))
(-set [this key value] (-set-assoc-children this key value)))))))

;;TODO implement as primitive
(defn -if-schema []
(-proxy-schema {:type :if
:fn (fn [_ children options]
(let [children (mapv #(schema % options) children)]
[children
(mapv -form children)
(delay
(let [[test then else] children]
(schema
[:or
[:and test then]
[:and [:not test] else]]
options)))]))
:min 3
;;TODO fennel-like cond syntax [:if test then test then else] => [:if test then [:if test then else]]
:max 3}))

;;TODO implement as primitive
(defn -iff-schema []
(-proxy-schema {:type :iff
:fn (fn [_ children options]
(let [children (mapv #(schema % options) children)]
[children
(mapv -form children)
(delay
(schema
[:or
(into [:and nil] children)
(into [:and nil] (map #(do [:not nil %])) children)]
options))]))
:min 2}))

;;TODO implement as primitive
(defn -implies-schema []
(-proxy-schema {:type :implies
:fn (fn [_ children options]
(let [[c & a :as children] (mapv #(schema % options) children)]
[children
(mapv -form children)
(delay
(schema
[:if c (into [:and nil] a) :any]
options))]))
:min 2}))

(defn -val-schema
([schema properties]
(-into-schema (-val-schema) properties (list schema) (-options schema)))
Expand Down Expand Up @@ -2830,13 +2826,13 @@
(defn base-schemas []
{:and (-and-schema)
:or (-or-schema)
:xor (-or-schema {:min 1 :max 1})
:disjoint (-or-schema {:min 0 :max 1})
:xor (-or-schema {:type :xor})
:disjoint (-or-schema {:type :disjoint})
:orn (-orn-schema)
:not (-not-schema)
:if (-if-schema)
:iff (-iff-schema)
:implies (-implies-schema)
:if (-or-schema {:type :if})
:iff (-or-schema {:type :iff})
:implies (-or-schema {:type :implies})
:map (-map-schema)
:map-of (-map-of-schema)
:has (-has-schema)
Expand Down
17 changes: 17 additions & 0 deletions src/malli/impl/util.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -97,3 +97,20 @@
(fn [_ _] true)
preds)
false))

(defn -if-pred
[[test then else]]
(fn [x]
(if (test x)
(then x)
(else x))))

(defn -implies-pred
[[c a]]
(-if-pred [c a any?]))

(defn -iff-pred
[[choose & preds]]
(let [all (-every-pred preds)
none (complement (-some-pred preds))]
(-if-pred [choose all none])))
Loading

0 comments on commit 50993bb

Please sign in to comment.