Skip to content

Commit

Permalink
Initial fix for or transformation
Browse files Browse the repository at this point in the history 
metosin/reitit#407
  • Loading branch information
@ikitommi
ikitommi committed May 25, 2020
1 parent c529192 commit 4f4066a
Show file tree
Hide file tree
Showing 2 changed files with 128 additions and 30 deletions.
110 changes: 81 additions & 29 deletions src/malli/core.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -125,18 +125,19 @@
(fail! ::child-error {:name name, :properties properties, :children children, :min 1, :max 1}))
[#(try (f % child) (catch #?(:clj Exception, :cljs js/Error) _ false)) children])))

(defn- -composite-schema [name f short-circuit]
(defn- -and-schema []
^{:type ::into-schema}
(reify IntoSchema
(-into-schema [_ properties children options]
(when-not (seq children)
(fail! ::no-children {:name name, :properties properties}))
(fail! ::no-children {:name :and, :properties properties}))
(let [child-schemas (mapv #(schema % options) children)
validators (distinct (map -validator child-schemas))
validator (apply f validators)]
validator (apply every-pred validators)
form (create-form :and properties (map -form child-schemas))]
^{:type ::schema}
(reify Schema
(-name [_] name)
(-name [_] :and)
(-validator [_] validator)
(-explainer [_ path]
(let [distance (if (seq properties) 2 1)
Expand All @@ -146,7 +147,6 @@
(fn [acc' explainer]
(let [acc'' (explainer x in acc')]
(cond
(and short-circuit (identical? acc' acc'')) (reduced acc)
(nil? acc'') acc'
:else acc'')))
acc explainers))))
Expand All @@ -157,31 +157,80 @@
(let [->this (phase this-transformer)
?->this (or ->this identity)
->children (into [] (keep phase) child-transformers)]
(if (not (seq ->children))
->this
(fn [x]
(reduce-kv
(fn [x' _ t] (t x'))
(?->this x) ->children)))))]
{:enter (build :enter)
:leave (build :leave)}))
(-accept [this visitor in options]
(visitor this (mapv #(-accept % visitor in options) child-schemas) in options))
(-properties [_] properties)
(-options [_] options)
(-form [_] form)
LensSchema
(-get [_ key default] (get child-schemas key default))
(-set [_ key value] (into-schema :and properties (assoc child-schemas key value))))))))

(defn- -or-schema []
^{:type ::into-schema}
(reify IntoSchema
(-into-schema [_ properties children options]
(when-not (seq children)
(fail! ::no-children {:name :or, :properties properties}))
(let [child-schemas (mapv #(schema % options) children)
validators (distinct (map -validator child-schemas))
validator (apply some-fn validators)
form (create-form :or properties (map -form child-schemas))]
^{:type ::schema}
(reify Schema
(-name [_] :or)
(-validator [_] validator)
(-explainer [_ path]
(let [distance (if (seq properties) 2 1)
explainers (mapv (fn [[i c]] (-explainer c (into path [(+ i distance)]))) (map-indexed vector child-schemas))]
(fn explain [x in acc]
(reduce
(fn [acc' explainer]
(let [acc'' (explainer x in acc')]
(cond
(identical? acc' acc'') (reduced acc)
(nil? acc'') acc'
:else acc'')))
acc explainers))))
(-transformer [this transformer method options]
(let [this-transformer (-value-transformer transformer this method options)
child-transformers (map #(-transformer % transformer method options) child-schemas)
build (fn [phase]
(let [->this (phase this-transformer)
?->this (or ->this identity)
->children (mapv #(or (phase %) identity) child-transformers)
validators (mapv -validator child-schemas)]
(cond
(not (seq ->children)) ->this
short-circuit (fn [x]
(let [x (?->this x)]
(reduce-kv
(fn [_ _ t]
(let [x' (t x)]
(if-not (identical? x' x)
(reduced x')
x)))
x ->children)))
:else (fn [x]
(reduce-kv
(fn [x' _ t] (t x'))
(?->this x) ->children)))))]
;; on the way in, we transforma all values into vector + the original
(= :enter phase) (let [->children (conj ->children identity)]
(fn [x] (let [x (?->this x)] (mapv #(% x) ->children))))
;; on the way out, we take the first transformed value that is valid
:else (fn [xs]
(let [xs (mapv ?->this xs)]
(reduce-kv
(fn [acc i x]
(let [x' ((nth ->children i) x)]
(if ((nth validators i) x') (reduced x') acc)))
(peek xs) (pop xs)))))))]
{:enter (build :enter)
:leave (build :leave)}))
(-accept [this visitor in options]
(visitor this (mapv #(-accept % visitor in options) child-schemas) in options))
(-properties [_] properties)
(-options [_] options)
(-form [_] (create-form name properties (map -form child-schemas)))
(-form [_] form)
LensSchema
(-get [_ key default] (get child-schemas key default))
(-set [_ key value] (into-schema name properties (assoc child-schemas key value))))))))
(-set [_ key value] (into-schema :or properties (assoc child-schemas key value))))))))

(defn- -properties-and-children [xs]
(if ((some-fn map? nil?) (first xs))
Expand All @@ -200,7 +249,7 @@

(defn- -parse-map-entries [children options]
(when-let [children (seq (remove -valid-child? children))]
(fail! ::child-error {:children children}))
(fail! ::child-error {:children children}))
(->> children (mapv #(-expand-key % options identity))))

(defn ^:no-doc map-entry-forms [entries]
Expand Down Expand Up @@ -323,7 +372,8 @@
(fn [_ key value]
(or (and (key-valid? key) (value-valid? value)) (reduced false)))
true m))
distance (if (seq properties) 2 1)]
distance (if (seq properties) 2 1)
form (create-form :map-of properties (mapv -form schemas))]
^{:type ::schema}
(reify Schema
(-name [_] :map-of)
Expand Down Expand Up @@ -362,7 +412,7 @@
(visitor this (mapv #(-accept % visitor in options) schemas) in options))
(-properties [_] properties)
(-options [_] options)
(-form [_] (create-form :map-of properties (mapv -form schemas))))))))
(-form [_] form))))))

(defn- -collection-schema [name fpred fwrap fempty]
^{:type ::into-schema}
Expand Down Expand Up @@ -483,7 +533,8 @@
(when-not (seq children)
(fail! ::no-children {:name :enum, :properties properties}))
(let [schema (set children)
validator (fn [x] (contains? schema x))]
validator (fn [x] (contains? schema x))
form (create-form :enum properties children)]
^{:type ::schema}
(reify Schema
(-name [_] :enum)
Expand All @@ -498,7 +549,7 @@
(visitor this (vec children) in options))
(-properties [_] properties)
(-options [_] options)
(-form [_] (create-form :enum properties children)))))))
(-form [_] form))))))

