diff --git a/README.md b/README.md index 914878357..f262b5a0f 100644 --- a/README.md +++ b/README.md @@ -158,7 +158,99 @@ You can use `:sequential` for any homogeneous Clojure sequence, `:vector` for ve ;; => false ``` -Support for Heterogeneous/Regex sequences is [WIP](https://github.com/metosin/malli/issues/180). +Malli also supports sequence regexes like [Seqexp](https://github.com/cgrand/seqexp) and Spec. +The supported operators are `:cat` & `:cat*` for concatenation / sequencing + +```clj +(m/validate [:cat string? int?] ["foo" 0]) ; => true + +(m/validate [:cat* [:s string?] [:n int?]] ["foo" 0]) ; => true +``` + +`:alt` & `:alt*` for alternatives + +```clj +(m/validate [:alt keyword? string?] ["foo"]) ; => true + +(m/validate [:alt* [:kw keyword?] [:s string?]] ["foo"]) ; => true +``` + +and `:?`, `:*`, `:+` & `:repeat` for repetition: + +```clj +(m/validate [:? int?] []) ; => true +(m/validate [:? int?] [1]) ; => true +(m/validate [:? int?] [1 2]) ; => false + +(m/validate [:* int?] []) ; => true +(m/validate [:* int?] [1 2 3]) ; => true + +(m/validate [:+ int?] []) ; => false +(m/validate [:+ int?] [1]) ; => true +(m/validate [:+ int?] [1 2 3]) ; => true + +(m/validate [:repeat {:min 2, :max 4} int?] [1]) ; => false +(m/validate [:repeat {:min 2, :max 4} int?] [1 2]) ; => true +(m/validate [:repeat {:min 2, :max 4} int?] [1 2 3 4]) ; => true (:max is inclusive, as elsewhere in Malli) +(m/validate [:repeat {:min 2, :max 4} int?] [1 2 3 4 5]) ; => false +``` + +`:cat*` and `:alt*` allow naming the subsequences / alternatives + +```clj +(m/explain [:* [:cat* [:prop string?] [:val [:alt* [:s string?] [:b boolean?]]]]] + ["-server" "foo" "-verbose" 11 "-user" "joe"]) +;; => {:schema [:* [:map [:prop string?] [:val [:map [:s string?] [:b boolean?]]]]], +;; :value ["-server" "foo" "-verbose" 11 "-user" "joe"], +;; :errors (#Error{:path [0 :val :s], :in [3], :schema string?, :value 11} +;; #Error{:path [0 :val :b], :in [3], :schema boolean?, :value 11})} +``` + +while `:cat` and `:alt` just use numeric indices for paths: + +```clj +(m/explain [:* [:cat string? [:alt string? boolean?]]] + ["-server" "foo" "-verbose" 11 "-user" "joe"]) +;; => {:schema [:* [:cat string? [:alt string? boolean?]]], +;; :value ["-server" "foo" "-verbose" 11 "-user" "joe"], +;; :errors (#Error{:path [0 1 0], :in [3], :schema string?, :value 11} +;; #Error{:path [0 1 1], :in [3], :schema boolean?, :value 11})} +``` + +As all these examples show, the "seqex" operators take any non-seqex child schema to +mean a sequence of one element that matches that schema. To force that behaviour for +a seqex child `:schema` can be used: + +```clj +(m/validate [:cat [:= :names] [:schema [:* string?]] + [:= :nums] [:schema [:* number?]]] + [:names ["a" "b"] :nums [1 2 3]]) ; => true + +;; whereas +(m/validate [:cat [:= :names] [:* string?] [:= :nums] [:* number?]] + [:names "a" "b" :nums 1 2 3]) ; => true +``` + +Although a lot of effort has gone into making the seqex implementation fast + +```clj +(require '[clojure.spec.alpha :as s]) +(require '[criterium.core :as cc]) + +(let [valid? (m/validator [:* int?] (range 1000))] + (cc/quick-bench (valid? (range 1000)))) ; Execution time mean : 189,953863 µs +(let [valid? (partial s/valid? (s/* int?))] + (cc/quick-bench (valid? (range 1000)))) ; Execution time mean : 2,576905 ms +(let [valid? (partial s/valid? (s/coll-of int?))] + (cc/quick-bench (valid? (range 1000)))) ; Execution time mean : 136,599310 µs +``` + +it is always better to use less general tools whenever possible: + +```clj +(let [valid? (m/validator [:sequential int?])] + (cc/quick-bench (valid? (range 1000)))) ; Execution time mean : 2,863314 µs +``` ## String schemas diff --git a/src/malli/core.cljc b/src/malli/core.cljc index 703fb9635..4e3cda8c8 100644 --- a/src/malli/core.cljc +++ b/src/malli/core.cljc @@ -1,9 +1,12 @@ (ns malli.core (:refer-clojure :exclude [eval type -deref deref -lookup -key]) (:require [malli.sci :as ms] + [malli.impl.util :as u] + [malli.impl.regex :as re] [malli.registry :as mr]) #?(:clj (:import (java.util.regex Pattern) - (clojure.lang IDeref MapEntry)))) + (clojure.lang IDeref) + [malli.impl.util SchemaError]))) ;; ;; protocols and records @@ -48,6 +51,31 @@ (-ref [this] "returns the reference name") (-deref [this] "returns the referenced schema")) +(defprotocol RegexSchema + (-regex-op? [this] "is this a regex operator (e.g. :cat, :*...)") + (-regex-validator [this] "returns the raw internal regex validator implementation") + (-regex-explainer [this path] "returns the raw internal regex explainer implementation") + (-regex-transformer [this transformer method options] "returns the raw internal regex transformer implementation")) + +(extend-type #?(:clj Object, :cljs default) + RegexSchema + (-regex-op? [_] false) + + (-regex-validator [this] + (if (satisfies? RefSchema this) + (-regex-validator (-deref this)) + (re/item-validator (-validator this)))) + + (-regex-explainer [this path] + (if (satisfies? RefSchema this) + (-regex-explainer (-deref this) path) + (re/item-explainer path this (-explainer this path)))) + + (-regex-transformer [this transformer method options] + (if (satisfies? RefSchema this) + (-regex-transformer (-deref this) transformer method options) + (re/item-transformer method (-validator this) (or (-transformer this transformer method options) identity))))) + (defprotocol Walker (-accept [this schema path options]) (-inner [this schema path options]) @@ -57,8 +85,6 @@ (-transformer-chain [this] "returns transformer chain as a vector of maps with :name, :encoders, :decoders and :options") (-value-transformer [this schema method options] "returns an value transforming interceptor for the given schema and method")) -(defrecord SchemaError [path in schema value type message]) - #?(:clj (defmethod print-method SchemaError [v ^java.io.Writer w] (.write w (str "#Error" (->> v (filter val) (into {})))))) #?(:clj (defmethod print-method ::into-schema [v ^java.io.Writer w] (.write w (str "#IntoSchema{:class " v "}")))) #?(:clj (defmethod print-method ::schema [v ^java.io.Writer w] (.write w (pr-str (-form v))))) @@ -78,19 +104,9 @@ (name x)) x)) -(defn -error - ([path in schema value] - (->SchemaError path in schema value nil nil)) - ([path in schema value type] - (->SchemaError path in schema value type nil))) +(def -fail! u/-fail!) -(defn -fail! - ([type] - (-fail! type nil)) - ([type data] - (-fail! type nil data)) - ([type message data] - (throw (ex-info (str type " " (pr-str data) message) {:type type, :data data})))) +(def -error u/-error) (defn -check-children! [type properties children {:keys [min max] :as opts}] (if (or (and min (< (count children) min)) (and max (> (count children) max))) @@ -122,6 +138,8 @@ (defn -update [m k f] (assoc m k (f (get m k)))) +(defn -memoize [f] (let [value (atom nil)] (fn [] (or @value) (reset! value (f))))) + (defn -inner-indexed [walker path children options] (mapv (fn [[i c]] (-inner walker c (conj path i) options)) (map-indexed vector children))) @@ -149,8 +167,7 @@ (-set-children schema children))) (defn -parse-entries [children {:keys [naked-keys lazy-refs]} options] - (let [-entry (fn [k v] #?(:clj (MapEntry. k v), :cljs (MapEntry. k v nil))) - -parse (fn [e] (let [[[k ?p ?v] f] (cond + (let [-parse (fn [e] (let [[[k ?p ?v] f] (cond (-reference? e) (if naked-keys [[e nil e] e]) (and (= 2 (count e)) (-reference? (first e)) (map? (last e))) (if naked-keys [(conj e (first e)) e]) :else [e (->> (-update (vec e) (dec (count e)) (-comp -form #(schema % options))) (keep identity) (vec))]) @@ -159,7 +176,7 @@ s (cond-> (or ?s (if (-reference? k) f)) lazy-refs (-lazy options)) c [k p (schema s options)]] {:children [c] - :entries [(-entry k (-val-schema (last c) p))] + :entries [(u/-tagged k (-val-schema (last c) p))] :forms [f]})) es (reduce #(merge-with into %1 %2) {} (mapv -parse children)) keys (->> es :entries (map first))] @@ -902,8 +919,7 @@ (-check-children! :ref properties children {:min 1, :max 1}) (when-not (-reference? ref) (-fail! ::invalid-ref {:ref ref})) - (let [-memoize (fn [f] (let [value (atom nil)] (fn [] (or @value) (reset! value (f))))) - -ref (or (and lazy (-memoize (fn [] (schema (mr/-schema (-registry options) ref) options)))) + (let [-ref (or (and lazy (-memoize (fn [] (schema (mr/-schema (-registry options) ref) options)))) (if-let [s (mr/-schema (-registry options) ref)] (-memoize (fn [] (schema s options)))) (when-not allow-invalid-refs (-fail! ::invalid-ref {:type :ref, :ref ref}))) @@ -925,9 +941,11 @@ deref-transformer (-memoize (fn [] (-transformer (-ref) transformer method options)))] (-intercepting this-transformer (fn [x] (if-some [t (deref-transformer)] (t x) x))))) (-walk [this walker path options] - (let [accept (fn [] (-inner walker (-ref) (into path [0 0]) (-update options ::walked-refs #(conj (or % #{}) ref))))] + (let [accept (fn [] (-inner walker (-ref) (into path [0 0]) + (-update options ::walked-refs #(conj (or % #{}) ref))))] (if (-accept walker this path options) - (if (or (not ((-boolean-fn (::walk-refs options false)) ref)) (contains? (::walked-refs options) ref)) + (if (or (not ((-boolean-fn (::walk-refs options false)) ref)) + (contains? (::walked-refs options) ref)) (-outer walker this path [ref] options) (-outer walker this path [(accept)] options))))) (-properties [_] properties) @@ -942,11 +960,17 @@ (-fail! ::index-out-of-bounds {:schema this, :key key}))) RefSchema (-ref [_] ref) - (-deref [_] (-ref)))))))) + (-deref [_] (-ref)) + RegexSchema + (-regex-op? [_] false) + (-regex-validator [this] (-fail! ::potentially-recursive-seqex this)) + (-regex-explainer [this _] (-fail! ::potentially-recursive-seqex this)) + (-regex-transformer [this _ _ _] (-fail! ::potentially-recursive-seqex this)))))))) (defn -schema-schema [{:keys [id raw] :as opts}] ^{:type ::into-schema} - (let [type (if (or id raw) ::schema :schema)] + (let [internal? (or id raw) + type (if internal? ::schema :schema)] (reify IntoSchema (-into-schema [_ properties children options] (-check-children! type properties children {:min 1, :max 1}) @@ -979,7 +1003,23 @@ (-fail! ::index-out-of-bounds {:schema this, :key key}))) RefSchema (-ref [_] id) - (-deref [_] child))))))) + (-deref [_] child) + + RegexSchema + (-regex-op? [_] false) + (-regex-validator [_] + (if internal? + (-regex-validator child) + (re/item-validator (-validator child)))) + (-regex-explainer [_ path] + (if internal? + (-regex-explainer child path) + (re/item-explainer path child (-explainer child path)))) + (-regex-transformer [_ transformer method options] + (if internal? + (-regex-transformer child transformer method options) + (re/item-transformer method (-validator child) + (or (-transformer child transformer method options) identity)))))))))) (defn -function-schema [] ^{:type ::into-schema} @@ -1020,6 +1060,92 @@ (-get [_ key default] (get children key default)) (-set [this key value] (-set-assoc-children this key value))))))) +(defn- regex-validator [schema] (re/validator (-regex-validator schema))) + +(defn- regex-explainer [schema path] (re/explainer schema path (-regex-explainer schema path))) + +(defn- regex-transformer [schema transformer method options] + (let [this-transformer (-value-transformer transformer schema method options) + ->children (re/transformer (-regex-transformer schema transformer method options))] + (-intercepting this-transformer ->children))) + +(defn -sequence-schema [{:keys [type child-bounds re-validator re-explainer re-transformer] :as opts}] + ^{:type ::into-schema} + (reify IntoSchema + (-into-schema [_ properties children options] + (-check-children! type properties children child-bounds) + (let [children (mapv #(schema % options) children) + form (-create-form type properties (mapv -form children))] + ^{:type ::schema} + (reify + Schema + (-type [_] type) + (-type-properties [_]) + (-validator [this] (regex-validator this)) + (-explainer [this path] (regex-explainer this path)) + (-transformer [this transformer method options] (regex-transformer this transformer method options)) + (-walk [this walker path options] + (if (-accept walker this path options) + (-outer walker this path (-inner-indexed walker path children options) options))) + (-properties [_] properties) + (-options [_] options) + (-children [_] children) + (-parent [_] (-sequence-schema opts)) + (-form [_] form) + + LensSchema + (-keep [_] true) + (-get [_ key default] (get children key default)) + (-set [this key value] (-set-assoc-children this key value)) + + RegexSchema + (-regex-op? [_] true) + (-regex-validator [_] + (re-validator properties (map -regex-validator children))) + (-regex-explainer [_ path] + (re-explainer properties (map-indexed (fn [i child] (-regex-explainer child (conj path i))) children))) + (-regex-transformer [_ transformer method options] + (re-transformer properties (map #(-regex-transformer % transformer method options) children)))))))) + +(defn -sequence-entry-schema [{:keys [type child-bounds re-validator re-explainer re-transformer] :as opts}] + ^{:type ::into-schema} + (reify IntoSchema + (-into-schema [_ properties children options] + (-check-children! type properties children child-bounds) + (let [{:keys [children entries forms]} (-parse-entries children opts options) + form (-create-form type properties forms)] + ^{:type ::schema} + (reify + Schema + (-type [_] type) + (-type-properties [_]) + (-validator [this] (regex-validator this)) + (-explainer [this path] (regex-explainer this path)) + (-transformer [this transformer method options] (regex-transformer this transformer method options)) + (-walk [this walker path options] + (if (-accept walker this path options) + (-outer walker this path (-inner-entries walker path entries options) options))) + (-properties [_] properties) + (-options [_] options) + (-children [_] children) + (-parent [_] (-sequence-entry-schema opts)) + (-form [_] form) + + LensSchema + (-keep [_] true) + (-get [this key default] (-get-entries this key default)) + (-set [this key value] (-set-entries this key value)) + + RegexSchema + (-regex-op? [_] true) + (-regex-validator [_] + (re-validator properties (map (fn [[k _ s]] [k (-regex-validator s)]) children))) + (-regex-explainer [_ path] + (re-explainer properties (map (fn [[k _ s]] [k (-regex-explainer s (conj path k))]) children))) + (-regex-transformer [_ transformer method options] + (re-transformer properties (map (fn [[k _ s]] [k (-regex-transformer s transformer method options)]) + children)))))))) + ;; ;; public api ;; @@ -1299,6 +1425,44 @@ :qualified-symbol (-qualified-symbol-schema) :uuid (-uuid-schema)}) +(defn sequence-schemas [] + {:+ (-sequence-schema {:type :+, :child-bounds {:min 1, :max 1} + :re-validator (fn [_ [child]] (re/+-validator child)) + :re-explainer (fn [_ [child]] (re/+-explainer child)) + :re-transformer (fn [_ [child]] (re/+-transformer child))}) + :* (-sequence-schema {:type :*, :child-bounds {:min 1, :max 1} + :re-validator (fn [_ [child]] (re/*-validator child)) + :re-explainer (fn [_ [child]] (re/*-explainer child)) + :re-transformer (fn [_ [child]] (re/*-transformer child))}) + :? (-sequence-schema {:type :?, :child-bounds {:min 1, :max 1} + :re-validator (fn [_ [child]] (re/?-validator child)) + :re-explainer (fn [_ [child]] (re/?-explainer child)) + :re-transformer (fn [_ [child]] (re/?-transformer child))}) + :repeat (-sequence-schema {:type :repeat, :child-bounds {:min 1, :max 1} + :re-validator (fn [{:keys [min max] :or {min 0, max ##Inf}} [child]] + (re/repeat-validator min max child)) + :re-explainer (fn [{:keys [min max] :or {min 0, max ##Inf}} [child]] + (re/repeat-explainer min max child)) + :re-transformer (fn [{:keys [min max] :or {min 0, max ##Inf}} [child]] + (re/repeat-transformer min max child))}) + + :cat (-sequence-schema {:type :cat, :child-bounds {} + :re-validator (fn [_ children] (apply re/cat-validator children)) + :re-explainer (fn [_ children] (apply re/cat-explainer children)) + :re-transformer (fn [_ children] (apply re/cat-transformer children))}) + :alt (-sequence-schema {:type :alt, :child-bounds {:min 1} + :re-validator (fn [_ children] (apply re/alt-validator children)) + :re-explainer (fn [_ children] (apply re/alt-explainer children)) + :re-transformer (fn [_ children] (apply re/alt-transformer children))}) + :cat* (-sequence-entry-schema {:type :cat*, :child-bounds {} + :re-validator (fn [_ children] (apply re/cat-validator children)) + :re-explainer (fn [_ children] (apply re/cat-explainer children)) + :re-transformer (fn [_ children] (apply re/cat-transformer children))}) + :alt* (-sequence-entry-schema {:type :alt*, :child-bounds {:min 1} + :re-validator (fn [_ children] (apply re/alt-validator children)) + :re-explainer (fn [_ children] (apply re/alt-explainer children)) + :re-transformer (fn [_ children] (apply re/alt-transformer children))})}) + (defn base-schemas [] {:and (-and-schema) :or (-or-schema) @@ -1319,7 +1483,7 @@ ::schema (-schema-schema {:raw true})}) (defn default-schemas [] - (merge (predicate-schemas) (class-schemas) (comparator-schemas) (type-schemas) (base-schemas))) + (merge (predicate-schemas) (class-schemas) (comparator-schemas) (type-schemas) (sequence-schemas) (base-schemas))) (def default-registry (mr/registry (cond (identical? mr/type "default") (default-schemas) diff --git a/src/malli/generator.cljc b/src/malli/generator.cljc index f6bef9ee0..7eaf534b8 100644 --- a/src/malli/generator.cljc +++ b/src/malli/generator.cljc @@ -114,6 +114,43 @@ (generate output-generator options))) {:arity (-> schema m/-arity)})))) +(defn -regex-generator [schema options] + (if (m/-regex-op? schema) + (generator schema options) + (gen/tuple (generator schema options)))) + +(defn- entry->schema [e] (if (vector? e) (get e 2) e)) + +(defn -cat-gen [schema options] + (->> (m/children schema options) + (map #(-regex-generator (entry->schema %) options)) + (apply gen/tuple) + (gen/fmap #(apply concat %)))) + +(defn -alt-gen [schema options] + (gen/one-of (keep (fn [e] + (let [child (entry->schema e)] + (some->> (-maybe-recur child options) (-regex-generator child)))) + (m/children schema options)))) + +(defn -?-gen [schema options] + (let [child (m/-get schema 0 nil)] + (if (m/-regex-op? child) + (gen/one-of [(generator child options) (gen/return ())]) + (gen/vector (generator child options) 0 1)))) + +(defn -*-gen [schema options] + (let [child (m/-get schema 0 nil)] + (if (m/-regex-op? child) + (gen/fmap #(apply concat %) (gen/vector (generator child options))) + (gen/vector (generator child options))))) + +(defn -repeat-gen [schema options] + (let [child (m/-get schema 0 nil)] + (if (m/-regex-op? child) + (gen/fmap #(apply concat %) (-coll-gen schema identity options)) + (-coll-gen schema identity options)))) + ;; ;; generators ;; @@ -167,6 +204,16 @@ (defmethod -schema-generator :union [schema options] (generator (m/deref schema) options)) (defmethod -schema-generator :select-keys [schema options] (generator (m/deref schema) options)) +(defmethod -schema-generator :cat [schema options] (-cat-gen schema options)) +(defmethod -schema-generator :cat* [schema options] (-cat-gen schema options)) +(defmethod -schema-generator :alt [schema options] (-alt-gen schema options)) +(defmethod -schema-generator :alt* [schema options] (-alt-gen schema options)) + +(defmethod -schema-generator :? [schema options] (-?-gen schema options)) +(defmethod -schema-generator :* [schema options] (-*-gen schema options)) +(defmethod -schema-generator :+ [schema options] (gen/not-empty (-*-gen schema options))) +(defmethod -schema-generator :repeat [schema options] (-repeat-gen schema options)) + (defn- -create [schema options] (let [{:gen/keys [gen fmap elements]} (merge (m/type-properties schema) (m/properties schema)) gen (or gen (when-not elements (if (satisfies? Generator schema) (-generator schema options) (-schema-generator schema options)))) diff --git a/src/malli/impl/regex.cljc b/src/malli/impl/regex.cljc new file mode 100644 index 000000000..6156b4ff6 --- /dev/null +++ b/src/malli/impl/regex.cljc @@ -0,0 +1,552 @@ +(ns malli.impl.regex + "Regular expressions of sequences implementation namespace. + + The implementation is very similar to Packrat or GLL parser combinators. + The parsing functions need to be written in CPS to support backtracking + inside :*, :+ and :repeat. They also need to be trampolined because the + (manually) CPS-converted code (for :*, :+ and :repeat) has to use tail + calls instead of loops and Clojure does not have TCO. + + Because backtracking is used we need to memoize (parsing function, seq + position, register stack) triples to avoid exponential behaviour. Discarding + the memoization cache after traversing an input seq also requires trampolining. + Because regular expressions don't use (nontail) recursion by definition, finding + a memoization entry just means the parser already went 'here' and ultimately + failed; much simpler than the graph-structured stacks of GLL. And the register + stack is only there for and used by :repeat. + + https://epsil.github.io/gll/ is a nice explanation of GLL parser combinators + and has links to papers etc. It also inspired Instaparse, which Engelberg + had a presentation about at Clojure/West 2014. + + Despite the CPS and memoization, this implementation looks more like normal + Clojure code than the 'Pike VM' in Seqexp. Hopefully JITs also see it that + way and compile decent machine code for it. It is also much easier to extend + for actual parsing (e.g. encode, decode [and conform?]) instead of just + recognition for `validate`." + + (:refer-clojure :exclude [+ * repeat cat]) + (:require [malli.impl.util :refer [-tagged -fail! -error]]) + #?(:clj (:import [java.util ArrayDeque]))) + +;;;; # Driver Protocols + +(defprotocol ^:private Driver + (succeed! [self]) + (succeeded? [self]) + (pop-thunk! [self])) + +(defprotocol ^:private IValidationDriver + (-park-validator! [driver validator regs pos coll k]) + (park-validator! [driver validator regs pos coll k])) + +(defprotocol ^:private IExplanationDriver + (-park-explainer! [driver explainer regs pos coll k]) + (park-explainer! [driver explainer regs pos coll k]) + (value-path [self pos]) + (fail! [self pos errors*]) + (latest-errors [self])) + +(defprotocol ^:private IParseDriver + (-park-transformer! [driver transformer regs coll* pos coll k]) + (park-transformer! [driver transformer regs coll* pos coll k]) + (succeed-with! [self v]) + (success-result [self])) + +;;;; # Primitives + +;;;; ## Seq Item + +(defn item-validator [valid?] + (fn [_ _ pos coll k] + (when (and (seq coll) (valid? (first coll))) + (k (inc pos) (rest coll))))) + +(defn item-explainer [path schema schema-explainer] + (fn [driver _ pos coll k] + (let [in (value-path driver pos)] + (if (seq coll) + (let [errors (schema-explainer (first coll) in [])] + (if (seq errors) + (fail! driver pos errors) + (k (inc pos) (rest coll)))) + (fail! driver pos [(-error path in schema nil :malli.core/end-of-input)]))))) + +(defn item-parser [valid?] + (fn [_ _ pos coll k] + (when (seq coll) + (let [v (first coll)] + (when (valid? v) + (k v (inc pos) (rest coll))))))) + +(defn item-encoder [valid? encode] + (fn [_ _ coll* pos coll k] + (when (seq coll) + (let [v (first coll)] + (when (valid? v) + (k (conj coll* (encode v)) (inc pos) (rest coll))))))) + +(defn item-decoder [decode valid?] + (fn [_ _ coll* pos coll k] + (when (seq coll) + (let [v (decode (first coll))] + (when (valid? v) + (k (conj coll* v) (inc pos) (rest coll))))))) + +(defn item-transformer [method validator t] + (case method + :encode (item-encoder validator t) + :decode (item-decoder t validator))) + +;;;; ## End of Seq + +(defn end-validator [] (fn [_ _ pos coll k] (when (empty? coll) (k pos coll)))) + +(defn end-explainer [schema path] + (fn [driver _ pos coll k] + (if (empty? coll) + (k pos coll) + (fail! driver pos (list (-error path (value-path driver pos) schema (first coll) :malli.core/input-remaining)))))) + +(defn end-parser [] (fn [_ _ pos coll k] (when (empty? coll) (k nil pos coll)))) + +(defn end-transformer [] (fn [_ _ coll* pos coll k] (when (empty? coll) (k coll* pos coll)))) + +;;;; # Combinators + +;;;; ## Catenation + +(defn- entry->regex [?kr] (if (vector? ?kr) (get ?kr 1) ?kr)) + +(defn cat-validator + ([] (fn [_ _ pos coll k] (k pos coll))) + ([?kr] (entry->regex ?kr)) + ([?kr ?kr*] + (let [r (entry->regex ?kr), r* (entry->regex ?kr*)] + (fn [driver regs pos coll k] + (r driver regs pos coll (fn [pos coll] (r* driver regs pos coll k)))))) + ([?kr ?kr* & ?krs] + (cat-validator ?kr (reduce (fn [acc ?kr] (cat-validator ?kr acc)) (reverse (cons ?kr* ?krs)))))) + +(defn cat-explainer + ([] (fn [_ _ pos coll k] (k pos coll))) + ([?kr] (entry->regex ?kr)) + ([?kr ?kr*] + (let [r (entry->regex ?kr), r* (entry->regex ?kr*)] + (fn [driver regs pos coll k] + (r driver regs pos coll (fn [pos coll] (r* driver regs pos coll k)))))) + ([?kr ?kr* & ?krs] + (cat-explainer ?kr (reduce (fn [acc ?kr] (cat-explainer ?kr acc)) (reverse (cons ?kr* ?krs)))))) + +(defn cat-parser [& rs] + (let [acc (reduce (fn [acc r] + (fn [driver regs coll* pos coll k] + (r driver regs pos coll + (fn [v pos coll] (acc driver regs (conj coll* v) pos coll k))))) + (fn [_ _ coll* pos coll k] (k coll* pos coll)) + (reverse rs))] + (fn [driver regs pos coll k] (acc driver regs [] pos coll k)))) + +(defn cat*-parser [& krs] + (let [acc (reduce (fn [acc [tag r]] + (fn [driver regs m pos coll k] + (r driver regs pos coll + (fn [v pos coll] (acc driver regs (assoc m tag v) pos coll k))))) + (fn [_ _ m pos coll k] (k m pos coll)) + (reverse krs))] + (fn [driver regs pos coll k] (acc driver regs {} pos coll k)))) + +(defn cat-transformer + ([] (fn [_ _ coll* pos coll k] (k coll* pos coll))) + ([?kr] (entry->regex ?kr)) + ([?kr ?kr*] + (let [r (entry->regex ?kr), r* (entry->regex ?kr*)] + (fn [driver regs coll* pos coll k] + (r driver regs coll* pos coll (fn [coll* pos coll] (r* driver regs coll* pos coll k)))))) + ([?kr ?kr* & ?krs] + (cat-transformer ?kr (reduce (fn [acc ?kr] (cat-transformer ?kr acc)) (reverse (cons ?kr* ?krs)))))) + +;;;; ## Alternation + +(defn alt-validator + ([?kr] (entry->regex ?kr)) + ([?kr ?kr*] + (let [r (entry->regex ?kr), r* (entry->regex ?kr*)] + (fn [driver regs pos coll k] + (park-validator! driver r* regs pos coll k) ; remember fallback + (park-validator! driver r regs pos coll k)))) + ([?kr ?kr* & ?krs] + (alt-validator ?kr (reduce (fn [acc ?kr] (alt-validator ?kr acc)) (reverse (cons ?kr* ?krs)))))) + +(defn alt-explainer + ([?kr] (entry->regex ?kr)) + ([?kr ?kr*] + (let [r (entry->regex ?kr), r* (entry->regex ?kr*)] + (fn [driver regs pos coll k] + (park-explainer! driver r* regs pos coll k) ; remember fallback + (park-explainer! driver r regs pos coll k)))) + ([?kr ?kr* & ?krs] + (alt-explainer ?kr (reduce (fn [acc ?kr] (alt-explainer ?kr acc)) (reverse (cons ?kr* ?krs)))))) + +(defn alt-parser + ([r] r) + ([r & rs] + (reduce (fn [acc r] + (fn [driver regs pos coll k] + (park-validator! driver acc regs pos coll k) ; remember fallback + (park-validator! driver r regs pos coll k))) + (reverse (cons r rs))))) + +(defn alt*-parser + ([[tag r]] (fn [driver pos coll k] (r driver pos coll (fn [v pos coll] (k (-tagged tag v) pos coll))))) + ([kr & krs] + (let [krs (reverse (cons kr krs))] + (reduce (fn [acc [tag r]] + (fn [driver regs pos coll k] + (park-validator! driver acc regs pos coll k) ; remember fallback + (park-validator! driver r regs pos coll (fn [v pos coll] (k (-tagged tag v) pos coll))))) + (alt*-parser (first krs)) + (rest krs))))) + +(defn alt-transformer + ([?kr] (entry->regex ?kr)) + ([?kr ?kr*] + (let [r (entry->regex ?kr), r* (entry->regex ?kr*)] + (fn [driver regs coll* pos coll k] + (park-transformer! driver r* regs coll* pos coll k) ; remember fallback + (park-transformer! driver r regs coll* pos coll k)))) + ([?kr ?kr* & ?krs] + (alt-transformer ?kr (reduce (fn [acc ?kr] (alt-transformer ?kr acc)) (reverse (cons ?kr* ?krs)))))) + +;;;; ## Option + +(defn ?-validator [p] (alt-validator p (cat-validator))) +(defn ?-explainer [p] (alt-explainer p (cat-explainer))) +(defn ?-parser [p] (alt-parser p (cat-parser))) +(defn ?-transformer [p] (alt-transformer p (cat-transformer))) + +;;;; ## Kleene Star + +(defn *-validator [p] + (let [*p-epsilon (cat-validator)] + (fn *p [driver regs pos coll k] + (park-validator! driver *p-epsilon regs pos coll k) ; remember fallback + (p driver regs pos coll (fn [pos coll] (park-validator! driver *p regs pos coll k)))))) ; TCO + +(defn *-explainer [p] + (let [*p-epsilon (cat-explainer)] + (fn *p [driver regs pos coll k] + (park-explainer! driver *p-epsilon regs pos coll k) ; remember fallback + (p driver regs pos coll (fn [pos coll] (park-explainer! driver *p regs pos coll k)))))) ; TCO + +(defn *-parser [p] + (let [*p-epsilon (fn [_ _ coll* pos coll k] (k coll* pos coll))] ; TCO + (fn *p + ([driver regs pos coll k] (*p driver regs [] pos coll k)) + ([driver regs coll* pos coll k] + (park-transformer! driver *p-epsilon regs coll* pos coll k) ; remember fallback + (p driver regs pos coll + (fn [v pos coll] (park-transformer! driver *p regs (conj coll* v) pos coll k))))))) ; TCO + +(defn *-transformer [p] + (let [*p-epsilon (cat-transformer)] + (fn *p [driver regs coll* pos coll k] + (park-transformer! driver *p-epsilon regs coll* pos coll k) ; remember fallback + (p driver regs coll* pos coll + (fn [coll* pos coll] (park-transformer! driver *p regs coll* pos coll k)))))) ; TCO + +;;;; ## Non-Kleene Plus + +(defn +-validator [p] (cat-validator p (*-validator p))) +(defn +-explainer [p] (cat-explainer p (*-explainer p))) +(defn +-parser [p] (cat-parser p (*-parser p))) +(defn +-transformer [p] (cat-transformer p (*-transformer p))) + +;;;; ## Repeat + +(defn repeat-validator [min max p] + (let [rep-epsilon (cat-validator)] + (letfn [(compulsories [driver regs pos coll k] + (if (< (peek regs) min) + (p driver regs pos coll + (fn [pos coll] + (-park-validator! driver + (fn [driver stack pos coll k] + (compulsories driver (conj (pop stack) (inc (peek stack))) pos coll k)) + regs pos coll k))) ; TCO + (optionals driver regs pos coll k))) + (optionals [driver regs pos coll k] + (if (< (peek regs) max) + (do + (park-validator! driver rep-epsilon regs pos coll k) ; remember fallback + (p driver regs pos coll + (fn [pos coll] + (-park-validator! driver + (fn [driver regs pos coll k] + (optionals driver (conj (pop regs) (inc (peek regs))) pos coll k)) + regs pos coll k)))) ; TCO + (k pos coll)))] + (fn [driver regs pos coll k] (compulsories driver (conj regs 0) pos coll k))))) + +(defn repeat-explainer [min max p] + (let [rep-epsilon (cat-explainer)] + (letfn [(compulsories [driver regs pos coll k] + (if (< (peek regs) min) + (p driver regs pos coll + (fn [pos coll] + (-park-explainer! driver + (fn [driver regs pos coll k] + (compulsories driver (conj (pop regs) (inc (peek regs))) pos coll k)) + regs pos coll k))) ; TCO + (optionals driver regs pos coll k))) + (optionals [driver regs pos coll k] + (if (< (peek regs) max) + (do + (park-explainer! driver rep-epsilon regs pos coll k) ; remember fallback + (p driver regs pos coll + (fn [pos coll] + (-park-explainer! driver + (fn [driver regs pos coll k] + (optionals driver (conj (pop regs) (inc (peek regs))) pos coll k)) + regs pos coll k)))) ; TCO + (k pos coll)))] + (fn [driver regs pos coll k] (compulsories driver (conj regs 0) pos coll k))))) + +(defn repeat-parser [min max p] + (let [rep-epsilon (cat-parser)] + (letfn [(compulsories [driver regs coll* pos coll k] + (if (< (peek regs) min) + (p driver regs pos coll + (fn [v pos coll] + (-park-transformer! driver + (fn [driver regs coll* pos coll k] + (compulsories driver (conj (pop regs) (inc (peek regs))) (conj coll* v) pos coll k)) + regs coll* pos coll k))) ; TCO + (optionals driver regs coll* pos coll k))) + (optionals [driver regs coll* pos coll k] + (if (< (peek regs) max) + (do + (park-transformer! driver rep-epsilon regs coll* pos coll k) ; remember fallback + (p driver regs pos coll + (fn [v pos coll] + (-park-transformer! + driver + (fn [driver regs coll* pos coll k] + (optionals driver (conj (pop regs) (inc (peek regs))) (conj coll* v) pos coll k)) + regs coll* pos coll k)))) ; TCO + (k pos coll)))] + (fn [driver regs pos coll k] (compulsories driver (conj regs 0) [] pos coll k))))) + +(defn repeat-transformer [min max p] + (let [rep-epsilon (cat-transformer)] + (letfn [(compulsories [driver regs coll* pos coll k] + (if (< (peek regs) min) + (p driver regs coll* pos coll + (fn [coll* pos coll] + (-park-transformer! driver + (fn [driver regs coll* pos coll k] + (compulsories driver (conj (pop regs) (inc (peek regs))) coll* pos coll k)) + regs coll* pos coll k))) ; TCO + (optionals driver regs coll* pos coll k))) + (optionals [driver regs coll* pos coll k] + (if (< (peek regs) max) + (do + (park-transformer! driver rep-epsilon regs coll* pos coll k) ; remember fallback + (p driver regs coll* pos coll + (fn [coll* pos coll] + (-park-transformer! driver + (fn [driver regs coll* pos coll k] + (optionals driver (conj (pop regs) (inc (peek regs))) coll* pos coll k)) + regs coll* pos coll k)))) ; TCO + (k coll* pos coll)))] + (fn [driver regs coll* pos coll k] (compulsories driver (conj regs 0) coll* pos coll k))))) + +;;;; # Shared Drivers + +(defn- make-stack [] #?(:clj (ArrayDeque.), :cljs #js [])) + +(defn- empty-stack? [^ArrayDeque stack] #?(:clj (.isEmpty stack), :cljs (zero? (alength stack)))) + +(defprotocol ^:private ICache + (ensure-cached! [cache f pos regs])) + +(deftype ^:private CacheEntry [^long hash f ^long pos regs]) + +;; Custom hash set so that Cljs Malli users can have decent perf without having to to set up Closure ES6 Set polyfill. +;; Uses quadratic probing with power-of-two sizes and triangular numbers, what a nice trick! +(deftype ^:private Cache + #?(:clj [^:unsynchronized-mutable ^"[Ljava.lang.Object;" values, ^:unsynchronized-mutable ^long size] + :cljs [^:mutable values, ^:mutable size]) + ICache + (ensure-cached! [_ f pos regs] + (when (> (unchecked-inc size) (bit-shift-right (alength values) 1)) ; potential new load factor > 0.5 + ;; Rehash: + (let [capacity* (bit-shift-left (alength values) 1) + values* (object-array capacity*) + max-index (unchecked-dec capacity*)] + (areduce values i _ nil + (when-some [^CacheEntry v (aget values i)] + (loop [i* (bit-and (.-hash v) max-index), collisions 0] + (if (aget values* i*) + (let [collisions (unchecked-inc collisions)] + (recur (bit-and (unchecked-add i* collisions) max-index) ; i* = (i* + collisions) % capacity* + collisions)) + (aset values* i* v))))) + (set! values values*))) + + (let [capacity (alength values) + max-index (unchecked-dec capacity) + ;; Unfortunately `hash-combine` hashes its second argument on clj and neither argument on cljs: + h #?(:clj (-> (hash f) (hash-combine pos) (hash-combine regs)) + :cljs (-> (hash f) (hash-combine (hash pos)) (hash-combine (hash regs))))] + (loop [i (bit-and h max-index), collisions 0] + (if-some [^CacheEntry entry (aget values i)] + (or (and (= (.-hash entry) h) + (= (.-f entry) f) + (= (.-pos entry) pos) + (= (.-regs entry) regs)) + (let [collisions (unchecked-inc collisions)] + (recur (bit-and (unchecked-add i collisions) max-index) ; i = (i + collisions) % capacity + collisions))) + (do + (aset values i (CacheEntry. h f pos regs)) + (set! size (unchecked-inc size)) + false)))))) + +(defn- make-cache [] (Cache. (object-array 2) 0)) + +(deftype ^:private CheckDriver + #?(:clj [^:unsynchronized-mutable ^boolean success, ^ArrayDeque stack, cache] + :cljs [^:mutable success, stack, cache]) + + Driver + (succeed! [_] (set! success (boolean true))) + (succeeded? [_] success) + (pop-thunk! [_] (when-not (empty-stack? stack) (.pop stack))) + + IValidationDriver + (-park-validator! [self validator regs pos coll k] (.push stack #(validator self regs pos coll k))) + (park-validator! [self validator regs pos coll k] + (when-not (ensure-cached! cache validator pos regs) + (-park-validator! self validator regs pos coll k)))) + +(deftype ^:private ParseDriver + #?(:clj [^:unsynchronized-mutable ^boolean success, ^ArrayDeque stack, cache + ^:unsynchronized-mutable result] + :cljs [^:mutable success, stack, cache, ^:mutable result]) + + Driver + (succeed! [_] (set! success (boolean true))) + (succeeded? [_] success) + (pop-thunk! [_] (when-not (empty-stack? stack) (.pop stack))) + + IValidationDriver + (-park-validator! [self validator regs pos coll k] (.push stack #(validator self regs pos coll k))) + (park-validator! [self validator regs pos coll k] + (when-not (ensure-cached! cache validator pos regs) + (-park-validator! self validator regs pos coll k))) + + IParseDriver + (-park-transformer! [driver transformer regs coll* pos coll k] + (.push stack #(transformer driver regs coll* pos coll k))) + (park-transformer! [driver transformer regs coll* pos coll k] + (when-not (ensure-cached! cache transformer pos regs) + (-park-transformer! driver transformer regs coll* pos coll k))) + (succeed-with! [self v] (succeed! self) (set! result v)) + (success-result [_] result)) + +;;;; # Validator + +(defn validator [p] + (let [p (cat-validator p (end-validator))] + (fn [coll] + (and (sequential? coll) + (let [driver (CheckDriver. false (make-stack) (make-cache))] + (p driver () 0 coll (fn [_ _] (succeed! driver))) + (or (succeeded? driver) + (loop [] + (if-some [thunk (pop-thunk! driver)] + (do + (thunk) + (or (succeeded? driver) (recur))) + false)))))))) + +;;;; # Explainer + +(deftype ^:private ExplanationDriver + #?(:clj [^:unsynchronized-mutable ^boolean success, ^ArrayDeque stack, cache + in, ^:unsynchronized-mutable errors-max-pos, ^:unsynchronized-mutable errors] + :cljs [^:mutable success, stack, cache, in, ^:mutable errors-max-pos, ^:mutable errors]) + + Driver + (succeed! [_] (set! success (boolean true))) + (succeeded? [_] success) + (pop-thunk! [_] (when-not (empty-stack? stack) (.pop stack))) + + IExplanationDriver + (-park-explainer! [self validator regs pos coll k] (.push stack #(validator self regs pos coll k))) + (park-explainer! [self validator regs pos coll k] + (when-not (ensure-cached! cache validator pos regs) + (-park-explainer! self validator regs pos coll k))) + (value-path [_ pos] (conj in pos)) + (fail! [_ pos errors*] + (cond + (> pos errors-max-pos) (do + (set! errors-max-pos pos) + (set! errors errors*)) + (= pos errors-max-pos) (set! errors (into errors errors*)))) + (latest-errors [_] errors)) + +(defn explainer [schema path p] + (let [p (cat-explainer p (end-explainer schema path))] + (fn [coll in errors] + (if (sequential? coll) + (let [pos 0 + driver (ExplanationDriver. false (make-stack) (make-cache) in pos [])] + (p driver () pos coll (fn [_ _] (succeed! driver))) + (if (succeeded? driver) + errors + (loop [] + (if-some [thunk (pop-thunk! driver)] + (do + (thunk) + (if (succeeded? driver) errors (recur))) + (into errors (latest-errors driver)))))) + (conj errors (-error path in schema coll :malli.core/invalid-type)))))) + +;;;; # Parser + +;; Unused ATM but should soon be used to implement Spec `conform` equivalent: +(defn parser [p] + (let [p (cat-parser p (end-parser))] + (fn [coll] + (if (sequential? coll) + (let [driver (ParseDriver. false (make-stack) (make-cache) nil)] + (p driver () 0 coll (fn [v _ _] (succeed-with! driver v))) + (if (succeeded? driver) + (first (success-result driver)) + (loop [] + (if-some [thunk (pop-thunk! driver)] + (do + (thunk) + (if (succeeded? driver) (first (success-result driver)) (recur))) + (-fail! :malli.core/nonconforming))))) + (-fail! :malli.core/nonconforming))))) + +;;;; # Transformer + +(defn transformer [p] + (let [p (cat-transformer p (end-transformer))] + (fn [coll] + (if (sequential? coll) + (let [driver (ParseDriver. false (make-stack) (make-cache) nil)] + (p driver () [] 0 coll (fn [coll* _ _] (succeed-with! driver coll*))) + (if (succeeded? driver) + (success-result driver) + (loop [] + (if-some [thunk (pop-thunk! driver)] + (do + (thunk) + (if (succeeded? driver) (success-result driver) (recur))) + coll)))) + coll)))) diff --git a/src/malli/impl/util.cljc b/src/malli/impl/util.cljc new file mode 100644 index 000000000..21e35b650 --- /dev/null +++ b/src/malli/impl/util.cljc @@ -0,0 +1,26 @@ +(ns malli.impl.util + #?(:clj (:import [clojure.lang MapEntry]))) + +(defn -tagged [k v] #?(:clj (MapEntry. k v), :cljs (MapEntry. k v nil))) + +(defn stateful-mapv [f coll s] + (let [s (volatile! s)] + [(mapv (fn [v] (let [[v* s*] (f v @s)] (vreset! s s*) v*)) + coll) + @s])) + +(defn -fail! + ([type] + (-fail! type nil)) + ([type data] + (-fail! type nil data)) + ([type message data] + (throw (ex-info (str type " " (pr-str data) message) {:type type, :data data})))) + +(defrecord SchemaError [path in schema value type message]) + +(defn -error + ([path in schema value] + (->SchemaError path in schema value nil nil)) + ([path in schema value type] + (->SchemaError path in schema value type nil))) diff --git a/test/malli/core_test.cljc b/test/malli/core_test.cljc index 56a5c1f49..8d259d951 100644 --- a/test/malli/core_test.cljc +++ b/test/malli/core_test.cljc @@ -5,6 +5,7 @@ [malli.transform :as mt] [malli.util :as mu] [malli.registry :as mr] + [malli.impl.util :as u] [clojure.walk :as walk] [malli.generator :as mg] [clojure.test.check.generators :as gen])) @@ -17,7 +18,7 @@ (update :schema m/form) (update :type (fnil identity nil)) (update :message (fnil identity nil)) - (m/map->SchemaError))))))) + (u/map->SchemaError))))))) (defn results= [& results] (apply = (map with-schema-forms results))) @@ -1057,7 +1058,260 @@ (is (= {:type name, :children [{:type 'int?}]} (mu/to-map-syntax [name int?])))) (is (= {:type :tuple, :children [{:type 'int?} {:type 'int?}]} - (mu/to-map-syntax [:tuple int? int?])))))) + (mu/to-map-syntax [:tuple int? int?]))))) + + (testing "seqex schemas" + (testing "validate & explain" + (doseq [typ [:cat :cat*]] + (testing typ + (testing "empty" + (let [s [typ]] + (are [v errs] + (let [es errs] + (and (= (m/validate s v) (nil? es)) + (results= (m/explain s v) (and es {:schema s, :value v, :errors es})))) + + 0 [{:path [], :in [], :schema s, :value 0, :type ::m/invalid-type}] + "foo" [{:path [], :in [], :schema s, :value "foo", :type ::m/invalid-type}] + nil [{:path [], :in [], :schema s, :value nil, :type ::m/invalid-type}] + [] nil + [0] [{:path [], :in [0], :schema s, :value 0, :type ::m/input-remaining}]))) + + (testing "single" + (let [s [typ (case typ :cat string? [:s string?])]] + (are [v errs] + (let [es errs] + (and (= (m/validate s v) (nil? es)) + (results= (m/explain s v) (and es {:schema s, :value v, :errors es})))) + + 0 [{:path [], :in [], :schema s, :value 0, :type ::m/invalid-type}] + "foo" [{:path [], :in [], :schema s, :value "foo", :type ::m/invalid-type}] + nil [{:path [], :in [], :schema s, :value nil, :type ::m/invalid-type}] + [] [{:path [(case typ :cat* :s 0)], :in [0], :schema string?, :value nil, :type ::m/end-of-input}] + ["foo"] nil + [0] [{:path [(case typ :cat* :s 0)], :in [0], :schema string?, :value 0}] + ["foo" "bar"] [{:path [], :in [1], :schema s, :value "bar", :type ::m/input-remaining}]))) + + (testing "pair" + (let [s [typ (case typ :cat string? [:s string?]) (case typ :cat int? [:n int?])]] + (are [v errs] + (let [es errs] + (and (= (m/validate s v) (nil? es)) + (results= (m/explain s v) (and es {:schema s, :value v, :errors es})))) + + 0 [{:path [], :in [], :schema s, :value 0, :type ::m/invalid-type}] + "foo" [{:path [], :in [], :schema s, :value "foo", :type ::m/invalid-type}] + nil [{:path [], :in [], :schema s, :value nil, :type ::m/invalid-type}] + [] [{:path [(case typ :cat* :s 0)], :in [0], :schema string?, :value nil, :type ::m/end-of-input}] + ["foo"] [{:path [(case typ :cat* :n 1)], :in [1], :schema int?, :value nil, :type ::m/end-of-input}] + ["foo" 0] nil + ["foo" "bar"] [{:path [(case typ :cat* :n 1)], :in [1], :schema int?, :value "bar"}] + [1 2] [{:path [(case typ :cat* :s 0)], :in [0], :schema string?, :value 1}] + ["foo" 0 1] [{:path [], :in [2], :schema s, :value 1, :type ::m/input-remaining}]))) + + (testing "triplet" + (let [s [typ (case typ :cat string? [:s string?]) (case typ :cat int? [:n int?]) + (case typ :cat keyword? [:k keyword?])]] + (are [v errs] + (let [es errs] + (and (= (m/validate s v) (nil? es)) + (results= (m/explain s v) (and es {:schema s, :value v, :errors es})))) + + 0 [{:path [], :in [], :schema s, :value 0, :type ::m/invalid-type}] + "foo" [{:path [], :in [], :schema s, :value "foo", :type ::m/invalid-type}] + nil [{:path [], :in [], :schema s, :value nil, :type ::m/invalid-type}] + [] [{:path [(case typ :cat* :s 0)], :in [0], :schema string?, :value nil, :type ::m/end-of-input}] + ["foo"] [{:path [(case typ :cat* :n 1)], :in [1], :schema int?, :value nil, :type ::m/end-of-input}] + ["foo" 0] [{:path [(case typ :cat* :k 2)], :in [2], :schema keyword?, :value nil, :type ::m/end-of-input}] + ["foo" 0 :bar] nil + ["foo" 0 "bar"] [{:path [(case typ :cat* :k 2)], :in [2], :schema keyword?, :value "bar"}] + ["foo" 0 :bar 0] [{:path [], :in [3], :schema s, :value 0, :type ::m/input-remaining}]))) + + (testing "* backtracks" + (is (m/validate [:cat [:* pos?] [:= 4]] [4 4 4 4]))))) + + (doseq [typ [:alt :alt*]] + (testing typ + (testing "empty" + (is (thrown? #?(:clj Exception, :cljs js/Error) (m/validator [typ])))) + + (testing "single" + (let [s [typ (case typ :alt string? [:s string?])]] + (are [v errs] + (let [es errs] + (and (= (m/validate s v) (nil? es)) + (results= (m/explain s v) (and es {:schema s, :value v, :errors es})))) + + 0 [{:path [], :in [], :schema s, :value 0, :type ::m/invalid-type}] + "foo" [{:path [], :in [], :schema s, :value "foo", :type ::m/invalid-type}] + nil [{:path [], :in [], :schema s, :value nil, :type ::m/invalid-type}] + ["foo"] nil + [0] [{:path [(case typ :alt* :s 0)], :in [0], :schema string?, :value 0}] + ["foo" 0] [{:path [], :in [1], :schema s, :value 0, :type ::m/input-remaining}]))) + + (testing "pair" + (let [s [typ (case typ :alt string? [:s string?]) (case typ :alt int? [:n int?])]] + (are [v errs] + (let [es errs] + (and (= (m/validate s v) (nil? es)) + (results= (m/explain s v) (and es {:schema s, :value v, :errors es})))) + + 0 [{:path [], :in [], :schema s, :value 0, :type ::m/invalid-type}] + "foo" [{:path [], :in [], :schema s, :value "foo", :type ::m/invalid-type}] + nil [{:path [], :in [], :schema s, :value nil, :type ::m/invalid-type}] + ["foo"] nil + [0] nil + ["foo" 0] [{:path [], :in [1], :schema s, :value 0, :type ::m/input-remaining}] + [0 "foo"] [{:path [], :in [1], :schema s, :value "foo", :type ::m/input-remaining}]))) + + (testing "triplet" + (let [s [typ (case typ :alt string? [:s string?]) (case typ :alt int? [:n int?]) + (case typ :alt keyword? [:k keyword?])]] + (are [v errs] + (let [es errs] + (and (= (m/validate s v) (nil? es)) + (results= (m/explain s v) (and es {:schema s, :value v, :errors es})))) + + 0 [{:path [], :in [], :schema s, :value 0, :type ::m/invalid-type}] + "foo" [{:path [], :in [], :schema s, :value "foo", :type ::m/invalid-type}] + nil [{:path [], :in [], :schema s, :value nil, :type ::m/invalid-type}] + ["foo"] nil + [0] nil + [:foo] nil + ["foo" 0] [{:path [], :in [1], :schema s, :value 0, :type ::m/input-remaining}] + [0 "foo"] [{:path [], :in [1], :schema s, :value "foo", :type ::m/input-remaining}] + [:foo 0] [{:path [], :in [1], :schema s, :value 0, :type ::m/input-remaining}]))))) + + (testing "?" + (is (thrown? #?(:clj Exception, :cljs js/Error) (m/validator [:?]))) + (is (thrown? #?(:clj Exception, :cljs js/Error) (m/validator [:? string? int?]))) + + (let [s [:? string?]] + (are [v errs] + (let [es errs] + (and (= (m/validate s v) (nil? es)) + (results= (m/explain s v) (and es {:schema s, :value v, :errors es})))) + + 0 [{:path [], :in [], :schema s, :value 0, :type ::m/invalid-type}] + "foo" [{:path [], :in [], :schema s, :value "foo", :type ::m/invalid-type}] + nil [{:path [], :in [], :schema s, :value nil, :type ::m/invalid-type}] + [] nil + ["foo"] nil + [0] [{:path [0], :in [0], :schema string?, :value 0} + {:path [], :in [0], :schema s, :value 0, :type ::m/input-remaining}] + ["foo" 0] [{:path [], :in [1], :schema s, :value 0, :type ::m/input-remaining}])) + + (testing "pathological case (terminates)" + (let [n 50] + (is (m/validate (into [:cat] (concat (repeat n [:? [:= :a]]) + (repeat n [:= :a]))) + (repeat n :a)))))) + + (testing "*" + (is (thrown? #?(:clj Exception, :cljs js/Error) (m/validator [:*]))) + (is (thrown? #?(:clj Exception, :cljs js/Error) (m/validator [:* string? int?]))) + + (let [s [:* string?]] + (are [v errs] + (let [es errs] + (and (= (m/validate s v) (nil? es)) + (results= (m/explain s v) (and es {:schema s, :value v, :errors es})))) + + 0 [{:path [], :in [], :schema s, :value 0, :type ::m/invalid-type}] + "foo" [{:path [], :in [], :schema s, :value "foo", :type ::m/invalid-type}] + nil [{:path [], :in [], :schema s, :value nil, :type ::m/invalid-type}] + [] nil + ["foo"] nil + [0] [{:path [0], :in [0], :schema string?, :value 0} + {:path [], :in [0], :schema s, :value 0, :type ::m/input-remaining}] + ["foo" 0] [{:path [0], :in [1], :schema string?, :value 0} + {:path [], :in [1], :schema s, :value 0, :type ::m/input-remaining}] + ["foo" "bar"] nil))) + + (testing "+" + (is (thrown? #?(:clj Exception, :cljs js/Error) (m/validator [:+]))) + (is (thrown? #?(:clj Exception, :cljs js/Error) (m/validator [:+ string? int?]))) + + (let [s [:+ string?]] + (are [v errs] + (let [es errs] + (and (= (m/validate s v) (nil? es)) + (results= (m/explain s v) (and es {:schema s, :value v, :errors es})))) + + 0 [{:path [], :in [], :schema s, :value 0, :type ::m/invalid-type}] + "foo" [{:path [], :in [], :schema s, :value "foo", :type ::m/invalid-type}] + nil [{:path [], :in [], :schema s, :value nil, :type ::m/invalid-type}] + [] [{:path [0], :in [0], :schema string?, :value nil, :type ::m/end-of-input}] + ["foo"] nil + [0] [{:path [0], :in [0], :schema string?, :value 0}] + ["foo" 0] [{:path [0], :in [1], :schema string?, :value 0} + {:path [], :in [1], :schema s, :value 0, :type ::m/input-remaining}] + ["foo" "bar"] nil))) + + (testing "repeat" + (is (thrown? #?(:clj Exception, :cljs js/Error) (m/validator [:repeat {:min 1, :max 3}]))) + (is (thrown? #?(:clj Exception, :cljs js/Error) (m/validator [:repeat {:min 1, :max 3} string? int?]))) + + (let [s [:repeat {:min 1, :max 3} string?]] + (are [v errs] + (let [es errs] + (and (= (m/validate s v) (nil? es)) + (results= (m/explain s v) (and es {:schema s, :value v, :errors es})))) + + 0 [{:path [], :in [], :schema s, :value 0, :type ::m/invalid-type}] + "foo" [{:path [], :in [], :schema s, :value "foo", :type ::m/invalid-type}] + nil [{:path [], :in [], :schema s, :value nil, :type ::m/invalid-type}] + [] [{:path [0], :in [0], :schema string?, :value nil, :type ::m/end-of-input}] + ["foo"] nil + [0] [{:path [0], :in [0], :schema string?, :value 0}] + ["foo" 0] [{:path [0], :in [1], :schema string?, :value 0} + {:path [], :in [1], :schema s, :value 0, :type ::m/input-remaining}] + ["foo" "bar"] nil + ["foo" "bar" 0] [{:path [0], :in [2], :schema string?, :value 0} + {:path [], :in [2], :schema s, :value 0, :type ::m/input-remaining}] + ["foo" "bar" "baz"] nil + ["foo" "bar" "baz" "quux"] [{:path [], :in [3], :schema s, :value "quux", :type ::m/input-remaining}]))) + + (testing ":schema wrap" + (is (thrown? #?(:clj Exception, :cljs js/Error) (m/validator [:schema]))) + (is (thrown? #?(:clj Exception, :cljs js/Error) (m/validator [:schema [:* string?] [:* int?]]))) + + (let [s [:* [:schema [:* string?]]]] + (are [v errs] + (let [es errs] + (and (= (m/validate s v) (nil? es)) + (results= (m/explain s v) (and es {:schema s, :value v, :errors es})))) + + 0 [{:path [], :in [], :schema s, :value 0, :type ::m/invalid-type}] + "foo" [{:path [], :in [], :schema s, :value "foo", :type ::m/invalid-type}] + [] nil + ["foo"] [{:path [0], :in [0], :schema [:* string?], :value "foo", :type ::m/invalid-type} + {:path [], :in [0], :schema s, :value "foo", :type ::m/input-remaining}] + [[]] nil + [["foo"]] nil + [[0]] [{:path [0 0], :in [0 0], :schema string?, :value 0} + {:path [0], :in [0 0], :schema [:* string?], :value 0, :type ::m/input-remaining} + {:path [], :in [0], :schema s, :value [0], :type ::m/input-remaining}]))) + + (testing "RefSchemas" + (is (m/validate + [:schema {:registry {"ints" [:+ int?] + "bools" [:+ boolean?]}} + [:* [:cat "ints" "bools"]]] + [1 true 2 2 false])) + (is (thrown-with-msg? #?(:clj Exception, :cljs js/Error) #":malli.core/potentially-recursive-seqex" + (m/validator + [:schema {:registry {::ints [:cat int? [:ref ::ints]]}} + ::ints]))) + (is (m/validate + [:schema {:registry {::ints [:* [:or int? [:ref ::ints]]]}} + ::ints] + [[1 2 3]])) + ;; A bit undesirable, but intentional: + (is (thrown-with-msg? #?(:clj Exception, :cljs js/Error) #":malli.core/potentially-recursive-seqex" + (m/validator + [:schema {:registry {::boll [:cat boolean?]}} + [:* [:ref ::boll]]]))))))) (deftest path-with-properties-test (let [?path #(-> % :errors first :path)] diff --git a/test/malli/generator_test.cljc b/test/malli/generator_test.cljc index f06d14359..e2ea20c58 100644 --- a/test/malli/generator_test.cljc +++ b/test/malli/generator_test.cljc @@ -1,5 +1,7 @@ (ns malli.generator-test (:require [clojure.test :refer [deftest testing is are]] + [clojure.test.check.properties :refer [for-all]] + [clojure.test.check.clojure-test :refer [defspec]] [clojure.test.check.generators :as gen] [malli.json-schema-test :as json-schema-test] [malli.generator :as mg] @@ -118,6 +120,50 @@ (is (every? #{1 2} (mg/sample [:and {:gen/gen (gen/elements [1 2])} int?] {:size 1000}))) (is (every? #{"1" "2"} (mg/sample [:and {:gen/gen (gen/elements [1 2]) :gen/fmap str} int?] {:size 1000}))))) +(defn- schema+coll-gen [type children-gen] + (gen/let [children children-gen] + (let [schema (into [type] children)] + (gen/tuple (gen/return schema) (mg/generator schema))))) + +(def ^:private seqex-child + (let [s (gen/elements [string? int? keyword?])] + (gen/one-of [s (gen/fmap #(vector :* %) s)]))) + +(defspec cat-test 100 + (for-all [[s coll] (schema+coll-gen :cat (gen/vector seqex-child))] + (m/validate s coll))) + +(defspec cat*-test 100 + (for-all [[s coll] (->> (gen/vector (gen/tuple gen/keyword seqex-child)) + (gen/such-that (fn [coll] (or (empty? coll) (apply distinct? (map first coll))))) + (schema+coll-gen :cat*))] + (m/validate s coll))) + +(defspec alt-test 100 + (for-all [[s coll] (schema+coll-gen :alt (gen/not-empty (gen/vector seqex-child)))] + (m/validate s coll))) + +(defspec alt*-test 100 + (for-all [[s coll] (->> (gen/not-empty (gen/vector (gen/tuple gen/keyword seqex-child))) + (gen/such-that (fn [coll] (or (empty? coll) (apply distinct? (map first coll))))) + (schema+coll-gen :alt*))] + (m/validate s coll))) + +(defspec ?*+-test 100 + (for-all [[s coll] (gen/let [type (gen/elements [:? :* :+]) + child seqex-child] + (let [schema [type child]] + (gen/tuple (gen/return schema) (mg/generator schema))))] + (m/validate s coll))) + +(defspec repeat-test 100 + (for-all [[s coll] (schema+coll-gen :repeat (gen/tuple + (gen/let [min gen/nat + len gen/nat] + {:min min, :max (+ min len)}) + seqex-child))] + (m/validate s coll))) + (deftest min-max-test (testing "valid properties" diff --git a/test/malli/transform_test.cljc b/test/malli/transform_test.cljc index 72770e380..8328db0b3 100644 --- a/test/malli/transform_test.cljc +++ b/test/malli/transform_test.cljc @@ -248,7 +248,98 @@ (is (= ["kikka" "1"] (m/encode [:tuple keyword? int?] [:kikka 1] mt/string-transformer))) (is (= 1.0 (m/encode [:tuple keyword? int?] 1.0 mt/string-transformer))) (is (= nil (m/encode [:tuple keyword? int?] nil mt/string-transformer))) - (is (= ["kikka" "1" "2"] (m/encode [:tuple keyword? int?] [:kikka 1 "2"] mt/string-transformer)))))) + (is (= ["kikka" "1" "2"] (m/encode [:tuple keyword? int?] [:kikka 1 "2"] mt/string-transformer))))) + + (testing "seqex" + (testing "decode" + (are [s v v*] + (= (m/decode s v mt/string-transformer) v*) + + [:cat] [] [] + [:cat] "1" "1" + [:cat] nil nil + [:cat int?] ["1"] [1] + [:cat int? keyword?] ["1" "kikka"] [1 :kikka] + [:cat int? keyword?] ["kikka" "kukka"] ["kikka" "kukka"] + + [:cat*] [] [] + [:cat*] "1" "1" + [:cat*] nil nil + [:cat* [:n int?]] ["1"] [1] + [:cat* [:n int?] [:k keyword?]] ["1" "kikka"] [1 :kikka] + [:cat* [:n int?] [:k keyword?]] ["kikka" "kukka"] ["kikka" "kukka"] + + [:alt int?] ["1"] [1] + [:alt int? keyword?] ["1"] [1] + [:alt keyword? int?] ["1"] [:1] + [:alt int? keyword?] ["kikka"] [:kikka] + + [:alt* [:n int?]] ["1"] [1] + [:alt* [:n int?] [:k keyword?]] ["1"] [1] + [:alt* [:k keyword?] [:n int?]] ["1"] [:1] + [:alt* [:n int?] [:k keyword?]] ["kikka"] [:kikka] + + [:? int?] [] [] + [:? int?] "1" "1" + [:? int?] nil nil + [:? int?] ["1"] [1] + [:? int?] ["1" "2"] ["1" "2"] + + [:* int?] [] [] + [:* int?] ["1"] [1] + [:* int?] ["1" "2"] [1 2] + [:* int?] ["1" "kikka"] ["1" "kikka"] + + [:+ int?] [] [] + [:+ int?] ["1"] [1] + [:+ int?] ["1" "2"] [1 2] + [:+ int?] ["1" "kikka"] ["1" "kikka"] + + [:repeat {:min 2, :max 4} int?] [] [] + [:repeat {:min 2, :max 4} int?] nil nil + [:repeat {:min 2, :max 4} int?] ["1"] ["1"] + [:repeat {:min 2, :max 4} int?] ["1" "2"] [1 2] + [:repeat {:min 2, :max 4} int?] ["1" "kikka"] ["1" "kikka"] + [:repeat {:min 2, :max 4} int?] ["1" "2" "3" "4" "5"] ["1" "2" "3" "4" "5"])) + + (testing "encode" + (are [s v v*] + (= (m/encode s v mt/string-transformer) v*) + + [:cat] [] [] + [:cat] 1 1 + [:cat] nil nil + [:cat int?] [1] ["1"] + [:cat int? keyword?] [1 :kikka] ["1" "kikka"] + [:cat int? keyword?] [:kikka :kukka] [:kikka :kukka] + + [:alt int?] [1] ["1"] + [:alt int? keyword?] [1] ["1"] + [:alt keyword? int?] [:1] ["1"] + [:alt int? keyword?] [:kikka] ["kikka"] + + [:? int?] [] [] + [:? int?] 1 1 + [:? int?] nil nil + [:? int?] [1] ["1"] + [:? int?] [1 2] [1 2] + + [:* int?] [] [] + [:* int?] [1] ["1"] + [:* int?] [1 2] ["1" "2"] + [:* int?] [1 :kikka] [1 :kikka] + + [:+ int?] [] [] + [:+ int?] [1] ["1"] + [:+ int?] [1 2] ["1" "2"] + [:+ int?] [1 :kikka] [1 :kikka] + + [:repeat {:min 2, :max 4} int?] [] [] + [:repeat {:min 2, :max 4} int?] nil nil + [:repeat {:min 2, :max 4} int?] [1] [1] + [:repeat {:min 2, :max 4} int?] [1 2] ["1" "2"] + [:repeat {:min 2, :max 4} int?] [1 :kikka] [1 :kikka] + [:repeat {:min 2, :max 4} int?] [1 2 3 4 5] [1 2 3 4 5])))) (deftest collection-transform-test (testing "decode"