(defn- -re-schema [class?]
^{:type ::into-schema}
Expand Down Expand Up @@ -536,7 +587,8 @@
(when-not (= 1 (count children))
(fail! ::child-error {:name :fn, :properties properties, :children children, :min 1, :max 1}))
(let [f (eval (first children))
validator (fn [x] (try (f x) (catch #?(:clj Exception, :cljs js/Error) _ false)))]
validator (fn [x] (try (f x) (catch #?(:clj Exception, :cljs js/Error) _ false)))
form (create-form :fn properties children)]
^{:type ::schema}
(reify Schema
(-name [_] :fn)
Expand All @@ -555,7 +607,7 @@
(visitor this (vec children) in options))
(-properties [_] properties)
(-options [_] options)
(-form [_] (create-form :fn properties children)))))))
(-form [_] form))))))

(defn- -maybe-schema []
^{:type ::into-schema}
Expand Down Expand Up @@ -856,8 +908,8 @@
(reduce-kv -register nil)))

(def base-registry
{:and (-composite-schema :and every-pred false)
:or (-composite-schema :or some-fn true)
{:and (-and-schema)
:or (-or-schema)
:map (-map-schema)
:map-of (-map-of-schema)
:vector (-collection-schema :vector vector? vec [])
Expand Down
48 changes: 47 additions & 1 deletion test/malli/core_test.cljc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,8 @@
(:require [clojure.test :refer [deftest testing is are]]
[malli.core :as m]
[malli.edn :as me]
[malli.transform :as mt]))
[malli.transform :as mt]
[malli.util :as mu]))

(defn with-schema-forms [result]
(some-> result
Expand Down Expand Up @@ -135,6 +136,51 @@

(is (= [:and 'int? [:or 'pos-int? 'neg-int?]] (m/form schema))))

(testing "transforming :or"
(testing "first valid transformed branch is used"
(are [input result]
(is (= (m/decode
[:or
[:map [:x keyword?]]
int?
[:map [:y keyword?]]
keyword?]
input
mt/string-transformer)
result))

{:x "true", :y "true"} {:x :true, :y "true"}
{:x false, :y "true"} {:x false, :y :true}
{:x false, :y false} {:x false, :y false}
1 1
"kikka" :kikka))

(testing "top-level transformations are retained"
(are [input result]
(is (= (m/decode
(mu/closed-schema
[:or {:decode/string {:enter (fn [m] (update m :enter #(or % true)))
:leave (fn [m] (update m :leave #(or % true)))}}
[:map
[:x keyword?]
[:enter boolean?]
[:leave boolean?]]
[:map
[:y keyword?]
[:enter boolean?]
[:leave boolean?]]])
input
mt/string-transformer)
result))

{:x "true"} {:x :true, :enter true, :leave true}
{:x "true", :enter "invalid"} {:x "true", :enter "invalid", :leave true}

{:y "true"} {:y :true, :enter true, :leave true}
{:y "true", :leave "invalid"} {:y "true", :enter true, :leave "invalid"}

{:x "true", :y "true"} {:x "true", :y "true", :enter true, :leave true})))

(testing "explain with branches"
(let [schema [:and pos-int? neg-int?]]
(is (results= {:schema schema,
Expand Down

0 comments on commit 4f4066a

Please sign in to comment.